mirror of https://gitlab.com/QEF/q-e.git
2119 lines
57 KiB
Tcl
2119 lines
57 KiB
Tcl
# 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.1 2008-02-15 17:01:46 kokalj Exp $
|
|
|
|
package require Tcl 8.2
|
|
package require cmdline
|
|
package provide fileutil 1.13.3
|
|
|
|
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 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
|
|
|
|
proc ::fileutil::ACCESS {args} {}
|
|
|
|
proc ::fileutil::GLOBF {current} {
|
|
concat \
|
|
[glob -nocomplain -directory $current -types f -- *] \
|
|
[glob -nocomplain -directory $current -types {hidden f} -- *]
|
|
}
|
|
|
|
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 isfile $x]} continue
|
|
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 isfile $x]} continue
|
|
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 isfile $x]} continue
|
|
lappend res $x
|
|
}
|
|
return $res
|
|
}
|
|
|
|
proc ::fileutil::GLOBD {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.
|
|
|
|
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.
|
|
|
|
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.
|
|
|
|
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.
|
|
|
|
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]} {
|
|
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.
|
|
|
|
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 {
|
|
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 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 {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.
|
|
|
|
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__]]]
|
|
}
|