diff options
| author | Steve Bennett <steveb@workware.net.au> | 2009-07-27 11:21:58 +1000 |
|---|---|---|
| committer | Steve Bennett <steveb@workware.net.au> | 2010-10-15 10:11:01 +1000 |
| commit | e273954f2766d3ccc5fa9c0ef47b64f51d88f377 (patch) | |
| tree | 696598c5060e4d8995fe54a78957b224962738fe /glob.tcl | |
| parent | 1bb6166bdb5e2a92b50e0ea178fa55a5f0d7261f (diff) | |
| download | jimtcl-e273954f2766d3ccc5fa9c0ef47b64f51d88f377.zip jimtcl-e273954f2766d3ccc5fa9c0ef47b64f51d88f377.tar.gz jimtcl-e273954f2766d3ccc5fa9c0ef47b64f51d88f377.tar.bz2 | |
Import various tinytcl compatibility packages
Also fix 'file type'
Diffstat (limited to 'glob.tcl')
| -rw-r--r-- | glob.tcl | 133 |
1 files changed, 133 insertions, 0 deletions
diff --git a/glob.tcl b/glob.tcl new file mode 100644 index 0000000..9529df0 --- /dev/null +++ b/glob.tcl @@ -0,0 +1,133 @@ +# (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
+}
|