fileutil.tcl

Go to the documentation of this file.

/*  fileutil.tcl --*/
/* */
/*  Tcl implementations of standard UNIX utilities.*/
/* */
/*  Copyright (c) 1998-2000 by Ajuba Solutions.*/
/*  Copyright (c) 2002      by Phil Ehrens <phil@slug.org> (fileType)*/
/*  Copyright (c) 2005-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: fileutil.tcl,v 1.70 2007/08/10 19:40:49 andreas_kupries Exp $*/

package require Tcl 8.2
package require cmdline
package provide fileutil 1.13.3

namespace ::fileutil {
    namespace export \
        grep find findByPattern cat touch foreachLine \
        jail stripPwd stripN stripPath tempdir tempfile \
        install fileType writeFile appendToFile \
        insertIntoFile removeFromFile replaceInFile \
        updateInPlace test tempdirRe
}

# ::fileutil = ::grep --
/* */
/*  Implementation of grep.  Adapted from the Tcler's Wiki.*/
/* */
/*  Arguments:*/
/*  pattern     pattern to search for.*/
/*  files       list of files to search; if NULL, uses stdin.*/
/* */
/*  Results:*/
/*  results     list of matches*/

ret  ::fileutil::grep (type pattern , optional files ={)} {
    set result [list]
    if {[llength $files] == 0} {
    /*  read from stdin*/
     lnum =  0
    while {[gets stdin line] >= 0} {
        incr lnum
        if {[regexp -- $pattern $line]} {
        lappend result "${lnum}:${line}"
        }
    }
    } else {
    foreach filename $files {
         file =  [open $filename r]
         lnum =  0
        while {[gets $file line] >= 0} {
        incr lnum
        if {[regexp -- $pattern $line]} {
            lappend result "${filename}:${lnum}:${line}"
        }
        }
        close $file
    }
    }
    return $result
}

/*  ::fileutil::find ==*/

/*  Below is the core command, which is portable across Tcl versions and*/
/*  platforms. Functionality which is common or platform and/or Tcl*/
/*  version dependent, has been factored out/ encapsulated into separate*/
/*  (small) commands. Only these commands may have multiple variant*/
/*  implementations per the available features of the Tcl core /*/
/*  platform.*/
/* */
/*  These commands are*/
/* */
/*  FADD   - Add path result, performs filtering. Portable!*/
/*  GLOBF  - Return files in a directory.         Tcl version/platform dependent.*/
/*  GLOBD  - Return dirs  in a directory.         Tcl version/platform dependent.*/
/*  ACCESS - Check directory for accessibility.   Tcl version/platform dependent.*/

ret  ::fileutil::find (optional basedir =. , optional filtercmd ={)} {
    set result {}
     filt =    [string length $filtercmd]

    if {[file isfile $basedir]} {
    /*  The base is a file, and therefore only possible result,*/
    /*  modulo filtering.*/

    FADD $basedir

    } elseif {[file isdirectory $basedir]} {

    /*  For a directory as base we do an iterative recursion through*/
    /*  the directory hierarchy starting at the base. We use a queue*/
    /*  (Tcl list) of directories we have to check. We access it by*/
    /*  index, and stop when we have reached beyond the end of the*/
    /*  list. This is faster than removing elements from the be-*/
    /*  ginning of the list, as that entails copying down a possibly*/
    /*  large list of directories, making it O(n*n). The index is*/
    /*  faster, O(n), at the expense of memory. Nothing is deleted*/
    /*  from the list until we have processed all directories in the*/
    /*  hierarchy.*/
    /* */
    /*  We scan each directory at least twice. First for files, then*/
    /*  for directories. The scans may internally make several*/
    /*  passes (normal vs hidden files).*/
    /* */
    /*  Looped directory structures due to symbolic links are*/
    /*  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.*/

     pending =  [list $basedir]
     at =       0
    array    known =  {}

    while {$at < [llength $pending]} {
        /*  Get next directory not yet processed.*/
         current =  [lindex $pending $at]
        incr at

        /*  Is the directory accessible? Continue if not.*/
        ACCESS $current

        /*  Files first, then the sub-directories ...*/

        foreach f [GLOBF $current] { FADD $f }

        foreach f [GLOBD $current] {
        /*  Ignore current and parent directory, this needs*/
        /*  explicit filtering outside of the filter command.*/
        if {
            [string equal [file tail $f]  "."] ||
            [string equal [file tail $f] ".."]
        } continue

        /*  Extend result, modulo filtering.*/
        FADD $f

        /*  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.*/

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

        lappend pending $f
        }
    }
    } else {
    return -code error "$basedir does not exist"
    }

    return $result
}

/*  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.*/

ret  ::fileutil::FADD (type filename) {
    upvar 1 result result filt filt filtercmd filtercmd
    if {!$filt} {
    lappend result $filename
    return
    }

    set here [pwd]
    cd [file dirname $filename]

    if {[uplevel 2 [linsert $filtercmd end [file tail $filename]]]} {
    lappend result $filename
    }

    cd $here
    return
}

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

/*  1. The -directory and -types swithes were added to glob in Tcl*/
/*     8.3. This means that we have to emulate them for Tcl 8.2.*/
/* */
/*  2. 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.*/
/* */
/*  3. 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::ACCESS (type args) {}

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

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

} elseif {[package vsatisfies [package present Tcl] 8.3]} {
    /*  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::ACCESS (type current) {
    if {[catch {
        set h [pwd] ; cd $current ; cd $h
    }]} {return -code continue}
    return
    }

    if {[string equal $::tcl_platform(platform) windows]} {
    ret  ::fileutil::GLOBF (type current) {
        concat \
        [glob -nocomplain -directory $current -types f          -- *] \
        [glob -nocomplain -directory $current -types {hidden f} -- *]]
    }
    } else {
    ret  ::fileutil::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::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
    }
} else {
    /*  8.2.*/
    /*  (Ad 1,2,3) We do not have -directory, nor -types. Full emulation required.*/

    ret  ::fileutil::ACCESS (type args) {}

    if {[string equal $::tcl_platform(platform) windows]} {
    /*  Hidden files cannot be handled by Tcl 8.2 in glob. We have*/
    /*  to punt.*/

    ret  ::fileutil::GLOBF (type current) {
        set current \\[join [split $current {}] \\]
        set res {}
        foreach x [glob -nocomplain -- [file join $current *]] {
        if {![file isfile $x]} continue
        lappend res $x
        }
        return $res
    }

    ret  ::fileutil::GLOBD (type current) {
        set current \\[join [split $current {}] \\]
        set res {}
        foreach x [glob -nocomplain -- [file join $current *]] {
        if {![file isdirectory $x]} continue
        lappend res $x
        }
        return $res
    }
    } else {
    /*  Hidden files on Unix are dot-files. We emulate the switch*/
    /*  '-types hidden' by using an explicit pattern.*/

    ret  ::fileutil::GLOBF (type current) {
        set current \\[join [split $current {}] \\]
        set res {}
        foreach x [glob -nocomplain -- [file join $current *] [file join $current .*]] {
        if {![file isfile $x]} continue
        lappend res $x
        }
        return $res
    }

    ret  ::fileutil::GLOBD (type current) {
        set current \\[join [split $current {}] \\]
        set res {}
        foreach x [glob -nocomplain -- [file join $current *] [file join $current .*]] {
        if {![file isdirectory $x]} continue
        lappend res $x
        }
        return $res
    }
    }
}

