# -*- tcl -*- # Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from -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