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.
363 lines
17 KiB
363 lines
17 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 999999.0a1.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::winpath::system::objclone $path] |
|
set strcopy_path [string map {\\ /} $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 {//?/ //./}} { |
|
#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::winpath::system::objclone $path] |
|
set strcopy_path [string map {\\ /} $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 {//?/ //./}} { |
|
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 an ordinary dos device 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_plain $path]} { |
|
#plain unc //server |
|
set strcopy_path [punk::winpath::system::objclone $path] |
|
set trimmedpath [string range $strcopy_path 2 end] |
|
file pathtype $trimmedpath |
|
return $trimmedpath |
|
} elseif {is_unc_path $path} { |
|
#//?/UNC/server/subpath or //./UNC/server/subpath |
|
set strcopy_path [punk::winpath::system::objclone $path] |
|
set trimmedpath [string range $strcopy_path 7 end] |
|
file pathtype $trimmedpath ;#shimmer it to path rep |
|
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::winpath::system::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 shortname {path} { |
|
set shortname "NA" |
|
if {[catch { |
|
set shortname [dict get [file attributes $path] -shortname] |
|
} errM]} { |
|
puts stderr "Failed to get shortname for '$path'" |
|
} |
|
return $shortname |
|
} |
|
proc test_ntfs_tunneling {prefix args} { |
|
puts stderr "We are looking for whether any of the final $prefix files or dirs took over the ctime attribute of the original $prefix files or dirs" |
|
puts stderr "We expect the ino values to get potentially reassigned depending on order of deletion/creation so matches are coincidental and not material" |
|
puts stderr "The shortnames are similarly allocated as they come - so presumably match by coincidence" |
|
puts stderr "However - if we record a file's shortname, then delete it. Recreating it by shortname within the tunneling timeframe will magically reassociate the longname" |
|
puts stderr "use test_ntfs_tunneling2 to test shortname tunneling" |
|
file mkdir $prefix-dir-rename |
|
file mkdir $prefix-dir-recreate |
|
set fd [open $prefix-file-recreate.txt w] |
|
puts $fd "original for recreate" |
|
close $fd |
|
set fd [open $prefix-file-rename.txt w] |
|
puts $fd "original for rename" |
|
close $fd |
|
puts stdout "ORIGINAL files/dirs" |
|
puts stdout "$prefix-dir-rename [file stat $prefix-dir-rename] " |
|
puts stdout "$prefix-dir-recreate [file stat $prefix-dir-recreate]" |
|
puts stdout "$prefix-file-recreate.txt [file stat $prefix-file-recreate.txt] short:[shortname $prefix-file-recreate.txt]" |
|
puts stdout "$prefix-file-rename.txt [file stat $prefix-file-rename.txt] short:[shortname $prefix-file-rename.txt]" |
|
puts stderr "waiting 10secs (to have discernable ctime differences)" |
|
after 5000 |
|
puts -nonewline stderr . |
|
after 5000 |
|
puts -nonewline stderr . |
|
after 500 |
|
|
|
#-- |
|
#seems to make no diff whether created or copied - no tunneling seen with dirs |
|
#file mkdir $prefix-dir-rename-temp |
|
file copy $prefix-dir-rename $prefix-dir-rename-temp |
|
#-- |
|
puts stderr \n |
|
puts stdout "$prefix-dir-rename-temp [file stat $prefix-dir-rename-temp] (temp to rename into place)" |
|
puts stderr "deleting $prefix-dir-rename" |
|
file delete $prefix-dir-rename |
|
puts stdout "renaming $prefix-dir-rename-temp to $prefix-dir-rename" |
|
file rename $prefix-dir-rename-temp $prefix-dir-rename |
|
|
|
puts stderr "deleting $prefix-dir-recreate" |
|
file delete $prefix-dir-recreate |
|
puts stdout "re-creating $prefix-dir-recreate" |
|
file mkdir $prefix-dir-recreate |
|
|
|
puts stderr "deleting $prefix-file-recreate.txt" |
|
file delete $prefix-file-recreate.txt |
|
puts stderr "Recreating $prefix-file-recreate.txt" |
|
set fd [open $prefix-file-recreate.txt w] |
|
puts $fd "replacement" |
|
close $fd |
|
|
|
puts stderr "copying $prefix-file-rename.txt to $prefix-file-rename-temp.txt" |
|
file copy $prefix-file-rename.txt $prefix-file-rename-temp.txt |
|
puts stdout "$prefix-file-rename-temp.txt [file stat $prefix-file-rename-temp.txt] short:[shortname $prefix-file-rename-temp.txt] (status of initial temp copy)" |
|
puts stderr "modifying temp copy before deletion of original.. (append)" |
|
set fd [open $prefix-file-rename-temp.txt a] |
|
puts $fd "added to file" |
|
close $fd |
|
puts stdout "$prefix-file-rename-temp.txt [file stat $prefix-file-rename-temp.txt] short:[shortname $prefix-file-rename-temp.txt] (status of appended temp copy)" |
|
puts stderr "deleting $prefix-file-rename.txt" |
|
file delete $prefix-file-rename.txt |
|
puts stderr "renaming temp file $prefix-file-rename-temp.txt to original $prefix-file-rename.txt" |
|
file rename $prefix-file-rename-temp.txt $prefix-file-rename.txt |
|
|
|
puts stdout "Final files/dirs" |
|
puts stdout "$prefix-dir-rename [file stat $prefix-dir-rename]" |
|
puts stdout "$prefix-dir-recreate [file stat $prefix-dir-recreate]" |
|
puts stdout "$prefix-file-recreate.txt [file stat $prefix-file-recreate.txt] short:[shortname $prefix-file-recreate.txt]" |
|
puts stdout "$prefix-file-rename.txt [file stat $prefix-file-rename.txt] short:[shortname $prefix-file-rename.txt]" |
|
} |
|
proc test_ntfs_tunneling2 {prefix {waitms 15000}} { |
|
#shortname -> longname tunneling |
|
puts stderr "Tunneling only happens if we delete via shortname? review" |
|
set f1 $prefix-longname-file1.txt |
|
set f2 $prefix-longname-file2.txt |
|
|
|
set fd [open $f1 w];close $fd |
|
set shortname1 [shortname $f1] |
|
puts stderr "longname:$f1 has shortname:$shortname1" |
|
set fd [open $f2 w];close $fd |
|
set shortname2 [shortname $f2] |
|
puts stderr "longname:$f2 has shortname:$shortname2" |
|
|
|
puts stderr "deleting $f1 via name $shortname1" |
|
file delete $shortname1 |
|
puts stdout "immediately recreating $shortname1 - should retain longname $f1 via tunneling" |
|
set fd [open $shortname1 w];close $fd |
|
set f1_exists [file exists $f1] |
|
puts stdout "file exists $f1 = $f1_exists" |
|
|
|
puts stderr "deleting $f2 via name $shortname2" |
|
file delete $shortname2 |
|
puts stderr "Waiting [expr {$waitms / 1000}] seconds.. (standard tunneling timeframe is 15 seconds if registry hasn't been tweaked)" |
|
after $waitms |
|
puts stdout "recreating $shortname2 after wait of $waitms ms - longname lost?" |
|
set fd [open $shortname2 w];close $fd |
|
set f2_exists [file exists $f2] |
|
puts stdout "file exists $f2 = $f2_exists" |
|
|
|
puts stdout -done- |
|
} |
|
} |
|
|
|
|
|
namespace eval punk::winpath::system { |
|
#get a copy of the item without affecting internal rep |
|
proc objclone {obj} { |
|
append obj2 $obj {} |
|
} |
|
} |
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
## Ready |
|
package provide punk::winpath [namespace eval punk::winpath { |
|
variable version |
|
set version 999999.0a1.0 |
|
}] |
|
return
|
|
|