Tcl Library Source Code

[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]
[keywords {temp file}]
[keywords test]

# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# 
# 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 \
	    install fileType writeFile appendToFile \
	    insertIntoFile removeFromFile replaceInFile \

	# handled by _fully_ normalizing directory paths and checking
	# if we encountered the normalized form before. The array
	# '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

	    # Is the directory accessible? Continue if not.

		# Detection of symlink loops via a portable path
		# 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
		Enter $current $f
		if {[Cycle $f]} continue
		set known($norm) .

		lappend pending $f
	    }
	}
    } else {
	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.

proc ::fileutil::FADD {filename} {
    upvar 1 result result filt filt filtercmd filtercmd

proc f_setupdot {} {
    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
}

proc f_setupnostat {} {

	exec chmod +r [tempPath find3/find4]
    }
    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    {}
    rename f_cleanupnoread  {}
    rename f_cleanall       {}

    set res [lsort [fileutil::find [tempPath {find 1}]]]
    f_cleanup
    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
    } err] $err
} {1 {wrong#args for "::fileutil::findByPattern", should be "::fileutil::findByPattern basedir ?-regexp|-glob? ?--? patterns"}}

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]]

[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}]
[require Tcl 8.3]
[require fileutil::traverse [opt 0.4.3]]

This is the lowest possible interface to the traverser, the core all
higher methods are built on. When invoked it returns a boolean value
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]

[list_begin options]
[opt_def -prefilter command_prefix]

		    [string equal [file tail $f] ".."]
		} continue

		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.

	    if {[llength $_results]} {

    # * Set of directories already visited (normalized paths), for
    #   detection of circular symbolic links.

    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]
	    Enter {} $_base
	    set _known($norm) .
	    lappend _pending $_base
	}

	# System is set up now.
	set _init 1
	return
    }

	return $l
    }
}

# ### ### ### ######### ######### #########
## Ready

package provide fileutil::traverse 0.4.3
package provide fileutil::traverse 0.4.4

    $t destroy
    unset rec
    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
return