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

134 lines (120 sloc) 3.897 kB
# (c) 2008 Steve Bennett <steveb@workware.net.au>
#
# Implements a Tcl-compatible glob command based on readdir
#
# The FreeBSD license
#
# Redistribution and use in source and binary forms, with or without
# modification, are permitted provided that the following conditions
# are met:
#
# 1. Redistributions of source code must retain the above copyright
# notice, this list of conditions and the following disclaimer.
# 2. Redistributions in binary form must reproduce the above
# copyright notice, this list of conditions and the following
# disclaimer in the documentation and/or other materials
# provided with the distribution.
#
# THIS SOFTWARE IS PROVIDED BY THE JIM TCL PROJECT ``AS IS'' AND ANY
# EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
# THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
# PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
# JIM TCL PROJECT OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT,
# INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
# (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
# OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
# HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
# STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
# ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
# ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
#
# The views and conclusions contained in the software and documentation
# are those of the authors and should not be interpreted as representing
# official policies, either expressed or implied, of the Jim Tcl Project.
package provide glob 1.0
package require readdir 1.0
# If $dir is a directory, return a list of all entries
# it contains which match $pattern
#
proc _glob_readdir_pattern {dir pattern} {
set result {}
# readdir doesn't return . or .., so simulate it here
if {$pattern eq "." || $pattern eq ".."} {
return $pattern
}
# Use -nocomplain here to return nothing if $dir is not a directory
foreach name [readdir -nocomplain $dir] {
if {[string match $pattern $name]} {
lappend result $name
}
}
return $result
}
# glob entries in directory $dir and pattern $rem
#
proc _glob_do {dir rem} {
# Take one level from rem
# Avoid regexp here
set i [string first / $rem]
if {$i < 0} {
set pattern $rem
set rempattern ""
} else {
set j $i
incr j
incr i -1
set pattern [string range $rem 0 $i]
set rempattern [string range $rem $j end]
}
# Determine the appropriate separator and globbing dir
set sep /
set globdir $dir
if {[string match "*/" $dir]} {
set sep ""
} elseif {$dir eq ""} {
set globdir .
set sep ""
}
set result {}
# Use readdir and select all files which match the pattern
foreach f [_glob_readdir_pattern $globdir $pattern] {
if {$rempattern eq ""} {
# This is a terminal entry, so add it
lappend result $dir$sep$f
} else {
# Expany any entries at this level and add them
lappend result {expand}[_glob_do $dir$sep$f $rempattern]
}
}
return $result
}
# Implements the Tcl glob command
#
# Usage: glob ?-nocomplain? pattern ...
#
# Patterns use string match pattern matching for each
# directory level.
#
# e.g. glob te[a-e]*/*.tcl
#
proc glob {args} {
set nocomplain 0
if {[lindex $args 0] eq "-nocomplain"} {
set nocomplain 1
set args [lrange $args 1 end]
}
set result {}
foreach pattern $args {
if {$pattern eq "/"} {
lappend result /
} elseif {[string match "/*" $pattern]} {
lappend result {expand}[_glob_do / [string range $pattern 1 end]]
} else {
lappend result {expand}[_glob_do "" $pattern]
}
}
if {$nocomplain == 0 && [llength $result] == 0} {
error "no files matched glob patterns"
}
return $result
}
Jump to Line
Something went wrong with that request. Please try again.