jim-glob-1.0.tcl

   1 # (c) 2008 Steve Bennett <steveb@workware.net.au>
   2 #
   3 # Implements a Tcl-compatible glob command based on readdir
   4 #
   5 # The FreeBSD license
   6 #
   7 # Redistribution and use in source and binary forms, with or without
   8 # modification, are permitted provided that the following conditions
   9 # are met:
  10 #
  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.
  17 #
  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.
  30 #
  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.
  34
  35 package provide glob 1.0
  36 package require readdir 1.0
  37
  38 # If $dir is a directory, return a list of all entries
  39 # it contains which match $pattern
  40 #
  41 proc _glob_readdir_pattern {dir pattern} {
  42         set result {}
  43
  44         # readdir doesn't return . or .., so simulate it here
  45         if {$pattern eq "." || $pattern eq ".."} {
  46                 return $pattern
  47         }
  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]} {
  51                         lappend result $name
  52                 }
  53         }
  54
  55         return $result
  56 }
  57
  58 # glob entries in directory $dir and pattern $rem
  59 #
  60 proc _glob_do {dir rem} {
  61         # Take one level from rem
  62         # Avoid regexp here
  63         set i [string first / $rem]
  64         if {$i < 0} {
  65                 set pattern $rem
  66                 set rempattern ""
  67         } else {
  68                 set j $i
  69                 incr j
  70                 incr i -1
  71                 set pattern [string range $rem 0 $i]
  72                 set rempattern [string range $rem $j end]
  73         }
  74
  75         # Determine the appropriate separator and globbing dir
  76         set sep /
  77         set globdir $dir
  78         if {[string match "*/" $dir]} {
  79                 set sep ""
  80         } elseif {$dir eq ""} {
  81                 set globdir .
  82                 set sep ""
  83         }
  84
  85         set result {}
  86
  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
  92                 } else {
  93                         # Expany any entries at this level and add them
  94                         lappend result {expand}[_glob_do $dir$sep$f $rempattern]
  95                 }
  96         }
  97         return $result
  98 }
  99
 100 # Implements the Tcl glob command
 101 #
 102 # Usage: glob ?-nocomplain? pattern ...
 103 #
 104 # Patterns use string match pattern matching for each
 105 # directory level.
 106 #
 107 # e.g. glob te[a-e]*/*.tcl
 108 #
 109 proc glob {args} {
 110         set nocomplain 0
 111
 112         if {[lindex $args 0] eq "-nocomplain"} {
 113                 set nocomplain 1
 114                 set args [lrange $args 1 end]
 115         }
 116
 117         set result {}
 118         foreach pattern $args {
 119                 if {$pattern eq "/"} {
 120                         lappend result /
 121                 } elseif {[string match "/*" $pattern]} {
 122                         lappend result {expand}[_glob_do / [string range $pattern 1 end]]
 123                 } else {
 124                         lappend result {expand}[_glob_do "" $pattern]
 125                 }
 126         }
 127
 128         if {$nocomplain == 0 && [llength $result] == 0} {
 129                 error "no files matched glob patterns"
 130         }
 131
 132         return $result
 133 }