/*  ::fileutil::findByPattern --*/
/* */
/*  Specialization of find. Finds files based on their names,*/
/*  which have to match the specified patterns. Options are used*/
/*  to specify which type of patterns (regexp-, glob-style) is*/
/*  used.*/
/* */
/*  Arguments:*/
/*  basedir     Directory to start searching from.*/
/*  args        Options (-glob, -regexp, --) followed by a*/
/*          list of patterns to search for.*/
/* */
/*  Results:*/
/*  files       a list of interesting files.*/

ret  ::fileutil::findByPattern (type basedir , type args) {
    set pos 0
    set cmd ::fileutil::FindGlob
    foreach a $args {
    incr pos
    switch -glob -- $a {
        --      {break}
        -regexp {set cmd ::fileutil::FindRegexp}
        -glob   {set cmd ::fileutil::FindGlob}
        -*      {return -code error "Unknown option $a"}
        default {incr pos -1 ; break}
    }
    }

    set args [lrange $args $pos end]

    if {[llength $args] != 1} {
    set pname [lindex [info level 0] 0]
    return -code error \
        "wrong#args for \"$pname\", should be\
        \"$pname basedir ?-regexp|-glob? ?--? patterns\""
    }

    set patterns [lindex $args 0]
    return [find $basedir [list $cmd $patterns]]
}


/*  ::fileutil::FindRegexp --*/
/* */
/*  Internal helper. Filter command used by 'findByPattern'*/
/*  to match files based on regular expressions.*/
/* */
/*  Arguments:*/
/*  patterns    List of regular expressions to match against.*/
/*  filename    Name of the file to match against the patterns.*/
/*  Results:*/
/*  interesting A boolean flag. Set to true if the file*/
/*          matches at least one of the patterns.*/

ret  ::fileutil::FindRegexp (type patterns , type filename) {
    foreach p $patterns {
    if {[regexp -- $p $filename]} {
        return 1
    }
    }
    return 0
}

/*  ::fileutil::FindGlob --*/
/* */
/*  Internal helper. Filter command used by 'findByPattern'*/
/*  to match files based on glob expressions.*/
/* */
/*  Arguments:*/
/*  patterns    List of glob expressions to match against.*/
/*  filename    Name of the file to match against the patterns.*/
/*  Results:*/
/*  interesting A boolean flag. Set to true if the file*/
/*          matches at least one of the patterns.*/

ret  ::fileutil::FindGlob (type patterns , type filename) {
    foreach p $patterns {
    if {[string match $p $filename]} {
        return 1
    }
    }
    return 0
}

/*  ::fileutil::stripPwd --*/
/* */
/*  If the specified path references is a path in [pwd] (or [pwd] itself) it*/
/*  is made relative to [pwd]. Otherwise it is left unchanged.*/
/*  In the case of [pwd] itself the result is the string '.'.*/
/* */
/*  Arguments:*/
/*  path        path to modify*/
/* */
/*  Results:*/
/*  path        The (possibly) modified path.*/

ret  ::fileutil::stripPwd (type path) {

    # [file split] is used to generate a canonical form for both
    # paths, for easy comparison, and also one which is easy to modify
    # using list commands.

    set pwd [pwd]
    if {[string equal $pwd $path]} {
    return "."
    }

    set pwd   [file split $pwd]
    set npath [file split $path]

    if {[string match ${pwd}* $npath]} {
    set path [eval [linsert [lrange $npath [llength $pwd] end] 0 file join ]]
    }
    return $path
}

/*  ::fileutil::stripN --*/
/* */
/*  Removes N elements from the beginning of the path.*/
/* */
/*  Arguments:*/
/*  path        path to modify*/
/*  n       number of elements to strip*/
/* */
/*  Results:*/
/*  path        The modified path*/

ret  ::fileutil::stripN (type path , type n) {
    set path [file split $path]
    if {$n >= [llength $path]} {
    return {}
    } else {
    return [eval [linsert [lrange $path $n end] 0 file join]]
    }
}

/*  ::fileutil::stripPath --*/
/* */
/*  If the specified path references/is a path in prefix (or prefix itself) it*/
/*  is made relative to prefix. Otherwise it is left unchanged.*/
/*  In the case of it being prefix itself the result is the string '.'.*/
/* */
/*  Arguments:*/
/*  prefix      prefix to strip from the path.*/
/*  path        path to modify*/
/* */
/*  Results:*/
/*  path        The (possibly) modified path.*/

ret  ::fileutil::stripPath (type prefix , type path) {
    # [file split] is used to generate a canonical form for both
    # paths, for easy comparison, and also one which is easy to modify
    # using list commands.

    if {[string equal $prefix $path]} {
    return "."
    }

    set prefix [file split $prefix]
    set npath  [file split $path]

    if {[string match ${prefix}* $npath]} {
    set path [eval [linsert [lrange $npath [llength $prefix] end] 0 file join ]]
    }
    return $path
}

/*  ::fileutil::jail --*/
/* */
/*  Ensures that the input path 'filename' stays within the the*/
/*  directory 'jail'. In this way it preventsuser-supplied paths*/
/*  from escaping the jail.*/
/* */
/*  Arguments:*/
/*  jail        The path to the directory the other must*/
/*          not escape from.*/
/*  filename    The path to prevent from escaping.*/
/* */
/*  Results:*/
/*  path        The (possibly) modified path surely within*/
/*          the confines of the jail.*/

ret  fileutil::jail (type jail , type filename) {
    if {![string equal [file pathtype $filename]  "relative"]} {
    # Although the path to check is absolute (or volumerelative on
    # windows) we cannot perform a simple prefix check to see if
    # the path is inside the jail or not. We have to normalize
    # both path and jail and then we can check. If the path is
    # outside we make the original path relative and prefix it
    # with the original jail. We do make the jail pseudo-absolute
    # by prefixing it with the current working directory for that.

    # Normalized jail. Fully resolved sym links, if any. Our main
    # complication is that normalize does not resolve symlinks in the
    # last component of the path given to it, so we add a bogus
    # component, resolve, and then strip it off again. That is why the
    # code is so large and long.

    set njail [eval [list file join] [lrange [file split \
        [Normalize [file join $jail __dummy__]]] 0 end-1]]

    # Normalize filename. Fully resolved sym links, if
    # any. S.a. for an explanation of the complication.

    set nfile [eval [list file join] [lrange [file split \
        [Normalize [file join $filename __dummy__]]] 0 end-1]]

    if {[string match ${njail}* $nfile]} {
        return $filename
    }

    # Outside the jail, put it inside. ... We normalize the input
    # path lexically for this, to prevent escapes still lurking in
    # the original path. (We cannot use the normalized path,
    # symlinks may have bent it out of shape in unrecognizable ways.

    return [eval [linsert [lrange [file split \
        [LexNormalize $filename]] 1 end] 0 file join [pwd] $jail]]
    } else {
    # The path is relative, consider it as outside
    # implicitly. Normalize it lexically! to prevent escapes, then
    # put the jail in front, use PWD to ensure absoluteness.

    return [eval [linsert [file split [LexNormalize $filename]] 0 \
        file join [pwd] $jail]]
    }
}


