You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
266 lines
12 KiB
266 lines
12 KiB
# -*- tcl -*- |
|
# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from <pkg>-buildversion.txt |
|
# |
|
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. |
|
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. |
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
# (C) 2023 |
|
# |
|
# @@ Meta Begin |
|
# Application punk::winpath 0.1.0 |
|
# Meta platform tcl |
|
# Meta license BSD |
|
# @@ Meta End |
|
|
|
|
|
|
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
## Requirements |
|
##e.g package require frobz |
|
|
|
|
|
|
|
|
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
namespace eval punk::winpath { |
|
namespace export winpath windir cdwin cdwindir illegalname_fix illegalname_test |
|
|
|
|
|
|
|
|
|
#\\servername\share etc or \\?\UNC\servername\share etc. |
|
proc is_unc_path {path} { |
|
set strcopy_path [punk::objclone $path] |
|
set strcopy_path [string map [list \\ /] $strcopy_path] ;#normalize to forward slashes for testing purposes (and forward slashes seem to be auto-translated by windows anyway) |
|
if {[string first "//" $strcopy_path] == 0} { |
|
#check for "Dos device path" syntax |
|
if {[string range $strcopy_path 0 3] in [list "//?/" "//./"]} { |
|
#Note that //./ doesn't appear to be supported in Tcl as at 2023-08 - but //?/ works (except for //?/UNC/Server/share) |
|
if {[string range $strcopy_path 4 6] eq "UNC"} { |
|
return 1 |
|
} else { |
|
#some other Dos device path. Could be a drive which is mapped to a UNC path - but the path itself isn't a unc path |
|
return 0 |
|
} |
|
} else { |
|
#leading double slash and not dos device path syntax |
|
return 1 |
|
} |
|
} |
|
return 0 |
|
} |
|
|
|
#ordinary \\Servername or \\servername\share or \\servername\share\path (or forward-slash equivalent) with no dos device syntax //?/ //./ etc. |
|
proc is_unc_path_plain {path} { |
|
if {[is_unc_path $path]} { |
|
if {![is_dos_device_path $path]} { |
|
return 1 |
|
} else { |
|
return 0 |
|
} |
|
} else { |
|
return 0 |
|
} |
|
} |
|
|
|
#int-rep path preserved - but 'file attributes', and therefor this operation, is expensive (on windows at least) |
|
proc pwdshortname {{path {}}} { |
|
if {$path eq ""} { |
|
set path [pwd] |
|
} else { |
|
if {[file pathtype $path] eq "relative"} { |
|
set path [file normalize $path] |
|
} |
|
} |
|
return [dict get [file attributes $path] -shortname] |
|
} |
|
#dos device path syntax allows windows api to acces extended-length paths and filenames with illegal path characters such as trailing dots or whitespace |
|
#(can exist on server shares and on NTFS - but standard apps can't access without dos device syntax) |
|
proc is_dos_device_path {path} { |
|
set strcopy_path [punk::objclone $path] |
|
set strcopy_path [string map [list \\ /] $strcopy_path] ;#normalize to forward slashes for testing purposes (and forward slashes seem to be auto-translated by windows anyway) |
|
if {[string range $strcopy_path 0 3] in [list "//?/" "//./"]} { |
|
return 1 |
|
} else { |
|
return 0 |
|
} |
|
} |
|
proc strip_dos_device_prefix {path} { |
|
#it's unlikely to be valid to strip only //?/ from a //?/UNC path so check for it here and diver to strip that. |
|
#(review.. or raise error because a //?/UNC path isn't *strictly* a UNC path? ) |
|
if {[is_unc_path $path]} { |
|
return [strip_unc_path_prefix $path] |
|
} |
|
if {[is_dos_device_path $path]} { |
|
return [string range $path 4 end] |
|
} else { |
|
return $path |
|
} |
|
} |
|
proc strip_unc_path_prefix {path} { |
|
if {[is_unc_path $path]} { |
|
#//?/UNC/server/etc |
|
set strcopy_path [punk::objclone $path] |
|
set trimmedpath [string range $strcopy_path 7 end] |
|
file pathtype $trimmedpath ;#shimmer it to path rep |
|
return $trimmedpath |
|
} elseif {is_unc_path_plain $path} { |
|
#plain unc //server |
|
set strcopy_path [punk::objclone $path] |
|
set trimmedpath [string range $strcopy_path 2 end] |
|
file pathtype $trimmedpath |
|
return $trimmedpath |
|
} else { |
|
return $path |
|
} |
|
} |
|
#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 (what usecase? 8.3 name is not always calculable independently) |
|
#The utility of this is questionable. prepending a dos-device path won't make a filename with illegal characters readable by windows. |
|
#It will need the 'shortname' at least for the illegal segment - if not the whole path |
|
#Whilst the 8.3 name algorithm - including undocumented hash function has been reverse engineered |
|
#- it depends on the content of the directory - as collisions cause a different name (e.g incremented number) |
|
#- it also depends on the history of the folder |
|
#- you can't take the current dir contents and a particular *existing* longname and determine the shortname algorithmically... |
|
#- the shortname may have been generated during a different directory state. |
|
#- It is then stored on disk (where?) - so access to reading the existing shortname is required. |
|
#- An implementation of the 8.3 algorithm would only be potentially useful in determining the name that will result from adding a new file |
|
# and would be subject to potential collisions if there are race-conditions in file creation |
|
#- Using an 8.3 algorithm externally would be dangerous in that it could appear to work a lot of the time - but return a different file entirely sometimes. |
|
#- Conclusion is that the 8.3 name must be retrieved rathern than calclated |
|
proc illegalname_fix {path} { |
|
#don't add extra dos device path syntax protection-prefix if already done |
|
if {[is_unc_path $path]} { |
|
error "illegalname_fix called on UNC path $path - unable to process" |
|
} |
|
if {[is_dos_device_path $path]} { |
|
#we may have appended |
|
return $path |
|
} |
|
|
|
|
|
|
|
#\\servername\share theoretically maps to: \\?\UNC\servername\share in protected form. https://learn.microsoft.com/en-us/dotnet/standard/io/file-path-formats |
|
#NOTE: 2023-08 on windows 10 at least \\?\UNC\Server\share doesn't work - ie we can't use illegalname_fix on UNC paths such as \\Server\share |
|
#(but mapped drive to same path will work) |
|
#Note that test-path cmdlet in powershell is also flaky with regards to \\?\UNC\Server paths. |
|
#It seems prudent for now to disallow \\?\ protection for UNC paths such as \\server\etc |
|
if {[is_unc_path $path]} { |
|
set err "" |
|
append err "illegalname_fix doesn't currently support UNC paths (non dos device leading double slash or //?/UNC/...)" |
|
append err \n " - because //?/UNC/Servername/share is not supported in Tcl (and only minimally even in powershell) as at 2023. (on windows use mapped drive instead)" |
|
error $err |
|
} |
|
|
|
set strcopy_path [punk::objclone $path] |
|
|
|
|
|
#Note: path could still have leading double slash if it is a Dos device path: e.g. //?/c:/etc |
|
if {[file pathtype $path] eq "absolute"} { |
|
if {$path eq "~"} { |
|
# non-normalized ~ is classified as absolute |
|
# tilde special meaning is a bit of a nuisance.. but as it's the entire path in this case.. presumably it should be kept that way |
|
# leave for caller to interpret it - but it's not an illegal name whether it's interpreted with special meaning or not |
|
# unlikely this fix will be called on a plain tilde anyway |
|
return $path |
|
} else { |
|
set fullpath $path |
|
} |
|
} else { |
|
#set fullpath [file normalize $path] ;#very slow on windows |
|
#set fullpath [pwd]/$path ;#will keep ./ in middle of path - not valid for dos-device paths |
|
if {[string range $strcopy_path 0 1] eq "./"} { |
|
set strcopy_path [string range $strcopy_path 2 end] |
|
} |
|
set fullpath [file join [pwd] $strcopy_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 "\\\\?\\" ;# value is: \\?\ prefix |
|
set protect2 "//?/" ;#file normalize may do this - it still works |
|
#don't use "//./" - not currently supported in Tcl - seems to work in powershell though. |
|
|
|
|
|
#choose //?/ as normalized version - since likely 'file normalize' will do it anyway, and experimentall, the windows API accepts both REVIEW |
|
set result ${protect2}$fullpath |
|
file pathtype $result ;#make it return a path rep |
|
return $result |
|
} |
|
|
|
#don't test for platform here - needs to be callable from any platform for potential passing to windows |
|
#we can create files with windows illegal names by using //?/ dos device path syntax - but we need to detect when that is required. |
|
# |
|
# path int-rep preserving |
|
proc illegalname_test {path} { |
|
#https://learn.microsoft.com/en-us/windows/win32/fileio/naming-a-file |
|
#according to the above: Use any character in the current code page for a name, including Unicode characters and characters in the extended character set (128–255), except for the following: |
|
set reserved [list < > : \" / \\ | ? *] |
|
|
|
|
|
#we need to exclude things like path/.. path/. |
|
foreach seg [file split $path] { |
|
if {$seg in [list . ..]} { |
|
#review - what if there is a folder or file that actually has a name such as . or .. ? |
|
#unlikely in normal use - but could done deliberately for bad reasons? |
|
#We are unable to check for it here anyway - as this command is intended for checking the path string - not the actual path on a filesystem. |
|
# |
|
#/./ /../ segments don't require protection - keep checking. |
|
continue |
|
} |
|
|
|
#only check for actual space as other whitespace seems to work without being stripped |
|
#trailing tab and trailing \n or \r seem to be creatable in windows with Tcl - map to some glyph |
|
if {[string index $seg 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 with dos device syntax |
|
return 0 |
|
} |
|
|
|
proc test_ntfs_tunneling {f1 f2 args} { |
|
file mkdir $f1 |
|
puts stderr "waiting 15secs..." |
|
after 5000 {puts -nonewline stderr .} |
|
after 5000 {puts -nonewline stderr .} |
|
after 5000 {puts -nonewline stderr .} |
|
after 500 {puts stderr \n} |
|
file mkdir $f2 |
|
puts stdout "$f1 [file stat $f1]" |
|
puts stdout "$f2 [file stat $f2]" |
|
file delete $f1 |
|
puts stdout "renaming $f2 to $f1" |
|
file rename $f2 $f1 |
|
puts stdout "$f1 [file stat $f1]" |
|
|
|
} |
|
|
|
} |
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
## Ready |
|
package provide punk::winpath [namespace eval punk::winpath { |
|
variable version |
|
set version 0.1.0 |
|
}] |
|
return
|
|
|