Attachment "futil.diff" to
ticket [410106ffff]
added by
andreas_kupries
2001-03-21 02:07:34.
--- ./modules/fileutil/pkgIndex.tcl.orig Thu Mar 2 00:27:00 2000
+++ ./modules/fileutil/pkgIndex.tcl Tue Mar 20 19:29:05 2001
@@ -8,4 +8,4 @@
# script is sourced, the variable $dir must contain the
# full path name of this file's directory.
-package ifneeded fileutil 1.0 [list source [file join $dir fileutil.tcl]]
+package ifneeded fileutil 1.1 [list source [file join $dir fileutil.tcl]]
--- ./modules/fileutil/ChangeLog.orig Fri Mar 10 23:59:17 2000
+++ ./modules/fileutil/ChangeLog Tue Mar 20 18:51:34 2001
@@ -1,11 +1,21 @@
+2001-03-20 Andreas Kupries <[email protected]>
+
+ * fileutil.tcl: New implementation of fileutil::find for unixoid
+ OSs using stat and device/inode configuration to detect and
+ break circular softlink structures. This implementation also
+ skips un'stat'able files and directories.
+
+ * fileutil.test: Added fileutil-1.4 testing the circle breaker
+ (only under unix).
+
2000-03-10 Eric Melski <[email protected]>
* fileutil.test:
* fileutil.tcl: Added cat function, duplicates standard UNIX "cat"
- utility.
+ utility.
2000-03-09 Eric Melski <[email protected]>
* fileutil.test: Collected tests into one file; adapted tests for
- use in/out of tcllib test framework.
+ use in/out of tcllib test framework.
--- ./modules/fileutil/fileutil.tcl.orig Fri Jun 2 20:43:54 2000
+++ ./modules/fileutil/fileutil.tcl Tue Mar 20 19:29:17 2001
@@ -9,7 +9,7 @@
#
# RCS: @(#) $Id: fileutil.tcl,v 1.4 2000/06/02 18:43:54 ericm Exp $
-package provide fileutil 1.0
+package provide fileutil 1.1
namespace eval ::fileutil {
namespace export *
@@ -53,43 +53,130 @@
return $result
}
-# ::fileutil::find --
+# ::fileutil::find ==
#
-# Implementation of find. Adapted from the Tcler's Wiki.
-#
-# Arguments:
-# basedir directory to start searching from; default is .
-# filtercmd command to use to evaluate interest in each file.
-# If NULL, all files are interesting.
-#
-# Results:
-# files a list of interesting files.
+# Two different implementations of this command, one for unix with its
+# softlinks, the other for the Win* platform. The trouble with
+# softlink is that they can generate circles in the directory and/or
+# file structure, leading a simple recursion into infinity. So we
+# record device/inode information for each file and directory we touch
+# to be able to skip it should we happen to visit it again.
+
+# Note about the general implementation: The tcl interpreter sets a
+# tcl stack limit of 1000 levels to prevent infinite recursions from
+# running out of bounds. As this command is implemented recursively it
+# will fail for very deeply nested directory structures.
+
+if {[string compare unix $tcl_platform(platform)]} {
+ # Not a unix platform => Original implementation
+ # Note: This may still fail for directories mounted via SAMBA,
+ # i.e. coming from a unix server.
-proc ::fileutil::find {{basedir .} {filtercmd {}}} {
- set oldwd [pwd]
- cd $basedir
- set cwd [pwd]
- set filenames [glob -nocomplain * .*]
- set files {}
- set filt [string length $filtercmd]
- # If we don't remove . and .. from the file list, we'll get stuck in
- # an infinite loop in an infinite loop in an infinite loop in an inf...
- foreach special [list "." ".."] {
- set index [lsearch -exact $filenames $special]
- set filenames [lreplace $filenames $index $index]
+ # ::fileutil::find --
+ #
+ # Implementation of find. Adapted from the Tcler's Wiki.
+ #
+ # Arguments:
+ # basedir directory to start searching from; default is .
+ # filtercmd command to use to evaluate interest in each file.
+ # If NULL, all files are interesting.
+ #
+ # Results:
+ # files a list of interesting files.
+
+ proc ::fileutil::find {{basedir .} {filtercmd {}}} {
+ set oldwd [pwd]
+ cd $basedir
+ set cwd [pwd]
+ set filenames [glob -nocomplain * .*]
+ set files {}
+ set filt [string length $filtercmd]
+ # If we don't remove . and .. from the file list, we'll get stuck in
+ # an infinite loop in an infinite loop in an infinite loop in an inf...
+ foreach special [list "." ".."] {
+ set index [lsearch -exact $filenames $special]
+ set filenames [lreplace $filenames $index $index]
+ }
+ foreach filename $filenames {
+ # Use uplevel to eval the command, not eval, so that variable
+ # substitutions occur in the right context.
+ if {!$filt || [uplevel $filtercmd [list $filename]]} {
+ lappend files [file join $cwd $filename]
+ }
+ if {[file isdirectory $filename]} {
+ set files [concat $files [find $filename $filtercmd]]
+ }
+ }
+ cd $oldwd
+ return $files
}
- foreach filename $filenames {
- # Use uplevel to eval the command, not eval, so that variable
- # substitutions occur in the right context.
- if {!$filt || [uplevel $filtercmd [list $filename]]} {
- lappend files [file join $cwd $filename]
+} else {
+ # Unix, record dev/inode to detect and break circles
+
+ # ::fileutil::find --
+ #
+ # Implementation of find. Adapted from the Tcler's Wiki.
+ #
+ # Arguments:
+ # basedir directory to start searching from; default is .
+ # filtercmd command to use to evaluate interest in each file.
+ # If NULL, all files are interesting.
+ #
+ # Results:
+ # files a list of interesting files.
+
+ proc ::fileutil::find {{basedir .} {filtercmd {}} {nodeVar {}}} {
+ if {$nodeVar == {}} {
+ # Main call, setup the device/inode structure
+ array set inodes {}
+ } else {
+ # Recursive call, import the device/inode record from the caller.
+ upvar $nodeVar inodes
+ }
+
+ set oldwd [pwd]
+ cd $basedir
+ set cwd [pwd]
+ set filenames [glob -nocomplain * .*]
+ set files {}
+ set filt [string length $filtercmd]
+ # If we don't remove . and .. from the file list, we'll get stuck in
+ # an infinite loop in an infinite loop in an infinite loop in an inf...
+ foreach special [list "." ".."] {
+ set index [lsearch -exact $filenames $special]
+ set filenames [lreplace $filenames $index $index]
}
- if {[file isdirectory $filename]} {
- set files [concat $files [find $filename $filtercmd]]
+ foreach filename $filenames {
+ # Stat each file/directory get exact information about its identity
+ # (device, inode). Non-'stat'able files are either junk (link to
+ # non-existing target) or not readable, i.e. inaccessible. In both
+ # cases it makes sense to ignore them.
+
+ if {[catch {file stat [file join $cwd $filename] stat}]} {
+ continue
+ }
+
+ # No skip over previously recorded files/directories and
+ # record the new files/directories.
+
+ set key "$stat(dev),$stat(ino)"
+ if {[info exists inodes($key)]} {
+ continue
+ }
+ set inodes($key) 1
+
+ # Use uplevel to eval the command, not eval, so that variable
+ # substitutions occur in the right context.
+ if {!$filt || [uplevel $filtercmd [list $filename]]} {
+ lappend files [file join $cwd $filename]
+ }
+ if {[file isdirectory $filename]} {
+ set files [concat $files [find $filename $filtercmd inodes]]
+ }
}
+ cd $oldwd
+ return $files
}
- cd $oldwd
- return $files
}
# ::fileutil::cat --
--- ./modules/fileutil/fileutil.test.orig Wed May 31 02:00:00 2000
+++ ./modules/fileutil/fileutil.test Tue Mar 20 19:30:14 2001
@@ -1,9 +1,11 @@
+# -*- tcl -*-
# Tests for the find function.
#
# Sourcing this file into Tcl runs the tests and generates output for errors.
# No output means no errors were found.
#
# Copyright (c) 1998-2000 by Ajuba Solutions.
+# Copyright (c) 2001 by ActiveState Tool Corp.
# All rights reserved.
#
# RCS: @(#) $Id: fileutil.test,v 1.3 2000/05/31 00:00:00 ericm Exp $
@@ -18,8 +20,19 @@
}
package require fileutil
+puts "fileutil [package present fileutil]"
# Build a sample tree to search
+# Structure
+#
+# dir
+# +--find1
+# +--find2
+# | +--file2
+# +--file1
+
+catch {removeDirectory find1} ; # start with a clean structure!
+
makeDirectory find1
makeDirectory [file join find1 find2]
makeFile "" [file join find1 file1]
@@ -40,6 +53,29 @@
test find-1.3 {find files bigger than a given size} {
fileutil::find [file join $dir find1] {fileIsBiggerThan 1}
} [list [file join $dir find1 find2 file2]]
+
+
+# Extend the previous sample tree
+# Extended structure:
+#
+# dir
+# +--find1
+# +--find2 <----------+
+# | +--file2 |
+# | +--file3 --> ../find2 -+
+# +--file1
+
+test find-1.4 {handling of circular links} {unix} {
+ catch {file delete -force [file join $dir find1 find2 file3]}
+ exec ln -s ../find2 [file join $dir find1 find2 file3]
+
+ # Find has to skip 'file3'
+ lsort [fileutil::find [file join $dir find1]]
+} [list [file join $dir find1 file1] [file join $dir find1 find2] \
+ [file join $dir find1 find2 file2]]
+
+
+catch {removeDirectory grepTest} ; # start with a clean structure!
# Build a sample tree to search
makeDirectory grepTest
