Version 8 of execx2

Updated 2009-06-28 19:36:53 by MHo

MHo This "work-in-progress"!

################################################################################
# Modul    : execx2.tcl
# Version  : 0.1
# Date     : 28.06.2009
# Author   : M.Hoffmann
# Wikipage : http://wiki.tcl.tk/23839
# History  : 0.1 first version
# Purpose  : Extended exec: a trap will be called for each 'couldn't...'-error,
#            so a mechanism can be implemented to provide the missing files,
#            e.g. by copying them out of the VFS.
#
#            This is the (somewhat incompatible) successor of execx
#            (see http://wiki.tcl.tk/14944), which doesn't support command
#            pipes. The original version couldn't be improved any further,
#            because it's nearly impossible to follow the whole exec syntax.
#            A standard callback gets installed by default, so that in normal
#            cases this code can be used just the same way as execx, with one
#            important difference: it's not possible anymore to force the use
#            of VFS files, because this code relies on errors from exec, and
#            those errors won't get fired if files where already present in FS.
# Copyright: You can use this code under the following terms:
#             - Don't blame me for any (direct or indirect) error;
#             - Mention me as the original author of this code.
################################################################################

package provide execx2 0.10

namespace eval execx2 {
    variable cleanup [list]; # holds the names of temp files for later cleanup
    # Notice: the following is subject to changes with each tcl version!
    variable re {^couldn't (execute|read file|write file) "([^"]*)": no such file or directory$}
    variable cb "defaultProvider"

    # Register a callback proc which is responsible to handle missing files.
    # The callback will be called from exec with two args: filename operation.
    # defaultProvider is automatically registered as the default callback.
    #
    proc callback {args} {
        variable cb
        if {[llength $args]} {
            set cb $args ; # set oder clear callback
        } else {
            set cb       ; # get current callback
        }
    }

    # For convenience: delete temporary files (main programs should take wait
    #  until all processes have finished!)
    #
    proc cleanup {} {
        catch {eval file delete -force -- $cleanup}
    }

    # The main routine, serves as an replacement for the original exec.
    #
    proc exec {args} {
        variable re
        variable cb

        while 1 {
            set code [catch {uplevel exec $args} rc]
            # Attention: for each error, the callback is triggered again...
            if {![string equal $cb ""]} {
                if {$code == 1} {
                    if {[regexp $re $rc m o p]} {
                        set pn $p
                        if {![catch {set pn [$cb $p $o]}]} {
                            if {![string equal $p $pn]} {
                                set args [string map [list $p $pn] $args]
                                continue
                            }
                        }
                    }
                }
            }
            return -code $code $rc; # Notice: no more autocleanup as with execx
        }
    }

    # Built in callback for some compatibility with execx:
    #  Checking $::starkit::topdir/bin and /tools for the missing file.
    #
    proc defaultProvider {f o} {
        variable cleanup

        if {[string equal $o "write file"]} {
           return $f; # not usefull here
        }
        set rootDir ..
        catch {set rootDir $::starkit::topdir}
        set progName [file tail $f]
        foreach dir {bin tools} {
            set toolDir [file join $rootDir $dir]
            # extension is unknown, first match counts!
            # Notice: glob works case sensitive within VFS!?
            set match [lindex [glob -nocomplain -dir $toolDir $progName*] 0]
            # Notice: [file normalize] doesn't work within VFS!?
            if {[string length $match]} {
                break
            } elseif {[string equal $dir "tools"]} {
                # undocumented chained hook for another fetch method
                catch {set f [httpProvider $f $o]}
                return $f; # no equivalent found in VFS
            }
        }
        set temp .
        catch {set temp $::env(tmp)}; # formerly only used $::env(temp)
        set dest [file join $temp [file tail $match]]
        # copy file or folder...
        if {![file exists $dest]} {
            # ...if not alreay present in destination
            if {[catch {eval [list file copy -force -- $match $temp]}]} {
                return $f; # do not yet propagate errors from here
            } elseif {[lsearch $cleanup $dest] < 0} {
                lappend cleanup $dest; # eventually better use an array
            }
        }
        if {[file isdirectory $match]} {
            set dest [file join $dest [file tail $match]]
        }
        return $dest
    }
}
#-------------------------------------------------------------------------------

See execx for the predecessor and some more comments.