traverse.tcl

Go to the documentation of this file.

/*  traverse.tcl --*/
/* */
/*  Directory traversal.*/
/* */
/*  Copyright (c) 2006-2007 by Andreas Kupries <andreas_kupries@users.sourceforge.net>*/
/* */
/*  See the file "license.terms" for information on usage and redistribution*/
/*  of this file, and for a DISCLAIMER OF ALL WARRANTIES.*/
/*  */
/*  RCS: @(#) $Id: traverse.tcl,v 1.4 2007/08/08 19:42:43 andreas_kupries Exp $*/

package require Tcl 8.3
package require snit    ; /*  OO core*/
package require control ; /*  Helpers for control structures*/

snit::type ::fileutil::traverse {

    /*  Incremental directory traversal.*/

    /*  API*/
    /*  create  %AUTO% basedirectory options... -> object*/
    /*  next    filevar                         -> boolean*/
    /*  foreach filevar script*/
    /*  files                                   -> list (path ...)*/

    /*  Options*/
    /*  -prefilter command-prefix*/
    /*  -filter    command-prefix*/
    /*  -errorcmd  command-prefix*/

    /*  Use cases*/
    /* */
    /*  (a) Basic incremental*/
    /*  - Create and configure a traversal object.*/
    /*  - Execute 'next' to retrieve one path at a time,*/
    /*    until the command returns False, signaling that*/
    /*    the iterator has exhausted the supply of paths.*/
    /*    (The path is stored in the named variable).*/
    /* */
    /*  The execution of 'next' can be done in a loop, or via event*/
    /*  processing.*/

    /*  (b) Basic loop*/
    /*  - Create and configure a traversal object.*/
    /*  - Run a script for each path, using 'foreach'.*/
    /*    This is a convenient standard wrapper around 'next'.*/
    /* */
    /*  The loop properly handles all possible Tcl result codes.*/

    /*  (c) Non-incremental, non-looping.*/
    /*  - Create and configure a traversal object.*/
    /*  - Retrieve a list of all paths via 'files'.*/

    /*  The -prefilter callback is executed for directories. Its result*/
    /*  determines if the traverser recurses into the directory or not.*/
    /*  The default is to always recurse into all directories. The call-*/
    /*  back is invoked with a single argument, the path of the*/
    /*  directory.*/
    /* */
    /*  The -filter callback is executed for all paths. Its result*/
    /*  determines if the current path is a valid result, and returned*/
    /*  by 'next'. The default is to accept all paths as valid. The*/
    /*  callback is invoked with a single argument, the path to check.*/

    /*  The -errorcmd callback is executed for all paths the traverser*/
    /*  has trouble with. Like being unable to cd into them, get their*/
    /*  status, etc. The default is to ignore any such problems. The*/
    /*  callback is invoked with a two arguments, the path for which the*/
    /*  error occured, and the error message. Errors thrown by the*/
    /*  filter callbacks are handled through this callback too. Errors*/
    /*  thrown by the error callback itself are not caught and ignored,*/
    /*  but allowed to pass to the caller, usually of 'next'.*/

    /*  Note: Low-level functionality, version and platform dependent is*/
    /*  implemented in procedures, and conditioally defined for optimal*/
    /*  use of features, etc. ...*/

    /*  Note: Traversal is done in depth-first pre-order.*/

    /*  Note: The options are handled only during*/
    /*  construction. Afterward they are read-only and attempts to*/
    /*  modify them will cause the system to throw errors.*/

    /*  ### ### ### ######### ######### #########*/
    /*  Implementation*/

    option -filter    -default {} -readonly 1
    option -prefilter -default {} -readonly 1
    option -errorcmd  -default {} -readonly 1

    constructor {basedir args} {
     _base =  $basedir
    $self configurelist $args
    return
    }

    ret  files () {
    set files {}
    $self foreach f {lappend files $f}
    return $files
    }

    ret  foreach (type fvar , type body) {
    upvar 1 $fvar currentfile

    # (Re-)initialize the traversal state on every call.
    $self Init

    while {[$self next currentfile]} {
        set code [catch {uplevel 1 $body} result]

        # decide what to do upon the return code:
        #
        #               0 - the body executed successfully
        #               1 - the body raised an error
        #               2 - the body invoked [return]
        #               3 - the body invoked [break]
        #               4 - the body invoked [continue]
        # everything else - return and pass on the results
        #
        switch -exact -- $code {
        0 {}
        1 {
            return -errorinfo [::control::ErrorInfoAsCaller uplevel foreach]  \
                -errorcode $::errorCode -code error $result
        }
        3 {
            # FRINK: nocheck
            return
        }
        4 {}
        default {
            return -code $code $result
        }
        }
    }
    return
    }

    ret  next (type fvar) {
    upvar 1 $fvar currentfile

    # Initialize on first call.
    if {!$_init} {
        $self Init
    }

    # We (still) have valid paths in the result stack, return the
    # next one.

    if {[llength $_results]} {
        set top      [lindex   $_results end]
        set _results [lreplace $_results end end]
        set currentfile $top
        return 1
    }

    # Take the next directory waiting in the processing stack and
    # fill the result stack with all valid files and sub-
    # directories contained in it. Extend the processing queue
    # with all sub-directories not yet seen already (!circular
    # symlinks) and accepted by the prefilter. We stop iterating
    # when we either have no directories to process anymore, or
    # the result stack contains at least one path we can return.

    while {[llength $_pending]} {
        set top      [lindex   $_pending end]
        set _pending [lreplace $_pending end end]

        # Directory accessible? Skip if not.
        if {![ACCESS $top]} {
        Error $top "Inacessible directory"
        continue
        }

        # Expand the result stack with all files in the directory,
        # modulo filtering.

        foreach f [GLOBF $top] {
        if {![Valid $f]} continue
        lappend _results $f
        }

        # Expand the result stack with all sub-directories in the
        # directory, modulo filtering. Further expand the
        # processing stack with the same directories, if not seen
        # yet and modulo pre-filtering.

        foreach f [GLOBD $top] {
        if {
            [string equal [file tail $f]  "."] ||
            [string equal [file tail $f] ".."]
        } continue

        if {[Valid $f]} {
            lappend _results $f
        }

        set norm [fileutil::fullnormalize $f]
        if {[info exists _known($norm)]} continue
        set _known($norm) .

        if {[Recurse $f]} {
            lappend _pending $f
        }
        }

        # Stop expanding if we have paths to return.

        if {[llength $_results]} {
        set top    [lindex   $_results end]
        set _results [lreplace $_results end end]
        set currentfile $top
        return 1
        }
    }

    # Allow re-initialization with next call.

    set _init 0
    return 0
    }

    /*  ### ### ### ######### ######### #########*/
    /*  Traversal state*/

    /*  * Initialization flag. Checked in 'next', reset by next when no*/
    /*    more files are available. Set in 'Init'.*/
    /*  * Base directory (or file) to start the traversal from.*/
    /*  * Stack of prefiltered unknown directories waiting for*/
    /*    processing, i.e. expansion (TOP at end).*/
    /*  * Stack of valid paths waiting to be returned as 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.*/

    /*  ### ### ### ######### ######### #########*/
    /*  Internal helpers.*/

    ret  Init () {
    # Path ok as result?
    if {[Valid $_base]} {
        lappend _results $_base
    }

    # Expansion allowed by prefilter?
    if {[file isdirectory $_base] && [Recurse $_base]} {
        lappend _pending $_base
    }

    array unset _known *

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

    ret  Valid (type path) {
    upvar 1 options options
    if {![llength $options(-filter)]} {return 1}
    set code [catch {uplevel \#0 [linsert $options(-filter) end $path]} valid]
    if {!$code} {return $valid}
    Error $path $valid
    return 0
    }

    ret  Recurse (type path) {
    upvar 1 options options
    if {![llength $options(-prefilter)]} {return 1}
    set code [catch {uplevel \#0 [linsert $options(-prefilter) end $path]} valid]
    if {!$code} {return $valid}
    Error $path $valid
    return 0
    }

    ret  Error (type path , type msg) {
    upvar 1 options options
    if {![llength $options(-errorcmd)]} return
    uplevel \#0 [linsert $options(-errorcmd) end $path $msg]
    return
    }

    /** 
     * ### ### ### ######### ######### #########
 */
}

/*  ### ### ### ######### ######### #########*/
/** 
 */

/*  The next three helper commands for the traverser depend strongly on*/
/*  the version of Tcl, and partially on the platform.*/

/*  1. In Tcl 8.3 using -types f will return only true files, but not*/
/*     links to files. This changed in 8.4+ where links to files are*/
/*     returned as well. So for 8.3 we have to handle the links*/
/*     separately (-types l) and also filter on our own.*/
/*     Note that Windows file links are hard links which are reported by*/
/*     -types f, but not -types l, so we can optimize that for the two*/
/*     platforms.*/
/* */
/*  2. In Tcl 8.3 we also have a crashing bug in glob (SIGABRT, "stat on*/
/*     a known file") when trying to perform 'glob -types {hidden f}' on*/
/*     a directory without e'x'ecute permissions. We code around by*/
/*     testing if we can cd into the directory (stat might return enough*/
/*     information too (mode), but possibly also not portable).*/
/* */
/*     For Tcl 8.2 and 8.4+ glob simply delivers an empty result*/
/*     (-nocomplain), without crashing. For them this command is defined*/
/*     so that the bytecode compiler removes it from the bytecode.*/
/* */
/*     This bug made the ACCESS helper necessary.*/
/*     We code around the problem by testing if we can cd into the*/
/*     directory (stat might return enough information too (mode), but*/
/*     possibly also not portable).*/

if {[package vsatisfies [package present Tcl] 8.4]} {
    /*  Tcl 8.4+.*/
    /*  (Ad 1) We have -directory, and -types,*/
    /*  (Ad 2) Links are returned for -types f/d if they refer to files/dirs.*/
    /*  (Ad 3) No bug to code around*/

    ret  ::fileutil::traverse::ACCESS (type args) {return 1}

    ret  ::fileutil::traverse::GLOBF (type current) {
    concat \
        [glob -nocomplain -directory $current -types f          -- *] \
        [glob -nocomplain -directory $current -types {hidden f} -- *]
    }

    ret  ::fileutil::traverse::GLOBD (type current) {
    concat \
        [glob -nocomplain -directory $current -types d          -- *] \
        [glob -nocomplain -directory $current -types {hidden d} -- *]
    }

} else {
    /*  8.3.*/
    /*  (Ad 1) We have -directory, and -types,*/
    /*  (Ad 2) Links are NOT returned for -types f/d, collect separately.*/
    /*         No symbolic file links on Windows.*/
    /*  (Ad 3) Bug to code around.*/

    ret  ::fileutil::traverse::ACCESS (type current) {
    if {[catch {
        set h [pwd] ; cd $current ; cd $h
    }]} {return 0}
    return 1
    }

    if {[string equal $::tcl_platform(platform) windows]} {
    ret  ::fileutil::traverse::GLOBF (type current) {
        concat \
        [glob -nocomplain -directory $current -types f          -- *] \
        [glob -nocomplain -directory $current -types {hidden f} -- *]]
    }
    } else {
    ret  ::fileutil::traverse::GLOBF (type current) {
        set l [concat \
               [glob -nocomplain -directory $current -types f          -- *] \
               [glob -nocomplain -directory $current -types {hidden f} -- *]]

        foreach x [concat \
               [glob -nocomplain -directory $current -types l          -- *] \
               [glob -nocomplain -directory $current -types {hidden l} -- *]] {
        if {![file isfile $x]} continue
        lappend l $x
        }

        return $l
    }
    }

    ret  ::fileutil::traverse::GLOBD (type current) {
    set l [concat \
           [glob -nocomplain -directory $current -types d          -- *] \
           [glob -nocomplain -directory $current -types {hidden d} -- *]]

    foreach x [concat \
               [glob -nocomplain -directory $current -types l          -- *] \
               [glob -nocomplain -directory $current -types {hidden l} -- *]] {
        if {![file isdirectory $x]} continue
        lappend l $x
    }

    return $l
    }
}

/*  ### ### ### ######### ######### #########*/
/*  Ready*/

package provide fileutil::traverse 0.3