1 # (c) 2008 Steve Bennett <steveb@workware.net.au>
3 # Implements a Tcl-compatible glob command based on readdir
7 # Redistribution and use in source and binary forms, with or without
8 # modification, are permitted provided that the following conditions
11 # 1. Redistributions of source code must retain the above copyright
12 # notice, this list of conditions and the following disclaimer.
13 # 2. Redistributions in binary form must reproduce the above
14 # copyright notice, this list of conditions and the following
15 # disclaimer in the documentation and/or other materials
16 # provided with the distribution.
18 # THIS SOFTWARE IS PROVIDED BY THE JIM TCL PROJECT ``AS IS'' AND ANY
19 # EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
20 # THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
21 # PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
22 # JIM TCL PROJECT OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT,
23 # INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
24 # (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
25 # OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
26 # HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
27 # STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
28 # ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
29 # ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
31 # The views and conclusions contained in the software and documentation
32 # are those of the authors and should not be interpreted as representing
33 # official policies, either expressed or implied, of the Jim Tcl Project.
35 package provide
glob 1.0
36 package require readdir
1.0
38 # If $dir is a directory, return a list of all entries
39 # it contains which match $pattern
41 proc _glob_readdir_pattern
{dir pattern
} {
44 # readdir doesn't return . or .., so simulate it here
45 if {$pattern eq
"." ||
$pattern eq
".."} {
48 # Use -nocomplain here to return nothing if $dir is not a directory
49 foreach name
[readdir
-nocomplain $dir] {
50 if {[string match
$pattern $name]} {
58 # glob entries in directory $dir and pattern $rem
60 proc _glob_do
{dir rem
} {
61 # Take one level from rem
63 set i
[string first
/ $rem]
71 set pattern
[string range
$rem 0 $i]
72 set rempattern
[string range
$rem $j end
]
75 # Determine the appropriate separator and globbing dir
78 if {[string match
"*/" $dir]} {
80 } elseif
{$dir eq
""} {
87 # Use readdir and select all files which match the pattern
88 foreach f
[_glob_readdir_pattern
$globdir $pattern] {
89 if {$rempattern eq
""} {
90 # This is a terminal entry, so add it
91 lappend result
$dir$sep$f
93 # Expany any entries at this level and add them
94 lappend result
{expand
}[_glob_do
$dir$sep$f $rempattern]
100 # Implements the Tcl glob command
102 # Usage: glob ?-nocomplain? pattern ...
104 # Patterns use string match pattern matching for each
107 # e.g. glob te[a-e]*/*.tcl
112 if {[lindex $args 0] eq
"-nocomplain"} {
114 set args
[lrange $args 1 end
]
118 foreach pattern
$args {
119 if {$pattern eq
"/"} {
121 } elseif
{[string match
"/*" $pattern]} {
122 lappend result
{expand
}[_glob_do
/ [string range
$pattern 1 end
]]
124 lappend result
{expand
}[_glob_do
"" $pattern]
128 if {$nocomplain == 0 && [llength $result] == 0} {
129 error "no files matched glob patterns"