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