diff options
Diffstat (limited to 'glob.tcl')
| -rw-r--r-- | glob.tcl | 196 |
1 files changed, 196 insertions, 0 deletions
diff --git a/glob.tcl b/glob.tcl new file mode 100644 index 0000000..9958857 --- /dev/null +++ b/glob.tcl @@ -0,0 +1,196 @@ +# 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 + +# Return a list of all entries in $dir that match the pattern. +proc glob.globdir {dir pattern} { + if {[file exists $dir/$pattern]} { + # Simple case + return [list $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 + } + } + + return $result +} + +# 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 + } + } + } + } 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 + } + list $rest {*}$newexp +} + +# 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 "" + } + + # 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 {[string index $dir end] ne "/" && $dir ne ""} { + append dir / + } + foreach name [glob.globdir $realdir $pattern] { + lappend result [file join $realdir $name] $dir$name + } + } + return $result +} + +# 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 "" + set tails 0 + + set n 0 + foreach arg $args { + if {[info exists param]} { + set $param $arg + unset param + incr n + continue + } + switch -glob -- $arg { + -d* { + set switch $arg + set param base + } + -n* { + set nocomplain 1 + } + -ta* { + set tails 1 + } + -- { + incr n + break + } + -* { + return -code error "bad option \"$arg\": must be -directory, -nocomplain, -tails, or --" + } + * { + break + } + } + incr n + } + if {[info exists param]} { + return -code error "missing argument to \"$switch\"" + } + if {[llength $args] <= $n} { + return -code error "wrong # args: should be \"glob ?options? pattern ?pattern ...?\"" + } + + set args [lrange $args $n end] + + set result {} + foreach pattern $args { + set escpattern [string map { + \\\\ \x01 \\\{ \x02 \\\} \x03 \\, \x04 + } $pattern] + set patexps [lassign [glob.explode $escpattern] 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] { + incr n + if {$tails} { + lappend result $name + } else { + lappend result [file join $base $name] + } + } + } + } + + if {!$nocomplain && [llength $result] == 0} { + set s $(([llength $args] > 1) ? "s" : "") + return -code error "no files matched glob pattern$s \"[join $args]\"" + } + + return $result +} |