Attachment "fileutil.tcl" to
ticket [3612359fff]
added by
acapola
2013-05-01 03:18:03.
# fileutil.tcl --
#
# Tcl implementations of standard UNIX utilities.
#
# Copyright (c) 1998-2000 by Ajuba Solutions.
# Copyright (c) 2002 by Phil Ehrens <[email protected]> (fileType)
# Copyright (c) 2005-2013 by Andreas Kupries <[email protected]>
#
# 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.5
namespace eval ::fileutil {
namespace export \
grep find findByPattern cat touch foreachLine \
jail stripPwd stripN stripPath tempdir tempfile \
install fileType writeFile appendToFile \
insertIntoFile removeFromFile replaceInFile \
updateInPlace test tempdirReset
}
# ::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
proc ::fileutil::grep {pattern {files {}}} {
set result [list]
if {[llength $files] == 0} {
# read from stdin
set lnum 0
while {[gets stdin line] >= 0} {
incr lnum
if {[regexp -- $pattern $line]} {
lappend result "${lnum}:${line}"
}
}
} else {
foreach filename $files {
set file [open $filename r]
set 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.
proc ::fileutil::find {{basedir .} {filtercmd {}}} {
set result {}
set 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.
set pending [list $basedir]
set at 0
array set known {}
while {$at < [llength $pending]} {
# Get next directory not yet processed.
set 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.
set norm [fileutil::fullnormalize $f]
if {[info exists known($norm)]} continue
set 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.
proc ::fileutil::FADD {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 switches 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.
#
# Note further that we have to handle broken links on our own. They
# are not returned by glob yet we want them in the output.
#
# 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.5]} {
# Tcl 8.5+.
# We have to check readability of "current" on our own, glob
# changed to error out instead of returning nothing.
proc ::fileutil::ACCESS {args} {}
proc ::fileutil::GLOBF {current} {
if {![file readable $current]} {
return {}
}
if {([file type $current] eq "link") &&
!([file exists [file readlink $current]] &&
[file readable [file readlink $current]])} {
return {}
}
set res [concat \
[glob -nocomplain -directory $current -types f -- *] \
[glob -nocomplain -directory $current -types {hidden f} -- *]]
# Look for broken links (They are reported as neither file nor directory).
foreach l [concat \
[glob -nocomplain -directory $current -types l -- *] \
[glob -nocomplain -directory $current -types {hidden l} -- *] ] {
if {[file isfile $l]} continue
if {[file isdirectory $l]} continue
lappend res $l
}
return $res
}
proc ::fileutil::GLOBD {current} {
if {![file readable $current]} {
return {}
}
if {([file type $current] eq "link") &&
!([file exists [file readlink $current]] &&
[file readable [file readlink $current]])} {
return {}
}
concat \
[glob -nocomplain -directory $current -types d -- *] \
[glob -nocomplain -directory $current -types {hidden d} -- *]
}
} elseif {[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
proc ::fileutil::ACCESS {args} {}
proc ::fileutil::GLOBF {current} {
set res [concat \
[glob -nocomplain -directory $current -types f -- *] \
[glob -nocomplain -directory $current -types {hidden f} -- *]]
# Look for broken links (They are reported as neither file nor directory).
foreach l [concat \
[glob -nocomplain -directory $current -types l -- *] \
[glob -nocomplain -directory $current -types {hidden l} -- *] ] {
if {[file isfile $l]} continue
if {[file isdirectory $l]} continue
lappend res $l
}
return $res
}
proc ::fileutil::GLOBD {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.
proc ::fileutil::ACCESS {current} {
if {[catch {
set h [pwd] ; cd $current ; cd $h
}]} {return -code continue}
return
}
if {[string equal $::tcl_platform(platform) windows]} {
proc ::fileutil::GLOBF {current} {
concat \
[glob -nocomplain -directory $current -types f -- *] \
[glob -nocomplain -directory $current -types {hidden f} -- *]]
}
} else {
proc ::fileutil::GLOBF {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 isdirectory $x]} continue
# We have now accepted files, links to files, and broken links.
lappend l $x
}
return $l
}
}
proc ::fileutil::GLOBD {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.
proc ::fileutil::ACCESS {args} {}
if {[string equal $::tcl_platform(platform) windows]} {
# Hidden files cannot be handled by Tcl 8.2 in glob. We have
# to punt.
proc ::fileutil::GLOBF {current} {
set current \\[join [split $current {}] \\]
set res {}
foreach x [glob -nocomplain -- [file join $current *]] {
if {[file isdirectory $x]} continue
if {[catch {file type $x}]} continue
# We have now accepted files, links to files, and
# broken links. We may also have accepted a directory
# as well, if the current path was inaccessible. This
# however will cause 'file type' to throw an error,
# hence the second check.
lappend res $x
}
return $res
}
proc ::fileutil::GLOBD {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.
proc ::fileutil::GLOBF {current} {
set current \\[join [split $current {}] \\]
set res {}
foreach x [glob -nocomplain -- [file join $current *] [file join $current .*]] {
if {[file isdirectory $x]} continue
if {[catch {file type $x}]} continue
# We have now accepted files, links to files, and
# broken links. We may also have accepted a directory
# as well, if the current path was inaccessible. This
# however will cause 'file type' to throw an error,
# hence the second check.
lappend res $x
}
return $res
}
proc ::fileutil::GLOBD {current} {
set current \\[join [split $current {}] \\]
set res {}
foreach x [glob -nocomplain -- $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.
proc ::fileutil::findByPattern {basedir 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.
proc ::fileutil::FindRegexp {patterns 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.
proc ::fileutil::FindGlob {patterns 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.
proc ::fileutil::stripPwd {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
proc ::fileutil::stripN {path 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.
if {[string equal $tcl_platform(platform) windows]} {
# Windows. While paths are stored with letter-case preserved al
# comparisons have to be done case-insensitive. For reference see
# SF Tcllib Bug 2499641.
proc ::fileutil::stripPath {prefix 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 prefix [file split $prefix]
set npath [file split $path]
if {[string equal -nocase $prefix $npath]} {
return "."
}
if {[string match -nocase "${prefix} *" $npath]} {
set path [eval [linsert [lrange $npath [llength $prefix] end] 0 file join ]]
}
return $path
}
} else {
proc ::fileutil::stripPath {prefix 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 prefix [file split $prefix]
set npath [file split $path]
if {[string equal $prefix $npath]} {
return "."
}
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.
proc fileutil::jail {jail 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 eval ::fileutil {
variable test
array set 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}}
}
}
proc ::fileutil::test {path codes {msgvar {}} {label {}}} {
variable test
if {[string equal $msgvar ""]} {
set 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
set 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]} {
set 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.
proc ::fileutil::cat {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.
proc ::fileutil::writeFile {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.
proc ::fileutil::appendToFile {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.
proc ::fileutil::insertIntoFile {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.
proc ::fileutil::removeFromFile {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.
proc ::fileutil::replaceInFile {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.
proc ::fileutil::updateInPlace {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
}
proc ::fileutil::Writable {fname 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
}
proc ::fileutil::ReadWritable {fname 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
}
proc ::fileutil::Spec {check alist ov fv 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
}
proc ::fileutil::Open2 {fname 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]
}
proc ::fileutil::Close2 {f temp in out} {
close $in
close $out
file copy -force $f ${f}.bak
file rename -force $temp $f
file delete -force ${f}.bak
return
}
proc ::fileutil::SetOptions {c opts} {
if {![llength $opts]} return
eval [linsert $opts 0 fconfigure $c]
return
}
proc ::fileutil::CheckLocation {at max 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"
}
}
proc ::fileutil::CheckLength {n at max 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.
proc ::fileutil::foreachLine {var filename 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 eval ::fileutil {
namespace export touch
}
proc ::fileutil::touch {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.
#
proc ::fileutil::fileType {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] &&
!([regexp -- {--- !doctools ---} $test] || [regexp -- "!tcl\.tk//DSL doctools//EN//" $test])) ||
([regexp -- {--- doctools ---} $test] || [regexp -- "tcl\.tk//DSL doctools//EN//" $test])} {
lappend type doctools
} elseif {([regexp "\\\[toc_begin " $test] &&
!([regexp -- {--- !doctoc ---} $test] || [regexp -- "!tcl\.tk//DSL doctoc//EN//" $test])) ||
([regexp -- {--- doctoc ---} $test] || [regexp -- "tcl\.tk//DSL doctoc//EN//" $test])} {
lappend type doctoc
} elseif {([regexp "\\\[index_begin " $test] &&
!([regexp -- {--- !docidx ---} $test] || [regexp -- "!tcl\.tk//DSL docidx//EN//" $test])) ||
([regexp -- {--- docidx ---} $test] || [regexp -- "tcl\.tk//DSL docidx//EN//" $test])} {
lappend type docidx
} elseif {[regexp -- "tcl\\.tk//DSL diagram//EN//" $test]} {
lappend type tkdiagram
} 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.
proc ::fileutil::tempdir {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]]
}
proc ::fileutil::tempdirReset {} {
variable tempdir {}
variable tempdirSet 0
return
}
proc ::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 {
lappend attempdirs $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 eval ::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
#
proc ::fileutil::tempfile {{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} {
set newname $prefix
for {set j 0} {$j < $nrand_chars} {incr j} {
append newname [string index $chars \
[expr {int(rand()*62)}]]
}
set newname [file join $tmpdir $newname]
if {[file exists $newname]} {
after 1
} else {
if {[catch {open $newname $access $permission} channel]} {
if {!$checked_dir_writable} {
set dirname [file dirname $newname]
if {![file writable $dirname]} {
return -code error "Directory $dirname is not writable"
}
set 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.
proc ::fileutil::install {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)
}
}
}
# ### ### ### ######### ######### #########
proc ::fileutil::lexnormalize_buggy {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 {}
}
#this version return ../../toto unchanged. original version returns toto !
proc ::fileutil::lexnormalize {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))
} {
set last [lindex $np [expr [llength $np]-1]]
if {$last!=".."} {
# .. : Remove the previous element added to the
# new path, if there actually is enough to remove.
set np [lrange $np 0 end-1]
} else {
lappend np $ele
}
} else {
# .. is the first thing we have, cannot remove anything
lappend np $ele
}
} 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.
proc ::fileutil::Normalize {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 {
proc ::fileutil::Normalize {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.
proc ::fileutil::relative {base 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.
proc ::fileutil::relativeUrl {base 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.
proc ::fileutil::fullnormalize {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__]]]
}
