4 changed files with 367 additions and 155 deletions
@ -0,0 +1,273 @@ |
|||||||
|
# -*- 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 |
||||||
|
|
||||||
|
#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. |
||||||
|
#In this case - we shouldn't examine what volumes exist (assume A: .. Z: are valid) |
||||||
|
#review zipfs:// other uri schemes? |
||||||
|
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) |
||||||
|
#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. |
||||||
|
#e.g there is potential confusion when there is a c folder on c: drive (c:/c) |
||||||
|
#I will attempt to provide a coherent operation for winpath ./ ../ etc , but it may disallow for example; change to /something or /x where these don't match a driveletter or /mnt |
||||||
|
#whereas tcl may allow cd to /something if a something folder happens to exist on the current volume based on cwd. |
||||||
|
#I think it's preferable to require an explicit driveletter /x or /mnt when using unix-like paths on windows - but practical considerations may prove me wrong.. |
||||||
|
#It's possible that this function should also ignore the current set of driveletters - and operate completely independent of whether a path actually exists |
||||||
|
#This makes it hard to use things like 'file normalize' - which also looks at things like current volume. |
||||||
|
# |
||||||
|
#Note for example the results of 'which' grep on windows can produce a path like /c/Users/somewhere/bin/grep |
||||||
|
#which tcl's file normalize may change to C:/c/Users or X:/c/Users - based on current volumen. Given that C:/c might exist - this can be problematic in a couple of ways. |
||||||
|
#The mixing of unix-like and windows commands on the same machine is a large part of the problem.. but this mix is now common |
||||||
|
# |
||||||
|
#convert /c/etc to C:/etc |
||||||
|
set re_slash_x_slash {^/([[:alpha:]]){1}/.*} |
||||||
|
set re_slash_else {^/([[:alpha:]]*)(.*)} |
||||||
|
set volumes [file volumes] |
||||||
|
#exclude things like //zipfs:/ |
||||||
|
set driveletters [list] |
||||||
|
foreach v $volumes { |
||||||
|
if {[regexp {^([[:alpha:]]){1}:/$} $v _ letter]} { |
||||||
|
lappend driveletters $letter |
||||||
|
} |
||||||
|
} |
||||||
|
#puts stderr "->$driveletters" |
||||||
|
|
||||||
|
if {[regexp $re_slash_x_slash $path _ letter]} { |
||||||
|
#upper case appears to be windows canonical form |
||||||
|
set path [string toupper $letter]:/[string range $path 3 end] |
||||||
|
} elseif {[regexp {^/mnt|MNT/([[:alpha:]]){1}/.*} $path _ letter]} { |
||||||
|
set path [string toupper $letter]:/[string range $path 7 end] |
||||||
|
} elseif {[regexp $re_slash_else $path _ firstpart remainder]} { |
||||||
|
#could be for example /c or /something/users |
||||||
|
if {[string length $firstpart] == 1} { |
||||||
|
set letter $firstpart |
||||||
|
set path [string toupper $letter]:/ |
||||||
|
} else { |
||||||
|
#attempt to use cygpath helper |
||||||
|
if {![catch { |
||||||
|
set cygpath [runout -n cygpath -w $path] ;#! |
||||||
|
set ::punk::last_run_display [list] ;#hack - review shouldn't really be necessary.. but because we call winpath from ./ - the repl looks for last_run_display |
||||||
|
} errM]} { |
||||||
|
set path [string map [list "\\" "/"] $cygpath] |
||||||
|
} else { |
||||||
|
error "Path '$path' does not appear to be in a standard form. For unix-like paths on windows such as /x, x must correspond to a drive letter. Consider installing cygwin's cygpath tool to see if that helps." |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
#puts stderr "=> $path" |
||||||
|
#things like 'which' seem to return a path minus the .exe - so we'll just test the containing folder |
||||||
|
# |
||||||
|
#By now file normalize shouldn't do too many shannanigans related to cwd.. |
||||||
|
#We want it to look at cwd for relative paths.. but we don't consider things like /c/Users to be relative even on windows |
||||||
|
if {![file exists [file dirname $path]]} { |
||||||
|
set path [file normalize $path] |
||||||
|
#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 {[illegalname_test $path]} { |
||||||
|
set path [illegalname_fix $path] |
||||||
|
} |
||||||
|
|
||||||
|
return $path |
||||||
|
} |
||||||
|
|
||||||
|
proc windir {path} { |
||||||
|
if {$path eq "~"} { |
||||||
|
#as the tilde hasn't been normalized.. we can't assume we're running on the actual platform |
||||||
|
return ~/.. |
||||||
|
} |
||||||
|
return [file dirname [winpath $path]] |
||||||
|
} |
||||||
|
|
||||||
|
#REVIEW high-coupling |
||||||
|
proc cdwin {path} { |
||||||
|
set path [winpath $path] |
||||||
|
if {$::repl::running} { |
||||||
|
repl::term::set_console_title $path |
||||||
|
} |
||||||
|
cd $path |
||||||
|
} |
||||||
|
proc cdwindir {path} { |
||||||
|
set path [winpath $path] |
||||||
|
if {$::repl::running} { |
||||||
|
repl::term::set_console_title $path |
||||||
|
} |
||||||
|
cd [file dirname $path] |
||||||
|
} |
||||||
|
|
||||||
|
#\\servername\share etc or \\?\UNC\servername\share etc. |
||||||
|
proc is_unc_path {path} { |
||||||
|
set path [string map [list \\ /] $path] ;#normalize to forward slashes for testing purposes (and forward slashes seem to be auto-translated by windows anyway) |
||||||
|
if {[string first "//" $path] == 0} { |
||||||
|
#check for "Dos device path" syntax |
||||||
|
if {[string range $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 $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]} { |
||||||
|
return 1 |
||||||
|
} else { |
||||||
|
return 0 |
||||||
|
} |
||||||
|
} else { |
||||||
|
return 0 |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
#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 path [string map [list \\ /] $path] ;#normalize to forward slashes for testing purposes (and forward slashes seem to be auto-translated by windows anyway) |
||||||
|
if {[string range $path 0 3] in [list "//?/" "//./"]} { |
||||||
|
return 1 |
||||||
|
} else { |
||||||
|
return 0 |
||||||
|
} |
||||||
|
} |
||||||
|
#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 illegalname_fix {path} { |
||||||
|
#don't add extra dos device path syntax protection-prefix if already done |
||||||
|
if {[is_dos_device_path $path]} { |
||||||
|
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 |
||||||
|
} |
||||||
|
#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 |
||||||
|
return $path |
||||||
|
} else { |
||||||
|
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 "\\\\?\\" ;# 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 |
||||||
|
return ${protect2}$fullpath |
||||||
|
} |
||||||
|
|
||||||
|
#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. |
||||||
|
proc illegalname_test {path} { |
||||||
|
#first test if already protected - we return false even if the file would be illegal without the protection! |
||||||
|
if {[is_dos_device_path $path]} { |
||||||
|
return 0 |
||||||
|
} |
||||||
|
#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 |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
#---------------------------------------------- |
||||||
|
#leave the winpath related aliases available on all platforms |
||||||
|
interp alias {} cdwin {} punk::winpath::cdwin |
||||||
|
interp alias {} cdwindir {} punk::winpath::cdwindir |
||||||
|
interp alias {} winpath {} punk::winpath::winpath |
||||||
|
interp alias {} windir {} punk::winpath::windir |
||||||
|
#---------------------------------------------- |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
## Ready |
||||||
|
package provide punk::winpath [namespace eval punk::winpath { |
||||||
|
variable version |
||||||
|
set version 999999.0a1.0 |
||||||
|
}] |
||||||
|
return |
||||||
Loading…
Reference in new issue