bootstrap package support
[jimtcl.git] / glob.tcl
blob995885728a08ef74f2011d6a87706830079d590b
1 # Implements a mostly Tcl-compatible glob command based on readdir
3 # (c) 2008 Steve Bennett <steveb@workware.net.au>
4 # (c) 2012 Alexander Shpilkin <ashpilkin@gmail.com>
6 # See LICENCE in this directory for licensing.
8 package require readdir
10 # Return a list of all entries in $dir that match the pattern.
11 proc glob.globdir {dir pattern} {
12 if {[file exists $dir/$pattern]} {
13 # Simple case
14 return [list $pattern]
17 set result {}
18 set files [readdir $dir]
19 lappend files . ..
21 foreach name $files {
22 if {[string match $pattern $name]} {
23 # Starting dots match only explicitly
24 if {[string index $name 0] eq "." && [string index $pattern 0] ne "."} {
25 continue
27 lappend result $name
31 return $result
34 # Return the list of patterns resulting from expanding any braced
35 # alternatives inside the given pattern, prepending the unprocessed
36 # part of the pattern. Does _not_ handle escaped braces or commas.
37 proc glob.explode {pattern} {
38 set oldexp {}
39 set newexp {""}
41 while 1 {
42 set oldexp $newexp
43 set newexp {}
44 set ob [string first \{ $pattern]
45 set cb [string first \} $pattern]
47 if {$ob < $cb && $ob != -1} {
48 set mid [string range $pattern 0 $ob-1]
49 set subexp [lassign [glob.explode [string range $pattern $ob+1 end]] pattern]
50 if {$pattern eq ""} {
51 error "unmatched open brace in glob pattern"
53 set pattern [string range $pattern 1 end]
55 foreach subs $subexp {
56 foreach sub [split $subs ,] {
57 foreach old $oldexp {
58 lappend newexp $old$mid$sub
62 } elseif {$cb != -1} {
63 set suf [string range $pattern 0 $cb-1]
64 set rest [string range $pattern $cb end]
65 break
66 } else {
67 set suf $pattern
68 set rest ""
69 break
73 foreach old $oldexp {
74 lappend newexp $old$suf
76 list $rest {*}$newexp
79 # Core glob implementation. Returns a list of files/directories inside
80 # base matching pattern, in {realname name} pairs.
81 proc glob.glob {base pattern} {
82 set dir [file dirname $pattern]
83 if {$pattern eq $dir || $pattern eq ""} {
84 return [list [file join $base $dir] $pattern]
85 } elseif {$pattern eq [file tail $pattern]} {
86 set dir ""
89 # Recursively expand the parent directory
90 set dirlist [glob.glob $base $dir]
91 set pattern [file tail $pattern]
93 # Collect the files/directories
94 set result {}
95 foreach {realdir dir} $dirlist {
96 if {![file isdir $realdir]} {
97 continue
99 if {[string index $dir end] ne "/" && $dir ne ""} {
100 append dir /
102 foreach name [glob.globdir $realdir $pattern] {
103 lappend result [file join $realdir $name] $dir$name
106 return $result
109 # Implements the Tcl glob command
111 # Usage: glob ?-nocomplain? ?-directory dir? ?--? pattern ...
113 # Patterns use 'string match' (glob) pattern matching for each
114 # directory level, plus support for braced alternations.
116 # e.g. glob {te[a-e]*/*.{c,tcl}}
118 # Note: files starting with . will only be returned if matching component
119 # of the pattern starts with .
120 proc glob {args} {
121 set nocomplain 0
122 set base ""
123 set tails 0
125 set n 0
126 foreach arg $args {
127 if {[info exists param]} {
128 set $param $arg
129 unset param
130 incr n
131 continue
133 switch -glob -- $arg {
134 -d* {
135 set switch $arg
136 set param base
138 -n* {
139 set nocomplain 1
141 -ta* {
142 set tails 1
144 -- {
145 incr n
146 break
148 -* {
149 return -code error "bad option \"$arg\": must be -directory, -nocomplain, -tails, or --"
152 break
155 incr n
157 if {[info exists param]} {
158 return -code error "missing argument to \"$switch\""
160 if {[llength $args] <= $n} {
161 return -code error "wrong # args: should be \"glob ?options? pattern ?pattern ...?\""
164 set args [lrange $args $n end]
166 set result {}
167 foreach pattern $args {
168 set escpattern [string map {
169 \\\\ \x01 \\\{ \x02 \\\} \x03 \\, \x04
170 } $pattern]
171 set patexps [lassign [glob.explode $escpattern] rest]
172 if {$rest ne ""} {
173 return -code error "unmatched close brace in glob pattern"
175 foreach patexp $patexps {
176 set patexp [string map {
177 \x01 \\\\ \x02 \{ \x03 \} \x04 ,
178 } $patexp]
179 foreach {realname name} [glob.glob $base $patexp] {
180 incr n
181 if {$tails} {
182 lappend result $name
183 } else {
184 lappend result [file join $base $name]
190 if {!$nocomplain && [llength $result] == 0} {
191 set s $(([llength $args] > 1) ? "s" : "")
192 return -code error "no files matched glob pattern$s \"[join $args]\""
195 return $result