/*  ::fileutil::test --*/
/* */
/*  Simple API to testing various properties of*/
/*  a path (read, write, file/dir, existence)*/
/* */
/*  Arguments:*/
/*  path    path to test*/
/*  codes   names of the properties to test*/
/*  msgvar  Name of variable to leave an error*/
/*      message in. Optional.*/
/*  label   Label for error message, optional*/
/* */
/*  Results:*/
/*  ok  boolean flag, set if the path passes*/
/*      all tests.*/

namespace ::fileutil {
    variable  test
    array  test =  {
    read   {readable    {Read access is denied}}
    write  {writable    {Write access is denied}}
    exec   {executable  {Is not executable}}
    exists {exists      {Does not exist}}
    file   {isfile      {Is not a file}}
    dir    {isdirectory {Is not a directory}}
    }
}

ret  ::fileutil::test (type path , type codes , optional msgvar ={) {label {}}} {
    variable test

    if {[string equal $msgvar ""]} {
     msg =  ""
    } else {
    upvar 1 $msgvar msg
    }

    if {![string equal $label ""]} {append label { }}

    if {![regexp {^(read|write|exec|exists|file|dir)} $codes]} {
    /*  Translate single characters into proper codes*/
     codes =  [string map {
        r read w write e exists x exec f file d dir
    } [split $codes {}]]
    }

    foreach c $codes {
    foreach {cmd text} $test($c) break
    if {![file $cmd $path]} {
         msg =  "$label\"$path\": $text"
        return 0
    }
    }

    return 1
}

/*  ::fileutil::cat --*/
/* */
/*  Tcl implementation of the UNIX "cat" command.  Returns the contents*/
/*  of the specified files.*/
/* */
/*  Arguments:*/
/*  args    names of the files to read, interspersed with options*/
/*      to set encodings, translations, or eofchar.*/
/* */
/*  Results:*/
/*  data    data read from the file.*/

ret  ::fileutil::cat (type args) {
    # Syntax: (?options? file)+
    # options = -encoding    ENC
    #         | -translation TRA
    #         | -eofchar     ECH
    #         | --

    if {![llength $args]} {
    # Argument processing stopped with arguments missing.
    return -code error \
        "wrong#args: should be\
        [lindex [info level 0] 0] ?-eofchar|-translation|-encoding arg?+ file ..."
    }

    # We go through the arguments using foreach and keeping track of
    # the index we are at. We do not shift the arguments out to the
    # left. That is inherently quadratic, copying everything down.

    set opts {}
    set mode maybeopt
    set channels {}

    foreach a $args {
    if {[string equal $mode optarg]} {
        lappend opts $a
        set mode maybeopt
        continue
    } elseif {[string equal $mode maybeopt]} {
        if {[string match -* $a]} {
        switch -exact -- $a {
            -encoding -
            -translation -
            -eofchar {
            lappend opts $a
            set mode optarg
            continue
            }
            -- {
            set mode file
            continue
            }
            default {
            return -code error \
                "Bad option \"$a\",\
                expected one of\
                -encoding, -eofchar,\
                or -translation"
            }
        }
        }
        # Not an option, but a file. Change mode and fall through.
        set mode file
    }
    # Process file arguments

    if {[string equal $a -]} {
        # Stdin reference is special.

        # Test that the current options are all ok.
        # For stdin we have to avoid closing it.

        set old [fconfigure stdin]
        set fail [catch {
        SetOptions stdin $opts
        } msg] ; # {}
        SetOptions stdin $old

        if {$fail} {
        return -code error $msg
        }

        lappend channels [list $a $opts 0]
    } else {
        if {![file exists $a]} {
        return -code error "Cannot read file \"$a\", does not exist"
        } elseif {![file isfile $a]} {
        return -code error "Cannot read file \"$a\", is not a file"
        } elseif {![file readable $a]} {
        return -code error "Cannot read file \"$a\", read access is denied"
        }

        # Test that the current options are all ok.
        set c [open $a r]
        set fail [catch {
        SetOptions $c $opts
        } msg] ; # {}
        close $c
        if {$fail} {
        return -code error $msg
        }

        lappend channels [list $a $opts [file size $a]]
    }

    # We may have more options and files coming after.
    set mode maybeopt
    }

    if {![string equal $mode maybeopt]} {
    # Argument processing stopped with arguments missing.
    return -code error \
        "wrong#args: should be\
        [lindex [info level 0] 0] ?-eofchar|-translation|-encoding arg?+ file ..."
    }

    set data ""
    foreach c $channels {
    foreach {fname opts size} $c break

    if {[string equal $fname -]} {
        set old [fconfigure stdin]
        SetOptions stdin $opts
        append data [read stdin]
        SetOptions stdin $old
        continue
    }

    set c [open $fname r]
    SetOptions $c $opts

    if {$size > 0} {
        # Used the [file size] command to get the size, which
        # preallocates memory, rather than trying to grow it as
        # the read progresses.
        append data [read $c $size]
    } else {
        # if the file has zero bytes it is either empty, or
        # something where [file size] reports 0 but the file
        # actually has data (like the files in the /proc
        # filesystem on Linux).
        append data [read $c]
    }
    close $c
    }

    return $data
}

/*  ::fileutil::writeFile --*/
/* */
/*  Write the specified data into the named file,*/
/*  creating it if necessary.*/
/* */
/*  Arguments:*/
/*  options...  Options and arguments.*/
/*  filename    Path to the file to write.*/
/*  data        The data to write into the file*/
/* */
/*  Results:*/
/*  None.*/

ret  ::fileutil::writeFile (type args) {
    # Syntax: ?options? file data
    # options = -encoding    ENC
    #         | -translation TRA
    #         | -eofchar     ECH
    #         | --

    Spec Writable $args opts fname data

    # Now perform the requested operation.

    file mkdir [file dirname $fname]
    set              c [open $fname w]
    SetOptions      $c $opts
    puts -nonewline $c $data
    close           $c
    return
}

/*  ::fileutil::appendToFile --*/
/* */
/*  Append the specified data at the end of the named file,*/
/*  creating it if necessary.*/
/* */
/*  Arguments:*/
/*  options...  Options and arguments.*/
/*  filename    Path to the file to extend.*/
/*  data        The data to extend the file with.*/
/* */
/*  Results:*/
/*  None.*/

ret  ::fileutil::appendToFile (type args) {
    # Syntax: ?options? file data
    # options = -encoding    ENC
    #         | -translation TRA
    #         | -eofchar     ECH
    #         | --

    Spec Writable $args opts fname data

    # Now perform the requested operation.

    file mkdir [file dirname $fname]
    set              c [open $fname a]
    SetOptions      $c $opts
    set at    [tell $c]
    puts -nonewline $c $data
    close           $c
    return $at
}

/*  ::fileutil::insertIntoFile --*/
/* */
/*  Insert the specified data into the named file,*/
/*  creating it if necessary, at the given locaton.*/
/* */
/*  Arguments:*/
/*  options...  Options and arguments.*/
/*  filename    Path to the file to extend.*/
/*  data        The data to extend the file with.*/
/* */
/*  Results:*/
/*  None.*/

