diff --git a/src/vfs/_vfscommon/modules/punk/nav/fs-0.1.0.tm b/src/vfs/_vfscommon/modules/punk/nav/fs-0.1.0.tm index cd9c632..96feac5 100644 --- a/src/vfs/_vfscommon/modules/punk/nav/fs-0.1.0.tm +++ b/src/vfs/_vfscommon/modules/punk/nav/fs-0.1.0.tm @@ -114,6 +114,9 @@ if {"windows" eq $::tcl_platform(platform)} { tcl::namespace::eval punk::nav::fs { tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase + #Both tcl's notion of pwd and VIRTUAL_CWD can be out of sync with the process CWD. This happens when in a VFS. + #We can also have VIRTUAL_CWD navigate to spaces that Tcl's cd can't - review + variable VIRTUAL_CWD ;#cwd that tracks pwd except when in zipfs locations that are not at or below a mountpoint if {![interp issafe]} { set VIRTUAL_CWD [pwd] @@ -128,8 +131,15 @@ tcl::namespace::eval punk::nav::fs { } return $::punk::nav::fs::VIRTUAL_CWD } - #Both tcl's notion of pwd and VIRTUAL_CWD can be out of sync with the process CWD. This happens when in a VFS. + #TODO - maintain per 'volume/server' CWD + #e.g cd and ./ to: + # d: + # //zipfs: + # //server + # https://example.com + # should return to the last CWD for that volume/server + #VIRTUAL_CWD follows pwd when changed via cd set stackrecord [commandstack::rename_command -renamer punk::nav::fs cd {args} { if {![catch { @@ -238,34 +248,44 @@ tcl::namespace::eval punk::nav::fs { set atail [lassign $args a1] if {[llength $args] == 1} { set a1 [lindex $args 0] - if {$a1 in [list . .. "./" "../"]} { - if {$a1 in [list ".." "../"]} { + switch -exact -- $a1 { + . - ./ { + tailcall punk::nav::fs::d/ + } + .. - ../ { if {$VIRTUAL_CWD eq "//zipfs:/" && ![string match //zipfs:/* [pwd]]} { #exit back to last nonzipfs path that was in use set VIRTUAL_CWD [pwd] - } else { - #set up1 [file normalize [file join $VIRTUAL_CWD ..]] ;#doesn't work! file normalize bug? review - submit ticket? - set up1 [file dirname $VIRTUAL_CWD] - if {[string match //zipfs:/* $up1]} { - if {[Zipfs_path_within_zipfs_mounts $up1]} { - cd $up1 - set VIRTUAL_CWD $up1 - } else { - set VIRTUAL_CWD $up1 - } + tailcall punk::nav::fs::d/ + } + + #we need to use normjoin to allow navigation to //server instead of just to //server/share (//server browsing unimplemented - review) + # [file join //server ..] would become /server/.. - use normjoin to get //server + # file dirname //server/share would stay as //server/share + #set up1 [file dirname $VIRTUAL_CWD] + set up1 [punk::path::normjoin $VIRTUAL_CWD ..] + if {[string match //zipfs:/* $up1]} { + if {[Zipfs_path_within_zipfs_mounts $up1]} { + cd $up1 + set VIRTUAL_CWD $up1 } else { - cd $a1 - #set VIRTUAL_CWD [file normalize $a1] + set VIRTUAL_CWD $up1 } + } else { + cd $up1 + #set VIRTUAL_CWD [file normalize $a1] } + tailcall punk::nav::fs::d/ } - tailcall punk::nav::fs::d/ } - if {[file pathtype $a1] ne "relative" && ![string match //zipfs:/* $a1]} { - if {[file type $a1] eq "directory"} { - cd $a1 - #set VIRTUAL_CWD $a1 - tailcall punk::nav::fs::d/ + + if {[file pathtype $a1] ne "relative"} { + if { ![string match //zipfs:/* $a1]} { + if {[file type $a1] eq "directory"} { + cd $a1 + #set VIRTUAL_CWD $a1 + tailcall punk::nav::fs::d/ + } } } @@ -279,6 +299,7 @@ tcl::namespace::eval punk::nav::fs { } if {![regexp {[*?]} $a1]} { + #NON-Glob target #review if {[string match //zipfs:/* $a1]} { if {[Zipfs_path_within_zipfs_mounts $a1]} { @@ -287,12 +308,15 @@ tcl::namespace::eval punk::nav::fs { set VIRTUAL_CWD $a1 set curdir $a1 } else { + set target [punk::path::normjoin $VIRTUAL_CWD $a1] if {[string match //zipfs:/* $VIRTUAL_CWD]} { - if {[Zipfs_path_within_zipfs_mounts $VIRTUAL_CWD/$a1]} { - commandstack::basecall cd $VIRTUAL_CWD/$a1 + if {[Zipfs_path_within_zipfs_mounts $target]} { + commandstack::basecall cd $target } } - set VIRTUAL_CWD $VIRTUAL_CWD/$a1 + if {[file type $target] eq "directory"} { + set VIRTUAL_CWD $target + } } tailcall punk::nav::fs::d/ } @@ -721,7 +745,7 @@ tcl::namespace::eval punk::nav::fs { set searchspec [lindex $searchspecs 0] # -- --- --- --- --- --- --- set opt_searchbase [dict get $opts -searchbase] - set opt_glob [dict get $opts -tailglob] + set opt_tailglob [dict get $opts -tailglob] set opt_with_sizes [dict get $opts -with_sizes] set opt_with_times [dict get $opts -with_times] # -- --- --- --- --- --- --- @@ -729,47 +753,72 @@ tcl::namespace::eval punk::nav::fs { #we don't want to normalize.. #for example if the user supplies ../ we want to see ../result - set relativepath [expr {[file pathtype $searchspec] eq "relative"}] - set searchbase $opt_searchbase - switch -- $opt_glob { + set is_relativesearchspec [expr {[file pathtype $searchspec] eq "relative"}] + if {$opt_searchbase eq ""} { + set searchbase . + } else { + set searchbase $opt_searchbase + } + + + switch -- $opt_tailglob { "" { - if {$relativepath} { - set location [file dirname [file join $searchbase $searchspec]] + if {$searchspec eq ""} { + set location } else { - set location [file dirname $searchspec] + if {$is_relativesarchspec} { + #set location [file dirname [file join $opt_searchbase $searchspec]] + set location [punk::path::normjoin $searchbase $searchspec ..] + } else { + set location [punk::path::normjoin $searchspec ..] + } + #here tail is treated as a search-pattern within location whether or not it contains glob chars "?" or "*" + set match_contents [file tail $searchspec] } - #here tail is treated as a search-pattern within location whether or not it contains glob chars "?" or "*" - set glob [file tail $searchspec] } "\uFFFF" { - set tail_has_globs [regexp {[*?]} [file tail $searchspec]] - if {$tail_has_globs} { - if {$relativepath} { - set location [file dirname [file join $searchbase $searchspec]] + set searchtail_has_globs [regexp {[*?]} [file tail $searchspec]] + if {$searchtail_has_globs} { + if {$is_relativesearchspec} { + #set location [file dirname [file join $searchbase $searchspec]] + #e.g subdir/* or sub/etc/x* + set location [punk::path::normjoin $searchbase $searchspec ..] } else { - set location [file dirname $searchspec] + set location [punk::path::normjoin $searchspec ..] } - set glob [file tail $searchspec] + set match_contents [file tail $searchspec] } else { #user didn't supply a glob within tail segment, nor did they specify a separate -tailglob - presume they want a directory listing - if {$relativepath} { - set location [file join $searchbase $searchspec] + if {$searchspec eq ""} { + set location $searchbase } else { - set location $searchspec + if {$is_relativesearchspec} { + #set location [file join $searchbase $searchspec] + set location [punk::path::normjoin $searchbase $searchspec] + } else { + #absolute path for search + set location $searchspec + } } - set glob * + set match_contents * } } default { #-tailglob supplied separately - ignore any globiness in tail segment of searchspec and treat literally - if {$relativepath} { - set location [file join $searchbase $searchspec] + if {$searchspec eq ""} { + set location $searchbase } else { - set location $searchspec + if {$is_relativesearchspec} { + #set location [file join $searchbase $searchspec] + set location [punk::path::normjoin $searchbase $searchspec] + } else { + set location $searchspec + } } - set glob $opt_glob + set match_contents $opt_tailglob } } + puts stdout "searchbase: $searchbase searchspec:$searchspec" set in_vfs 0 if {[llength [package provide vfs]]} { @@ -794,7 +843,7 @@ tcl::namespace::eval punk::nav::fs { set next_opt_with_times [list -with_times $opt_with_times] } if {$in_vfs} { - set listing [punk::du::lib::du_dirlisting_tclvfs $location -glob $glob {*}$next_opt_with_sizes {*}$next_opt_with_times] + set listing [punk::du::lib::du_dirlisting_tclvfs $location -glob $match_contents {*}$next_opt_with_sizes {*}$next_opt_with_times] } else { set in_zipfs 0 if {[info commands ::tcl::zipfs::mount] ne ""} { @@ -810,9 +859,9 @@ tcl::namespace::eval punk::nav::fs { } if {$in_zipfs} { #relative vs absolute? review - cwd valid for //zipfs:/ ?? - set listing [punk::du::lib::du_dirlisting_zipfs $location -glob $glob {*}$next_opt_with_sizes {*}$next_opt_with_times] + set listing [punk::du::lib::du_dirlisting_zipfs $location -glob $match_contents {*}$next_opt_with_sizes {*}$next_opt_with_times] } else { - set listing [punk::du::dirlisting $location -glob $glob {*}$next_opt_with_sizes {*}$next_opt_with_times] + set listing [punk::du::dirlisting $location -glob $match_contents {*}$next_opt_with_sizes {*}$next_opt_with_times] } } @@ -904,7 +953,7 @@ tcl::namespace::eval punk::nav::fs { lappend nonportable $nm } } - set front_of_dict [dict create location $location searchbase $searchbase] + set front_of_dict [dict create location $location searchbase $opt_searchbase] set listing [dict merge $front_of_dict $listing] set updated [dict create dirs $dirs files $files filesizes $filesizes nonportable $nonportable flaggedhidden $flaggedhidden underlayfiles $underlayfiles underlayfilesizes $underlayfilesizes] @@ -1128,6 +1177,8 @@ tcl::namespace::eval punk::nav::fs { } } + #REVIEW - at least one version of Tcl during development couldn't navigate using cd to intermediate paths between the zipfs root and the mountpoint. + #TODO - test if this can still occur. proc Zipfs_path_within_zipfs_mounts {zipfspath} { if {![string match //zipfs:/* $zipfspath]} {error "Zipfs_path_within_zipfs_mounts error. Supplied zipfspath $zipfspath must be a //zipfs:/* path"} set is_within_mount 0 diff --git a/src/vfs/_vfscommon/modules/punk/path-0.1.0.tm b/src/vfs/_vfscommon/modules/punk/path-0.1.0.tm index c3370c9..2165c0f 100644 --- a/src/vfs/_vfscommon/modules/punk/path-0.1.0.tm +++ b/src/vfs/_vfscommon/modules/punk/path-0.1.0.tm @@ -106,7 +106,7 @@ namespace eval punk::path { #[list_begin definitions] # -- --- - #punk::path::stringnorm + #punk::path::normjoin # - simplify . and .. segments as far as possible whilst respecting specific types of root. # -- --- #a form of file normalize that supports //xxx to be treated as server path names @@ -141,34 +141,45 @@ namespace eval punk::path { # file split //./UNC/server/share/subpath -> //./UNC server share subpath # file split //server/share/subpath -> //server/share subpath #TODO - disallow all change of root or change from relative path to absolute result. - #e.g stringnorm relpath/../d:/secret should not return d:/secret - but ./d:/secret + #e.g normjoin relpath/../d:/secret should not return d:/secret - but ./d:/secret # ================ #known issues: #1) - # stringnorm d://a//b//c -> d://a/b/c + # normjoin d://a//b//c -> d://a/b/c # This is because we don't detect specific schemes. ie it's treated the same as https://a/b/c -> https://a/b/c # Not considered a problem - just potentially surprising. # To avoid it we would have to enumerate possible schemes. # As it stands a unix system could define a 'scheme' that happens to match windows style driveletters. Consider a 'feature' ? review. # won't fix? #2) - # stringnorm https:///real.com/../fake.com -> https:///fake.com + # normjoin https:///real.com/../fake.com -> https:///fake.com # The extra slash means effectively our servername is empty - this is potentially confusing but probably the right thing to do here. # It's a concern only if upstream treats the tripple slash in this case as valid and maps it to https:// - which would probably be bad anyway. # won't fix (review) #3) #similarly - # stringnorm //./UNC//server/share/subpath -> ///server/share/subpath (when 2 or more slashes directly after UNC) - # stringnorm ///server/share -> ///server/share + # normjoin //./UNC//server/share/subpath -> ///server/share/subpath (when 2 or more slashes directly after UNC) + # normjoin ///server/share -> ///server/share #This is effectively an empty servername in the input with 'server' being pushed one level down - and the output is consistent # possibly won't fix - review + #4) inconsistency + # we return normalized //server/share for //./UNC/server share + # but other dos device paths are maintained + # e.g //./c:/etc + # This is because such paths could contain alternate segment names (windows shortnames) which we aren't in a position to resolve. + # caller should + # #as with 'case' below - caller will need to run a post 'file normalize' + #5) we don't normalize case like file normalize does on windows platform. + # This is intentional. It could only be done with reference to underlying filesystem which we don't want here. + # # ================ # #relpaths all end up with leading . - while not always the simplest form, this is ok. (helps stop inadvertent conversions to absolutes) - # Tests - TDOO - # stringnorm /d:/..//vfs:/test -> /vfs:/test (good - not converted to //vfs:/test) - proc stringnorm {path} { - set path [string map "\\\\ /" $path] + # Tests - TODO + # normjoin /d:/..//vfs:/test -> /vfs:/test (good - not converted to //vfs:/test) + proc normjoin {args} { + set args [lmap a $args {string map "\\\\ /" $a}] + set path [plainjoin {*}$args] switch -exact $path { "" { return "" @@ -219,10 +230,16 @@ namespace eval punk::path { #convert to 'standard' //server/... path for processing set path "/[string range $path 7 end]" ;# //server/... } else { - #error "stringnorm non-UNC dos device path '$path' not supported" + #error "normjoin non-UNC dos device path '$path' not supported" #first segment after //./ or //?/ represents the volume or drive. #not applicable to unix - but unlikely to conflict with a genuine usecase there (review) #we should pass through and stop navigation below //./vol + #!!! + #not anomaly in tcl (continues in tcl9) + #file exists //./c:/test -> 0 + #file exists //?/c:/test -> 1 + #file exists //./BootPartition/Windows -> 1 + #file exists //?/BootPartition/Windows -> 0 set is_nonunc_dosdevice 1 } } @@ -376,10 +393,161 @@ namespace eval punk::path { return $result } + proc trim_final_slash {str} { + if {[string index $str end] eq "/"} { + return [string range $str 0 end-1] + } + return $str + } + + + #x-platform - punk::path::pathtype - can be used in safe interps - different concept of pathtypes to 'file pathtype' + # - no volumerelative + # - no lookup of file volumes (volume is a windows concept - but with //zipfs:/ somewhat applicable to other platforms) + # - /* as absolute (covers also //zipfs:/ (volume), //server , //./etc , //./UNC) + # - xxx:// as absolute (scheme) + # - xxx:/ or x:/ as absolute + # - x: xxx: -> as absolute (volume-basic or volume-extended) + + #note also on windows - legacy name for COM devices + # COM1 = COM1: + # //./COM1 ?? review + + proc pathtype {str} { + set str [string map "\\\\ /" $str] + if {[string index $str 0] eq "/"} { + #todo - look for //xxx:/ prefix (generalisation of //zipfs:/) as a 'volume' specifically {volume mount} ?? - review + # look for //server prefix as {absolute server} + # look for //./UNC/server or //?/UNC/server as {absolute server UNC} ? + # look for //./ as {absolute dosdevice} + return absolute + } + + #only firstsegment with single colon at last position (after some non empty string) counts as volume or scheme - review + #e.g a:b:/.. or a::/.. or :/.. is not treated as volume/scheme whereas ab:/ is. + set firstslash [string first / $str] + if {$firstslash == -1} { + set firstsegment $str + } else { + set firstsegment [string range $str 0 $firstslash-1] + } + if {[set firstc [string first : $firstsegment]] > 0} { + set lhs_firstsegment [string range $firstsegment 0 $firstc-1] + set rhs_firstsegment [string range $firstsegment $firstc+1 end] ;#exclude a:b/ etc + if {$rhs_firstsegment eq ""} { + set rhs_entire_path [string range $str $firstc+1 end] + #assert lhs_firstsegment not empty since firstc > 0 + #count following / sequence + set i 0 + set slashes_after_firstsegment "" ;#run of slashes *directly* following first segment + while {$i < [string length $rhs_entire_path]} { + if {[string index $rhs_entire_path $i] eq "/"} { + append slashes_after_firstsegment / + } else { + break + } + incr i + } + switch -exact -- $slashes_after_firstsegment { + "" - / { + if {[string length $lhs_firstsegment] == 1} { + return {absolute volume basic} + } else { + return {absolute volume extended} + } + } + default { + #2 or more / + #this will return 'scheme' even for c:// - even though that may look like a windows volume - review + return {absolute scheme} + } + } + } + } + #assert first element of any return has been absolute or relative + return relative + } + + + proc plain {str} { + set str [string map "\\\\ /" $str] + set pathinfo [punk::path::pathtype $str] + if {[lindex $pathinfo 0] eq "relative" && ![string match ./* $str]} { + set str ./$str + } + if {[string index $str end] eq "/"} { + if {[string map {/ ""} $str] eq ""} { + #all slash segment + return $str + } else { + if {[lindex $pathinfo 1] ni {volume scheme}} { + return [string range $str 0 end-1] + } + } + } + return $str + } + #purely string based - no reference to filesystem knowledge + #unix-style forward slash only + proc plainjoin {args} { + set args [lmap a $args {string map "\\\\ /" $a}] + #if {[llength $args] == 1} { + # return [lindex $args 0] + #} + set out "" + foreach a $args { + if {![string length $out]} { + append out [plain $a] + } else { + set a [plain $a] + if {[string map {/ ""} $out] eq ""} { + set out [string range $out 0 end-1] + } + + if {[string map {/ ""} $a] eq ""} { + #all / segment + append out [string range $a 0 end-1] + } else { + if {[string length $a] > 2 && [string match "./*" $a]} { + set a [string range $a 2 end] + } + if {[string index $out end] eq "/"} { + append out $a + } else { + append out / $a + } + } + } + } + return $out + } + proc plainjoin1 {args} { + if {[llength $args] == 1} { + return [lindex $args 0] + } + set out [trim_final_slash [lindex $args 0]] + foreach a [lrange $args 1 end] { + set a [trim_final_slash $a] + append out / $a + } + return $out + } + #intention? #proc filepath_dotted_dirname {path} { #} + proc strip_prefixdepth {path prefix} { + if {$prefix eq ""} { + return [norm $path] + } + return [file join \ + {*}[lrange \ + [file split [norm $path]] \ + [llength [file split [norm $prefix]]] \ + end]] + } + proc pathglob_as_re {pathglob} { #*** !doctools #[call [fun pathglob_as_re] [arg pathglob]]