Add support for glob -directory

Implement support for the -directory option to the [glob]
command. The -tails option is accepted for Tcl compatibility,
but ignored; the command always behaves as if -tails were given.

1 files changed, 137 insertions, 93 deletions

diff --git a/glob.tcl b/glob.tcl
index 4bfb4f9..5e6abb5 100644
--- a/glob.tcl
+++ b/glob.tcl
@@ -1,127 +1,171 @@
-# Implements a Tcl-compatible glob command based on readdir
+# Implements a mostly Tcl-compatible glob command based on readdir
 #
 # (c) 2008 Steve Bennett <steveb@workware.net.au>
+# (c) 2012 Alexander Shpilkin <ashpilkin@gmail.com>
 #
 # See LICENCE in this directory for licensing.
 
 package require readdir
 
-# Implements the Tcl glob command
-#
-# Usage: glob ?-nocomplain? pattern ...
-#
-# Patterns use 'string match' (glob) pattern matching for each
-# directory level, plus support for braced alternations.
-#
-# e.g. glob "te[a-e]*/*.{c,tcl}"
-#
-# Note: files starting with . will only be returned if matching component
-#       of the pattern starts with .
-proc glob {args} {
-
-	# If $dir is a directory, return a list of all entries
-	# it contains which match $pattern
-	#
-	local proc glob.readdir_pattern {dir pattern} {
-		set result {}
-
-		# readdir doesn't return . or .., so simulate it here
-		if {$pattern in {. ..}} {
-			return $pattern
+# Return a list of all entries in $dir that match the pattern.
+proc glob.globdir {dir pattern} {
+	set result {}
+	set files [readdir $dir]
+	lappend files . ..
+
+	foreach name $files {
+		if {[string match $pattern $name]} {
+			# Starting dots match only explicitly
+			if {[string index $name 0] eq "." && [string index $pattern 0] ne "."} {
+				continue
+			}
+			lappend result $name
 		}
+	}
 
-		# If the pattern isn't actually a pattern...
-		if {[string match {*[[*?]*} $pattern]} {
-			# Use -nocomplain here to return nothing if $dir is not a directory
-			set files [readdir -nocomplain $dir]
-		} elseif {[file isdir $dir] && [file exists [file join $dir $pattern]]} {
-			set files [list $pattern]
-		} else {
-			set files ""
-		}
+	return $result
+}
 
-		foreach name $files {
-			if {[string match $pattern $name]} {
-				# Only include entries starting with . if the pattern starts with .
-				if {[string index $name 0] eq "." && [string index $pattern 0] ne "."} {
-					continue
+# Return the list of patterns resulting from expanding any braced
+# alternatives inside the given pattern, prepending the unprocessed
+# part of the pattern. Does _not_ handle escaped braces or commas.
+proc glob.explode {pattern} {
+	set oldexp {}
+	set newexp {""}
+
+	while 1 {
+		set oldexp $newexp
+		set newexp {}
+		set ob [string first \{ $pattern]
+		set cb [string first \} $pattern]
+
+		if {$ob < $cb && $ob != -1} {
+			set mid [string range $pattern 0 $ob-1]
+			set subexp [lassign [glob.explode [string range $pattern $ob+1 end]] pattern]
+			if {$pattern eq ""} {
+				error "unmatched open brace in glob pattern"
+			}
+			set pattern [string range $pattern 1 end]
+
+			foreach subs $subexp {
+				foreach sub [split $subs ,] {
+					foreach old $oldexp {
+						lappend newexp $old$mid$sub
+					}
 				}
-				lappend result $name
 			}
+		} elseif {$cb != -1} {
+			set suf  [string range $pattern 0 $cb-1]
+			set rest [string range $pattern $cb end]
+			break
+		} else {
+			set suf  $pattern
+			set rest ""
+			break
 		}
+	}
+
+	foreach old $oldexp {
+		lappend newexp $old$suf
+	}
+	linsert $newexp 0 $rest
+}
 
-		return $result
+# Core glob implementation. Returns a list of files/directories inside
+# base matching pattern, in {realname name} pairs.
+proc glob.glob {base pattern} {
+	set dir [file dirname $pattern]
+	if {$pattern eq $dir || $pattern eq ""} {
+		return [list [file join $base $dir] $pattern]
+	} elseif {$pattern eq [file tail $pattern]} {
+		set dir ""
 	}
 
-	# If the pattern contains a braced expression, return a list of
-	# patterns with the braces expanded. {c,b}* => c* b*
-	# Otherwise just return the pattern
-	# Note: Only supports one braced expression. i.e. not {a,b}*{c,d}*
-	proc glob.expandbraces {pattern} {
-		# Avoid regexp for dependency reasons.
-		# XXX: Doesn't handle backslashed braces
-		if {[set fb [string first "\{" $pattern]] < 0} {
-			return [list $pattern]
+	# Recursively expand the parent directory
+	set dirlist [glob.glob $base $dir]
+	set pattern [file tail $pattern]
+
+	# Collect the files/directories
+	set result {}
+	foreach {realdir dir} $dirlist {
+		if {![file isdir $realdir]} {
+			continue
 		}
-		if {[set nb [string first "\}" $pattern $fb]] < 0} {
-			return [list $pattern]
+		if {[string index $dir end] ne "/" && $dir ne ""} {
+			append dir /
 		}
-		set before [string range $pattern 0 $fb-1]
-		set braced [string range $pattern $fb+1 $nb-1]
-		set after [string range $pattern $nb+1 end]
-
-		lmap part [split $braced ,] {
-			set pat $before$part$after
+		foreach name [glob.globdir $realdir $pattern] {
+			lappend result [file join $realdir $name] $dir$name
 		}
 	}
+	return $result
+}
 
-	# Core glob implementation. Returns a list of files/directories matching the pattern
-	proc glob.glob {pattern} {
-		set dir [file dirname $pattern]
-		if {$dir eq $pattern} {
-			# At the top level
-			return [list $dir]
-		}
+# Implements the Tcl glob command
+#
+# Usage: glob ?-nocomplain? ?-directory dir? ?--? pattern ...
+#
+# Patterns use 'string match' (glob) pattern matching for each
+# directory level, plus support for braced alternations.
+#
+# e.g. glob {te[a-e]*/*.{c,tcl}}
+#
+# Note: files starting with . will only be returned if matching component
+#       of the pattern starts with .
+proc glob {args} {
+	set nocomplain 0
+	set base ""
 
-		# Recursively expand the parent directory
-		set dirlist [glob.glob $dir]
-		set pattern [file tail $pattern]
-
-		# Now collect the fiels/directories
-		set result {}
-		foreach dir $dirlist {
-			set globdir $dir
-			if {[string match "*/" $dir]} {
-				set sep ""
-			} elseif {$dir eq "."} {
-				set globdir ""
-				set sep ""
-			} else {
-				set sep /
-			}
-			foreach pat [glob.expandbraces $pattern] {
-				foreach name [glob.readdir_pattern $dir $pat] {
-					lappend result $globdir$sep$name
+	while {[llength $args] > 0} {
+		switch -glob -- [set switch [lindex $args 0]] {
+			-directory {
+				if {[llength $args] < 2} {
+					return -code error "missing argument to \"$switch\""
 				}
+				set base [lindex $args 1]
+				set args [lrange $args 1 end]
+			}
+			-nocomplain {
+				set nocomplain 1
+			}
+			-tails {
+				# Ignored for Tcl compatibility
 			}
-		}
-		return $result
-	}
-
-	# Start of main glob
-	set nocomplain 0
 
-	if {[lindex $args 0] eq "-nocomplain"} {
-		set nocomplain 1
+			-* {
+				return -code error "bad option \"$switch\": must be -directory, -nocomplain, -tails, or --"
+			}
+			-- -
+			*  {
+				break
+			}
+		}
 		set args [lrange $args 1 end]
 	}
+	if {[llength $args] < 1} {
+		return -code error "wrong # args: should be \"glob ?options? pattern ?pattern ...?\""
+	}
 
 	set result {}
 	foreach pattern $args {
-		lappend result {*}[glob.glob $pattern]
-	}
+		set pattern [string map {
+			\\\\ \x01 \\\{ \x02 \\\} \x03 \\, \x04
+		} $pattern]
+		set patexps [lassign [glob.explode $pattern] rest]
+		if {$rest ne ""} {
+			return -code error "unmatched close brace in glob pattern"
+		}
+		foreach patexp $patexps {
+			set patexp [string map {
+				\x01 \\\\ \x02 \{ \x03 \} \x04 ,
+			} $patexp]
+			foreach {realname name} [glob.glob $base $patexp] {
+				lappend result $name
+			}
+		}
+	}	
 
-	if {$nocomplain == 0 && [llength $result] == 0} {
+	if {!$nocomplain && [llength $result] == 0} {
 		return -code error "no files matched glob patterns"
 	}