@ -3534,6 +3534,9 @@ namespace eval punk {
error "usage: punk::xmore args where args are run as {*}\$args | more" error "usage: punk::xmore args where args are run as {*}\$args | more"
} }
} }
#review - is this intended to be useful/callable on non-windows platforms?
#it should in theory be useable from another platform that wants to create a path for use on windows.
proc winpath {path} { proc winpath {path} {
#NOTE: tcl file exists gives different answers on windows for paths like /c depending on cwd (presumably based on file pathtype of volumerelative) #NOTE: tcl file exists gives different answers on windows for paths like /c depending on cwd (presumably based on file pathtype of volumerelative)
#This is add odds with attempting to navigate on a windows system which has cygwin, wsl etc... It also makes it difficult for functions intended to operate independent of CWD. #This is add odds with attempting to navigate on a windows system which has cygwin, wsl etc... It also makes it difficult for functions intended to operate independent of CWD.
@ -3591,6 +3594,12 @@ namespace eval punk {
set path [file normalize $path] set path [file normalize $path]
#may still not exist.. that's ok. #may still not exist.. that's ok.
} }
#file normalize may change backslashes to forward slashes.. including things like the special \\?\ prefix which is intended to stop windows api from parsing a name
#2023 - this is ok as //?/ also seems to work.. but it is unclear if that is because Tcl is re-converting to backslashes
if {[punk::winpath_illegalname_test] $path} {
set path [punk::winpath_illegalname_fix $path]
}
return $path return $path
} }
proc windir {path} { proc windir {path} {
@ -3666,10 +3675,22 @@ namespace eval punk {
set a1 [lindex $args 0] set a1 [lindex $args 0]
set a2 [lindex $args 1] set a2 [lindex $args 1]
set a3 [lindex $args 2] set a3 [lindex $args 2]
set fileops [list -b -c -d -e -f -h -L -s -S -x -w]
if {[llength $args] == 1} { if {[llength $args] == 1} {
#equivalent of -n STRING #equivalent of -n STRING
set boolresult [expr {[string length $a1] != 0}] set boolresult [expr {[string length $a1] != 0}]
} elseif {[llength $args] == 2} { } elseif {[llength $args] == 2} {
if {$a1 in $fileops} {
if {$::tcl_platform(platform) eq "windows"} {
#e.g trailing dot or trailing space
if {[punk::winpath_illegalname_test $a2]} {
#protect with \\?\ to stop windows api from parsing
#will do nothing if already prefixed with \\?\
set a2 [punk::winpath_illegalname_fix $a2]
}
}
}
switch -- $a1 { switch -- $a1 {
-b { -b {
#dubious utility on FreeBSD, windows? #dubious utility on FreeBSD, windows?
@ -4765,7 +4786,92 @@ namespace eval punk {
interp alias {} aliases {} punk aliases interp alias {} aliases {} punk aliases
interp alias {} alias {} punk alias interp alias {} alias {} punk alias
interp alias {} treemore {} punk::xmore tree interp alias {} treemore {} punk::xmore tree
interp alias {} fcat {} fileutil::cat
#we don't validate that path is actually illegal because we don't know the full range of such names.
#The caller can apply this to any path.
#don't test for platform here - needs to be callable from any platform for potential passing to windows
proc winpath_illegalname_fix {path} {
if {[file pathtype $path] eq "absolute"} {
set fullpath $path
} else {
set fullpath [pwd]/$path
}
#For file I/O, the "\\?\" prefix to a path string tells the Windows APIs to disable all string parsing
# and to send the string that follows it straight to the file system.
set protect {\\?}
append protect "\\"
set protect2 "//?/" ;#file normalize may do this - it still works
#don't add extra protect-prefix if already done
if {[string range $path 0 3] in [list $protect $protect2]} {
return $path
}
return ${protect}$fullpath
}
#don't test for platform here - needs to be callable from any platform for potential passing to windows
proc winpath_illegalname_test {path} {
set protect "\\\\?\\" ;# value is: \\?\
#todo - test folder segments within path?
#first test if already protected - we return false even if the file would be illegal without the protection!
if {[string range $path 0 3] eq $protect} {
return 0
}
if {[string index $path end] in [list " " "."]} {
#windows API doesn't handle trailing dots or spaces (silently strips?) - even though such files can be created on NTFS systems (or seen via samba etc)
return 1
}
#glob chars '* ?' are probably illegal.. but although x*y.txt and x?y.txt don't display properly (* ? replaced with some other glyph)
#- they seem to be readable from cmd and tclsh as is.
# pipe symbol also has glyph substitution and behaves the same e.g a|b.txt
#(at least with encoding system utf-8)
#todo - determine what else constitutes an illegal name according to windows APIs and requires protection
return 0
}
proc fcat {args} {
if {$::tcl_platform(platform) ne "windows"} {
return [fileutil::cat {*}$args]
}
set knownopts [list -eofchar -translation -encoding]
set last_opt 0
for {set i 0} {$i < [llength $args]} {incr i} {
puts stdout "i:$i a: [lindex $args $i] known: [expr {[lindex $args $i] in $knownopts}]"
if {[lindex $args $i] in $knownopts} {
puts ">known at $i : [lindex $args $i]"
if {($i % 2) != 0} {
error "unexpected option at index $i. known options: $knownopts must come in -opt val pairs."
}
incr i
set last_opt $i
} else {
set last_opt [expr {$i - 1}]
break
}
}
set first_non_opt [expr {$last_opt + 1}]
puts stderr "first_non_opt: $first_non_opt"
set opts [lrange $args -1 $first_non_opt-1]
set paths [lrange $args $first_non_opt end]
if {![llength $paths]} {
error "Unable to find file in the supplied arguments: $args. Ensure options are all -opt val pairs and that file name(s) follow"
}
puts stderr "opts: $opts paths: $paths"
set finalpaths [list]
foreach p $paths {
if {[punk::winpath_illegalname_test $p]} {
lappend finalpaths [punk::winpath_illegalname_fix $p]
} else {
lappend finalpaths $p
}
}
fileutil::cat {*}$opts {*}$finalpaths
}
#fileutil::cat except with checking for windows illegal path names (when on windows platform)
interp alias {} fcat {} punk::fcat
#---------------------------------------------- #----------------------------------------------
interp alias {} linelistraw {} punk::linelistraw interp alias {} linelistraw {} punk::linelistraw
