-if 0 {
-########################
-
-globfind.tcl --
-
-Written by Stephen Huntley (stephen.huntley@alum.mit.edu)
-License: Tcl license
-Version 1.5
-
-The proc globfind is a replacement for tcllib's fileutil::find
-
-Usage: globfind ?basedir ?filtercmd? ?switches??
-
-Options:
-
-basedir - the directory from which to start the search. Defaults to current directory.
-
-filtercmd - Tcl command; for each file found in the basedir, the filename will be
-appended to filtercmd and the result will be evaluated. The evaluation should return
-0 or 1; only files whose return code is 1 will be included in the final return result.
-
-switches - The switches will "prefilter" the results before the filtercmd is applied. The
-available switches are:
-
- -depth - sets the number of levels down from the basedir into which the
- filesystem hierarchy will be searched. A value of zero is interpreted
- as infinite depth.
-
- -pattern - a glob-style filename-matching wildcard. ex: -pattern *.pdf
-
- -types - any value acceptable to the "types" switch of the glob command.
- ex: -types {d hidden}
-
-Side effects:
-
-If somewhere within the search space a directory is a link to another directory within
-the search space, then the variable ::globfind::REDUNDANCY will be set to 1 (otherwise
-it will be set to 0). The name of the redundant directory will be appended to the
-variable ::globfind::redundant_files. This may be used to help track down and eliminate
-infinitely looping links in the search space.
-
-Unlike fileutil::find, the name of the basedir will be included in the results if it fits
-the prefilter and filtercmd criteria (thus emulating the behavior of the standard Unix
-GNU find utility).
-
-----
-
-globfind is designed as a fast and simple alternative to fileutil::find. It takes
-advantage of glob's ability to use multiple patterns to scan deeply into a directory
-structure in a single command, hence the name.
-
-It reports symbolic links along with other files by default, but checks for nesting of
-links which might otherwise lead to infinite search loops. It reports hidden files by
-default unless the -types switch is used to specify exactly what is wanted.
-
-globfind may be used with Tcl versions earlier than 8.4, but emulation of missing
-features of the glob command in those versions will result in slower performance.
-
-globfind is generally two to three times faster than fileutil::find, and fractionally
-faster than perl's File::Find function for comparable searches.
-
-The filtercmd may be omitted if only prefiltering is desired; in this case it may be a
-bit faster to use the proc globtraverse, which uses the same basedir value and
-command-line switches as globfind, but does not take a filtercmd value.
-
-If one wanted to search for pdf files for example, one could use the command:
-
- globfind $basedir {string match -nocase *.pdf}
-
-It would, however, in this case be much faster to use:
-
- globtraverse $basedir -pattern *.pdf
-
-########################
-}
-
-
-package provide fileutil::globfind 1.5
-
-namespace eval ::fileutil::globfind {
-
-namespace export globfind globtraverse
-
-proc globfind {{basedir .} {filtercmd {}} args} {
- set returnFiles {}
- set types {}
- set basedir [file normalize $basedir]
-
- # account for possibility that filtercmd is missing by
- # reformatting $args variable:
- set args [concat [list $filtercmd] $args]
- if [expr fmod([llength $args],2)] {
- set filtercmd [lindex $args 0]
- set args [lrange $args 1 end]
- } else {
- set filtercmd {}
- }
-
- set filt [string length $filtercmd]
- set 83ok [package vsatisfies [package present Tcl] 8.3]
-
- # process command-line switches:
- foreach {flag value} $args {
- if {[string first $flag -types] >= 0} {set flag "-types"}
- if {[string first $flag -pattern] >= 0} {set flag "-pattern"}
- if {[string first $flag -depth] >= 0} {set flag "-depth"}
-
- switch -- $flag {
- -types {
- set types [list $value]
-
- # can't use -types pre-8.3, because it doesn't exist in glob command.
- # thus if it is specified, error out:
- if !$83ok {error {error: "-types" flag not supported in version 8.2 and earlier}}
-
- # bug in 8.3, if -types {hidden f} is used, possible crash. So disallow:
- if {(![package vcompare [package present Tcl] 8.3]) && ($tcl_platform(platform) == "unix") && ([lsearch $types "hidden"] >= 0) && ([lsearch $types "f"] >= 0)} {
- error {Tcl 8.3 bug: potential program crash if "-types {hidden f}" used}
- }
-
- set types "-types $types"
- }
- -pattern {set pattern [list $value]}
- -depth {set depth [expr [list $value]]}
- default {error "$flag: incorrect flag value"}
- }
- }
-
- # add basedir to result if it satisfies prefilter conditions:
- set returnFiles [eval [eval list globtraverse [list [file dirname $basedir]] $args -depth 1]]
- if {[lsearch -exact $returnFiles $basedir] >= 0} {set returnFiles [list $basedir]} else {set returnFiles {}}
- # get all files in basedir that satisfy prefilter conditions:
- set returnFiles [concat $returnFiles [eval [eval list globtraverse \$basedir $args]]]
-
- # get hidden files if no specific types requested:
- if {$types == {}} {
-
- # save redundant file values already gathered:
- set redundant_files {}
- if [set REDUNDANCY $[namespace current]::REDUNDANCY] {
- set redundant_files $[namespace current]::redundant_files
- }
-
- # get hidden files:
- set returnFiles [concat $returnFiles [eval [eval list globtraverse \$basedir $args -type hidden]]]
-
- # virtual filesystems ignore hidden tag, so just in case, filter out duplicates:
- set returnFiles [lsort -unique $returnFiles]
-
- # collate redundant file info:
- if $[namespace current]::REDUNDANCY {
- set [namespace current]::redundant_files [concat $[namespace current]::redundant_files $redundant_files]
- } else {
- set [namespace current]::redundant_files $redundant_files
- }
- set [namespace current]::REDUNDANCY [expr ($[namespace current]::REDUNDANCY || $REDUNDANCY)]
- }
-
- # apply filtercmd to prefiltered results if one is specified:
- if $filt {
- set filterFiles {}
- foreach filename $returnFiles {
- if [uplevel $filtercmd [list $filename]] {
- lappend filterFiles $filename
- }
- }
- } else {
- set filterFiles $returnFiles
- }
-
- return $filterFiles
-}
-
-proc globtraverse {{basedir .} args} {
- set [namespace current]::REDUNDANCY 0
- unset -nocomplain [namespace current]::redundant_files
- set depth 0
-
- # search 16 directory levels per iteration, glob can't handle more patterns than that at once.
- set maxDepth 16
-
- set pattern *
- set types {}
- set resultList {}
-
- set basedir [file normalize $basedir]
- if ![file isdirectory $basedir] {return}
-
- set baseDepth [llength [file split $basedir]] ; # calculate starting depth
-
- lappend checkDirs $basedir ; # initialize list of dirs to check
-
- # format basedir variable for later infinite loop checking:
- set basedir $basedir/
- set basedir [string map {// /} $basedir]
-
- set 83ok [package vsatisfies [package present Tcl] 8.3]
-
- # process command-line switches:
- foreach {flag value} $args {
- if {[string first $flag -types] >= 0} {set flag "-types"}
- if {[string first $flag -pattern] >= 0} {set flag "-pattern"}
- if {[string first $flag -depth] >= 0} {set flag "-depth"}
-
- switch -- $flag {
- -types {
- set types [list $value]
- if !$83ok {error {error: "-types" flag not supported in version 8.2 and earlier}}
- if {(![package vcompare [package present Tcl] 8.3]) && ($tcl_platform(platform) == "unix") && ([lsearch $types "hidden"] >= 0) && ([lsearch $types "f"] >= 0)} {
- error {Tcl 8.3 bug: potential program crash if "-types {hidden f}" used}
- }
- set types "-types $types"
- }
- -pattern {set pattern [list $value]}
- -depth {set depth [expr [list $value]]}
- default {error "$flag: incorrect flag value"}
- }
- }
-
- # Main result-gathering loop:
- while {[llength $checkDirs]} {
- set currentDir [lindex $checkDirs 0]
-
- set currentDepth [expr [llength [file split $currentDir]] - $baseDepth] ; # distance from start depth
-
- set searchDepth [expr $depth - $currentDepth] ; # distance from max depth to search to
-
- # build multi-pattern argument to feed to glob command:
- set globPatternTotal {}
- set globPattern *
- set incrPattern /*
- for {set i 1} {$i <= $maxDepth} {incr i} {
- set customPattern [string range $globPattern 0 end-1]
- append customPattern $pattern
- lappend globPatternTotal $customPattern
- append globPattern $incrPattern
- incr searchDepth -1
- if {$searchDepth == 0} {break}
- }
-
- # save pattern to use for iterative dir search later:
- set dirPattern [string range $globPattern 0 end-2]
-
- # glob pre-8.3 doesn't support -directory switch; emulate it if necessary:
- if $83ok {
- set contents [eval glob -nocomplain -directory \$currentDir $types -- $globPatternTotal]
- } else {
- set wd [pwd]
- set newContents {}
- cd $currentDir
- if [catch {set contents [eval glob -nocomplain -- $globPatternTotal]} err] {
- cd $wd
- error $err
- }
- cd $wd
- foreach item $contents {
- set item [file join $currentDir $item]
- lappend newContents $item
- }
- set contents $newContents
- unset newContents
- }
- set resultList [concat $resultList $contents]
-
- # check if iterative dir search is necessary (if specified depth not yet reached):
- set contents {}
- set findDirs 1
- if {([expr $currentDepth + [llength [file split $dirPattern]]] >= $depth) && ($depth > 0)} {set findDirs 0}
-
- # find dirs at current depth boundary to prime iterative search.
- # Pre-8.3 glob doesn't support -type or -dir switches; emulate if necessary:
- if {$83ok && $findDirs} {
- set contents [glob -nocomplain -directory $currentDir -type d -- $dirPattern]
- } elseif $findDirs {
- set wd [pwd]
- set newContents {}
- cd $currentDir
- if [catch {set contents [glob -nocomplain -- $dirPattern/]} err] {
- cd $wd
- error $err
- }
- cd $wd
- foreach item $contents {
- set item [file join $currentDir [string range $item 0 end-1]]
- lappend newContents $item
- }
- set contents $newContents
- unset newContents
- }
-
- # check for redundant links in dir list:
- set contentLength [llength $contents]
- set i 0
- while {$i < $contentLength} {
- set item [lindex $contents end-$i]
- incr i
-
- # kludge to fully resolve link to native name:
- set linkValue [file dirname [file normalize [file join $item __dummy__]]]
-
- # if item is a link, and native name is already in the search space, skip it:
- if {($linkValue != $item) && (![string first $basedir $linkValue])} {
- set [namespace current]::REDUNDANCY 1
- lappend [namespace current]::redundant_files $item
- continue
- }
-
- lappend checkDirs $item
- }
-
- # remove current search dir from search list to prime for next iteration:
- set checkDirs [lrange $checkDirs 1 end]
- }
- return $resultList
-}
-
-# Tcl pre-8.4 lacks [file normalize] command; emulate it if necessary:
-proc ::fileutil::globfind::file {args} {
- if {[lindex $args 0] == "normalize"} {
- set filename [lindex $args 1]
- set tail [file tail $filename]
- set filename [::fileutil::fullnormalize [file dirname $filename]]
- set filename [file join $filename $tail]
- return $filename
- } else {
- return [uplevel ::file $args]
- }
-}
-
-# Eliminate emulation of [file normalize] if version 8.4 or better:
-if [package vsatisfies [package present Tcl] 8.4] {
- rename ::fileutil::globfind::file {}
-} else {
- package require fileutil 1.13
-}
-
-}
-# end namespace ::fileutil::globfind
+if 0 {\r
+########################\r
+\r
+globfind.tcl --\r
+\r
+Written by Stephen Huntley (stephen.huntley@alum.mit.edu)\r
+License: Tcl license\r
+Version 1.5.3\r
+\r
+The proc globfind is a replacement for tcllib's fileutil::find\r
+\r
+Usage: globfind ?basedir ?filtercmd? ?switches??\r
+\r
+Options:\r
+\r
+basedir - the directory from which to start the search. Defaults to current directory.\r
+\r
+filtercmd - Tcl command; for each file found in the basedir, the filename will be\r
+appended to filtercmd and the result will be evaluated. The evaluation should return\r
+0 or 1; only files whose return code is 1 will be included in the final return result.\r
+\r
+switches - The switches will "prefilter" the results before the filtercmd is applied. The\r
+available switches are:\r
+\r
+ -depth - sets the number of levels down from the basedir into which the \r
+ filesystem hierarchy will be searched. A value of zero is interpreted\r
+ as infinite depth.\r
+\r
+ -pattern - a glob-style filename-matching wildcard. ex: -pattern *.pdf\r
+\r
+ -types - any value acceptable to the "types" switch of the glob command.\r
+ ex: -types {d hidden}\r
+\r
+Side effects:\r
+\r
+If somewhere within the search space a directory is a link to another directory within\r
+the search space, then the variable ::fileutil::globfind::REDUNDANCY will be set to 1 \r
+(otherwise it will be set to 0). The name of the redundant directory will be appended to the\r
+variable ::fileutil::globfind::redundant_files. This information may be used to help track down \r
+and eliminate infinitely looping links in the search space.\r
+\r
+Unlike fileutil::find, the name of the basedir will be included in the results if it fits\r
+the prefilter and filtercmd criteria (thus emulating the behavior of the standard Unix \r
+GNU find utility).\r
+\r
+----\r
+\r
+globfind is designed as a fast and simple alternative to fileutil::find. It takes \r
+advantage of glob's ability to use multiple patterns to scan deeply into a directory \r
+structure in a single command, hence the name.\r
+\r
+It reports symbolic links along with other files by default, but checks for nesting of\r
+links which might otherwise lead to infinite search loops. It reports hidden files by\r
+default unless the -types switch is used to specify exactly what is wanted.\r
+\r
+globfind may be used with Tcl versions earlier than 8.4, but emulation of missing\r
+features of the glob command in those versions will result in slower performance.\r
+\r
+globfind is generally two to three times faster than fileutil::find, and fractionally\r
+faster than perl's File::Find function for comparable searches.\r
+\r
+The filtercmd may be omitted if only prefiltering is desired; in this case it may be a \r
+bit faster to use the proc globtraverse, which uses the same basedir value and \r
+command-line switches as globfind, but does not take a filtercmd value.\r
+\r
+If one wanted to search for pdf files for example, one could use the command:\r
+\r
+ globfind $basedir {string match -nocase *.pdf}\r
+\r
+It would, however, in this case be much faster to use:\r
+\r
+ globtraverse $basedir -pattern *.pdf\r
+\r
+########################\r
+}\r
+\r
+\r
+package provide fileutil::globfind 1.5\r
+\r
+namespace eval ::fileutil::globfind {\r
+\r
+namespace export globfind globtraverse\r
+\r
+proc globfind {{basedir .} {filtercmd {}} args} {\r
+ set returnFiles {}\r
+ set types {}\r
+ set basedir [file normalize $basedir]\r
+\r
+ # account for possibility that filtercmd is missing by \r
+ # reformatting $args variable: \r
+ set args [concat [list $filtercmd] $args]\r
+ if [expr fmod([llength $args],2)] {\r
+ set filtercmd [lindex $args 0]\r
+ set args [lrange $args 1 end]\r
+ } else {\r
+ set filtercmd {}\r
+ }\r
+\r
+ set filt [string length $filtercmd]\r
+ set 83ok [package vsatisfies [package present Tcl] 8.3]\r
+\r
+ # process command-line switches:\r
+ foreach {flag value} $args {\r
+ if {[string first $flag -types] >= 0} {set flag "-types"}\r
+ if {[string first $flag -pattern] >= 0} {set flag "-pattern"}\r
+ if {[string first $flag -depth] >= 0} {set flag "-depth"}\r
+\r
+ switch -- $flag {\r
+ -types {\r
+ set types [list $value]\r
+\r
+ # can't use -types pre-8.3, because it doesn't exist in glob command.\r
+ # thus if it is specified, error out:\r
+ if !$83ok {error {error: "-types" flag not supported in version 8.2 and earlier}}\r
+\r
+ # bug in 8.3, if -types {hidden f} is used, possible crash. So disallow:\r
+ if {(![package vcompare [package present Tcl] 8.3]) && ($tcl_platform(platform) == "unix") && ([lsearch $types "hidden"] >= 0) && ([lsearch $types "f"] >= 0)} {\r
+ error {Tcl 8.3 bug: potential program crash if "-types {hidden f}" used}\r
+ }\r
+\r
+ set types "-types $types"\r
+ }\r
+ -pattern {set pattern [list $value]}\r
+ -depth {set depth [expr [list $value]]}\r
+ default {error "$flag: incorrect flag value"}\r
+ }\r
+ }\r
+\r
+ # add basedir to result if it satisfies prefilter conditions:\r
+ set returnFiles [eval [eval list globtraverse [list [file dirname $basedir]] $args -depth 1]]\r
+ if {[lsearch -exact $returnFiles $basedir] >= 0} {set returnFiles [list $basedir]} else {set returnFiles {}}\r
+ # get all files in basedir that satisfy prefilter conditions:\r
+ set returnFiles [concat $returnFiles [eval [eval list globtraverse \$basedir $args]]]\r
+\r
+ # get hidden files if no specific types requested:\r
+ if {$types == {}} {\r
+ \r
+ # save redundant file values already gathered:\r
+ set redundant_files {}\r
+ if [set REDUNDANCY $[namespace current]::REDUNDANCY] {\r
+ set redundant_files $[namespace current]::redundant_files\r
+ }\r
+\r
+ # get hidden files:\r
+ set returnFiles [concat $returnFiles [eval [eval list globtraverse \$basedir $args -type hidden]]]\r
+\r
+ # virtual filesystems ignore hidden tag, so just in case, filter out duplicates:\r
+ set returnFiles [lsort -unique $returnFiles]\r
+\r
+ # collate redundant file info:\r
+ if $[namespace current]::REDUNDANCY {\r
+ set [namespace current]::redundant_files [concat $[namespace current]::redundant_files $redundant_files]\r
+ } else {\r
+ set [namespace current]::redundant_files $redundant_files\r
+ }\r
+ set [namespace current]::REDUNDANCY [expr ($[namespace current]::REDUNDANCY || $REDUNDANCY)]\r
+ }\r
+\r
+ # apply filtercmd to prefiltered results if one is specified:\r
+ if $filt {\r
+ set filterFiles {}\r
+ foreach filename $returnFiles {\r
+ if [uplevel $filtercmd [list $filename]] {\r
+ lappend filterFiles $filename\r
+ }\r
+ }\r
+ } else {\r
+ set filterFiles $returnFiles\r
+ }\r
+\r
+ return $filterFiles\r
+}\r
+\r
+proc globtraverse {{basedir .} args} {\r
+ set [namespace current]::REDUNDANCY 0\r
+ unset -nocomplain [namespace current]::redundant_files\r
+ set depth 0\r
+\r
+ # search 16 directory levels per iteration, glob can't handle more patterns than that at once.\r
+ set maxDepth 16\r
+\r
+ set pattern *\r
+ set types {}\r
+ set resultList {}\r
+\r
+ set basedir [file normalize $basedir]\r
+ if ![file isdirectory $basedir] {return}\r
+\r
+ set baseDepth [llength [file split $basedir]] ; # calculate starting depth\r
+\r
+ lappend checkDirs $basedir ; # initialize list of dirs to check\r
+\r
+ # format basedir variable for later infinite loop checking:\r
+ set basedir $basedir/\r
+ set basedir [string map {// /} $basedir]\r
+\r
+ set 83ok [package vsatisfies [package present Tcl] 8.3]\r
+\r
+ # process command-line switches:\r
+ foreach {flag value} $args {\r
+ if {[string first $flag -types] >= 0} {set flag "-types"}\r
+ if {[string first $flag -pattern] >= 0} {set flag "-pattern"}\r
+ if {[string first $flag -depth] >= 0} {set flag "-depth"}\r
+\r
+ switch -- $flag {\r
+ -types {\r
+ set types [list $value]\r
+ if !$83ok {error {error: "-types" flag not supported in version 8.2 and earlier}}\r
+ if {(![package vcompare [package present Tcl] 8.3]) && ($tcl_platform(platform) == "unix") && ([lsearch $types "hidden"] >= 0) && ([lsearch $types "f"] >= 0)} {\r
+ error {Tcl 8.3 bug: potential program crash if "-types {hidden f}" used}\r
+ }\r
+ set types "-types $types"\r
+ }\r
+ -pattern {set pattern [list $value]}\r
+ -depth {set depth [expr [list $value]]}\r
+ default {error "$flag: incorrect flag value"}\r
+ }\r
+ }\r
+\r
+ # Main result-gathering loop:\r
+ while {[llength $checkDirs]} {\r
+ set currentDir [lindex $checkDirs 0]\r
+\r
+ set currentDepth [expr [llength [file split $currentDir]] - $baseDepth] ; # distance from start depth\r
+\r
+ set searchDepth [expr $depth - $currentDepth] ; # distance from max depth to search to\r
+\r
+ # build multi-pattern argument to feed to glob command:\r
+ set globPatternTotal {}\r
+ set globPattern *\r
+ set incrPattern /*\r
+ for {set i 1} {$i <= $maxDepth} {incr i} {\r
+ set customPattern [string range $globPattern 0 end-1]\r
+ append customPattern $pattern\r
+ lappend globPatternTotal $customPattern\r
+ append globPattern $incrPattern\r
+ incr searchDepth -1\r
+ if {$searchDepth == 0} {break}\r
+ }\r
+\r
+ # save pattern to use for iterative dir search later:\r
+ set dirPattern [string range $globPattern 0 end-2]\r
+\r
+ # glob pre-8.3 doesn't support -directory switch; emulate it if necessary:\r
+ if $83ok {\r
+ set contents [eval glob -nocomplain -directory \$currentDir $types -- $globPatternTotal]\r
+ } else {\r
+ set wd [pwd]\r
+ set newContents {}\r
+ cd $currentDir\r
+ if [catch {set contents [eval glob -nocomplain -- $globPatternTotal]} err] {\r
+ cd $wd\r
+ error $err\r
+ }\r
+ cd $wd\r
+ foreach item $contents {\r
+ set item [file join $currentDir $item]\r
+ lappend newContents $item\r
+ }\r
+ set contents $newContents\r
+ unset newContents\r
+ }\r
+ set resultList [concat $resultList $contents]\r
+\r
+ # check if iterative dir search is necessary (if specified depth not yet reached):\r
+ set contents {}\r
+ set findDirs 1\r
+ if {([expr $currentDepth + [llength [file split $dirPattern]]] >= $depth) && ($depth > 0)} {set findDirs 0}\r
+\r
+ # find dirs at current depth boundary to prime iterative search.\r
+ # Pre-8.3 glob doesn't support -type or -dir switches; emulate if necessary:\r
+ if {$83ok && $findDirs} {\r
+ set contents [glob -nocomplain -directory $currentDir -type d -- $dirPattern]\r
+ } elseif $findDirs {\r
+ set wd [pwd]\r
+ set newContents {}\r
+ cd $currentDir\r
+ if [catch {set contents [glob -nocomplain -- $dirPattern/]} err] {\r
+ cd $wd\r
+ error $err\r
+ }\r
+ cd $wd\r
+ foreach item $contents {\r
+ set item [file join $currentDir [string range $item 0 end-1]]\r
+ lappend newContents $item\r
+ }\r
+ set contents $newContents\r
+ unset newContents\r
+ }\r
+\r
+ # check for redundant links in dir list:\r
+ set contentLength [llength $contents]\r
+ set i 0\r
+ while {$i < $contentLength} {\r
+ set item [lindex $contents end-$i]\r
+ incr i\r
+ \r
+ # kludge to fully resolve link to native name:\r
+ set linkValue [file dirname [file normalize [file join $item __dummy__]]]\r
+\r
+ # if item is a link, and native name is already in the search space, skip it:\r
+ if {($linkValue != $item) && (![string first $basedir/ $linkValue/])} {\r
+ set [namespace current]::REDUNDANCY 1\r
+ lappend [namespace current]::redundant_files $item\r
+ continue\r
+ }\r
+\r
+ lappend checkDirs $item \r
+ }\r
+\r
+ # remove current search dir from search list to prime for next iteration:\r
+ set checkDirs [lrange $checkDirs 1 end]\r
+ } \r
+ return $resultList\r
+}\r
+\r
+# Tcl pre-8.4 lacks [file normalize] command; emulate it if necessary:\r
+proc ::fileutil::globfind::file {args} {\r
+ if {[lindex $args 0] == "normalize"} {\r
+ set filename [lindex $args 1]\r
+ set tail [file tail $filename]\r
+ set filename [::fileutil::fullnormalize [file dirname $filename]]\r
+ set filename [file join $filename $tail]\r
+ return $filename\r
+ } else {\r
+ return [uplevel ::file $args]\r
+ }\r
+}\r
+\r
+# Eliminate emulation of [file normalize] if version 8.4 or better:\r
+if [package vsatisfies [package present Tcl] 8.4] {\r
+ rename ::fileutil::globfind::file {}\r
+} else {\r
+ package require fileutil 1.13\r
+}\r
+\r
+\r
+# -----------------\r
+# Following are sample filter commands that can be used with globfind:\r
+\r
+# scfind: a command suitable for use as a filtercmd with globfind, arguments\r
+# duplicate a subset of GNU find args.\r
+\r
+proc scfind {args} {\r
+ set filename [file join [pwd] [lindex $args end]]\r
+ set switches [lrange $args 0 end-1]\r
+\r
+ array set types {\r
+ f file\r
+ d directory\r
+ c characterSpecial\r
+ b blockSpecial\r
+ p fifo\r
+ l link\r
+ s socket\r
+ }\r
+\r
+ array set signs {\r
+ - <\r
+ + >\r
+ }\r
+\r
+ array set multiplier {\r
+ time 86400\r
+ min 3600\r
+ }\r
+ file stat $filename fs\r
+ set pass 1\r
+ set switchLength [llength $switches]\r
+ for {set i 0} {$i < $switchLength} {incr i} {\r
+ set sw [lindex $switches $i]\r
+ switch -- $sw {\r
+ -type {\r
+ set value [lindex $switches [incr i]]\r
+ if ![string equal $fs(type) $types($value)] {return 0}\r
+ }\r
+ -regex {\r
+ set value [lindex $switches [incr i]]\r
+ if ![regexp $value $filename] {return 0}\r
+ }\r
+ -size {\r
+ set value [lindex $switches [incr i]]\r
+ set sign "=="\r
+ if [info exists signs([string index $value 0])] {\r
+ set sign $signs([string index $value 0])\r
+ set value [string range $value 1 end]\r
+ }\r
+ set sizetype [string index $value end]\r
+ set value [string range $value 0 end-1]\r
+ if [string equal $sizetype b] {set value [expr $value * 512]}\r
+ if [string equal $sizetype k] {set value [expr $value * 1024]}\r
+ if [string equal $sizetype w] {set value [expr $value * 2]}\r
+\r
+ if ![expr $fs(size) $sign $value] {return 0}\r
+ }\r
+ -atime -\r
+ -mtime -\r
+ -ctime -\r
+ -amin -\r
+ -mmin -\r
+ -cmin {\r
+ set value [lindex $switches [incr i]]\r
+\r
+ set sw [string range $sw 1 end]\r
+ set time "[string index $sw 0]time"\r
+ set interval [string range $sw 1 end]\r
+ set sign "=="\r
+ if [info exists signs([string index $value 0])] {\r
+ set sign $signs([string index $value 0])\r
+ set value [string range $value 1 end]\r
+ }\r
+ set value [expr [clock seconds] - ($value * $multiplier($interval))]\r
+ if ![expr $value $sign $fs($time)] {return 0}\r
+ }\r
+ }\r
+ }\r
+ return 1\r
+}\r
+\r
+# find: example use of globfind and scfind to duplicate a subset of the\r
+# command line interface of GNU find.\r
+# ex: \r
+# find $env(HOME) -type l -atime +1\r
+\r
+proc find {args} {\r
+ globfind [lindex $args 0] [list [subst "scfind $args"]]\r
+}\r
+\r
+# -----------------\r
+\r
+# globsync: sync two locations so that the target looks just like the source:\r
+\r
+# If "destructive" is set to 1, files in the target will be deleted if files in equivalent\r
+# locations in source don't exist. If 0, files that exist only in target will be left\r
+# alone, leaving target not an exact duplicate of source.\r
+\r
+# if "log" is set to 1, progress messages will be written to stdout. If 0, not.\r
+\r
+# "source" is location to be duplicated.\r
+# "target" is location to be synced to look like source.\r
+# file is parameter fed to globsync by globfind.\r
+\r
+# ex: globfind ~user_a {globsync 1 1 ~user_a ~user_b}\r
+\r
+proc globsync {destructive log source target file} {\r
+ set source [file normalize $source]\r
+ set target [file normalize $target]\r
+ set sourceLength [llength [file split $source]]\r
+ set targetLength [llength [file split $target]]\r
+ set targetFile [file normalize [file join $target [join [lrange [file split $file] $sourceLength end] /]]]\r
+ array set sourceAttr [file attributes $file]\r
+ file stat $file fs\r
+ array set sourceAttr "mtime $fs(mtime)"\r
+ if ![file isdirectory $file] {\r
+\r
+ if [file isdirectory $targetFile] {file delete -force -- $targetFile}\r
+ set err [catch {file copy -force -- $file $targetFile} result]\r
+ if $err {set err [catch {file mkdir [file dirname $targetFile] ; file copy -force -- $file $targetFile} result]}\r
+ if $err {errHandle $result}\r
+ if $log {puts "copied $file to $targetFile"}\r
+\r
+ array set targetAttr [file attributes $targetFile]\r
+ foreach attr [array names sourceAttr] {\r
+ if {[array get sourceAttr $attr] != [array get targetAttr $attr]} {catch {file attributes $targetFile $attr $sourceAttr($attr)}}\r
+ }\r
+ return 0\r
+ }\r
+ set err [catch {file mkdir $targetFile} result]\r
+ if $err {set err [catch {file delete -force -- $targetFile ; file mkdir $targetFile} result]}\r
+ if $err {errHandle $result}\r
+ array set targetAttr [file attributes $targetFile]\r
+ file stat $targetFile fs\r
+ array set targetAttr "mtime $fs(mtime)"\r
+ foreach attr [array names sourceAttr] {\r
+ if {[array get sourceAttr $attr] != [array get targetAttr $attr]} {\r
+ catch {file attributes $targetFile $attr $sourceAttr($attr)}\r
+ }\r
+ }\r
+ set sourceDirs [glob -dir $file -nocomplain -type d *]\r
+ if {[lindex [file system $file] 0] != "tclvfs"} {append sourceDirs " [glob -dir $file -nocomplain -type {d hidden} *]"}\r
+ set targetDirs [glob -dir $targetFile -nocomplain -type d *]\r
+ if {[lindex [file system $targetFile] 0] != "tclvfs"} {append sourceDirs " [glob -dir $targetFile -nocomplain -type {d hidden} *]"}\r
+\r
+ if !$destructive {set targetDirs {}}\r
+ foreach td $targetDirs {\r
+ set sd [file join $source [join [lrange [file split $td] $targetLength end] /]]\r
+ if {[lsearch $sourceDirs $sd] < 0} { \r
+ file delete -force -- $td\r
+ if $log {puts "deleted directory $td"}\r
+\r
+ }\r
+ }\r
+ set sourceFiles [glob -dir $file -nocomplain -types {b c f l p s} *]\r
+ if {[lindex [file system $file] 0] != "tclvfs"} {append sourceFiles " [glob -dir $file -nocomplain -types {b c f l p s hidden} *]"}\r
+ \r
+ set targetFiles {}\r
+ if $destructive {\r
+ set targetFiles [glob -dir $targetFile -nocomplain -types {b c f l p s} *]\r
+ if {[lindex [file system $targetFile] 0] != "tclvfs"} {append targetFiles " [glob -dir $targetFile -nocomplain -types {b c f l p s hidden} *]"}\r
+ }\r
+ foreach tf $targetFiles {\r
+ set sf [file join $source [join [lrange [file split $tf] $targetLength end] /]]\r
+ if {[lsearch $sourceFiles $sf] < 0} {\r
+ file delete -force -- $tf\r
+ if $log {puts "deleted file $tf"}\r
+ } \r
+ }\r
+ return 0\r
+}\r
+\r
+proc errHandle {result} {\r
+ error $result\r
+}\r
+\r
+}\r
+# end namespace ::fileutil::globfind\r
projects / tclvfs / commitdiff