ret  ::fileutil::insertIntoFile (type args) {

    # Syntax: ?options? file at data
    # options = -encoding    ENC
    #         | -translation TRA
    #         | -eofchar     ECH
    #         | --

    Spec ReadWritable $args opts fname at data

    set max [file size $fname]
    CheckLocation $at $max insertion

    if {[string length $data] == 0} {
    # Another degenerate case, inserting nothing.
    # Leave the file well enough alone.
    return
    }

    foreach {c o t} [Open2 $fname $opts] break

    # The degenerate cases of both appending and insertion at the
    # beginning of the file allow more optimized implementations of
    # the operation.

    if {$at == 0} {
    puts -nonewline    $o $data
    fcopy           $c $o
    } elseif {$at == $max} {
    fcopy           $c $o
    puts -nonewline    $o $data
    } else {
    fcopy           $c $o -size $at
    puts -nonewline    $o $data
    fcopy           $c $o
    }

    Close2 $fname $t $c $o
    return
}

/*  ::fileutil::removeFromFile --*/
/* */
/*  Remove n characters from the named file,*/
/*  starting at the given locaton.*/
/* */
/*  Arguments:*/
/*  options...  Options and arguments.*/
/*  filename    Path to the file to extend.*/
/*  at      Location to start the removal from.*/
/*  n       Number of characters to remove.*/
/* */
/*  Results:*/
/*  None.*/

ret  ::fileutil::removeFromFile (type args) {

    # Syntax: ?options? file at n
    # options = -encoding    ENC
    #         | -translation TRA
    #         | -eofchar     ECH
    #         | --

    Spec ReadWritable $args opts fname at n

    set max [file size $fname]
    CheckLocation    $at $max removal
    CheckLength   $n $at $max removal

    if {$n == 0} {
    # Another degenerate case, removing nothing.
    # Leave the file well enough alone.
    return
    }

    foreach {c o t} [Open2 $fname $opts] break

    # The degenerate cases of both removal from the beginning or end
    # of the file allow more optimized implementations of the
    # operation.

    if {$at == 0} {
    seek  $c    $n current
    fcopy $c $o
    } elseif {($at + $n) == $max} {
    fcopy $c $o -size $at
    # Nothing further to copy.
    } else {
    fcopy $c $o -size $at
    seek  $c    $n current
    fcopy $c $o
    }

    Close2 $fname $t $c $o
    return
}

/*  ::fileutil::replaceInFile --*/
/* */
/*  Remove n characters from the named file,*/
/*  starting at the given locaton, and replace*/
/*  it with the given data.*/
/* */
/*  Arguments:*/
/*  options...  Options and arguments.*/
/*  filename    Path to the file to extend.*/
/*  at      Location to start the removal from.*/
/*  n       Number of characters to remove.*/
/*  data        The replacement data.*/
/* */
/*  Results:*/
/*  None.*/

ret  ::fileutil::replaceInFile (type args) {

    # Syntax: ?options? file at n data
    # options = -encoding    ENC
    #         | -translation TRA
    #         | -eofchar     ECH
    #         | --

    Spec ReadWritable $args opts fname at n data

    set max [file size $fname]
    CheckLocation    $at $max replacement
    CheckLength   $n $at $max replacement

    if {
    ($n == 0) &&
    ([string length $data] == 0)
    } {
    # Another degenerate case, replacing nothing with
    # nothing. Leave the file well enough alone.
    return
    }

    foreach {c o t} [Open2 $fname $opts] break

    # Check for degenerate cases and handle them separately,
    # i.e. strip the no-op parts out of the general implementation.

    if {$at == 0} {
    if {$n == 0} {
        # Insertion instead of replacement.

        puts -nonewline    $o $data
        fcopy           $c $o

    } elseif {[string length $data] == 0} {
        # Removal instead of replacement.

        seek  $c    $n current
        fcopy $c $o

    } else {
        # General replacement at front.

        seek         $c    $n current
        puts -nonewline $o $data
        fcopy        $c $o
    }
    } elseif {($at + $n) == $max} {
    if {$n == 0} {
        # Appending instead of replacement

        fcopy           $c $o
        puts -nonewline    $o $data

    } elseif {[string length $data] == 0} {
        # Truncating instead of replacement

        fcopy $c $o -size $at
        # Nothing further to copy.

    } else {
        # General replacement at end

        fcopy        $c $o -size $at
        puts -nonewline $o $data
    }
    } else {
    if {$n == 0} {
        # General insertion.

        fcopy           $c $o -size $at
        puts -nonewline    $o $data
        fcopy           $c $o

    } elseif {[string length $data] == 0} {
        # General removal.

        fcopy $c $o -size $at
        seek  $c    $n current
        fcopy $c $o

    } else {
        # General replacement.

        fcopy        $c $o -size $at
        seek         $c    $n current
        puts -nonewline $o $data
        fcopy        $c $o
    }
    }

    Close2 $fname $t $c $o
    return
}

/*  ::fileutil::updateInPlace --*/
/* */
/*  Run command prefix on the contents of the*/
/*  file and replace them with the result of*/
/*  the command.*/
/* */
/*  Arguments:*/
/*  options...  Options and arguments.*/
/*  filename    Path to the file to extend.*/
/*  cmd     Command prefix to run.*/
/* */
/*  Results:*/
/*  None.*/

ret  ::fileutil::updateInPlace (type args) {
    # Syntax: ?options? file cmd
    # options = -encoding    ENC
    #         | -translation TRA
    #         | -eofchar     ECH
    #         | --

    Spec ReadWritable $args opts fname cmd

    # readFile/cat inlined ...

    set             c [open $fname r]
    SetOptions     $c $opts
    set data [read $c]
    close          $c

    # Transformation. Abort and do not modify the target file if an
    # error was raised during this step.

    lappend cmd $data
    set code [catch {uplevel 1 $cmd} res]
    if {$code} {
    return -code $code $res
    }

    # writeFile inlined, with careful preservation of old contents
    # until we are sure that the write was ok.

    if {[catch {
    file rename -force $fname ${fname}.bak

    set              o [open $fname w]
    SetOptions      $o $opts
    puts -nonewline $o $res
    close           $o

    file delete -force ${fname}.bak
    } msg]} {
    if {[file exists ${fname}.bak]} {
        catch {
        file rename -force ${fname}.bak $fname
        }
        return -code error $msg
    }
    }
    return
}

ret  ::fileutil::Writable (type fname , type mv) {
    upvar 1 $mv msg
    if {[file exists $fname]} {
    if {![file isfile $fname]} {
        set msg "Cannot use file \"$fname\", is not a file"
        return 0
    } elseif {![file writable $fname]} {
        set msg "Cannot use file \"$fname\", write access is denied"
        return 0
    }
    }
    return 1
}

ret  ::fileutil::ReadWritable (type fname , type mv) {
    upvar 1 $mv msg
    if {![file exists $fname]} {
    set msg "Cannot use file \"$fname\", does not exist"
    return 0
    } elseif {![file isfile $fname]} {
    set msg "Cannot use file \"$fname\", is not a file"
    return 0
    } elseif {![file writable $fname]} {
    set msg "Cannot use file \"$fname\", write access is denied"
    return 0
    } elseif {![file readable $fname]} {
    set msg "Cannot use file \"$fname\", read access is denied"
    return 0
    }
    return 1
}

