updated punk::path & punk::nav::fs in _vfscommon

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 . .. "./" "../"]} {
+                switch -exact -- $a1 {
-                    if {$a1 in [list ".." "../"]} {
+                    . - ./ {
+                        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 {
+                            tailcall punk::nav::fs::d/ 
-                            #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]} {
+                        #we need to use normjoin to allow navigation to //server instead of just to //server/share (//server browsing unimplemented - review)  
-                                if {[Zipfs_path_within_zipfs_mounts $up1]} {
+                        #  [file join //server ..] would become /server/..  - use normjoin to get //server 
-                                    cd $up1
+                        #  file dirname //server/share would stay as //server/share  
-                                    set VIRTUAL_CWD $up1
+                        #set up1 [file dirname $VIRTUAL_CWD]
-                                } else {
+                        set up1 [punk::path::normjoin $VIRTUAL_CWD ..]
-                                    set VIRTUAL_CWD $up1
+                        if {[string match //zipfs:/* $up1]} {
-                                }
+                            if {[Zipfs_path_within_zipfs_mounts $up1]} {
+                                cd $up1
+                                set VIRTUAL_CWD $up1
                             } else {
-                                cd $a1
+                                set VIRTUAL_CWD $up1
-                                #set VIRTUAL_CWD [file normalize $a1]
                             }
+                        } 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"} {
+                if {[file pathtype $a1] ne "relative"} {
-                        cd $a1
+                    if { ![string match //zipfs:/* $a1]} {
-                        #set VIRTUAL_CWD $a1
+                        if {[file type $a1] eq "directory"} {
-                        tailcall punk::nav::fs::d/
+                            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]} {
+                            if {[Zipfs_path_within_zipfs_mounts $target]} {
-                                commandstack::basecall cd $VIRTUAL_CWD/$a1
+                                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 is_relativesearchspec [expr {[file pathtype $searchspec] eq "relative"}]
-        set searchbase $opt_searchbase
+        if {$opt_searchbase eq ""} {
-        switch -- $opt_glob {
+            set searchbase .
+        } else {
+            set searchbase $opt_searchbase
+        }
+
+
+        switch -- $opt_tailglob {
             "" {
-                if {$relativepath} {
+                if {$searchspec eq ""} {
-                    set location [file dirname [file join $searchbase $searchspec]]
+                    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]]
+                set searchtail_has_globs [regexp {[*?]} [file tail $searchspec]]
-                if {$tail_has_globs} {
+                if {$searchtail_has_globs} {
-                    if {$relativepath} {
+                    if {$is_relativesearchspec} {
-                        set location [file dirname [file join $searchbase $searchspec]]
+                        #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} {
+                    if {$searchspec eq ""} {
-                        set location [file join $searchbase $searchspec]
+                        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} {
+                if {$searchspec eq ""} {
-                    set location [file join $searchbase $searchspec]
+                    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

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)
+    # normjoin //./UNC//server/share/subpath -> ///server/share/subpath  (when 2 or more slashes directly after UNC)
-    # stringnorm ///server/share  -> ///server/share
+    # 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
+    # Tests - TODO
-    # stringnorm /d:/..//vfs:/test -> /vfs:/test  (good - not converted to //vfs:/test)
+    # normjoin /d:/..//vfs:/test -> /vfs:/test  (good - not converted to //vfs:/test)
-    proc stringnorm {path} {
+    proc normjoin {args} {
-        set path [string map "\\\\ /" $path]
+        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 //./<dosdevice>  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]]