Index: modules/fileutil/fileutil.man ================================================================== --- modules/fileutil/fileutil.man +++ modules/fileutil/fileutil.man @@ -1,6 +1,6 @@ -[vset PACKAGE_VERSION 1.14.8] +[vset PACKAGE_VERSION 1.14.9] [comment {-*- tcl -*- doctools manpage}] [manpage_begin fileutil n [vset PACKAGE_VERSION]] [keywords cat] [keywords {file utilities}] [keywords grep] Index: modules/fileutil/fileutil.tcl ================================================================== --- modules/fileutil/fileutil.tcl +++ modules/fileutil/fileutil.tcl @@ -11,11 +11,11 @@ # # RCS: @(#) $Id: fileutil.tcl,v 1.78 2010/06/17 04:46:19 andreas_kupries Exp $ package require Tcl 8.2 package require cmdline -package provide fileutil 1.14.8 +package provide fileutil 1.14.9 namespace eval ::fileutil { namespace export \ grep find findByPattern cat touch foreachLine \ jail stripPwd stripN stripPath tempdir tempfile \ @@ -111,11 +111,13 @@ # 'known' is our cache where we record the known normalized # paths. set pending [list $basedir] set at 0 - array set known {} + array set parent {} + array set norm {} + Enter {} $basedir while {$at < [llength $pending]} { # Get next directory not yet processed. set current [lindex $pending $at] incr at @@ -142,13 +144,12 @@ # normalization computing a canonical form of the path # followed by a check if that canonical form was # encountered before. If ok, record directory for # expansion in future iterations. - set norm [fileutil::fullnormalize $f] - if {[info exists known($norm)]} continue - set known($norm) . + Enter $current $f + if {[Cycle $f]} continue lappend pending $f } } } else { @@ -155,10 +156,27 @@ return -code error "$basedir does not exist" } return $result } + +proc ::fileutil::Enter {parent path} { + upvar 1 parent _parent norm _norm + set _parent($path) $parent + set _norm($path) [fileutil::fullnormalize $path] +} + +proc ::fileutil::Cycle {path} { + upvar 1 parent parent _norm _norm + set nform $_norm($path) + set paren $_parent($path) + while {$paren ne {}} { + if {$_norm($paren) eq $nform} { return yes } + set paren $_parent($paren) + } + return no +} # Helper command for fileutil::find. Performs the filtering of the # result per a filter command for the candidates found by the # traversal core, see above. This is portable. Index: modules/fileutil/find.setup ================================================================== --- modules/fileutil/find.setup +++ modules/fileutil/find.setup @@ -213,10 +213,107 @@ makeDirectory dotfiles makeFile "" [file join dotfiles foo] makeFile "" [file join dotfiles .foo] return } + + + +# Complex directory tree with DAG-links and circular links. We want to +# break the latter, but not the former. I.e. DAG-links allow us to +# find a file by multiple paths, and we wish to see these all. +# +# Paths Links Seen Broken Why +# dir/a | a +# dir/b | a/c +# dir/a/c | a/c/g == a +# dir/a/d | a/c/h +# dir/a/c/g --> .. | a/c/h/e == c +# dir/a/c/h --> ../../b | a/c/h/f +# dir/a/c/i | a/c/i +# dir/b/e --> ../a/c | a/d +# dir/b/f | b +# | b/e +# | b/e/g +# | b/e/g/c +# | b/e/g/c/g == b/e/g +# | b/e/g/c/h == b +# | b/e/g/d +# | b/e/h == b +# | b/e/i +# | b/f + +proc pathmap {args} { + set res {} + foreach p $args { + lappend res [tempPath $p] + } + return $res +} + +proc f_setupcircle3 {} { + + makeDirectory z/a + makeDirectory z/a/c + makeDirectory z/b + makeFile "" z/a/d + makeFile "" z/a/c/i + makeFile "" z/b/f + + f_link z/a/c/g ../../a + f_link z/a/c/h ../../b + f_link z/b/e ../a/c + return +} + +proc f_cleanup3 {} { + # Remove sym links first. Not doing this causes the file delete for + # the directory to fail (on Windows, Unix would have been fine). + catch { removeFile z/a/c/g } + catch { removeFile z/a/c/h } + catch { removeFile z/b/e } + removeDirectory z + return +} + +proc f_link {src target} { + # Added use of 'file link' for Tcl 8.4+, on windows, to have a + # modicum of x-platform testing regarding the handling of symbolic + # links. + + if { + [string equal $::tcl_platform(platform) windows] && + [package vsatisfies [package require Tcl] 8.4] + } { + if {[string equal $::tcl_platform(platform) windows]} { + # Windows doesn't like the .. in the target, it needs an + # absolute path. + + # NOTE/BUG Even so the 'fullnormalize' in the traverser + # returns bogus results for the link, whereas use of file + # normalize and fullnormalize in a simple tclsh, + # i.e. outside of the testing is ok. + + # It seems if the 'file join' in fullnormalize is replaced + # by a plain / then the results are ok again => The + # handling of paths on Windows by the Tcl core is bogus in + # some way which breaks the core 'normalize'. + + set here [pwd] + cd [file dirname [tempPath $src]] + file link [file tail $src] [file normalize $target] + cd $here + } else { + file link [tempPath $src] $target + } + return + } + + exec ln -s $target [tempPath $src] + return +} + proc f_cleanupdot {} { removeDirectory dotfiles return } @@ -267,13 +364,17 @@ removeDirectory find3 return } proc f_cleanall {} { + rename f_link {} rename f_setup {} rename f_cleanup {} + rename f_cleanup3 {} rename f_setupcircle {} + rename f_setupcircle2 {} + rename f_setupcircle3 {} rename f_setupdot {} rename f_cleanupdot {} rename f_setupnostat {} rename f_cleanupnostat {} rename f_setupnoread {} Index: modules/fileutil/find.test ================================================================== --- modules/fileutil/find.test +++ modules/fileutil/find.test @@ -138,10 +138,33 @@ set res } [list [tempPath {find 1/file [1]}] \ [tempPath {find 1/find 2}] \ [tempPath {find 1/find 2/file 3}]] + +test find-1.11.0 {find result, circular links, unix} -setup { + f_setupcircle3 +} -constraints unix -body { + join [lsort [fileutil::find [tempPath z]]] \n +} -cleanup { + f_cleanup3 +} -result [join [pathmap \ + z z/a z/a/c z/a/c/g z/a/c/h z/a/c/h/e z/a/c/h/f \ + z/a/c/i z/a/d z/b z/b/e z/b/e/g z/b/e/g/c z/b/e/g/d \ + z/b/e/h z/b/e/i z/b/f] \n] + +test find-1.11.1 {find result, circular links, windows, 8.4+} -setup { + f_setupcircle3 +} -constraints {win tcl8.4plus} -body { + join [lsort [fileutil::find [tempPath z]]] \n +} -cleanup { + f_cleanup3 +} -result [join [pathmap \ + z z/a z/a/c z/a/c/g z/a/c/h z/a/c/h/e z/a/c/h/f \ + z/a/c/i z/a/d z/b z/b/e z/b/e/g z/b/e/g/c z/b/e/g/d \ + z/b/e/h z/b/e/i z/b/f] \n] + # ------------------------------------------------------------------------- test find-2.0 {find by pattern} { list [catch { ::fileutil::findByPattern [tempPath {}] -glob {fil*} foo Index: modules/fileutil/pkgIndex.tcl ================================================================== --- modules/fileutil/pkgIndex.tcl +++ modules/fileutil/pkgIndex.tcl @@ -1,10 +1,10 @@ if {![package vsatisfies [package provide Tcl] 8.2]} {return} -package ifneeded fileutil 1.14.8 [list source [file join $dir fileutil.tcl]] +package ifneeded fileutil 1.14.9 [list source [file join $dir fileutil.tcl]] if {![package vsatisfies [package provide Tcl] 8.3]} {return} -package ifneeded fileutil::traverse 0.4.3 [list source [file join $dir traverse.tcl]] +package ifneeded fileutil::traverse 0.4.4 [list source [file join $dir traverse.tcl]] if {![package vsatisfies [package provide Tcl] 8.4]} {return} package ifneeded fileutil::multi 0.1 [list source [file join $dir multi.tcl]] package ifneeded fileutil::multi::op 0.5.3 [list source [file join $dir multiop.tcl]] package ifneeded fileutil::decode 0.2 [list source [file join $dir decode.tcl]] Index: modules/fileutil/traverse.man ================================================================== --- modules/fileutil/traverse.man +++ modules/fileutil/traverse.man @@ -1,7 +1,7 @@ [comment {-*- text -*- doctools manpage}] -[manpage_begin fileutil_traverse n 0.4.3] +[manpage_begin fileutil_traverse n 0.4.4] [keywords {directory traversal}] [keywords traversal] [moddesc {file utilities}] [titledesc {Iterative directory traversal}] [category {Programming tools}] @@ -78,14 +78,20 @@ indicating whether it found a path matching the current configuration ([const True]), or not ([const False]). If a path was found it is stored into the variable named by [arg filevar], in the context of the caller. -The [method foreach] method simply calls this method in a loop until -it returned [const False]. This method is exposed so that we are also -able to incrementally traverse a directory hierarchy in an event-based -manner. +[para] The [method foreach] method simply calls this method in a loop +until it returned [const False]. This method is exposed so that we are +also able to incrementally traverse a directory hierarchy in an +event-based manner. + +[para] Note that the traverser does follow symbolic links, except when +doing so would cause it to enter a link-cycle. In other words, the +command takes care to [emph not] lose itself in infinite loops upon +encountering circular link structures. Note that even links which are +not followed will still appear in the result. [list_end] [section OPTIONS] Index: modules/fileutil/traverse.tcl ================================================================== --- modules/fileutil/traverse.tcl +++ modules/fileutil/traverse.tcl @@ -204,15 +204,14 @@ if {[Valid $f]} { lappend _results $f } - set norm [fileutil::fullnormalize $f] - if {[info exists _known($norm)]} continue + Enter $top $f + if {[Cycle $f]} continue if {[Recurse $f]} { - set _known($norm) . lappend _pending $f } } # Stop expanding if we have paths to return. @@ -245,27 +244,56 @@ variable _init 0 ; # Initialization flag. variable _base {} ; # Base directory. variable _pending {} ; # Processing stack. variable _results {} ; # Result stack. - variable _known -array {} ; # Seen paths. + + # sym link handling (to break cycles, while allowing the following of non-cycle links). + # Notes + # - path parent tracking is lexical. + # - path identity tracking is based on the normalized path, i.e. the path with all + # symlinks resolved. + # Maps + # - path -> parent (easier to follow the list than doing dirname's) + # - path -> normalized (cache to avoid redundant calls of fullnormalize) + # cycle <=> A parent's normalized form (NF) is identical to the current path's NF + + variable _parent -array {} + variable _norm -array {} # ### ### ### ######### ######### ######### ## Internal helpers. + + proc Enter {parent path} { + upvar 1 _parent _parent _norm _norm + set _parent($path) $parent + set _norm($path) [fileutil::fullnormalize $path] + } + + proc Cycle {path} { + upvar 1 _parent _parent _norm _norm + set nform $_norm($path) + set paren $_parent($path) + while {$paren ne {}} { + if {$_norm($paren) eq $nform} { return yes } + set paren $_parent($paren) + } + return no + } method Init {} { - array unset _known * + array unset _parent * + array unset _norm * # Path ok as result? if {[Valid $_base]} { lappend _results $_base } # Expansion allowed by prefilter? if {[file isdirectory $_base] && [Recurse $_base]} { - set norm [fileutil::fullnormalize $_base] - set _known($norm) . + Enter {} $_base lappend _pending $_base } # System is set up now. set _init 1 @@ -415,6 +443,6 @@ } # ### ### ### ######### ######### ######### ## Ready -package provide fileutil::traverse 0.4.3 +package provide fileutil::traverse 0.4.4 Index: modules/fileutil/traverse.test ================================================================== --- modules/fileutil/traverse.test +++ modules/fileutil/traverse.test @@ -300,10 +300,38 @@ f_cleanupnostat } -result [list [list [tempPath find3/find4] {Inacessible directory}]] # traverse 1.3.x - error callback, all platforms - Not possible. We have # no win32 setup code for non-readable/non-accessible directories. + +# ------------------------------------------------------------------------- + +test traverse-1.4.0 {Traverse result, circular links, unix} -setup { + f_setupcircle3 + set t [fileutil::traverse %AUTO% [tempPath z]] +} -constraints unix -body { + join [lsort [$t files]] \n +} -cleanup { + $t destroy + f_cleanup3 +} -result [join [pathmap \ + z z/a z/a/c z/a/c/g z/a/c/h z/a/c/h/e z/a/c/h/f \ + z/a/c/i z/a/d z/b z/b/e z/b/e/g z/b/e/g/c z/b/e/g/d \ + z/b/e/h z/b/e/i z/b/f] \n] + +test traverse-1.4.1 {Traverse result, circular links, windows, 8.4+} -setup { + f_setupcircle3 + set t [fileutil::traverse %AUTO% [tempPath z]] +} -constraints {win tcl8.4plus} -body { + join [lsort [$t files]] \n +} -cleanup { + $t destroy + f_cleanup3 +} -result [join [pathmap \ + z z/a z/a/c z/a/c/g z/a/c/h z/a/c/h/e z/a/c/h/f \ + z/a/c/i z/a/d z/b z/b/e z/b/e/g z/b/e/g/c z/b/e/g/d \ + z/b/e/h z/b/e/i z/b/f] \n] # ------------------------------------------------------------------------- f_cleanall testsuiteCleanup