From ad4a451a198b58b7485b266dd72b7aac9af103fc Mon Sep 17 00:00:00 2001 From: Julian Noble Date: Sun, 6 Aug 2023 03:24:06 +1000 Subject: [PATCH] split winpath funcs to own tm, win-dos-device path fixes for illegal windows pathnames, dirfiles colourised display of these paths --- src/modules/punk-0.1.tm | 241 +++++++------------ src/modules/punk/mix-0.2.tm | 5 +- src/modules/punk/winpath-999999.0a1.0.tm | 273 ++++++++++++++++++++++ src/modules/punk/winpath-buildversion.txt | 3 + 4 files changed, 367 insertions(+), 155 deletions(-) create mode 100644 src/modules/punk/winpath-999999.0a1.0.tm create mode 100644 src/modules/punk/winpath-buildversion.txt diff --git a/src/modules/punk-0.1.tm b/src/modules/punk-0.1.tm index b4c56812..3d727e30 100644 --- a/src/modules/punk-0.1.tm +++ b/src/modules/punk-0.1.tm @@ -70,6 +70,7 @@ namespace eval ::repl { variable running 0 } package require punk::config +package require punk::winpath ;# for windows paths - but has functions that can be called on unix systems namespace eval punk { interp alias {} purelist {} lreplace x 0 0 ;#required by pipe system @@ -4604,76 +4605,6 @@ namespace eval punk { } } - #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. - 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 {[punk::winpath_illegalname_test $path]} { - set path [punk::winpath_illegalname_fix $path] - } - - return $path - } - proc windir {path} { - return [file dirname [punk::winpath $path]] - } #environment path as list # @@ -4707,9 +4638,12 @@ namespace eval punk { set a1 [lindex $args 0] if {$a1 in [list -b -c -d -e -f -h -L -s -S -x -w]} { set a2 [lindex $args 1] - set attrinfo [file attributes $a2] - if {[dict exists $attrinfo -vfs] && [dict get $attrinfo -vfs] == 1} { - puts stderr "WARNING: external 'test' being called on vfs path. External command will probably not have access to the vfs. Use 'TEST' for Tcl view of vfs mounted filesystems." + if {![catch { + set attrinfo [file attributes $a2] + } errM]} { + if {[dict exists $attrinfo -vfs] && [dict get $attrinfo -vfs] == 1} { + puts stderr "WARNING: external 'test' being called on vfs path. External command will probably not have access to the vfs. Use 'TEST' for Tcl view of vfs mounted filesystems." + } } } tailcall run test {*}$args @@ -4752,11 +4686,11 @@ namespace eval punk { if {$a1 in $fileops} { if {$::tcl_platform(platform) eq "windows"} { #e.g trailing dot or trailing space - if {[punk::winpath_illegalname_test $a2]} { + if {[punk::winpath::illegalname_test $a2]} { #protect with \\?\ to stop windows api from parsing #will do nothing if already prefixed with \\?\ - set a2 [punk::winpath_illegalname_fix $a2] + set a2 [punk::winpath::illegalname_fix $a2] } } } @@ -4999,7 +4933,7 @@ namespace eval punk { } #------------------------------------------------------------------- - namespace export help aliases alias nsjoin nsprefix cdwin cdwindir dirfiles dirfiles_dict exitcode winpath windir % pipedata pipecase pipeline pipematch pipeswitch pipeswitchc pipecase linelist linesort inspect list_as_lines is_list_all_in_list is_list_all_ni_list val treemore + namespace export help aliases alias nsjoin nsprefix cdwin cdwindir dirfiles dirfiles_dict exitcode windir % pipedata pipecase pipeline pipematch pipeswitch pipeswitchc pipecase linelist linesort inspect list_as_lines is_list_all_in_list is_list_all_ni_list val treemore namespace ensemble create proc hasglobs {str} { @@ -5724,7 +5658,7 @@ namespace eval punk { return [list_as_lines $displaylist] } - #todo - package as navdir + #todo - package as punk::navdir #todo - in thread #todo - streaming version proc dirfiles_dict {{glob ""}} { @@ -5736,7 +5670,7 @@ namespace eval punk { set ftail [file tail $glob] if {[string first ? $ftail] >= 0 || [string first * $ftail] >=0} { - #has globchar (we only recognise in tail) + #has globchar (we only recognise as glob in tail) set location $dirname set glob $ftail } else { @@ -5777,15 +5711,30 @@ namespace eval punk { set files [lsort $files] ;#todo natsort - return [list dirs $dirs hiddendirs $hiddendirs vfs $vfs files $files hiddenfiles $hiddenfiles location $location] + set illegalwinfiles [list] + foreach fname $files { + if {[punk::winpath::illegalname_test $fname]} { + lappend illegalwinfiles $fname + } + } + set illegalwindirs [list] + foreach dname $dirs { + if {[punk::winpath::illegalname_test $dname]} { + lappend illegalwindirs $dname + } + } + return [list dirs $dirs hiddendirs $hiddendirs vfs $vfs files $files hiddenfiles $hiddenfiles illegalwinfiles $illegalwinfiles illegalwindirs $illegalwindirs location $location] } + #todo - color key via repl-telemetry? help command? documentation? or add tag columns as done in namespace listing? proc dirfiles_dict_as_lines {contents} { package require overtype set dirs [dict get $contents dirs] set hiddendirs [dict get $contents hiddendirs] set files [dict get $contents files] set hiddenfiles [dict get $contents hiddenfiles] + set illegalwindirs [dict get $contents illegalwindirs] + set illegalwinfiles [dict get $contents illegalwinfiles] set vfs [dict get $contents vfs] set widest [pipedata [list {*}$dirs ""] {lmap v $data {string length $v}} {tcl::mathfunc::max {*}$data}] @@ -5800,25 +5749,37 @@ namespace eval punk { if {[string length $d]} { if {$d in $hiddendirs} { set d1 [a+ cyan] - set d2 [a+] } if {[dict exists $vfs $d]} { if {$d in $hiddendirs} { #we could have a hidden dir which is also a vfs.. color will be overridden giving no indicatio of 'hidden' status - REVIEW #(This situation encountered on windows - even though file attr showed -hidden 0 - the glob with -types hidden returned it.. possibly a tcl glob bug on windows) #mark it differently for now.. (todo bug report?) - set d1 [a+ red White bold] - set d2 [a+] + if {$d in $illegalwindirs} { + set d1 [a+ red Yellow bold] + } else { + set d1 [a+ green Purple bold] + } } else { - set d1 [a+ red bold] - set d2 [a+] + if {$d in $illegalwindirs} { + set d1 [a+ red White bold] + } else { + set d1 [a+ green bold] + } + } + } else { + if {$d in $illegalwindirs} { + set d1 [a+ red bold] } } } if {[string length $f]} { if {$f in $hiddenfiles} { - set f1 [a+ grey] - set f2 [a+] + set f1 [a+ Purple] + } else { + if {$f in $illegalwinfiles} { + set f1 [a+ red bold] + } } } lappend displaylist $d1[overtype::left $col1 $d]$d2$f1$f$f2 @@ -5947,7 +5908,7 @@ namespace eval punk { if {$platform eq "windows"} { #unix looking paths like /c/users or /usr/local/etc are reported by tcl as volumerelative.. (as opposed to absolute on unix platforms) if {[string index $path 0] eq "/"} { - set path_absolute [punk::winpath $path] + set path_absolute [punk::winpath::winpath $path] #puts stderr "winpath: $path" } else { set path_absolute $base/$path @@ -5959,6 +5920,11 @@ namespace eval punk { } else { set path_absolute $base/$path } + if {$platform eq "windows"} { + if {[punk::winpath::illegalname_test $path_absolute]} { + set path_absolute [punk::winpath::illegalname_fix $path_absolute] ;#add dos-device-prefix protection if not already present + } + } return $path_absolute } #NOTE - as we expect to run other apps (e.g Tk) in the same process, but possibly different threads - we should be careful about use of cd which is per-process not per-thread. @@ -6387,20 +6353,6 @@ namespace eval punk { return $result } } - proc cdwin {path} { - set path [punk::winpath $path] - if {$::repl::running} { - repl::term::set_console_title $path - } - cd $path - } - proc cdwindir {path} { - set path [punk::winpath $path] - if {$::repl::running} { - repl::term::set_console_title $path - } - cd [file dirname $path] - } #like linelist - but keeps leading and trailing empty lines #single \n produces {} {} #the result can be joined to reform the arg if a single arg supplied @@ -6850,47 +6802,6 @@ namespace eval punk { interp alias {} tmhere {} .= pwd |path> {::tcl::tm::add {*}$data; set path} |> inspect -label added_to_module_path <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 winpath_illegalname_fix {path} { - if {[file pathtype $path] eq "absolute"} { - 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 {\\?} - append protect "\\" - set protect2 "//?/" ;#file normalize may do this - it still works - #don't add extra protect-prefix if already done - if {[string range $path 0 3] in [list $protect $protect2]} { - return $path - } - return ${protect}$fullpath - } - - #don't test for platform here - needs to be callable from any platform for potential passing to windows - proc winpath_illegalname_test {path} { - set protect "\\\\?\\" ;# value is: \\?\ - #todo - test folder segments within path? - #first test if already protected - we return false even if the file would be illegal without the protection! - if {[string range $path 0 3] eq $protect} { - return 0 - } - if {[string index $path 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 - return 0 - } proc fcat {args} { if {$::tcl_platform(platform) ne "windows"} { @@ -6921,17 +6832,17 @@ namespace eval punk { } set first_non_opt [expr {$last_opt + 1}] - puts stderr "first_non_opt: $first_non_opt" + #puts stderr "first_non_opt: $first_non_opt" set opts [lrange $args -1 $first_non_opt-1] set paths [lrange $args $first_non_opt end] if {![llength $paths]} { error "Unable to find file in the supplied arguments: $args. Ensure options are all -opt val pairs and that file name(s) follow" } - puts stderr "opts: $opts paths: $paths" + #puts stderr "opts: $opts paths: $paths" set finalpaths [list] foreach p $paths { - if {[punk::winpath_illegalname_test $p]} { - lappend finalpaths [punk::winpath_illegalname_fix $p] + if {[punk::winpath::illegalname_test $p]} { + lappend finalpaths [punk::winpath::illegalname_fix $p] } else { lappend finalpaths $p } @@ -6939,6 +6850,37 @@ namespace eval punk { fileutil::cat {*}$opts {*}$finalpaths } + #simplify path with respect to /./ & /../ elements - independent of platform + #NOTE: anomalies in standard tcl processing on windows: + #e.g file normalize {//host} -> c:/host + #file normalize {//host/share} -> //host/share + #To get back to some consistent cross platform behaviour - we will define //something as a root/volume i.e we can't backtrack above it with .. + proc filepath_dotted_minimal {path} { + set path [string map [list \\ /] $path] + set doubleslash1_posn [string first // $path] + if {[punk::winpath::is_dos_device_path $path]} { + + + } else { + if {$doubleslash1_posn == 0} { + #this is handled differently on different platforms as far as 'file split' is concerned. + #e.g for file split //sharehost/share/path/etc + #e.g on windows: -> //sharehost/share path + #e.g on freebsd: -> / sharehost share path etc + #however..also on windows: file split //sharehost -> / sharehost + #normalize by dropping leading slash before split - and then treating first 2 segments as a root + set normtail [string map [list //]] + set parts [file split [string range $path 1 end]] + + + } + set parts [file split $path] + } + } + proc filepath_dotted_dirname {path} { + + } + #fileutil::cat except with checking for windows illegal path names (when on windows platform) interp alias {} fcat {} punk::fcat @@ -7144,13 +7086,6 @@ namespace eval punk { - #---------------------------------------------- - #leave the winpath related aliases available on all platforms - interp alias {} cdwin {} punk cdwin - interp alias {} cdwindir {} punk cdwindir - interp alias {} winpath {} punk winpath - interp alias {} windir {} punk windir - #---------------------------------------------- #git interp alias {} gs {} git status -sb interp alias {} gl {} git log --oneline --decorate ;#decorate so stdout consistent with what we see on console diff --git a/src/modules/punk/mix-0.2.tm b/src/modules/punk/mix-0.2.tm index 53a4c581..5246dbf4 100644 --- a/src/modules/punk/mix-0.2.tm +++ b/src/modules/punk/mix-0.2.tm @@ -236,12 +236,13 @@ namespace eval punk::mix::cli { set tpldir [lib::mix_templates_dir] set fd [open $tpldir/module/module_template-0.0.1.tm r]; set filedata [read $fd]; close $fd set filedata [string map [list %pkg% $modulename %year% $year %license% $opt_license] $filedata] - set fd [open $modulefolder/${moduletail}-$magicversion.tm w] + set modulefile $modulefolder/${moduletail}-$magicversion.tm + set fd [open $modulefile w] fconfigure $fd -translation binary puts -nonewline $fd $filedata close $fd - + return [list file $modulefile version $opt_version] } proc make {args} { diff --git a/src/modules/punk/winpath-999999.0a1.0.tm b/src/modules/punk/winpath-999999.0a1.0.tm new file mode 100644 index 00000000..067311d9 --- /dev/null +++ b/src/modules/punk/winpath-999999.0a1.0.tm @@ -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 -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 diff --git a/src/modules/punk/winpath-buildversion.txt b/src/modules/punk/winpath-buildversion.txt new file mode 100644 index 00000000..f47d01c8 --- /dev/null +++ b/src/modules/punk/winpath-buildversion.txt @@ -0,0 +1,3 @@ +0.1.0 +#First line must be a semantic version number +#all other lines are ignored.