ret  ::fileutil::Spec (type check , type alist , type ov , type fv , type args) {
    upvar 1 $ov opts $fv fname

    set  n [llength $args] ; # Num more args
    incr n                 ; # Count path as well

    set opts {}
    set mode maybeopt

    set at 0
    foreach a $alist {
    if {[string equal $mode optarg]} {
        lappend opts $a
        set mode maybeopt
        incr at
        continue
    } elseif {[string equal $mode maybeopt]} {
        if {[string match -* $a]} {
        switch -exact -- $a {
            -encoding -
            -translation -
            -eofchar {
            lappend opts $a
            set mode optarg
            incr at
            continue
            }
            -- {
            # Stop processing.
            incr at
            break
            }
            default {
            return -code error \
                "Bad option \"$a\",\
                expected one of\
                -encoding, -eofchar,\
                or -translation"
            }
        }
        }
        # Not an option, but a file.
        # Stop processing.
        break
    }
    }

    if {([llength $alist] - $at) != $n} {
    # Argument processing stopped with arguments missing, or too
    # many
    return -code error \
        "wrong#args: should be\
        [lindex [info level 1] 0] ?-eofchar|-translation|-encoding arg? file $args"
    }

    set fname [lindex $alist $at]
    incr at
    foreach \
        var $args \
        val [lrange $alist $at end] {
    upvar 1 $var A
    set A $val
    }

    # Check given path ...

    if {![eval [linsert $check end $a msg]]} {
    return -code error $msg
    }

    return
}

ret  ::fileutil::Open2 (type fname , type opts) {
    set c [open $fname r]
    set t [tempfile]
    set o [open $t     w]

    SetOptions $c $opts
    SetOptions $o $opts

    return [list $c $o $t]
}

ret  ::fileutil::Close2 (type f , type temp , type in , type out) {
    close $in
    close $out

    file copy   -force $f ${f}.bak
    file rename -force $temp $f
    file delete -force ${f}.bak
    return
}

ret  ::fileutil::SetOptions (type c , type opts) {
    if {![llength $opts]} return
    eval [linsert $opts 0 fconfigure $c]
    return
}

ret  ::fileutil::CheckLocation (type at , type max , type label) {
    if {![string is integer -strict $at]} {
    return -code error \
        "Expected integer but got \"$at\""
    } elseif {$at < 0} {
    return -code error \
        "Bad $label point $at, before start of data"
    } elseif {$at > $max} {
    return -code error \
        "Bad $label point $at, behind end of data"
    }
}

ret  ::fileutil::CheckLength (type n , type at , type max , type label) {
    if {![string is integer -strict $n]} {
    return -code error \
        "Expected integer but got \"$n\""
    } elseif {$n < 0} {
    return -code error \
        "Bad $label size $n"
    } elseif {($at + $n) > $max} {
    return -code error \
        "Bad $label size $n, going behind end of data"
    }
}

/*  ::fileutil::foreachLine --*/
/* */
/*  Executes a script for every line in a file.*/
/* */
/*  Arguments:*/
/*  var     name of the variable to contain the lines*/
/*  filename    name of the file to read.*/
/*  cmd     The script to execute.*/
/* */
/*  Results:*/
/*  None.*/

ret  ::fileutil::foreachLine (type var , type filename , type cmd) {
    upvar 1 $var line
    set fp [open $filename r]

    # -future- Use try/eval from tcllib/control
    catch {
    set code 0
    set result {}
    while {[gets $fp line] >= 0} {
        set code [catch {uplevel 1 $cmd} result]
        if {($code != 0) && ($code != 4)} {break}
    }
    }
    close $fp

    if {($code == 0) || ($code == 3) || ($code == 4)} {
        return $result
    }
    if {$code == 1} {
        global errorCode errorInfo
        return \
        -code      $code      \
        -errorcode $errorCode \
        -errorinfo $errorInfo \
        $result
    }
    return -code $code $result
}

/*  ::fileutil::touch --*/
/* */
/*  Tcl implementation of the UNIX "touch" command.*/
/* */
/*  touch [-a] [-m] [-c] [-r ref_file] [-t time] filename ...*/
/* */
/*  Arguments:*/
/*  -a      change the access time only, unless -m also specified*/
/*  -m      change the modification time only, unless -a also specified*/
/*  -c      silently prevent creating a file if it did not previously exist*/
/*  -r ref_file use the ref_file's time instead of the current time*/
/*  -t time     use the specified time instead of the current time*/
/*          ("time" is an integer clock value, like [clock seconds])*/
/*  filename ...    the files to modify*/
/* */
/*  Results*/
/*  None.*/
/* */
/*  Errors:*/
/*  Both of "-r" and "-t" cannot be specified.*/

if {[package vsatisfies [package provide Tcl] 8.3]} {
    namespace ::fileutil {
    namespace export touch
    }

    ret  ::fileutil::touch (type args) {
        # Don't bother catching errors, just let them propagate up
        
        set options {
            {a          "set the atime only"}
            {m          "set the mtime only"}
            {c          "do not create non-existant files"}
            {r.arg  ""  "use time from ref_file"}
            {t.arg  -1  "use specified time"}
        }
        set usage ": [lindex [info level 0] 0]\
                      \[options] filename ...\noptions:"
        array set params [::cmdline::getoptions args $options $usage]
        
        # process -a and -m options
        set set_atime [set set_mtime "true"]
        if {  $params(a) && ! $params(m)} {set set_mtime "false"}
        if {! $params(a) &&   $params(m)} {set set_atime "false"}
        
        # process -r and -t
        set has_t [expr {$params(t) != -1}]
        set has_r [expr {[string length $params(r)] > 0}]
        if {$has_t && $has_r} {
            return -code error "Cannot specify both -r and -t"
        } elseif {$has_t} {
            set atime [set mtime $params(t)]
        } elseif {$has_r} {
            file stat $params(r) stat
            set atime $stat(atime)
            set mtime $stat(mtime)
        } else {
            set atime [set mtime [clock seconds]]
        }

        # do it
        foreach filename $args {
            if {! [file exists $filename]} {
                if {$params(c)} {continue}
                close [open $filename w]
            }
            if {$set_atime} {file atime $filename $atime}
            if {$set_mtime} {file mtime $filename $mtime}
        }
        return
    }
}

/*  ::fileutil::fileType --*/
/* */
/*  Do some simple heuristics to determine file type.*/
/* */
/* */
/*  Arguments:*/
/*  filename        Name of the file to test.*/
/* */
/*  Results*/
/*  type            Type of the file.  May be a list if multiple tests*/
/*                        are positive (eg, a file could be both a directory */
/*                        and a link).  In general, the list proceeds from most*/
/*                        general (eg, binary) to most specific (eg, gif), so*/
/*                        the full type for a GIF file would be */
/*                        "binary graphic gif"*/
/* */
/*                        At present, the following types can be detected:*/
/* */
/*                        directory*/
/*                        empty*/
/*                        binary*/
/*                        text*/
/*                        script <interpreter>*/
/*                        executable [elf, dos, ne, pe]*/
/*                        binary graphic [gif, jpeg, png, tiff, bitmap, icns]*/
/*                        ps, eps, pdf*/
/*                        html*/
/*                        xml <doctype>*/
/*                        message pgp*/
/*                        compressed [bzip, gzip, zip, tar]*/
/*                        audio [mpeg, wave]*/
/*                        gravity_wave_data_frame*/
/*                        link*/
/*          doctools, doctoc, and docidx documentation files.*/
/*                   */

