2008-11-05 Steve Bennett <steveb@workware.net.au>

	* jim-glob-1.0.tcl, jim-readdir.c: Add readdir extension and glob package for glob command

3 files changed, 259 insertions, 0 deletions

diff --git a/ChangeLog b/ChangeLog
index 99aeb91..5155a2a 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,5 +1,9 @@
 2008-11-05 Steve Bennett <steveb@workware.net.au>
 
+	* jim-glob-1.0.tcl, jim-readdir.c: Add readdir extension and glob package for glob command
+
+2008-11-05 Steve Bennett <steveb@workware.net.au>
+
 	* jim-regexp.c: Add regexp extension for regexp and regsub commands
 
 2008-11-04 Uwe Klein <uklein@klein-messgeraete.de>
diff --git a/jim-glob-1.0.tcl b/jim-glob-1.0.tcl
new file mode 100644
index 0000000..9529df0
--- /dev/null
+++ b/jim-glob-1.0.tcl
@@ -0,0 +1,133 @@
+# (c) 2008 Steve Bennett <steveb@workware.net.au>

+#

+# Implements a Tcl-compatible glob command based on readdir

+#

+# The FreeBSD license

+# 

+# Redistribution and use in source and binary forms, with or without

+# modification, are permitted provided that the following conditions

+# are met:

+# 

+# 1. Redistributions of source code must retain the above copyright

+#    notice, this list of conditions and the following disclaimer.

+# 2. Redistributions in binary form must reproduce the above

+#    copyright notice, this list of conditions and the following

+#    disclaimer in the documentation and/or other materials

+#    provided with the distribution.

+# 

+# THIS SOFTWARE IS PROVIDED BY THE JIM TCL PROJECT ``AS IS'' AND ANY

+# EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,

+# THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A

+# PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE

+# JIM TCL PROJECT OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT,

+# INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES

+# (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS

+# OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)

+# HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,

+# STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)

+# ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF

+# ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

+# 

+# The views and conclusions contained in the software and documentation

+# are those of the authors and should not be interpreted as representing

+# official policies, either expressed or implied, of the Jim Tcl Project.

+

+package provide glob 1.0

+package require readdir 1.0

+

+# If $dir is a directory, return a list of all entries

+# it contains which match $pattern

+#

+proc _glob_readdir_pattern {dir pattern} {

+	set result {}

+

+	# readdir doesn't return . or .., so simulate it here

+	if {$pattern eq "." || $pattern eq ".."} {

+		return $pattern

+	}

+	# Use -nocomplain here to return nothing if $dir is not a directory

+	foreach name [readdir -nocomplain $dir] {

+		if {[string match $pattern $name]} {

+			lappend result $name

+		}

+	}

+

+	return $result

+}

+

+# glob entries in directory $dir and pattern $rem

+#

+proc _glob_do {dir rem} {

+	# Take one level from rem

+	# Avoid regexp here

+	set i [string first / $rem]

+	if {$i < 0} {

+		set pattern $rem

+		set rempattern ""

+	} else {

+		set j $i

+		incr j

+		incr i -1

+		set pattern [string range $rem 0 $i]

+		set rempattern [string range $rem $j end]

+	}

+

+	# Determine the appropriate separator and globbing dir

+	set sep /

+	set globdir $dir

+	if {[string match "*/" $dir]} {

+		set sep ""

+	} elseif {$dir eq ""} {

+		set globdir .

+		set sep ""

+	}

+

+	set result {}

+

+	# Use readdir and select all files which match the pattern

+	foreach f [_glob_readdir_pattern $globdir $pattern] {

+		if {$rempattern eq ""} {

+			# This is a terminal entry, so add it

+			lappend result $dir$sep$f

+		} else {

+			# Expany any entries at this level and add them

+			lappend result {expand}[_glob_do $dir$sep$f $rempattern]

+		}

+	}

+	return $result

+}

+

+# Implements the Tcl glob command

+#

+# Usage: glob ?-nocomplain? pattern ...

+#

+# Patterns use string match pattern matching for each

+# directory level.

+#

+# e.g. glob te[a-e]*/*.tcl

+#

+proc glob {args} {

+	set nocomplain 0

+

+	if {[lindex $args 0] eq "-nocomplain"} {

+		set nocomplain 1

+		set args [lrange $args 1 end]

+	}

+

+	set result {}

+	foreach pattern $args {

+		if {$pattern eq "/"} {

+			lappend result /

+		} elseif {[string match "/*" $pattern]} {

+			lappend result {expand}[_glob_do / [string range $pattern 1 end]]

+		} else {

+			lappend result {expand}[_glob_do "" $pattern]

+		}

+	}

+

+	if {$nocomplain == 0 && [llength $result] == 0} {

+		error "no files matched glob patterns"

+	}

+

+	return $result

+}

