Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
branch: master
Fetching contributors…

Cannot retrieve contributors at this time

197 lines (177 sloc) 4.457 kb
# 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
}
Jump to Line
Something went wrong with that request. Please try again.