jn
/
punkshell
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity
Browse Source

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

master
Julian Noble 4 months ago
parent
f8b44d6306
commit
34dbd83adb
2 changed files with 281 additions and 62 deletions
Whitespace
Show all changes Ignore whitespace when comparing lines Ignore changes in amount of whitespace Ignore changes in whitespace at EOL
Split View
Diff Options
Show Stats Download Patch File Download Diff File
  1. 123
      src/vfs/_vfscommon/modules/punk/nav/fs-0.1.0.tm
  2. 190
      src/vfs/_vfscommon/modules/punk/path-0.1.0.tm

123
src/vfs/_vfscommon/modules/punk/nav/fs-0.1.0.tm
Unescape View File

@ -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,7 +131,14 @@ 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} {
@ -238,14 +248,22 @@ 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]
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
@ -254,20 +272,22 @@ tcl::namespace::eval punk::nav::fs {
set VIRTUAL_CWD $up1
}
} else {
cd $a1
cd $up1
#set VIRTUAL_CWD [file normalize $a1]
}
}
}
tailcall punk::nav::fs::d/
}
if {[file pathtype $a1] ne "relative" && ![string match //zipfs:/* $a1]} {
}
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/
}
}
}
if {![regexp {[*?]} $a1] && ![string match //zipfs:/* $a1] && ![string match "//zipfs:/*" $VIRTUAL_CWD]} {
@ -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
}
}
if {[file type $target] eq "directory"} {
set VIRTUAL_CWD $target
}
set VIRTUAL_CWD $VIRTUAL_CWD/$a1
}
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"}]
if {$opt_searchbase eq ""} {
set searchbase .
} else {
set searchbase $opt_searchbase
switch -- $opt_glob {
}
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 glob [file tail $searchspec]
set match_contents [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 {
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 {
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

190
src/vfs/_vfscommon/modules/punk/path-0.1.0.tm
Unescape View File

@ -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 //./<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]]

Write Preview
Loading…
Cancel
Save