# -*- 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 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/([[:alpha:]]){1}/.*} [string tolower $path] _ letter]} { set path [string toupper $letter]:/[string range $path 7 end] } elseif {[regexp {^/mnt/([[:alpha:]]){1}$} [string tolower $path] _ letter]} { set path [string toupper $letter]:/ } 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 } } proc pwdshortname {{path {}}} { if {![string length $path]} { set path [pwd] } return [dict get [file attributes [file normalize $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 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