diff --git a/jim-readdir.c b/jim-readdir.c
new file mode 100644
index 0000000..8dcd4cf
--- /dev/null
+++ b/jim-readdir.c
@@ -0,0 +1,122 @@
+/*

+ * (c) 2008 Steve Bennett <steveb@worware.net.au>

+ *

+ * Tcl readdir command.

+ *

+ * The FreeBSD license

+ * 

+ * Redistribution and use in source and binary forms, with or without

+ * modification, are permitted provided that the following conditions

+ * are met:

+ * 

+ * 1. Redistributions of source code must retain the above copyright

+ *    notice, this list of conditions and the following disclaimer.

+ * 2. Redistributions in binary form must reproduce the above

+ *    copyright notice, this list of conditions and the following

+ *    disclaimer in the documentation and/or other materials

+ *    provided with the distribution.

+ * 

+ * THIS SOFTWARE IS PROVIDED BY THE JIM TCL PROJECT ``AS IS'' AND ANY

+ * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,

+ * THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A

+ * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE

+ * JIM TCL PROJECT OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT,

+ * INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES

+ * (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS

+ * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)

+ * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,

+ * STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)

+ * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF

+ * ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

+ * 

+ * The views and conclusions contained in the software and documentation

+ * are those of the authors and should not be interpreted as representing

+ * official policies, either expressed or implied, of the Jim Tcl Project.

+ *

+ * Based on original work by:

+ *-----------------------------------------------------------------------------

+ * Copyright 1991-1994 Karl Lehenbauer and Mark Diekhans.

+ *

+ * Permission to use, copy, modify, and distribute this software and its

+ * documentation for any purpose and without fee is hereby granted, provided

+ * that the above copyright notice appear in all copies.  Karl Lehenbauer and

+ * Mark Diekhans make no representations about the suitability of this

+ * software for any purpose.  It is provided "as is" without express or

+ * implied warranty.

+ *-----------------------------------------------------------------------------

+ */

+

+#include <errno.h>

+#include <stdio.h>

+#include <string.h>

+#include <dirent.h>

+

+#define JIM_EXTENSION

+#include "jim.h"

+

+/*

+ *-----------------------------------------------------------------------------

+ *

+ * Jim_ReaddirCmd --

+ *     Implements the rename TCL command:

+ *         readdir ?-nocomplain? dirPath

+ *

+ * Results:

+ *      Standard TCL result.

+ *-----------------------------------------------------------------------------

+ */

+int

+Jim_ReaddirCmd (Jim_Interp *interp, int argc, Jim_Obj *const *argv)

+{

+    const char          *dirPath;

+    DIR           *dirPtr;

+    struct dirent *entryPtr;

+    int nocomplain = 0;

+

+    if (argc == 3 && Jim_CompareStringImmediate(interp, argv[1], "-nocomplain")) {

+        nocomplain = 1;

+    }

+    if (argc != 2 && !nocomplain) {

+        Jim_WrongNumArgs(interp, 1, argv, "?-nocomplain? dirPath");

+        return JIM_ERR;

+    }

+

+    dirPath = Jim_GetString(argv[1 + nocomplain], NULL);

+

+    dirPtr = opendir (dirPath);

+    if (dirPtr == NULL)  {

+        if (nocomplain) {

+            return JIM_OK;

+        }

+        Jim_SetResultString(interp, strerror(errno), -1);

+        return JIM_ERR;

+    }

+    Jim_SetResultString(interp, strerror(errno), -1);

+

+    Jim_SetResult(interp, Jim_NewListObj(interp, NULL, 0));

+

+    while ((entryPtr = readdir (dirPtr)) != NULL) {

+        if (entryPtr->d_name [0] == '.') {

+            if (entryPtr->d_name [1] == '\0') {

+                continue;

+            }

+            if ((entryPtr->d_name [1] == '.') &&

+                (entryPtr->d_name [2] == '\0'))

+                continue;

+        }

+        Jim_ListAppendElement(interp, Jim_GetResult(interp), Jim_NewStringObj(interp, entryPtr->d_name, -1));

+    }

+    closedir (dirPtr);

+

+    return JIM_OK;

+}

+

+int Jim_OnLoad(Jim_Interp *interp)

+{

+    Jim_InitExtension(interp);

+    if (Jim_PackageProvide(interp, "readdir", "1.0", JIM_ERRMSG) != JIM_OK) {

+        return JIM_ERR;

+    }

+    Jim_CreateCommand(interp, "readdir", Jim_ReaddirCmd, NULL, NULL);

+    return JIM_OK;

+}