if {([package vcompare [package provide Tcl] 7.6] < 0)
&& [string match unix $tcl_platform(platform)]} {
# The subcommands copy, delete, rename, and mkdir were added to
# the Tcl command 'file' in Tcl version 7.6. The following command
# approximates them on Unix platforms. It may not agree with
# the Tcl 7.6+ command 'file' in all of its functionality (notably
# the way it reports errors). Further refinements should be made as
# needed.
rename file Tcl7.5_file
proc file {option args} {
switch -glob -- $option {
c* {
if {[string first $option copy] != 0} {
return [uplevel [list Tcl7.5_file $option] $args]
}
# Translate -force into -f
if {[string match -force [lindex $args 0]]} {
set args [lreplace $args 0 0 -f]
}
uplevel exec cp $args
}
de* {
if {[string first $option delete] != 0} {
return [uplevel [list Tcl7.5_file $option] $args]
}
if {[string match -force [lindex $args 0]]} {
set args [lreplace $args 0 0 -f]
}
catch {uplevel exec rm $args}
}
mk* {
if {[string first $option mkdir] != 0} {
return [uplevel [list Tcl7.5_file $option] $args]
}
uplevel exec mkdir $args
}
ren* {
if {[string first $option rename] != 0} {
return [uplevel [list Tcl7.5_file $option] $args]
}
if {[string match -force [lindex $args 0]]} {
set args [lreplace $args 0 0 -f]
}
uplevel exec mv $args
}
default {
uplevel [list Tcl7.5_file $option] $args
}
}
}
}
if {[package vcompare [package provide Tcl] 8] < 0} {
# The subcommands nativename and attributes were added to
# the Tcl command 'file' in Tcl version 8.0. Here is an approximation
# for earlier Tcl versions:
rename file Tcl7.6_file
;proc file {option args} {
switch -glob -- $option {
att* {
if {[string first $option attributes] != 0} {
uplevel [list Tcl7.6_file $option] $args
}
return -code error "Tcl [package provide Tcl] does not support\
\[file attributes\].\n\tUpgrade to Tcl 8.0 to use it."
}
n* {
if {[string first $option nativename] != 0} {
uplevel [list Tcl7.6_file $option] $args
}
if {![llength $args]} {
return -code error "wrong # args: should be\
\"file nativename name ?arg ...?\""
}
set fcomps [file split [lindex $args 0]]
# Take care of tilde substitution
set first [lindex $fcomps 0]
if {[string match ~* $first]} {
set first [file join [file dirname $first] [file tail $first]]
}
set result [eval file join [list $first] [lrange $fcomps 1 end]]
global tcl_platform
if {[string match windows $tcl_platform(platform)]} {
regsub -all -- / $result \\ result
}
return $result
}
default {
uplevel [list Tcl7.6_file $option] $args
}
}
}
}
if {[package vcompare [package provide Tcl] 8.4] < 0} {
# The subcommands nativename and attributes were added to
# the Tcl command 'file' in Tcl version 8.0. Here is an approximation
# for earlier Tcl versions:
rename file Tcl8.0_file
;proc file {option args} {
switch -glob -- $option {
norm* {
set sp [file split [lindex $args 0]]
if {[file pathtype [lindex $sp 0]] == "relative"} {
set sp [file split [eval [list file join [pwd]] $sp]]
}
set np {}
foreach ele $sp {
if {$ele != ".."} {
if {$ele != "."} { lappend np $ele }
} elseif {[llength $np]> 1} {
set np [lrange $np 0 [expr {[llength $np] - 2}]]
}
}
if {[llength $np] > 0} { return [eval file join $np] }
}
default {
uplevel [list Tcl8.0_file $option] $args
}
}
}
}The normalize I saw above was purely lexical and did not resolve symlinks. Here is a variant which behaves like the 8.4 file normalize, at least it passes the part of the Tcl testsuite dealing with 'normalize'.
proc file_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 {}
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} {
if {[string equal link [file type [set p [eval file join $np]]]]} {
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]
}
}[tcl_user] - 2009-07-29 04:51:36One thing I observed in the file_normalize proc for Tcl8.4 behaviour is that 'file normalize' will return the normalized path even if the file does not exist. But this proc requires the file to exist before the path can be normalized
