If there's anyone out there who is looking for something to do, this page could use an update to cover the new [file] subcommands introduced in releases 8.3 and 8.4 of Tcl.
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]
}
}