1# Implements a Tcl-compatible glob command based on readdir
2#
3# (c) 2008 Steve Bennett <steveb@workware.net.au>
4#
5# See LICENCE in this directory for licensing.
6
7package require readdir
8
9# Implements the Tcl glob command
10#
11# Usage: glob ?-nocomplain? pattern ...
12#
13# Patterns use 'string match' (glob) pattern matching for each
14# directory level, plus support for braced alternations.
15#
16# e.g. glob "te[a-e]*/*.{c,tcl}"
17#
18# Note: files starting with . will only be returned if matching component
19#       of the pattern starts with .
20proc glob {args} {
21
22	# If $dir is a directory, return a list of all entries
23	# it contains which match $pattern
24	#
25	local proc glob.readdir_pattern {dir pattern} {
26		set result {}
27
28		# readdir doesn't return . or .., so simulate it here
29		if {$pattern in {. ..}} {
30			return $pattern
31		}
32
33		# If the pattern isn't actually a pattern...
34		if {[string match {*[*?]*} $pattern]} {
35			# Use -nocomplain here to return nothing if $dir is not a directory
36			set files [readdir -nocomplain $dir]
37		} elseif {[file isdir $dir] && [file exists $dir/$pattern]} {
38			set files [list $pattern]
39		} else {
40			set files ""
41		}
42
43		foreach name $files {
44			if {[string match $pattern $name]} {
45				# Only include entries starting with . if the pattern starts with .
46				if {[string index $name 0] eq "." && [string index $pattern 0] ne "."} {
47					continue
48				}
49				lappend result $name
50			}
51		}
52
53		return $result
54	}
55
56	# If the pattern contains a braced expression, return a list of
57	# patterns with the braces expanded. {c,b}* => c* b*
58	# Otherwise just return the pattern
59	# Note: Only supports one braced expression. i.e. not {a,b}*{c,d}*
60	proc glob.expandbraces {pattern} {
61		# Avoid regexp for dependency reasons.
62		# XXX: Doesn't handle backslashed braces
63		if {[set fb [string first "\{" $pattern]] < 0} {
64			return $pattern
65		}
66		if {[set nb [string first "\}" $pattern $fb]] < 0} {
67			return $pattern
68		}
69		set before [string range $pattern 0 $fb-1]
70		set braced [string range $pattern $fb+1 $nb-1]
71		set after [string range $pattern $nb+1 end]
72
73		lmap part [split $braced ,] {
74			set pat $before$part$after
75		}
76	}
77
78	# Core glob implementation. Returns a list of files/directories matching the pattern
79	proc glob.glob {pattern} {
80		set dir [file dirname $pattern]
81		if {$dir eq $pattern} {
82			# At the top level
83			return [list $dir]
84		}
85
86		# Recursively expand the parent directory
87		set dirlist [glob.glob $dir]
88		set pattern [file tail $pattern]
89
90		# Now collect the fiels/directories
91		set result {}
92		foreach dir $dirlist {
93			set globdir $dir
94			if {[string match "*/" $dir]} {
95				set sep ""
96			} elseif {$dir eq "."} {
97				set globdir ""
98				set sep ""
99			} else {
100				set sep /
101			}
102			foreach pat [glob.expandbraces $pattern] {
103				foreach name [glob.readdir_pattern $dir $pat] {
104					lappend result $globdir$sep$name
105				}
106			}
107		}
108		return $result
109	}
110
111	# Start of main glob
112	set nocomplain 0
113
114	if {[lindex $args 0] eq "-nocomplain"} {
115		set nocomplain 1
116		set args [lrange $args 1 end]
117	}
118
119	set result {}
120	foreach pattern $args {
121		lappend result {*}[glob.glob $pattern]
122	}
123
124	if {$nocomplain == 0 && [llength $result] == 0} {
125		return -code error "no files matched glob patterns"
126	}
127
128	return $result
129}
130