ret  ::fileutil::fileType (type filename) {
    ;## existence test
    if { ! [ file exists $filename ] } {
        set err "file not found: '$filename'"
        return -code error $err
    }
    ;## directory test
    if { [ file isdirectory $filename ] } {
        set type directory
        if { ! [ catch {file readlink $filename} ] } {
            lappend type link
        }
        return $type
    }
    ;## empty file test
    if { ! [ file size $filename ] } {
        set type empty
        if { ! [ catch {file readlink $filename} ] } {
            lappend type link
        }
        return $type
    }
    set bin_rx {[\x00-\x08\x0b\x0e-\x1f]}

    if { [ catch {
        set fid [ open $filename r ]
        fconfigure $fid -translation binary
        fconfigure $fid -buffersize 1024
        fconfigure $fid -buffering full
        set test [ read $fid 1024 ]
        ::close $fid
    } err ] } {
        catch { ::close $fid }
        return -code error "::fileutil::fileType: $err"
    }

    if { [ regexp $bin_rx $test ] } {
        set type binary
        set binary 1
    } else {
        set type text
        set binary 0
    }

    # SF Tcllib bug [795585]. Allowing whitespace between #!
    # and path of script interpreter

    set metakit 0

    if { [ regexp {^\#\!\s*(\S+)} $test -> terp ] } {
        lappend type script $terp
    } elseif {[regexp "\\\[manpage_begin " $test]} {
    lappend type doctools
    } elseif {[regexp "\\\[toc_begin " $test]} {
    lappend type doctoc
    } elseif {[regexp "\\\[index_begin " $test]} {
    lappend type docidx
    } elseif { $binary && [ regexp {^[\x7F]ELF} $test ] } {
        lappend type executable elf
    } elseif { $binary && [string match "MZ*" $test] } {
        if { [scan [string index $test 24] %c] < 64 } {
            lappend type executable dos
        } else {
            binary scan [string range $test 60 61] s next
            set sig [string range $test $next [expr {$next + 1}]]
            if { $sig == "NE" || $sig == "PE" } {
                lappend type executable [string tolower $sig]
            } else {
                lappend type executable dos
            }
        }
    } elseif { $binary && [string match "BZh91AY\&SY*" $test] } {
        lappend type compressed bzip
    } elseif { $binary && [string match "\x1f\x8b*" $test] } {
        lappend type compressed gzip
    } elseif { $binary && [string range $test 257 262] == "ustar\x00" } {
        lappend type compressed tar
    } elseif { $binary && [string match "\x50\x4b\x03\x04*" $test] } {
        lappend type compressed zip
    } elseif { $binary && [string match "GIF*" $test] } {
        lappend type graphic gif
    } elseif { $binary && [string match "icns*" $test] } {
        lappend type graphic icns bigendian
    } elseif { $binary && [string match "snci*" $test] } {
        lappend type graphic icns smallendian
    } elseif { $binary && [string match "\x89PNG*" $test] } {
        lappend type graphic png
    } elseif { $binary && [string match "\xFF\xD8\xFF*" $test] } {
        binary scan $test x3H2x2a5 marker txt
        if { $marker == "e0" && $txt == "JFIF\x00" } {
            lappend type graphic jpeg jfif
        } elseif { $marker == "e1" && $txt == "Exif\x00" } {
            lappend type graphic jpeg exif
        }
    } elseif { $binary && [string match "MM\x00\**" $test] } {
        lappend type graphic tiff
    } elseif { $binary && [string match "BM*" $test] && [string range $test 6 9] == "\x00\x00\x00\x00" } {
        lappend type graphic bitmap
    } elseif { $binary && [string match "\%PDF\-*" $test] } {
        lappend type pdf
    } elseif { ! $binary && [string match -nocase "*<html>*" $test] } {
        lappend type html
    } elseif { [string match "\%\!PS\-*" $test] } {
       lappend type ps
       if { [string match "* EPSF\-*" $test] } {
           lappend type eps
       }
    } elseif { [string match -nocase "*<\?xml*" $test] } {
        lappend type xml
        if { [ regexp -nocase {\<\!DOCTYPE\s+(\S+)} $test -> doctype ] } {
            lappend type $doctype
        }
    } elseif { [string match {*BEGIN PGP MESSAGE*} $test] } {
        lappend type message pgp
    } elseif { $binary && [string match {IGWD*} $test] } {
        lappend type gravity_wave_data_frame
    } elseif {[string match "JL\x1a\x00*" $test] && ([file size $filename] >= 27)} {
    lappend type metakit smallendian
    set metakit 1
    } elseif {[string match "LJ\x1a\x00*" $test] && ([file size $filename] >= 27)} {
    lappend type metakit bigendian
    set metakit 1
    } elseif { $binary && [string match "RIFF*" $test] && [string range $test 8 11] == "WAVE" } {
        lappend type audio wave
    } elseif { $binary && [string match "ID3*" $test] } {
        lappend type audio mpeg
    } elseif { $binary && [binary scan $test S tmp] && [expr {$tmp & 0xFFE0}] == 65504 } {
        lappend type audio mpeg
    }

    # Additional checks of file contents at the end of the file,
    # possibly pointing into the middle too (attached metakit,
    # attached zip).

    ## Metakit File format: http://www.equi4.com/metakit/metakit-ff.html
    ## Metakit database attached ? ##

    if {!$metakit && ([file size $filename] >= 27)} {
    # The offsets in the footer are in always bigendian format

    if { [ catch {
        set fid [ open $filename r ]
        fconfigure $fid -translation binary
        fconfigure $fid -buffersize 1024
        fconfigure $fid -buffering full
        seek $fid -16 end
        set test [ read $fid 16 ]
        ::close $fid
    } err ] } {
        catch { ::close $fid }
        return -code error "::fileutil::fileType: $err"
    }

    binary scan $test IIII __ hdroffset __ __
    set hdroffset [expr {[file size $filename] - 16 - $hdroffset}]

    # Further checks iff the offset is actually inside the file.

    if {($hdroffset >= 0) && ($hdroffset < [file size $filename])} {
        # Seek to the specified location and try to match a metakit header
        # at this location.

        if { [ catch {
        set         fid [ open $filename r ]
        fconfigure $fid -translation binary
        fconfigure $fid -buffersize 1024
        fconfigure $fid -buffering full
        seek       $fid $hdroffset start
        set test [ read $fid 16 ]
        ::close $fid
        } err ] } {
        catch { ::close $fid }
        return -code error "::fileutil::fileType: $err"
        }

        if {[string match "JL\x1a\x00*" $test]} {
        lappend type attached metakit smallendian
        set metakit 1
        } elseif {[string match "LJ\x1a\x00*" $test]} {
        lappend type attached metakit bigendian
        set metakit 1
        }
    }
    }

    ## Zip File Format: http://zziplib.sourceforge.net/zzip-parse.html
    ## http://www.pkware.com/products/enterprise/white_papers/appnote.html


    ;## lastly, is it a link?
    if { ! [ catch {file readlink $filename} ] } {
        lappend type link
    }
    return $type
}

/*  ::fileutil::tempdir --*/
/* */
/*  Return the correct directory to use for temporary files.*/
/*  Python attempts this sequence, which seems logical:*/
/* */
/*        1. The directory named by the `TMPDIR' environment variable.*/
/* */
/*        2. The directory named by the `TEMP' environment variable.*/
/* */
/*        3. The directory named by the `TMP' environment variable.*/
/* */
/*        4. A platform-specific location:*/
/*             * On Macintosh, the `Temporary Items' folder.*/
/* */
/*             * On Windows, the directories `C:\\TEMP', `C:\\TMP',*/
/*               `\\TEMP', and `\\TMP', in that order.*/
/* */
/*             * On all other platforms, the directories `/tmp',*/
/*               `/var/tmp', and `/usr/tmp', in that order.*/
/* */
/*        5. As a last resort, the current working directory.*/
/* */
/*  The code here also does*/
/* */
/*  0. The directory set by invoking tempdir with an argument.*/
/*     If this is present it is used exclusively.*/
/* */
/*  Arguments:*/
/*  None.*/
/* */
/*  Side Effects:*/
/*  None.*/
/* */
/*  Results:*/
/*  The directory for temporary files.*/

ret  ::fileutil::tempdir (type args) {
    if {[llength $args] > 1} {
    return -code error {wrong#args: should be "::fileutil::tempdir ?path?"}
    } elseif {[llength $args] == 1} {
    variable tempdir    [lindex $args 0]
    variable tempdirSet 1
    return
    }
    return [Normalize [TempDir]]
}

ret  ::fileutil::tempdirReset () {
    variable tempdir    {}
    variable tempdirSet 0
    return
}

ret  ::fileutil::TempDir () {
    global tcl_platform env
    variable tempdir
    variable tempdirSet

    set attempdirs [list]
    set problems   {}

    if {$tempdirSet} {
    lappend attempdirs $tempdir
    lappend problems {User/Application specified tempdir}
    } else {
    foreach tmp {TMPDIR TEMP TMP} {
        if { [info exists env($tmp)] } {
        lappend attempdirs $env($tmp)
        } else {
        lappend problems "No environment variable $tmp"
        }
    }

    switch $tcl_platform(platform) {
        windows {
        lappend attempdirs "C:\\TEMP" "C:\\TMP" "\\TEMP" "\\TMP"
        }
        macintosh {
        set tmpdir $env(TRASH_FOLDER)  ;# a better place?
        }
        default {
        lappend attempdirs \
            [file join / tmp] \
            [file join / var tmp] \
            [file join / usr tmp]
        }
    }

    lappend attempdirs [pwd]
    }

    foreach tmp $attempdirs {
    if { [file isdirectory $tmp] && [file writable $tmp] } {
        return $tmp
    } elseif { ![file isdirectory $tmp] } {
        lappend problems "Not a directory: $tmp"
    } else {
        lappend problems "Not writable: $tmp"
    }
    }

    # Fail if nothing worked.
    return -code error "Unable to determine a proper directory for temporary files\n[join $problems \n]"
}

namespace ::fileutil {
    variable tempdir    {}
    variable tempdirSet 0
}

/*  ::fileutil::tempfile --*/
/* */
/*    generate a temporary file name suitable for writing to*/
/*    the file name will be unique, writable and will be in the */
/*    appropriate system specific temp directory*/
/*    Code taken from http://mini.net/tcl/772 attributed to*/
/*     Igor Volobouev and anon.*/
/* */
/*  Arguments:*/
/*    prefix     - a prefix for the filename, p*/
/*  Results:*/
/*    returns a file name*/
/* */

ret  ::fileutil::tempfile (optional prefix ={)} {
    return [Normalize [TempFile $prefix]]
}

proc ::fileutil::TempFile {prefix} {
    set tmpdir [tempdir]

    set chars "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789"
    set nrand_chars 10
    set maxtries 10
    set access [list RDWR CREAT EXCL TRUNC]
    set permission 0600
    set channel ""
    set checked_dir_writable 0
    set mypid [pid]
    for {set i 0} {$i < $maxtries} {incr i} {
     newname =  $prefix
    for { j =  0} {$j < $nrand_chars} {incr j} {
        append newname [string index $chars \
            [expr {int(rand()*62)}]]
    }
     newname =  [file join $tmpdir $newname]
    if {[file exists $newname]} {
        after 1
    } else {
        if {[catch {open $newname $access $permission} channel]} {
        if {!$checked_dir_writable} {
             dirname =  [file dirname $newname]
            if {![file writable $dirname]} {
            return -code error "Directory $dirname is not writable"
            }
             checked = _dir_writable 1
        }
        } else {
        /*  Success*/
        close $channel
        return $newname
        }
    }
    }
    if {[string compare $channel ""]} {
    return -code error "Failed to open a temporary file: $channel"
    } else {
    return -code error "Failed to find an unused temporary file name"
    }
}

/*  ::fileutil::install --*/
/* */
/*  Tcl version of the 'install' command, which copies files from*/
/*  one places to another and also optionally sets some attributes*/
/*  such as group, owner, and permissions.*/
/* */
/*  Arguments:*/
/*  -m      Change the file permissions to the specified*/
/*                        value.  Valid arguments are those accepted by*/
/*          file attributes -permissions*/
/* */
/*  Results:*/
/*  None.*/

/*  TODO - add options for group/owner manipulation.*/

ret  ::fileutil::install (type args) {
    set options {
    {m.arg "" "Set permission mode"}
    }
    set usage ": [lindex [info level 0] 0]\
\[options] source destination \noptions:"
    array set params [::cmdline::getoptions args $options $usage]
    # Args should now just be the source and destination.
    if { [llength $args] < 2 } {
    return -code error $usage
    }
    set src [lindex $args 0]
    set dst [lindex $args 1]
    file copy -force $src $dst
    if { $params(m) != "" } {
    set targets [::fileutil::find $dst]
    foreach fl $targets {
        file attributes $fl -permissions $params(m)
    }
    }
}

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

ret  ::fileutil::LexNormalize (type sp) {
    set spx [file split $sp]

    # Resolution of embedded relative modifiers (., and ..).

    if {
    ([lsearch -exact $spx . ] < 0) &&
    ([lsearch -exact $spx ..] < 0)
    } {
    # Quick path out if there are no relative modifiers
    return $sp
    }

    set absolute [expr {![string equal [file pathtype $sp] relative]}]
    # A volumerelative path counts as absolute for our purposes.

    set sp $spx
    set np {}
    set noskip 1

    while {[llength $sp]} {
    set ele    [lindex $sp 0]
    set sp     [lrange $sp 1 end]
    set islast [expr {[llength $sp] == 0}]

    if {[string equal $ele ".."]} {
        if {
        ($absolute  && ([llength $np] >  1)) ||
        (!$absolute && ([llength $np] >= 1))
        } {
        # .. : Remove the previous element added to the
        # new path, if there actually is enough to remove.
        set np [lrange $np 0 end-1]
        }
    } elseif {[string equal $ele "."]} {
        # Ignore .'s, they stay at the current location
        continue
    } else {
        # A regular element.
        lappend np $ele
    }
    }
    if {[llength $np] > 0} {
    return [eval [linsert $np 0 file join]]
    # 8.5: return [file join {*}$np]
    }
    return {}
}

/*  ### ### ### ######### ######### #########*/
/*  Forward compatibility. Some routines require path normalization,*/
/*  something we have supported by the builtin 'file' only since Tcl*/
/*  8.4. For versions of Tcl before that, to be supported by the*/
/*  module, we implement a normalizer in Tcl itself. Slow, but working.*/

if {[package vcompare [package provide Tcl] 8.4] < 0} {
    /*  Pre 8.4. We do not have 'file normalize'. We create an*/
    /*  approximation for it based on earlier commands.*/

    /*  ... Hm. This is lexical normalization. It does not resolve*/
    /*  symlinks in the path to their origin.*/

    ret  ::fileutil::Normalize (type sp) {
    set sp [file split $sp]

    # Conversion of the incoming path to absolute.
    if {[string equal [file pathtype [lindex $sp 0]] "relative"]} {
        set sp [file split [eval [list file join [pwd]] $sp]]
    }

    # Resolution of symlink components, and embedded relative
    # modifiers (., and ..).

    set np {}
    set noskip 1
    while {[llength $sp]} {
        set ele    [lindex $sp 0]
        set sp     [lrange $sp 1 end]
        set islast [expr {[llength $sp] == 0}]

        if {[string equal $ele ".."]} {
        if {[llength $np] > 1} {
            # .. : Remove the previous element added to the
            # new path, if there actually is enough to remove.
            set np [lrange $np 0 end-1]
        }
        } elseif {[string equal $ele "."]} {
        # Ignore .'s, they stay at the current location
        continue
        } else {
        # A regular element. If it is not the last component
        # then check if the combination is a symlink, and if
        # yes, resolve it.

        lappend np $ele

        if {!$islast && $noskip} {
            # The flag 'noskip' is technically not required,
            # just 'file exists'. However if a path P does not
            # exist, then all longer paths starting with P can
            # not exist either, and using the flag to store
            # this knowledge then saves us a number of
            # unnecessary stat calls. IOW this a performance
            # optimization.

            set p [eval file join $np]
            set noskip [file exists $p]
            if {$noskip} {
            if {[string equal link [file type $p]]} {
                set dst [file readlink $p]

                # We always push the destination in front of
                # the source path (in expanded form). So that
                # we handle .., .'s, and symlinks inside of
                # this path as well. An absolute path clears
                # the result, a relative one just removes the
                # last, now resolved component.

                set sp [eval [linsert [file split $dst] 0 linsert $sp 0]]

                if {![string equal relative [file pathtype $dst]]} {
                # Absolute|volrelative destination, clear
                # result, we have to start over.
                set np {}
                } else {
                # Relative link, just remove the resolved
                # component again.
                set np [lrange $np 0 end-1]
                }
            }
            }
        }
        }
    }
    if {[llength $np] > 0} {
        return [eval file join $np]
    }
    return {}
    }
} else {
    ret  ::fileutil::Normalize (type sp) {
    file normalize $sp
    }
}

/*  ::fileutil::relative --*/
/* */
/*  Taking two _directory_ paths, a base and a destination, computes the path*/
/*  of the destination relative to the base.*/
/* */
/*  Arguments:*/
/*  base    The path to make the destination relative to.*/
/*  dst The destination path*/
/* */
/*  Results:*/
/*  The path of the destination, relative to the base.*/

ret  ::fileutil::relative (type base , type dst) {
    # Ensure that the link to directory 'dst' is properly done relative to
    # the directory 'base'.

    if {![string equal [file pathtype $base] [file pathtype $dst]]} {
    return -code error "Unable to compute relation for paths of different pathtypes: [file pathtype $base] vs. [file pathtype $dst], ($base vs. $dst)"
    }

    set base [LexNormalize [file join [pwd] $base]]
    set dst  [LexNormalize [file join [pwd] $dst]]

    set save $dst
    set base [file split $base]
    set dst  [file split $dst]

    while {[string equal [lindex $dst 0] [lindex $base 0]]} {
    set dst  [lrange $dst  1 end]
    set base [lrange $base 1 end]
    if {![llength $dst]} {break}
    }

    set dstlen  [llength $dst]
    set baselen [llength $base]

    if {($dstlen == 0) && ($baselen == 0)} {
    # Cases:
    # (a) base == dst

    set dst .
    } else {
    # Cases:
    # (b) base is: base/sub = sub
    #     dst  is: base     = {}

    # (c) base is: base     = {}
    #     dst  is: base/sub = sub

    while {$baselen > 0} {
        set dst [linsert $dst 0 ..]
        incr baselen -1
    }
    # 8.5: set dst [file join {*}$dst]
    set dst [eval [linsert $dst 0 file join]]
    }

    return $dst
}

/*  ::fileutil::relativeUrl --*/
/* */
/*  Taking two _file_ paths, a base and a destination, computes the path*/
/*  of the destination relative to the base, from the inside of the base.*/
/* */
/*  This is how a browser resolves relative links in a file, hence the*/
/*  url in the command name.*/
/* */
/*  Arguments:*/
/*  base    The file path to make the destination relative to.*/
/*  dst The destination file path*/
/* */
/*  Results:*/
/*  The path of the destination file, relative to the base file.*/

ret  ::fileutil::relativeUrl (type base , type dst) {
    # Like 'relative', but for links from _inside_ a file to a
    # different file.

    if {![string equal [file pathtype $base] [file pathtype $dst]]} {
    return -code error "Unable to compute relation for paths of different pathtypes: [file pathtype $base] vs. [file pathtype $dst], ($base vs. $dst)"
    }

    set base [LexNormalize [file join [pwd] $base]]
    set dst  [LexNormalize [file join [pwd] $dst]]

    set basedir [file dirname $base]
    set dstdir  [file dirname $dst]

    set dstdir  [relative $basedir $dstdir]

    # dstdir == '.' on input => dstdir output has trailing './'. Strip
    # this superfluous segment off.

    if {[string equal $dstdir "."]} {
    return [file tail $dst]
    } elseif {[string equal [file tail $dstdir] "."]} {
    return [file join [file dirname $dstdir] [file tail $dst]]
    } else {
    return [file join $dstdir [file tail $dst]]
    }
}

/*  ::fileutil::fullnormalize --*/
/* */
/*  Normalizes a path completely. I.e. a symlink in the last*/
/*  element is resolved as well, not only symlinks in the higher*/
/*  elements.*/
/* */
/*  Arguments:*/
/*  path    The path to normalize*/
/* */
/*  Results:*/
/*  The input path with all symlinks resolved.*/

ret  ::fileutil::fullnormalize (type path) {
    # When encountering symlinks in a file copy operation Tcl copies
    # the link, not the contents of the file it references. There are
    # situations there this is not acceptable. For these this command
    # resolves all symbolic links in the path, including in the last
    # element of the path. A "file copy" using the return value of
    # this command copies an actual file, it will not encounter
    # symlinks.

    # BUG / WORKAROUND. Using the / instead of the join seems to work
    # around a bug in the path handling on windows which can break the
    # core 'file normalize' for symbolic links. This was exposed by
    # the find testsuite which could not reproduced outside. I believe
    # that there is some deep path bug in the core triggered under
    # special circumstances. Use of / likely forces a refresh through
    # the string rep and so avoids the problem with the path intrep.

    return [file dirname [Normalize $path/__dummy__]]
    #return [file dirname [Normalize [file join $path __dummy__]]]
}