$v]} {
@@ -4952,17 +4959,14 @@ namespace eval punk {
} else {
#tags ?
#debug.punk.pipe {>>raw commandline: [concat $rhs $segment_members_filled]} 5
- if 0 {
-
-
-
+ if {false} {
#set s [list uplevel 1 [concat $rhs $segment_members_filled]]
if {![info exists pscript]} {
upvar ::_pipescript pscript
}
if {![info exists pscript]} {
#set pscript $s
- set pscript [funcl::o_of_n 1 $segment_members]
+ set pscript [funcl::o_of_n 1 $segment_members]
} else {
#set pscript [string map [list $pscript] {uplevel 1 [concat $rhs $segment_members_filled [
]]}]
#set snew "set pipe_$i \[uplevel 1 \[list $rhs $segment_members_filled "
@@ -4972,6 +4976,7 @@ namespace eval punk {
}
}
+
set cmdlist_result [uplevel 1 $segment_members_filled]
#set d [_multi_bind_result $returnvarspec [punk::K $segment_members_filled [unset segment_members_filled]]]
set d [_multi_bind_result $returnvarspec [lindex [list $cmdlist_result [unset cmdlist_result]] 0 ]]
@@ -7321,16 +7326,22 @@ namespace eval punk {
if {$topic in [list tcl]} {
- if {[punk::lib::system::has_script_var_bug]} {
- append warningblock \n "minor warning: punk::lib::system::has_script_var_bug returned true! (string rep for list variable in script generated when script changed)"
+ if {[punk::lib::system::has_tclbug_script_var]} {
+ append warningblock \n "minor warning: punk::lib::system::has_tclbug_script_var returned true! (string rep for list variable in script generated when script changed)"
}
- if {[punk::lib::system::has_safeinterp_compile_bug]} {
+ if {[punk::lib::system::has_tclbug_safeinterp_compile]} {
set indent " "
- append warningblock \n "[a+ web-red]warning: punk::lib::system::has_safeinterp_compile_bug returned true!" \n
+ append warningblock \n "[a+ web-red]warning: punk::lib::system::has_tclbug_safeinterp returned true!" \n
append warningblock "${indent}(ensemble commands not compiled in safe interps - heavy performance impact in safe interps)" \n
append warningblock "${indent}see https://core.tcl-lang.org/tcl/tktview/1095bf7f75"
append warningblock [a]
}
+ if {[punk::lib::system::has_tclbug_list_quoting_emptyjoin]} {
+ set indent " "
+ append warningblock \n "[a+ web-red]warning: punk::lib::system::has_tclbug_list_quoting returned true!" \n
+ append warningblock "${indent}lists elements not properly quoted in some cases. e.g 'list {*}[lindex {etc #foo} 1] {*}[list]' (#foo not braced)" \n
+ append warningblock "${indent}see https://core.tcl-lang.org/tcl/tktview/e38dce74e2"
+ }
}
set text ""
diff --git a/src/vfs/_vfscommon/modules/punk/basictelnet-0.1.0.tm b/src/vfs/_vfscommon/modules/punk/basictelnet-0.1.0.tm
index 6a5c481d..4a1df513 100644
--- a/src/vfs/_vfscommon/modules/punk/basictelnet-0.1.0.tm
+++ b/src/vfs/_vfscommon/modules/punk/basictelnet-0.1.0.tm
@@ -525,7 +525,7 @@ namespace eval punk::basictelnet {
# - review
#if we didn't make agreement that server would echo and we're in raw mode
- if {![dict get $server_option_state 1] && $::punk::console::is_raw} {
+ if {![dict get $server_option_state 1] && [tsv::get console is_raw]} {
puts -nonewline stdout $chunk
}
# -- --- --- ---
diff --git a/src/vfs/_vfscommon/modules/punk/console-0.1.1.tm b/src/vfs/_vfscommon/modules/punk/console-0.1.1.tm
index 95ecb27d..001a7653 100644
--- a/src/vfs/_vfscommon/modules/punk/console-0.1.1.tm
+++ b/src/vfs/_vfscommon/modules/punk/console-0.1.1.tm
@@ -44,6 +44,7 @@
#[list_begin itemized]
package require Tcl 8.6-
+package require Thread ;#tsv required to sync is_raw
package require punk::ansi
#*** !doctools
#[item] [package {Tcl 8.6-}]
@@ -84,7 +85,12 @@ namespace eval punk::console {
variable previous_stty_state_stdin ""
variable previous_stty_state_stdout ""
variable previous_stty_state_stderr ""
- variable is_raw 0
+
+ #variable is_raw 0
+ if {![tsv::exists console is_raw]} {
+ tsv::set console is_raw 0
+ }
+
variable input_chunks_waiting
if {![info exists input_chunks_waiting(stdin)]} {
set input_chunks_waiting(stdin) [list]
@@ -183,7 +189,8 @@ namespace eval punk::console {
#NOTE - the is_raw is only being set in current interp - but the channel is shared.
#this is problematic with the repl thread being separate. - must be a tsv? REVIEW
proc enableRaw {{channel stdin}} {
- variable is_raw
+ #variable is_raw
+
variable previous_stty_state_$channel
set sttycmd [auto_execok stty]
if {[set previous_stty_state_$channel] eq ""} {
@@ -193,21 +200,21 @@ namespace eval punk::console {
}
exec {*}$sttycmd raw -echo <@$channel
- set is_raw 1
+ tsv::set console is_raw 1
return [dict create previous [set previous_stty_state_$channel]]
}
proc disableRaw {{channel stdin}} {
- variable is_raw
+ #variable is_raw
variable previous_stty_state_$channel
set sttycmd [auto_execok stty]
if {[set previous_stty_state_$channel] ne ""} {
exec {*}$sttycmd [set previous_stty_state_$channel]
set previous_stty_state_$channel ""
- set is_raw 0
+ tsv::set console is_raw 0
return restored
}
exec {*}$sttycmd -raw echo <@$channel
- set is_raw 0
+ tsv::set console is_raw 0
return done
}
proc enableVirtualTerminal {{channels {input output}}} {
@@ -249,11 +256,11 @@ namespace eval punk::console {
}
proc mode {{raw_or_line query}} {
- variable is_raw
+ #variable is_raw
variable ansi_available
set raw_or_line [string tolower $raw_or_line]
if {$raw_or_line eq "query"} {
- if {$is_raw} {
+ if {[tsv::get console is_raw]} {
return "raw"
} else {
return "line"
@@ -493,7 +500,7 @@ namespace eval punk::console {
}
proc [namespace parent]::enableRaw {{channel stdin}} {
- variable is_raw
+ #variable is_raw
variable previous_stty_state_$channel
if {[package provide twapi] ne ""} {
@@ -506,7 +513,7 @@ namespace eval punk::console {
#set newmode [dict merge $oldmode [dict create -lineinput 0 -echoinput 0]]
set newmode [twapi::get_console_input_mode]
- set is_raw 1
+ tsv::set console is_raw 1
#don't disable handler - it will detect is_raw
### twapi::set_console_control_handler {}
return [list stdin [list from $oldmode to $newmode]]
@@ -516,7 +523,7 @@ namespace eval punk::console {
}
exec {*}$sttycmd raw -echo <@$channel
- set is_raw 1
+ tsv::set console is_raw 1
#review - inconsistent return dict
return [dict create stdin [list from [set previous_stty_state_$channel] to "" note "fixme - to state not shown"]]
} else {
@@ -528,7 +535,7 @@ namespace eval punk::console {
#could be we were missing a step in reopening stdin and console configuration?
proc [namespace parent]::disableRaw {{channel stdin}} {
- variable is_raw
+ #variable is_raw
variable previous_stty_state_$channel
if {[package provide twapi] ne ""} {
@@ -537,7 +544,7 @@ namespace eval punk::console {
# Turn on the echo and line-editing bits
twapi::modify_console_input_mode $console_handle -lineinput 1 -echoinput 1
set newmode [twapi::get_console_input_mode]
- set is_raw 0
+ tsv::set console is_raw 0
return [list stdin [list from $oldmode to $newmode]]
} elseif {[set sttycmd [auto_execok stty]] ne ""} {
#stty can return info on windows - but doesn't seem to be able to set anything.
@@ -550,7 +557,7 @@ namespace eval punk::console {
return restored
}
exec {*}$sttycmd -raw echo <@$channel
- set is_raw 0
+ tsv::set console is_raw 0
#do we really want to exec stty yet again to show final 'to' state?
#probably not. We should work out how to read the stty result flags and set a result.. or just limit from,to to showing echo and lineedit states.
return [list stdin [list from "[set previous_stty_state_$channel]" to "" note "fixme - to state not shown"]]
@@ -634,7 +641,7 @@ namespace eval punk::console {
puts -nonewline $output $query;flush $output
#todo - test and save rawstate so we don't disableRaw if console was already raw
- if {!$::punk::console::is_raw} {
+ if {![tsv::get console is_raw]} {
set was_raw 0
punk::console::enableRaw
} else {
@@ -1378,7 +1385,7 @@ namespace eval punk::console {
#todo - compare speed with get_cursor_pos - work out why the big difference
proc test_cursor_pos {} {
- if {!$::punk::console::is_raw} {
+ if {![tsv::get console is_raw]} {
set was_raw 0
enableRaw
} else {
diff --git a/src/vfs/_vfscommon/modules/punk/du-0.1.0.tm b/src/vfs/_vfscommon/modules/punk/du-0.1.0.tm
index 1e1986e6..9f74d2d5 100644
--- a/src/vfs/_vfscommon/modules/punk/du-0.1.0.tm
+++ b/src/vfs/_vfscommon/modules/punk/du-0.1.0.tm
@@ -1065,56 +1065,65 @@ namespace eval punk::du {
#note - with this design, we can't glob for all except dotfiles - this is for cross-platform consistency and efficiency (Review).
#dotfiles aren't considered hidden on all platforms
#some sort of antiglob is a possible enhancement and more consistent with the view that leading dot should be treated as any other filename character in this context.
- if {$opt_glob eq "*"} {
- #Note - glob operations seem to be faster than looped tests like 'file isdirectory' & 'file readlink'
- #set parent [lindex $folders $folderidx]
- set hdirs [glob -nocomplain -dir $folderpath -types {hidden d} * .*]
- #set hdirs {}
- set dirs [glob -nocomplain -dir $folderpath -types d * .*]
-
- set hlinks [glob -nocomplain -dir $folderpath -types {hidden l} * .*]
- #set hlinks {}
- set links [glob -nocomplain -dir $folderpath -types l * .*] ;#links may have dupes - we don't care. struct::set difference will remove (?)
- #set links [lsort -unique [concat $hlinks $links[unset links]]]
-
- set hfiles [glob -nocomplain -dir $folderpath -types {hidden f} * .*]
- #set hfiles {}
- set files [glob -nocomplain -dir $folderpath -types f * .*]
- #set files {}
- } else {
- set hdirs [glob -nocomplain -dir $folderpath -types {hidden d} $opt_glob]
- set dirs [glob -nocomplain -dir $folderpath -types d $opt_glob]
+ if {"windows" eq $::tcl_platform(platform)} {
+ if {$opt_glob eq "*"} {
+ #Note - glob operations seem to be faster than looped tests like 'file isdirectory' & 'file readlink'
+ #set parent [lindex $folders $folderidx]
+ set hdirs [glob -nocomplain -dir $folderpath -types {hidden d} * .*]
+ set dirs [glob -nocomplain -dir $folderpath -types d * .*]
+
+ set hlinks [glob -nocomplain -dir $folderpath -types {hidden l} * .*]
+ set links [glob -nocomplain -dir $folderpath -types l * .*] ;#links may have dupes - we don't care. punk::lib::struct_set_diff_unique
- set hlinks [glob -nocomplain -dir $folderpath -types {hidden l} $opt_glob]
- set links [glob -nocomplain -dir $folderpath -types l $opt_glob] ;#links may have dupes - we don't care. struct::set difference will remove (?)
+ set hfiles [glob -nocomplain -dir $folderpath -types {hidden f} * .*]
+ set files [glob -nocomplain -dir $folderpath -types f * .*]
+ } else {
+ set hdirs [glob -nocomplain -dir $folderpath -types {hidden d} $opt_glob]
+ set dirs [glob -nocomplain -dir $folderpath -types d $opt_glob]
+
+ set hlinks [glob -nocomplain -dir $folderpath -types {hidden l} $opt_glob]
+ set links [glob -nocomplain -dir $folderpath -types l $opt_glob] ;#links may have dupes - we don't care. punk::lib::struct_set_diff_unique
+
+ set hfiles [glob -nocomplain -dir $folderpath -types {hidden f} $opt_glob]
+ set files [glob -nocomplain -dir $folderpath -types f $opt_glob]
+ }
+ } else {
+ set hdirs {}
+ set hfiles {}
+ set hlinks {}
+ if {$opt_glob eq "*"} {
+ #Note - glob operations seem to be faster than looped tests like 'file isdirectory' & 'file readlink'
+ #set parent [lindex $folders $folderidx]
+ set dirs [glob -nocomplain -dir $folderpath -types d * .*]
+ set links [glob -nocomplain -dir $folderpath -types l * .*] ;#links may have dupes - we don't care. punk::lib::struct_set_diff_unique
+ set files [glob -nocomplain -dir $folderpath -types f * .*]
+ } else {
+ set dirs [glob -nocomplain -dir $folderpath -types d $opt_glob]
+ set links [glob -nocomplain -dir $folderpath -types l $opt_glob] ;#links may have dupes - we don't care. punk::lib::struct_set_diff_unique
+ set files [glob -nocomplain -dir $folderpath -types f $opt_glob]
+ }
- set hfiles [glob -nocomplain -dir $folderpath -types {hidden f} $opt_glob]
- set files [glob -nocomplain -dir $folderpath -types f $opt_glob]
}
#note struct::set difference produces unordered result
#struct::set difference removes duplicates (but not always.. e.g if using tcl impl and 2nd element empty!)
- #relying on struct::set to remove dupes is somewhat risky. It is not well documented - and behaviour of dupes in inputs is underspecified as it appears to be intended for mathematical 'sets'
+ #relying on struct::set to remove dupes is somewhat risky.
+ #It is not well documented - and behaviour of dupes in inputs is underspecified as it appears to be intended for mathematical 'sets' ie lists without dupes
+ #for this reason we must use the wrapper punk::lib::struct_set_diff_unique, which will use the well behaved critcl for speed if avail, but fall back to a deduping tcl version
#remove links and . .. from directories, remove links from files
#ideally we would like to classify links by whether they point to files vs dirs - but there are enough cross-platform differences that we will have to leave it to the caller to sort out for now.
#struct::set will affect order: tcl vs critcl give different ordering!
- set files [struct::set difference [concat $hfiles $files[unset files]] $links]
- set dirs [struct::set difference [concat $hdirs $dirs[unset dirs]] [concat $links [list [file join $folderpath .] [file join $folderpath ..] ]]]
- #set links [lsort -unique [concat $links $hlinks]]
+ set files [punk::lib::struct_set_diff_unique [list {*}$hfiles {*}$files[unset files]] $links]
+ set dirs [punk::lib::struct_set_diff_unique [list {*}$hdirs {*}$dirs[unset dirs] ] [list {*}$links [file join $folderpath .] [file join $folderpath ..]]]
#----
set mdata_lists [du_get_metadata_lists $sized_types $timed_types $files $dirs $links]
-
- if {"windows" eq $::tcl_platform(platform)} {
- set flaggedhidden [concat $hdirs $hfiles $hlinks]
- } else {
- #unix dotted files/folders are not 'flagged' as such - it's a convention - so the client can use the same convention to decide if something is hidden
- #this allows us to return less data - but more importantly - reserve flaggedhidden for systems where such a flag exists and avoid conflating the different concepts of what is hidden
- set flaggedhidden {}
- }
+ set flaggedhidden [list {*}$hdirs {*}$hfiles {*}$hlinks]
+ #unix dotted files/folders are not 'flagged' as such - it's a convention - so the client can use the same convention to decide if something is hidden
+ #this allows us to return less data - but more importantly - reserve flaggedhidden for systems where such a flag exists and avoid conflating the different concepts of what is hidden
set vfsmounts [get_vfsmounts_in_folder $folderpath]
@@ -1223,21 +1232,21 @@ namespace eval punk::du {
#if {[punk::mix::base::lib::path_a_above_b $folderpath "//zipfs:/"]} {}
- #zipfs files also reported as links by glob - review - should we preserve this in response?
+ #todo - hidden? not returned in attributes on windows at least.
+ #zipfs files also reported as links by glob - review - should we preserve this in response? (2024 unable to duplicate)
if {$opt_glob eq "*"} {
set dirs [glob -nocomplain -dir $folderpath -types d * .*] ;# also returns links to dirs
- #set links [glob -nocomplain -dir $folderpath -types l * .*] ;# links may have dupes - we don't care. struct::set difference will remove
- set links [list]
+ set links [glob -nocomplain -dir $folderpath -types l * .*] ;# links may have dupes - we don't care. struct::set difference will remove
set files [glob -nocomplain -dir $folderpath -types f * .*] ;# also returns links to files
} else {
set dirs [glob -nocomplain -dir $folderpath -types d $opt_glob]
- #set links [glob -nocomplain -dir $folderpath -types l $opt_glob]
- set links [list]
+ set links [glob -nocomplain -dir $folderpath -types l $opt_glob]
set files [glob -nocomplain -dir $folderpath -types f $opt_glob]
}
#remove any links from our dirs and files collections
- set dirs [struct::set difference $dirs[unset dirs] [concat $links [list [file join $folderpath .] [file join $folderpath ..] ]]]
- set files [struct::set difference $files[unset files] $links]
+ #see du_dirlisting_generic re struct::set difference issues
+ set dirs [punk::lib::struct_set_diff_unique $dirs[unset dirs] [list {*}$links [file join $folderpath .] [file join $folderpath ..]]]
+ set files [punk::lib::struct_set_diff_unique $files[unset files] $links]
#nested vfs mount.. REVIEW - does anything need special handling?
@@ -1300,34 +1309,63 @@ namespace eval punk::du {
}
# -- --- --- --- --- --- --- --- --- --- --- --- --- ---
+ #at least some vfs on windows seem to support the -hidden attribute
+ #we are presuming glob will accept the -types hidden option for all vfs - even if it doesn't really apply REVIEW
+ #The extra globs aren't nice - but hopefully the vfs is reasonably performant (?)
set errors [dict create]
- if {$opt_glob eq "*"} {
- set dirs [glob -nocomplain -dir $folderpath -types d * .*] ;# also returns links to dirs
- #review - how are links handled in vfs? presumably if the vfs is a full implementation they should work at least within the vfs?
- set links [glob -nocomplain -dir $folderpath -types l * .*] ;# links may have dupes - we don't care. struct::set difference will remove
- set files [glob -nocomplain -dir $folderpath -types f * .*] ;# also returns links to files
+ if {"windows" eq $::tcl_platform(platform)} {
+ if {$opt_glob eq "*"} {
+ set hdirs [glob -nocomplain -dir $folderpath -types {hidden d} * .*]
+ set dirs [glob -nocomplain -dir $folderpath -types d * .*] ;# also returns links to dirs
+ #review - how are links handled in vfs? presumably if the vfs is a full implementation they should work at least within the vfs?
+ set hlinks [glob -nocomplain -dir $folderpath -types {hidden l} * .*]
+ set links [glob -nocomplain -dir $folderpath -types l * .*] ;# links may have dupes - we don't care. struct::set difference will remove
+ set hfiles [glob -nocomplain -dir $folderpath -types {hidden l} * .*]
+ set files [glob -nocomplain -dir $folderpath -types f * .*] ;# also returns links to files
+ } else {
+ set hdirs [glob -nocomplain -dir $folderpath -types {hidden d} $opt_glob]
+ set dirs [glob -nocomplain -dir $folderpath -types d $opt_glob]
+ set hlinks [glob -nocomplain -dir $folderpath -types {hidden l} $opt_glob]
+ set links [glob -nocomplain -dir $folderpath -types l $opt_glob]
+ set hfiles [glob -nocomplain -dir $folderpath -types {hidden f} $opt_glob]
+ set files [glob -nocomplain -dir $folderpath -types f $opt_glob]
+ }
} else {
- set dirs [glob -nocomplain -dir $folderpath -types d $opt_glob]
- set links [glob -nocomplain -dir $folderpath -types l $opt_glob]
- set files [glob -nocomplain -dir $folderpath -types f $opt_glob]
+ #we leave it to the ui on unix to classify dotfiles as hidden
+ set hdirs {}
+ set hfiles {}
+ set hlinks {}
+ if {$opt_glob eq "*"} {
+ set dirs [glob -nocomplain -dir $folderpath -types d * .*] ;# also returns links to dirs
+ #review - how are links handled in vfs? presumably if the vfs is a full implementation they should work at least within the vfs?
+ set links [glob -nocomplain -dir $folderpath -types l * .*] ;# links may have dupes - we don't care. struct::set difference will remove
+ set files [glob -nocomplain -dir $folderpath -types f * .*] ;# also returns links to files
+ } else {
+ set dirs [glob -nocomplain -dir $folderpath -types d $opt_glob]
+ set links [glob -nocomplain -dir $folderpath -types l $opt_glob]
+ set files [glob -nocomplain -dir $folderpath -types f $opt_glob]
+ }
}
#remove any links from our dirs and files collections
- set dirs [struct::set difference $dirs[unset dirs] [concat $links [list [file join $folderpath .] [file join $folderpath ..] ]]]
- set files [struct::set difference $files[unset files] $links]
+ #see du_dirlisting_generic re struct::set difference issues
+ set dirs [punk::lib::struct_set_diff_unique $dirs[unset dirs] [list {*}$links [file join $folderpath .] [file join $folderpath ..] ]]
+ set files [punk::lib::struct_set_diff_unique $files[unset files] $links]
#nested vfs mount.. REVIEW - does anything need special handling?
set vfsmounts [get_vfsmounts_in_folder $folderpath]
set mdata_lists [du_get_metadata_lists $sized_types $timed_types $files $dirs $links]
+ set flaggedhidden [list {*}$hdirs {*}$hfiles {*}$hlinks]
set effective_opts $opts
dict set effective_opts -with_times $timed_types
dict set effective_opts -with_sizes $sized_types
- return [list dirs $dirs vfsmounts $vfsmounts links $links files $files filesizes [dict get $mdata_lists fsizes] sizes [dict get $mdata_lists allsizes] times [dict get $mdata_lists alltimes] flaggedhidden {} flaggedsystem {} flaggedreadonly {} altname {} opts $effective_opts errors $errors]
+ return [list dirs $dirs vfsmounts $vfsmounts links $links files $files filesizes [dict get $mdata_lists fsizes] sizes [dict get $mdata_lists allsizes] times [dict get $mdata_lists alltimes] flaggedhidden $flaggedhidden flaggedsystem {} flaggedreadonly {} altname {} opts $effective_opts errors $errors]
}
#we can halve the number of round trips on unix-like systems, where 'hidden' always corresponds to dotted files
+ #but we don't classify as such anyway. (leave for UI)
proc du_dirlisting_unix {folderpath args} {
set defaults [dict create\
-glob *\
@@ -1379,6 +1417,9 @@ namespace eval punk::du {
}
#this is not consistent with standard way * works for unix folders - but it is consistent with behaviour of this facility on windows
+ #we don't classify anything as 'flaggedhidden' on unix.
+ #it is a convention for dotfiles rather than a flag - and we'll leave the distinction for the display library
+ #This
if {$opt_glob eq "*"} {
set dirs [glob -nocomplain -dir $folderpath -types d * .*] ;# also returns links to dirs
set links [glob -nocomplain -dir $folderpath -types l * .*] ;# links may have dupes - we don't care. struct::set difference will remove
@@ -1389,8 +1430,9 @@ namespace eval punk::du {
set files [glob -nocomplain -dir $folderpath -types f $opt_glob]
}
#remove any links from our dirs and files collections
- set dirs [struct::set difference $dirs[unset dirs] [concat $links [list [file join $folderpath .] [file join $folderpath ..] ]]]
- set files [struct::set difference $files[unset files] $links]
+ #see du_dirlisting_generic re struct::set difference issues
+ set dirs [punk::lib::struct_set_diff_unique $dirs[unset dirs] [list {*}$links [file join $folderpath .] [file join $folderpath ..] ]]
+ set files [punk::lib::struct_set_diff_unique $files[unset files] $links]
set vfsmounts [get_vfsmounts_in_folder $folderpath]
set mdata_lists [du_get_metadata_lists $sized_types $timed_types $files $dirs $links]
@@ -1406,7 +1448,7 @@ namespace eval punk::du {
#return fsizes,allsizes,alltimes metadata in same order as files,dirs,links lists - if specified in sized_types
proc du_get_metadata_lists {sized_types timed_types files dirs links} {
set meta_dict [dict create]
- set meta_types [concat $sized_types $timed_types]
+ set meta_types [list {*}$sized_types {*}$timed_types]
#known tcl stat keys 2023 - review
set empty_stat_dict [dict create atime {} ctime {} dev {} gid {} ino {} mode {} mtime {} nlink {} size {} type {} uid {}]
#make sure we call file stat only once per item
@@ -1419,6 +1461,7 @@ namespace eval punk::du {
if {![catch {file stat $path arrstat} errM]} {
dict set meta_dict $path [dict create shorttype $ft {*}[array get arrstat]]
} else {
+ puts stderr "du_get_metadata_lists: file stat $path error: $errM"
dict lappend errors $path "file stat error: $errM"
dict set meta_dict $path [dict create shorttype $ft {*}$empty_stat_dict]
}
@@ -1437,6 +1480,9 @@ namespace eval punk::du {
if {$ft eq "f"} {
#subst with na if empty?
lappend fsizes [dict get $pathinfo size]
+ if {[dict get $pathinfo size] eq ""} {
+ puts stderr "du_get_metadata_lists: fsize $path is empty!"
+ }
}
}
if {$ft in $timed_types} {
@@ -1446,7 +1492,7 @@ namespace eval punk::du {
#todo - fix . The list lengths will presumably match but have empty values if failed to stat
if {"f" in $sized_types} {
if {[llength $fsizes] ne [llength $files]} {
- dict lappend errors $folderpath "failed to retrieve all file sizes"
+ dict lappend errors general "failed to retrieve all file sizes"
}
}
return [dict create fsizes $fsizes allsizes $allsizes alltimes $alltimes]
diff --git a/src/vfs/_vfscommon/modules/punk/lib-0.1.1.tm b/src/vfs/_vfscommon/modules/punk/lib-0.1.1.tm
index 8f51075e..070621bc 100644
--- a/src/vfs/_vfscommon/modules/punk/lib-0.1.1.tm
+++ b/src/vfs/_vfscommon/modules/punk/lib-0.1.1.tm
@@ -339,6 +339,144 @@ namespace eval punk::lib {
set has_twapi [expr {![catch {package require twapi}]}]
}
+ # == == == == == == == == == == == == == == == == == == == == == == == == == == == == == == ==
+ # Maintenance - This is the primary source for tm_version... functions
+ # - certain packages script require these but without package dependency
+ # - 1 punk boot script
+ # - 2 packagetrace module
+ # - These should be updated to sync with this
+ # == == == == == == == == == == == == == == == == == == == == == == == == == == == == == == ==
+ proc tm_version_isvalid {versionpart} {
+ #Needs to be suitable for use with Tcl's 'package vcompare'
+ if {![catch [list package vcompare $versionpart $versionpart]]} {
+ return 1
+ } else {
+ return 0
+ }
+ }
+ proc tm_version_major {version} {
+ if {![tm_version_isvalid $version]} {
+ error "Invalid version '$version' is not a proper Tcl module version number"
+ }
+ set firstpart [lindex [split $version .] 0]
+ #check for a/b in first segment
+ if {[string is integer -strict $firstpart]} {
+ return $firstpart
+ }
+ if {[string first a $firstpart] > 0} {
+ return [lindex [split $firstpart a] 0]
+ }
+ if {[string first b $firstpart] > 0} {
+ return [lindex [split $firstpart b] 0]
+ }
+ error "tm_version_major unable to determine major version from version number '$version'"
+ }
+ proc tm_version_canonical {ver} {
+ #accepts a single valid version only - not a bounded or unbounded spec
+ if {![tm_version_isvalid $ver]} {
+ error "tm_version_canonical version '$ver' is not valid for a package version"
+ }
+ set parts [split $ver .]
+ set newparts [list]
+ foreach o $parts {
+ set trimmed [string trimleft $o 0]
+ set firstnonzero [string index $trimmed 0]
+ switch -exact -- $firstnonzero {
+ "" {
+ lappend newparts 0
+ }
+ a - b {
+ #e.g 000bnnnn -> bnnnnn
+ set tailtrimmed [string trimleft [string range $trimmed 1 end] 0]
+ if {$tailtrimmed eq ""} {
+ set tailtrimmed 0
+ }
+ lappend newparts 0$firstnonzero$tailtrimmed
+ }
+ default {
+ #digit
+ if {[string is integer -strict $trimmed]} {
+ #e.g 0100 -> 100
+ lappend newparts $trimmed
+ } else {
+ #e.g 0100b003 -> 100b003 (still need to process tail)
+ if {[set apos [string first a $trimmed]] > 0} {
+ set lhs [string range $trimmed 0 $apos-1] ;#assert lhs non-empty and only digits or wouldn't be in this branch
+ set rhs [string range $trimmed $apos+1 end] ;#assert rhs non-empty and only digits
+ set rhs [string trimleft $rhs 0]
+ if {$rhs eq ""} {
+ set rhs 0
+ }
+ lappend newparts ${lhs}a${rhs}
+ } elseif {[set bpos [string first b $trimmed]] > 0} {
+ set lhs [string range $trimmed 0 $bpos-1] ;#assert lhs non-empty and only digits or wouldn't be in this branch
+ set rhs [string range $trimmed $bpos+1 end] ;#assert rhs non-empty and only digits
+ set rhs [string trimleft $rhs 0]
+ if {$rhs eq ""} {
+ set rhs 0
+ }
+ lappend newparts ${lhs}b${rhs}
+ } else {
+ #assert - shouldn't get here trimmed val should have been empty, an int or contained an a or b
+ error "tm_version_canonical error - trimfail - unexpected"
+ }
+ }
+ }
+ }
+ }
+ return [join $newparts .]
+ }
+ proc tm_version_required_canonical {versionspec} {
+ #also trim leading zero from any dottedpart?
+ #Tcl *allows* leading zeros in any of the dotted parts - but they are not significant.
+ #e.g 1.01 is equivalent to 1.1 and 01.001
+ #also 1b3 == 1b0003
+
+ if {[string trim $versionspec] eq ""} {return ""} ;#unspecified = any version
+ set errmsg "tm_version_required_canonical - invalid version specification"
+ if {[string first - $versionspec] < 0} {
+ #no dash
+ #looks like a minbounded version (ie a single version with no dash) convert to min-max form
+ set from $versionspec
+ if {![tm_version_isvalid $from]} {
+ error "$errmsg '$versionpec'"
+ }
+ if {![catch {tm_version_major $from} majorv]} {
+ set from [tm_version_canonical $from]
+ return "${from}-[expr {$majorv +1}]"
+ } else {
+ error "$errmsg '$versionspec'"
+ }
+ } else {
+ # min- or min-max
+ #validation and canonicalisation (strip leading zeroes from each segment, including either side of a or b)
+ set parts [split $versionspec -] ;#we expect only 2 parts
+ lassign $parts from to
+ if {![tm_version_isvalid $from]} {
+ error "$errmsg '$versionspec'"
+ }
+ set from [tm_version_canonical $from]
+ if {[llength $parts] == 2} {
+ if {$to ne ""} {
+ if {![tm_version_isvalid $to]} {
+ error "$errmsg '$versionspec'"
+ }
+ set to [tm_version_canonical $to]
+ return $from-$to
+ } else {
+ return $from-
+ }
+ } else {
+ error "$errmsg '$versionspec'"
+ }
+ error "tm_version_required_canonical should have already returned a canonicalised versionspec - or produced an error with reason before this point"
+ }
+ }
+ # end tm_version... functions
+ # == == == == == == == == == == == == == == == == == == == == == == == == == == == == == == ==
+
+
+
# -- ---
#https://stackoverflow.com/questions/17631269/whats-the-best-way-to-join-two-lists
#DKF's 2013 recommendation of using list {*}$first {*}$second seems not to apply in 2024
@@ -1575,8 +1713,20 @@ namespace eval punk::lib {
lremove $fromlist {*}$doomed
}
+ #fix for tcl impl of struct::set::diff which doesn't dedupe
+ proc struct_set_diff_unique {A B} {
+ package require struct::set ;#require even if tcl impl - so the dependency isn't missed accidentally due to Loaded state of programmers machine.
+ if {[struct::set::Loaded] eq "tcl"} {
+ return [punk::lib::setdiff $A $B]
+ } else {
+ #use (presumably critcl) implementation for speed
+ return [struct::set difference $A $B]
+ }
+ }
+
+
#non-dupe preserving - for consistency in dedupe behaviour we don't shortcircuit empty B
- #consistent dedupe and order-maintenance of remaining items in A differentiate this from struct::set difference
+ #consistent dedupe and order-maintenance of remaining items in A differentiate this from struct::set difference (dedupes with critcl, doesn't with tcl implementation 2024)
#also struct::set difference with critcl is faster
proc setdiff {A B} {
if {[llength $A] == 0} {return {}}
@@ -2387,7 +2537,7 @@ namespace eval punk::lib {
set stdin_state [fconfigure stdin]
if {[catch {
package require punk::console
- set console_raw [set ::punk::console::is_raw]
+ set console_raw [tsv::get console is_raw]
} err_console]} {
#assume normal line mode
set console_raw 0
@@ -3032,6 +3182,11 @@ namespace eval punk::lib {
proc objclone {obj} {
append obj2 $obj {}
}
+ proc set_clone {varname obj} {
+ #used by repl's codeinterp. Maintains internal rep, easier to call e.g interp eval code [list punk::set_clone varnmame $val]
+ append obj2 $obj {}
+ uplevel 1 [list set $varname $obj2]
+ }
@@ -3175,7 +3330,7 @@ tcl::namespace::eval punk::lib::system {
#[para] Internal functions that are not part of the API
#[list_begin definitions]
- proc has_script_var_bug {} {
+ proc has_tclbug_script_var {} {
set script {set j [list spud] ; list}
append script \n
uplevel #0 $script
@@ -3194,7 +3349,15 @@ tcl::namespace::eval punk::lib::system {
return false
}
}
- proc has_safeinterp_compile_bug {{show 0}} {
+
+ proc has_tclbug_list_quoting_emptyjoin {} {
+ #https://core.tcl-lang.org/tcl/tktview/e38dce74e2
+ set v1 [list {*}[lindex #foo] {*}[]] ;#can return "#foo" instead of "{#foo}" under some beta 9 releases
+ set v2 [list #foo] ;#normal tcl list quoting for 1st element that looks like a comment -> "{#foo}"
+ return [expr {![string equal $v1 $v2]}] ;#if they're not equal - we have the bug.
+ }
+
+ proc has_tclbug_safeinterp_compile {{show 0}} {
#ensemble calls within safe interp not compiled
namespace eval [namespace current]::testcompile {
proc ensembletest {} {string index a 0}
diff --git a/src/vfs/_vfscommon/modules/punk/mix/base-0.1.tm b/src/vfs/_vfscommon/modules/punk/mix/base-0.1.tm
index 806b172e..dfdc71f9 100644
--- a/src/vfs/_vfscommon/modules/punk/mix/base-0.1.tm
+++ b/src/vfs/_vfscommon/modules/punk/mix/base-0.1.tm
@@ -473,13 +473,26 @@ namespace eval punk::mix::base {
#set data [fileutil::cat -translation binary $filename] ;#no significant performance diff on windows - and doesn't handle win-illegal names
zlib adler32 $data
}
- #zlib crc vie file-slurp
+ #zlib crc via file-slurp
proc cksum_crc_file {filename} {
package require zlib
set data [punk::mix::util::fcat -translation binary -encoding iso8859-1 $filename]
zlib crc $data
}
+ proc cksum_md5_data {data} {
+ if {[package vsatisfies [package present md5] 2-]} {
+ return [md5::md5 -hex $data]
+ } else {
+ return [md5::md5 $data]
+ }
+ }
+ #fallback md5 via file-slurp - shouldn't be needed if have md5 2-
+ proc cksum_md5_file {filename} {
+ set data [punk::mix::util::fcat -translation binary -encoding iso8859-1 $filename]
+ cksum_md5_data $data
+ }
+
#required to be able to accept relative paths
#for full cksum - using tar could reduce number of hashes to be made..
@@ -624,7 +637,11 @@ namespace eval punk::mix::base {
}
md5 {
package require md5
- set cksum_command [list md5::md5 -hex -file]
+ if {[package vsatisfies [package present md5] 2- ] } {
+ set cksum_command [list md5::md5 -hex -file]
+ } else {
+ set cksum_comand [list cksum_md5_file]
+ }
}
cksum {
package require cksum ;#tcllib
@@ -637,7 +654,7 @@ namespace eval punk::mix::base {
set cksum_command [list cksum_adler32_file]
}
sha3 - sha3-256 {
- #todo - replace with something that doesn't call another process
+ #todo - replace with something that doesn't call another process - only if tcllibc not available!
#set cksum_command [list apply {{file} {lindex [exec fossil sha3sum -256 $file] 0}}]
set cksum_command [list $sha3_implementation 256]
}
@@ -684,7 +701,7 @@ namespace eval punk::mix::base {
set sizeinfo "(file type $ftype - tarred size [punk::lib::format_number [file size $archivename]] bytes)"
}
set tsstart [clock millis]
- puts -nonewline stdout "cksum_path: calculating cksum for $target $sizeinfo ... "
+ puts -nonewline stdout "cksum_path: calculating cksum using $opt_cksum_algorithm for $target $sizeinfo ... "
set cksum [{*}$cksum_command $archivename]
set tsend [clock millis]
set ms [expr {$tsend - $tsstart}]
diff --git a/src/vfs/_vfscommon/modules/punk/mix/commandset/doc-0.1.0.tm b/src/vfs/_vfscommon/modules/punk/mix/commandset/doc-0.1.0.tm
index 856c9340..1d8d40e1 100644
--- a/src/vfs/_vfscommon/modules/punk/mix/commandset/doc-0.1.0.tm
+++ b/src/vfs/_vfscommon/modules/punk/mix/commandset/doc-0.1.0.tm
@@ -271,7 +271,12 @@ namespace eval punk::mix::commandset::doc {
#this case only came up because docgen used to path munge to long filenames - but left because we know there is a limit and renaming fixes it - even if it's ugly - but still allows doc generation.
#review - if we're checking fname - should also test length of whole path and determine limits for tar
package require md5
- set target_docname [md5::md5 -hex [encoding convertto utf-8 $fullpath]]_overlongfilename.man
+ if {[package vsatisfies [package present md5] 2- ] } {
+ set md5opt "-hex"
+ } else {
+ set md5opt ""
+ }
+ set target_docname [md5::md5 {*}$md5opt [encoding convertto utf-8 $fullpath]]_overlongfilename.man
puts stderr "WARNING - overlong file name - renaming $fullpath"
puts stderr " to [file dirname $fullpath]/$target_docname"
}
diff --git a/src/vfs/_vfscommon/modules/punk/mix/util-0.1.0.tm b/src/vfs/_vfscommon/modules/punk/mix/util-0.1.0.tm
index aca7eeed..d1459369 100644
--- a/src/vfs/_vfscommon/modules/punk/mix/util-0.1.0.tm
+++ b/src/vfs/_vfscommon/modules/punk/mix/util-0.1.0.tm
@@ -261,6 +261,8 @@ namespace eval punk::mix::util {
return
}
+ # review punk::lib::tm_version.. functions
+
proc is_valid_tm_version {versionpart} {
#Needs to be suitable for use with Tcl's 'package vcompare'
if {![catch [list package vcompare $versionpart $versionpart]]} {
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 426271a7..9cf44529 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
@@ -821,9 +821,12 @@ tcl::namespace::eval punk::nav::fs {
set match_contents $opt_tailglob
}
}
- puts stdout "searchbase: $searchbase searchspec:$searchspec"
+ #puts stdout "searchbase: $searchbase searchspec:$searchspec"
- set in_vfs 0
+
+ #file attr //cookit:/ returns {-vfs 1 -handle {}}
+ #we will treat it differently for now - use generic handler REVIEW
+ set in_vfs 0 ;#we use this only for a vfs which is reported to have a mountpoint by vfs::filesystem info - not all that have -vfs 1 attr like cookit.
if {[llength [package provide vfs]]} {
foreach mount [vfs::filesystem info] {
if {[punk::mix::base::lib::path_a_atorbelow_b $location $mount]} {
@@ -849,22 +852,45 @@ tcl::namespace::eval punk::nav::fs {
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 ""} {
- if {[string match //zipfs:/* $location]} {
- set in_zipfs 1
+ set in_cookit 1
+ set in_other_pseudovol 1
+ switch -glob -- $location {
+ //zipfs:/* {
+ if {[info commands ::tcl::zipfs::mount] ne ""} {
+ set in_zipfs 1
+ }
+ }
+ //cookit:/* {
+ set in_cookit 1
+ }
+ default {
+ #handle 'other/unknown' that mounts at a volume-like path //pseudovol:/
+ if {[regexp {//((?:(?!:|/).)+):/.*} $location _match pseudovol]} {
+ #pseudovol probably more than one char long
+ #we don't really expect something like //c:/ , but anyway, it's not the same as c:/ and for all we know someone could use that as a volume name?
+ set in_other_pseudovol 1 ;#flag so we don't use twapi - hope generic can handle it (uses tcl glob)
+ } else {
+ #we could use 'file attr' here to test if {-vfs 1}
+ #but it's an extra filesystem hit on all normal paths too (which can be expensive on some systems)
+ #instead for now we'll assume any reasonable vfs should have been found by vfs::filesystem::info or mounted as a pseudovolume
+ }
+
}
- #dict for {zmount zpath} [zipfs mount] {
- # if {[punk::mix::base::lib::path_a_atorbelow_b $location $zmount]} {
- # set in_zipfs 1
- # break
- # }
- #}
}
+
if {$in_zipfs} {
#relative vs absolute? review - cwd valid for //zipfs:/ ??
- set listing [punk::du::lib::du_dirlisting_zipfs $location -glob $match_contents {*}$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]
+ } elseif {$in_cookit} {
+ #seems to be a vfs - except it mounts on a pseudo-volume path //cookit:/
+ #don't use twapi
+ #could possibly use du_dirlisting_tclvfs REVIEW
+ #files and folders are all returned with the -types hidden option for glob on windows
+ set listing [punk::du::lib::du_dirlisting_generic $location -glob $match_contents {*}$next_opt_with_sizes {*}$next_opt_with_times]
+ } elseif {$in_other} {
+ set listing [punk::du::lib::du_dirlisting_generic $location -glob $match_contents {*}$next_opt_with_sizes {*}$next_opt_with_times]
} else {
- set listing [punk::du::dirlisting $location -glob $match_contents {*}$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]
}
}
diff --git a/src/vfs/_vfscommon/modules/punk/packagepreference-0.1.0.tm b/src/vfs/_vfscommon/modules/punk/packagepreference-0.1.0.tm
index d950eab4..e38c76c6 100644
--- a/src/vfs/_vfscommon/modules/punk/packagepreference-0.1.0.tm
+++ b/src/vfs/_vfscommon/modules/punk/packagepreference-0.1.0.tm
@@ -155,18 +155,26 @@ tcl::namespace::eval punk::packagepreference {
if {[lindex $args 1] eq "-exact"} {
set pkg [lindex $args 2]
set vwant [lindex $args 3]
- if {[set ver [package provide $pkg]] ne ""} {
- if {$ver eq $vwant} {
- return $vwant
- } else {
- #package already provided with a different version.. we will defer to underlying implementation to return the standard error
- return [$COMMANDSTACKNEXT {*}$args]
- }
+ if {[set ver [$COMMANDSTACKNEXT_ORIGINAL provide $pkg]] ne ""} {
+ #although we could shortcircuit using vsatisfies to return the ver
+ #we should instead pass through to COMMANDSTACKNEXT so as not to interfere with whatever it does.
+ return [$COMMANDSTACKNEXT {*}$args]
+
+ #if {$vwant eq "" || [$COMMANDSTACKNEXT vsatisfies $ver $vwant]} {
+ # return $ver
+ #} else {
+ # #package already provided with a different version.. we will defer to underlying implementation to return the standard error
+ # return [$COMMANDSTACKNEXT {*}$args]
+ #}
}
} else {
set pkg [lindex $args 1]
- if {[set ver [package provide $pkg]] ne ""} {
- return $ver
+ set vwant [lindex $args 2]
+ if {[set ver [$COMMANDSTACKNEXT_ORIGINAL provide $pkg]] ne ""} {
+ return [$COMMANDSTACKNEXT {*}$args]
+ #if {$vwant eq "" || [$COMMANDSTACKNEXT vsatisfies $ver $vwant]} {
+ # return $ver
+ #}
}
}
if {[regexp {[A-Z]} $pkg]} {
diff --git a/src/vfs/_vfscommon/modules/punk/repl-0.1.tm b/src/vfs/_vfscommon/modules/punk/repl-0.1.tm
index eef8799d..86908ae6 100644
--- a/src/vfs/_vfscommon/modules/punk/repl-0.1.tm
+++ b/src/vfs/_vfscommon/modules/punk/repl-0.1.tm
@@ -73,6 +73,7 @@ namespace eval repl {
#variable last_unknown ""
tsv::set repl last_unknown ""
+ tsv::set console is_raw 0
variable output ""
#important not to initialize - as it can be preset by cooperating package before app-punk has been package required
#(this is an example of a deaddrop)
@@ -149,7 +150,7 @@ proc ::punk::repl::init_signal_handlers {} {
flush stderr
incr signal_control_c
#rputs stderr "* console_control: $args"
- if {$::punk::console::is_raw} {
+ if {[tsv::get console is_raw]} {
if {[lindex $::errorCode 0] eq "CHILDKILLED"} {
#rputs stderr "\n|repl> ctrl-c errorCode: $::errorCode"
#avoid spurious triggers after interrupting a command..
@@ -615,7 +616,8 @@ proc repl::doprompt {prompt {col {green bold}}} {
flush stdout; #we are writing this prompt on stderr, but stdout could still be writing to screen
#our first char on stderr is based on the 'lastchar' of stdout which we have recorded but may not have arrived on screen.
#The issue we're trying to avoid is the (stderr)prompt arriving midway through a large stdout chunk
- #REVIEW - this basic attempt to get stderr/stdout to cooperate is experimental and unlikely to achieve the desired effect
+ #REVIEW - this basic attempt to get stderr/stdout to cooperate is experimental and unlikely to achieve the desired effect in all situations
+ #It the above flush does seem to help though.
#note that our 'flush stdout' tcl call does not wait if stdout is non-blocking
#todo - investigate if the overhead is reasonable for a special channel that accepts stdout and stderr records with a reader to send to console in chunk-sizes we know will be emitted correctly
# - reader of such channel could be ok to be blocking (on read? on write to real channels?)... except everything still needs to be interruptable by things like signals?
@@ -1296,9 +1298,11 @@ proc repl::repl_handler {inputchan prompt_config} {
if {[dict get $original_input_conf -inputmode] eq "raw"} {
#user or script has apparently put stdin into raw mode - update punk::console::is_raw to match
set rawmode 1
- set ::punk::console::is_raw 1
+ #set ::punk::console::is_raw 1
+ tsv::set console is_raw 1
} else {
- set ::punk::console::is_raw 0
+ #set ::punk::console::is_raw 0
+ tsv::set console is_raw 0
}
#what about enable/disable virtualTerminal ?
#using stdin -inputmode to switch modes won't set virtualterminal input state appropriately
@@ -1308,7 +1312,8 @@ proc repl::repl_handler {inputchan prompt_config} {
} else {
#JMN FIX!
#this returns 0 in rawmode on 8.6 after repl thread changes
- set rawmode [set ::punk::console::is_raw]
+ #set rawmode [set ::punk::console::is_raw]
+ set rawmode [tsv::get console is_raw]
}
if {!$rawmode} {
@@ -1672,7 +1677,8 @@ proc repl::repl_process_data {inputchan chunktype chunk stdinlines prompt_config
set debugprompt [dict get $prompt_config debugprompt]
- set rawmode [set ::punk::console::is_raw]
+ #set rawmode [set ::punk::console::is_raw]
+ set rawmode [tsv::get console is_raw]
if {!$rawmode} {
#puts stderr "-->got [ansistring VIEW -lf 1 $stdinlines]<--"
@@ -2056,6 +2062,10 @@ proc repl::repl_process_data {inputchan chunktype chunk stdinlines prompt_config
#/scriptlib/tests/listrep_bug.tcl
#after the uplevel #0 $commandstr call
# vars within the script that were set to a list, and have no string-rep, will generate a string-rep once the script (commandstr) is unset, or set to another value
+ #review - although the rep change is weird - what actual problem was caused aside from an unexpected shimmer?
+ #probably just that the repl can't then be used to debug representation issues and possibly that the performance is not ideal for list pipeline commands(?)
+ #now that we eval in another thread and interp - we seem to lose the list rep anyway.
+ #(unless we also save the script in that interp too in a run_command_cache)
global run_command_string
set run_command_string "$commandstr\n" ;#add anything that won't affect script.
global run_command_cache
@@ -2145,7 +2155,7 @@ proc repl::repl_process_data {inputchan chunktype chunk stdinlines prompt_config
#-----------------------------------------
#list/string-rep bug workaround part 2
- #todo - set flag based on punk::lib::system::has_script_var_bug
+ #todo - set flag based on punk::lib::system::has_tclbug_script_var
lappend run_command_cache $run_command_string
#puts stderr "run_command_string rep: [rep $run_command_string]"
if {[llength $run_command_cache] > 2000} {
@@ -2693,8 +2703,10 @@ namespace eval repl {
#todo - add/remove shellfilter stacked ansiwrap
}
proc mode args {
+ #with tsv::set console is_raw we don't need to call mode in both the replthread and the codethread
+ # REVIEW - call in local interp? how about if codethread is safe interp?
+ #interp eval code [list ::punk::console::mode {*}$args]
thread::send %replthread% [list punk::console::mode {*}$args]
- interp eval code [list ::punk::console::mode {*}$args]
}
proc cmdtype cmd {
code invokehidden tcl:info:cmdtype $cmd
@@ -2825,6 +2837,7 @@ namespace eval repl {
code alias ::md5::md5 ::repl::interphelpers::md5
code alias exit ::repl::interphelpers::quit
} elseif {$safe == 2} {
+ #safebase
safe::interpCreate code -nested 1
#safe::setLogCmd ::repl::interpextras::safe_msg ;#using setLogcmd early will show the auto_path notice - which is *verbose*
#while it may conceivably be useful in debugging safe itself - auto_path and tcl::tm::list can be inspected to show these values in the safe interp itself anyway - so early logging is of limited utility here.
@@ -2900,6 +2913,7 @@ namespace eval repl {
namespace eval ::codeinterp {
variable errstack {}
variable outstack {}
+ variable run_command_cache
}
# -- ---
diff --git a/src/vfs/_vfscommon/modules/punk/repl/codethread-0.1.0.tm b/src/vfs/_vfscommon/modules/punk/repl/codethread-0.1.0.tm
index 09b8a0be..39b5bf78 100644
--- a/src/vfs/_vfscommon/modules/punk/repl/codethread-0.1.0.tm
+++ b/src/vfs/_vfscommon/modules/punk/repl/codethread-0.1.0.tm
@@ -20,12 +20,12 @@
#*** !doctools
#[manpage_begin shellspy_module_punk::repl::codethread 0 0.1.0]
#[copyright "2024"]
-#[titledesc {Module API}] [comment {-- Name section and table of contents description --}]
-#[moddesc {-}] [comment {-- Description at end of page heading --}]
+#[titledesc {Module repl codethread}] [comment {-- Name section and table of contents description --}]
+#[moddesc {codethread for repl - root interpreter}] [comment {-- Description at end of page heading --}]
#[require punk::repl::codethread]
-#[keywords module]
+#[keywords module repl]
#[description]
-#[para] -
+#[para] This is part of the infrastructure required for the punk::repl to operate
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
@@ -131,11 +131,14 @@ tcl::namespace::eval punk::repl::codethread {
# return "ok"
#}
+ variable run_command_cache
+
proc is_running {} {
variable running
return $running
}
proc runscript {script} {
+
#puts stderr "->runscript"
variable replthread_cond
variable output_stdout ""
@@ -169,9 +172,18 @@ tcl::namespace::eval punk::repl::codethread {
#set errhandle [shellfilter::stack::item_tophandle stderr]
#interp transfer "" $errhandle code
- set scope [interp eval code [list set ::punk::ns::ns_current]]
set status [catch {
- interp eval code [list tcl::namespace::inscope $scope $script]
+ #shennanigans to keep compiled script around after call.
+ #otherwise when $script goes out of scope - internal rep of vars set in script changes.
+ #The shimmering may be no big deal(?) - but debug/analysis using tcl::unsupported::representation becomes impossible.
+ interp eval code [list ::punk::lib::set_clone ::codeinterp::clonescript $script] ;#like objclone
+ interp eval code {
+ lappend ::codeinterp::run_command_cache $::codeinterp::clonescript
+ if {[llength $::codeinterp::run_command_cache] > 2000} {
+ set ::codeinterp::run_command_cache [lrange $::codeinterp::run_command_cache 1750 end][unset ::codeinterp::run_command_cache]
+ }
+ tcl::namespace::inscope $::punk::ns::ns_current $::codeinterp::clonescript
+ }
} result]
diff --git a/src/vfs/_vfscommon/modules/punk/repo-0.1.1.tm b/src/vfs/_vfscommon/modules/punk/repo-0.1.1.tm
index 4e0217b0..bc93a9c3 100644
--- a/src/vfs/_vfscommon/modules/punk/repo-0.1.1.tm
+++ b/src/vfs/_vfscommon/modules/punk/repo-0.1.1.tm
@@ -27,6 +27,11 @@
#
# path/repo functions
#
+
+#REVIEW punk::repo required early by punk boot script to find projectdir
+#todo - split off basic find_project chain of functions to a smaller package and import as necessary here
+#Then we can reduce early dependencies in punk boot
+
if {$::tcl_platform(platform) eq "windows"} {
package require punk::winpath
} else {
diff --git a/src/vfs/_vfscommon/modules/textblock-0.1.1.tm b/src/vfs/_vfscommon/modules/textblock-0.1.1.tm
index 96fb263d..b822b353 100644
--- a/src/vfs/_vfscommon/modules/textblock-0.1.1.tm
+++ b/src/vfs/_vfscommon/modules/textblock-0.1.1.tm
@@ -5280,8 +5280,8 @@ tcl::namespace::eval textblock {
It excludes the extra top and side join elements htlj,hlbj,vllj,vlrj"
*values -min 1 -max 1
frametype -help "name from the predefined frametypes:
- or an adhoc
- }]
+ or an adhoc "
+ }]
append spec \n "frametype -help \"A predefined \""
punk::args::get_dict $spec $args
return
@@ -6804,7 +6804,11 @@ tcl::namespace::eval textblock {
if {$use_md5} {
#package require md5 ;#already required at package load
- set hash [md5::md5 -hex [encoding convertto utf-8 $hashables]] ;#need fast and unique to content - not cryptographic - review
+ if {[package vsatisfies [package present md5] 2- ] } {
+ set hash [md5::md5 -hex [encoding convertto utf-8 $hashables]] ;#need fast and unique to content - not cryptographic - review
+ } else {
+ set hash [md5::md5 [encoding convertto utf-8 $hashables]]
+ }
} else {
set hash $hashables
}
diff --git a/src/vfs/critcl.vfs/README.md b/src/vfs/critcl-3.3.1.vfs/README.md
similarity index 100%
rename from src/vfs/critcl.vfs/README.md
rename to src/vfs/critcl-3.3.1.vfs/README.md
diff --git a/src/vfs/critcl-3.3.1.vfs/build.tcl b/src/vfs/critcl-3.3.1.vfs/build.tcl
new file mode 100644
index 00000000..61955b93
--- /dev/null
+++ b/src/vfs/critcl-3.3.1.vfs/build.tcl
@@ -0,0 +1,801 @@
+#!/bin/sh
+# -*- tcl -*- \
+exec tclsh "$0" ${1+"$@"}
+package require Tcl 8.6 9
+unset -nocomplain ::errorInfo
+set me [file normalize [info script]]
+proc main {} {
+ global argv
+ if {![llength $argv]} { set argv help}
+ if {[catch {
+ eval _$argv
+ }]} usage
+ exit 0
+}
+set packages {
+ {app-critcl {.. critcl critcl.tcl} critcl-app}
+ {critcl critcl.tcl}
+ {critcl-bitmap bitmap.tcl}
+ {critcl-class class.tcl}
+ {critcl-cutil cutil.tcl}
+ {critcl-emap emap.tcl}
+ {critcl-enum enum.tcl}
+ {critcl-iassoc iassoc.tcl}
+ {critcl-literals literals.tcl}
+ {critcl-platform platform.tcl}
+ {critcl-util util.tcl}
+ {stubs_container container.tcl}
+ {stubs_gen_decl gen_decl.tcl}
+ {stubs_gen_header gen_header.tcl}
+ {stubs_gen_init gen_init.tcl}
+ {stubs_gen_lib gen_lib.tcl}
+ {stubs_gen_macro gen_macro.tcl}
+ {stubs_gen_slot gen_slot.tcl}
+ {stubs_genframe genframe.tcl}
+ {stubs_reader reader.tcl}
+ {stubs_writer writer.tcl}
+}
+proc usage {{status 1}} {
+ global errorInfo
+ if {[info exists errorInfo] && ($errorInfo ne {}) &&
+ ![string match {invalid command name "_*"*} $errorInfo]
+ } {
+ puts stderr $::errorInfo
+ exit
+ }
+
+ global argv0
+ set prefix "Usage: "
+ foreach c [lsort -dict [info commands _*]] {
+ set c [string range $c 1 end]
+ if {[catch {
+ H${c}
+ } res]} {
+ puts stderr "$prefix[underlined]$argv0 $c[reset] args...\n"
+ } else {
+ puts stderr "$prefix[underlined]$argv0 $c[reset] $res\n"
+ }
+ set prefix " "
+ }
+ exit $status
+}
+
+proc underlined {} { return "\033\[4m" }
+proc reset {} { return "\033\[0m" }
+
+proc +x {path} {
+ catch { file attributes $path -permissions ugo+x }
+ return
+}
+proc critapp {dst} {
+ global tcl_platform
+ set app [file join $dst critcl]
+ if {$tcl_platform(platform) eq "windows"} {
+ append app .tcl
+ }
+ return $app
+}
+proc vfile {dir vfile} {
+ global me
+ set selfdir [file dirname $me]
+ eval [linsert $vfile 0 file join $selfdir lib $dir]
+}
+proc grep {file pattern} {
+ set lines [split [read [set chan [open $file r]]] \n]
+ close $chan
+ return [lsearch -all -inline -glob $lines $pattern]
+}
+proc version {file} {
+ set provisions [grep $file {*package provide*}]
+ #puts /$provisions/
+ return [lindex $provisions 0 3]
+}
+proc tmpdir {} {
+ set tmpraw "critcl.[clock clicks]"
+ set tmpdir $tmpraw.[pid]
+ file delete -force $tmpdir
+ file mkdir $tmpdir
+ file delete -force $tmpraw
+
+ puts "Assembly in: $tmpdir"
+ return $tmpdir
+}
+proc relativedir {dest here} {
+ # Convert dest into a relative path which is relative to `here`.
+ set save $dest
+
+ #puts stderr [list relativedir $dest $label]
+
+ set here [file split $here]
+ set dest [file split $dest]
+
+ #puts stderr [list relativedir < $here]
+ #puts stderr [list relativedir > $dest]
+
+ while {[string equal [lindex $dest 0] [lindex $here 0]]} {
+ set dest [lrange $dest 1 end]
+ set here [lrange $here 1 end]
+ if {[llength $dest] == 0} {break}
+ }
+ set ul [llength $dest]
+ set hl [llength $here]
+
+ if {$ul == 0} {
+ set dest [lindex [file split $save] end]
+ } else {
+ while {$hl > 1} {
+ set dest [linsert $dest 0 ..]
+ incr hl -1
+ }
+ set dest [eval file join $dest]
+ }
+
+ #puts stderr [list relativedir --> $dest]
+ return $dest
+}
+proc id {cv vv} {
+ upvar 1 $cv commit $vv version
+
+ set commit [exec git log -1 --pretty=format:%H]
+ set version [exec git describe]
+
+ puts "Commit: $commit"
+ puts "Version: $version"
+ return
+}
+proc savedoc {tmpdir} {
+ puts {Collecting the documentation ...}
+ file copy -force [file join embedded www] [file join $tmpdir doc]
+ return
+}
+proc pkgdirname {name version} {
+ return $name-$version
+}
+proc placedoc {tmpdir} {
+ file delete -force doc
+ file copy -force [file join $tmpdir doc] doc
+ return
+}
+proc 2website {} {
+ puts {Switching to gh-pages...}
+ exec 2>@ stderr >@ stdout git checkout gh-pages
+ return
+}
+proc reminder {commit} {
+ puts ""
+ puts "We are in branch gh-pages now, coming from $commit"
+ puts ""
+ return
+}
+proc shquote value {
+ return "\"[string map [list \\ \\\\ $ \\$ ` \\`] $value]\""
+}
+proc dest-dir {} {
+ global paths
+ if {![info exists paths(dest-dir)]} {
+ global env
+ if {[info exists env(DESTDIR)]} {
+ set paths(dest-dir) [string trimright $env(DESTDIR) /]
+ } else {
+ set paths(dest-dir) ""
+ }
+ } elseif {$paths(dest-dir) ne ""} {
+ set paths(dest-dir) [string trimright $paths(dest-dir) /]
+ }
+ return $paths(dest-dir)
+}
+proc prefix {} {
+ global paths
+ if {![info exists paths(prefix)]} {
+ set paths(prefix) [file dirname [file dirname [norm [info nameofexecutable]]]]
+ }
+ return $paths(prefix)
+}
+proc exec-prefix {} {
+ global paths
+ if {![info exists paths(exec-prefix)]} {
+ set paths(exec-prefix) [prefix]
+ }
+ return $paths(exec-prefix)
+}
+proc bin-dir {} {
+ global paths
+ if {![info exists paths(bin-dir)]} {
+ set paths(bin-dir) [exec-prefix]/bin
+ }
+ return $paths(bin-dir)
+}
+proc lib-dir {} {
+ global paths
+ if {![info exists paths(lib-dir)]} {
+ set paths(lib-dir) [exec-prefix]/lib
+ }
+ return $paths(lib-dir)
+}
+proc include-dir {} {
+ global paths
+ if {![info exists paths(include-dir)]} {
+ set paths(include-dir) [prefix]/include
+ }
+ return $paths(include-dir)
+}
+proc process-install-options {} {
+ upvar 1 args argv target target
+ while {[llength $argv]} {
+ set o [lindex $argv 0]
+ if {![string match -* $o]} break
+ switch -exact -- $o {
+ -target {
+ # ignore 0
+ set target [lindex $argv 1]
+ set argv [lrange $argv 2 end]
+ }
+ --dest-dir -
+ --prefix -
+ --exec-prefix -
+ --bin-dir -
+ --lib-dir -
+ --include-dir {
+ # ignore 0
+ set path [lindex $argv 1]
+ set argv [lrange $argv 2 end]
+ set key [string range $o 2 end]
+ global paths
+ set paths($key) [norm $path]
+ }
+ -- break
+ default {
+ puts [Hinstall]
+ exit 1
+ }
+ }
+ }
+ return
+}
+proc norm {path} {
+ # normalize smybolic links in the path, including the last element.
+ return [file dirname [file normalize [file join $path ...]]]
+}
+proc query {q c} {
+ puts -nonewline "$q ? "
+ flush stdout
+ set a [string tolower [gets stdin]]
+ if {($a ne "y" ) && ($a ne "yes")} {
+ puts "$c"
+ exit 1
+ }
+}
+proc thisexe {} {
+ return [info nameofexecutable]
+}
+proc wfile {path data} {
+ # Easier to write our own copy than requiring fileutil and then using fileutil::writeFile.
+ set fd [open $path w]
+ puts -nonewline $fd $data
+ close $fd
+ return
+}
+proc cat {path} {
+ # Easier to write our own copy than requiring fileutil and then using fileutil::cat.
+ set fd [open $path r]
+ set data [read $fd]
+ close $fd
+ return $data
+}
+proc Hsynopsis {} { return "\n\tGenerate a synopsis of procs and builtin types" }
+proc _synopsis {} {
+ puts Public:
+ puts [exec grep -n ^proc lib/critcl/critcl.tcl \
+ | sed -e "s| \{$||" -e {s/:proc ::critcl::/ /} \
+ | grep -v { [A-Z]} \
+ | grep -v { at::[A-Z]} \
+ | sort -k 2 \
+ | sed -e {s/^/ /}]
+
+ puts Private:
+ puts [exec grep -n ^proc lib/critcl/critcl.tcl \
+ | sed -e "s| \{$||" -e {s/:proc ::critcl::/ /} \
+ | grep {[A-Z]} \
+ | sort -k 2 \
+ | sed -e {s/^/ /}]
+
+ puts "Builtin argument types:"
+ puts [exec grep -n { argtype} lib/critcl/critcl.tcl \
+ | grep -v "\\\$ntype" \
+ | sed -e "s| \{$||" -e {s/:[ ]*argtype/ /} \
+ | sort -k 2 \
+ | sed -e {s/^/ /}]
+
+ puts "Builtin result types:"
+ puts [exec grep -n { resulttype} lib/critcl/critcl.tcl \
+ | sed -e "s| \{$||" -e {s/:[ ]*resulttype/ /} \
+ | sort -k 2 \
+ | sed -e {s/^/ /}]
+
+ return
+}
+
+proc Hhelp {} { return "\n\tPrint this help" }
+proc _help {} {
+ usage 0
+ return
+}
+proc Hrecipes {} { return "\n\tList all build commands, without details" }
+proc _recipes {} {
+ set r {}
+ foreach c [info commands _*] {
+ lappend r [string range $c 1 end]
+ }
+ puts [lsort -dict $r]
+ return
+}
+proc Htest {} { return "\n\tRun the testsuite" }
+proc _test {} {
+ global argv
+ set argv {} ;# clear -- tcltest shall see nothing
+ # Run all .test files in the test directory.
+ set selfdir [file dirname $::me]
+ foreach testsuite [lsort -dict [glob -directory [file join $selfdir test] *.test]] {
+ puts ""
+ puts "_ _ __ ___ _____ ________ _____________ _____________________ *** [file tail $testsuite] ***"
+ if {[catch {
+ exec >@ stdout 2>@ stderr [thisexe] $testsuite
+ }]} {
+ puts $::errorInfo
+ }
+ }
+
+ puts ""
+ puts "_ _ __ ___ _____ ________ _____________ _____________________"
+ puts ""
+ return
+}
+proc Hdoc {} { return "\n\t(Re)Generate the embedded documentation" }
+proc _doc {} {
+ cd [file join [file dirname $::me] doc]
+
+ puts "Removing old documentation..."
+ file delete -force [file join .. embedded man]
+ file delete -force [file join .. embedded www]
+ file delete -force [file join .. embedded md]
+
+ file mkdir [file join .. embedded man]
+ file mkdir [file join .. embedded www]
+ file mkdir [file join .. embedded md]
+
+ puts "Generating man pages..."
+ exec 2>@ stderr >@ stdout dtplite -ext n -o [file join .. embedded man] nroff .
+ puts "Generating html..."
+ exec 2>@ stderr >@ stdout dtplite -o [file join .. embedded www] html .
+ puts "Generating markdown..."
+ exec 2>@ stderr >@ stdout dtplite -ext md -o [file join .. embedded md] markdown .
+
+ cd [file join .. embedded man]
+ file delete -force .idxdoc .tocdoc
+ cd [file join .. www]
+ file delete -force .idxdoc .tocdoc
+ cd [file join .. md]
+ file delete -force .idxdoc .tocdoc
+
+ return
+}
+proc Htextdoc {} { return "destination\n\tWrite plain text documentation to the specified directory" }
+proc _textdoc {dst} {
+ set destination [file normalize $dst]
+
+ cd [file join [file dirname $::me] doc]
+
+ puts "Removing old text documentation at ${dst}..."
+ file delete -force $destination
+
+ file mkdir $destination
+
+ puts "Generating pages..."
+ exec 2>@ stderr >@ stdout dtplite -ext txt -o $destination text .
+
+ cd $destination
+ file delete -force .idxdoc .tocdoc
+
+ return
+}
+proc Hfigures {} { return "\n\t(Re)Generate the figures and diagrams for the documentation" }
+proc _figures {} {
+ cd [file join [file dirname $::me] doc figures]
+
+ puts "Generating (tklib) diagrams..."
+ eval [linsert [glob *.dia] 0 exec 2>@ stderr >@ stdout dia convert -t -o . png]
+
+ return
+}
+proc Hrelease {} { return "\n\tGenerate a release from the current commit.\n\tAssumed to be properly tagged.\n\tLeaves checkout in the gh-pages branch, ready for commit+push" }
+proc _release {} {
+ # # ## ### ##### ######## #############
+ # Get scratchpad to assemble the release in.
+ # Get version and hash of the commit to be released.
+
+ query "Have you run the tests" "Please do"
+ query "Have you run the examples" "Please do"
+ query "Have you bumped the version numbers" "Came back after doing so!"
+
+ set tmpdir [tmpdir]
+ id commit version
+
+ savedoc $tmpdir
+
+ # # ## ### ##### ######## #############
+ #puts {Generate starkit...}
+ #_starkit [file join $tmpdir critcl31.kit]
+
+ # # ## ### ##### ######## #############
+ #puts {Collecting starpack prefix...}
+ # which we use the existing starpack for, from the gh-pages branch
+
+ #exec 2>@ stderr >@ stdout git checkout gh-pages
+ #file copy [file join download critcl31.exe] [file join $tmpdir prefix.exe]
+ #exec 2>@ stderr >@ stdout git checkout $commit
+
+ # # ## ### ##### ######## #############
+ #puts {Generate starpack...}
+ #_starpack [file join $tmpdir prefix.exe] [file join $tmpdir critcl31.exe]
+ # TODO: vacuum the thing. fix permissions if so.
+
+ # # ## ### ##### ######## #############
+ 2website
+ placedoc $tmpdir
+
+ #file copy -force [file join $tmpdir critcl31.kit] [file join download critcl31.kit]
+ #file copy -force [file join $tmpdir critcl31.exe] [file join download critcl31.exe]
+
+ set index [cat index.html]
+ set pattern "\\\[commit .*\\\] \\(v\[^)\]*\\)
+ # integer change to decimal) "not used" is marked when the field
+ # is not needed anywhere here
+ array set aPosixHeader {
+ name {s 0 99} # 100
+ mode {o 100 107} # "8 - not used now"
+ uid {n 108 115} # 8
+ gid {n 116 123} # 8
+ size {n 124 135} # 12
+ mtime {n 136 147} # 12
+ chksum {o 148 155} # "8 - not used"
+ typeflag {o 156 156} # 1
+ linkname {s 157 256} # "100 - not used"
+ magic {s 257 262} # "6 - not used"
+ version {o 263 264} # "2 - not used"
+ uname {s 265 296} # "32 - not used"
+ gname {s 297 328} # "32 - not used"
+ devmajor {o 329 336} # "8 - not used"
+ devminor {o 337 344} # "8 - not used"
+ prefix {o 345 499} # "155 - not used"
+ }
+
+ # just for compatibility with posix-header
+ # only DIRTYPE is used
+ array set aTypeFlag {
+ REGTYPE 0 # "regular file"
+ AREGTYPE \000 # "regular file"
+ LNKTYPE 1 # link
+ SYMTYPE 2 # reserved
+ CHRTYPE 3 # "character special"
+ BLKTYPE 4 # "block special"
+ DIRTYPE 5 # directory
+ FIFOTYPE 6 # "FIFO special"
+ CONTTYPE 7 # reserved
+ }
+}
+
+proc vfs::tar::_data {fd arr {varPtr ""}} {
+ upvar 1 $arr sb
+
+ if {$varPtr eq ""} {
+ seek $fd $sb(size) current
+ } else {
+ upvar 1 $varPtr data
+ set data [read $fd $sb(size)]
+ }
+}
+
+proc vfs::tar::TOC {fd arr toc} {
+ variable aPosixHeader
+ variable aTypeFlag
+ variable HEADER_SIZE
+ variable BLOCK_SIZE
+
+ upvar 1 $arr sb
+ upvar 1 $toc _toc
+
+ set pos 0
+ set sb(nitems) 0
+
+ # loop through file in blocks of BLOCK_SIZE
+ while {![eof $fd]} {
+ seek $fd $pos
+ set hdr [read $fd $BLOCK_SIZE]
+
+ # read header-fields from block (see aPosixHeader)
+ foreach key {name typeflag size mtime uid gid} {
+ set type [lindex $aPosixHeader($key) 0]
+ set positions [lrange $aPosixHeader($key) 1 2]
+ switch $type {
+ s {
+ set $key [eval [list string range $hdr] $positions]
+ # cut the trailing Nulls
+ set $key [string range [set $key] 0 [expr [string first "\000" [set $key]]-1]]
+ }
+ o {
+ # leave it as is (octal value)
+ set $key [eval [list string range $hdr] $positions]
+ }
+ n {
+ set $key [eval [list string range $hdr] $positions]
+ # change to integer
+ scan [set $key] "%o" $key
+ # if not set, set default-value "0"
+ # (size == "" is not a very good value)
+ if {![string is integer [set $key]] || [set $key] == ""} { set $key 0 }
+ }
+ default {
+ error "tar::TOC: '$fd' wrong type for header-field: '$type'"
+ }
+ }
+ }
+
+ # only the last three octals are interesting for mode
+ # ignore mode now, should this be added??
+ # set mode 0[string range $mode end-3 end]
+
+ # get the increment to the next valid block
+ # (ignore file-blocks in between)
+ # if size == 0 the minimum incr is 512
+ set incr [expr {int(ceil($size/double($BLOCK_SIZE)))*$BLOCK_SIZE+$BLOCK_SIZE}]
+
+ set startPosition [expr {$pos+$BLOCK_SIZE}]
+ # make it relative to this working-directory, remove the
+ # leading "relative"-paths
+ regexp -- {^(?:\.\.?/)*/?(.*)} $name -> name
+
+ if {$name != ""} {
+ incr sb(nitems)
+ set sb($name,start) [expr {$pos+$BLOCK_SIZE}]
+ set sb($name,size) $size
+ set type "file"
+ # the mode should be 0777?? or must be changed to decimal?
+ if {$typeflag == $aTypeFlag(DIRTYPE)} {
+ # directory! append this without /
+ # leave mode: 0777
+ # (else we might not be able to walk through archive)
+ set type "directory"
+ lappend _toc([string trimright $name "/"]) \
+ name [string trimright $name "/"] \
+ type $type mtime $mtime size $size mode 0777 \
+ ino -1 start $startPosition \
+ depth [llength [file split $name]] \
+ uid $uid gid $gid
+ }
+ lappend _toc($name) \
+ name $name \
+ type $type mtime $mtime size $size mode 0777 \
+ ino -1 start $startPosition depth [llength [file split $name]] \
+ uid $uid gid $gid
+ }
+ incr pos $incr
+ }
+ return
+}
+
+proc vfs::tar::_open {path} {
+ set fd [::open $path]
+
+ if {[catch {
+ upvar #0 vfs::tar::$fd.toc toc
+ fconfigure $fd -translation binary ;#-buffering none
+ vfs::tar::TOC $fd sb toc
+ } err]} {
+ close $fd
+ return -code error $err
+ }
+
+ return $fd
+}
+
+proc vfs::tar::_exists {fd path} {
+ #::vfs::log "$fd $path"
+ if {$path == ""} {
+ return 1
+ } else {
+ upvar #0 vfs::tar::$fd.toc toc
+ return [expr {[info exists toc($path)] || [info exists toc([string trimright $path "/"]/)]}]
+ }
+}
+
+proc vfs::tar::_stat {fd path arr} {
+ upvar #0 vfs::tar::$fd.toc toc
+ upvar 1 $arr sb
+
+ if { $path == "" || $path == "." } {
+ array set sb {
+ type directory mtime 0 size 0 mode 0777
+ ino -1 depth 0 name ""
+ }
+ } elseif {![info exists toc($path)] } {
+ return -code error "could not read \"$path\": no such file or directory"
+ } else {
+ array set sb $toc($path)
+ }
+
+ # set missing attributes
+ set sb(dev) -1
+ set sb(nlink) 1
+ set sb(atime) $sb(mtime)
+ set sb(ctime) $sb(mtime)
+
+ return ""
+}
+
+# Treats empty pattern as asking for a particular file only.
+# Directly copied from zipvfs.
+proc vfs::tar::_getdir {fd path {pat *}} {
+ upvar #0 vfs::tar::$fd.toc toc
+
+ if { $path == "." || $path == "" } {
+ set path $pat
+ } else {
+ set path [string tolower $path]
+ if {$pat != ""} {
+ append path /$pat
+ }
+ }
+ set depth [llength [file split $path]]
+
+ if {$depth} {
+ set ret {}
+ foreach key [array names toc $path] {
+ if {[string index $key end] eq "/"} {
+ # Directories are listed twice: both with and without
+ # the trailing '/', so we ignore the one with
+ continue
+ }
+ array set sb $toc($key)
+
+ if { $sb(depth) == $depth } {
+ if {[info exists toc(${key}/)]} {
+ array set sb $toc(${key}/)
+ }
+ # remove sb(name) (because == $key)
+ lappend ret [file tail $key]
+ }
+ unset sb
+ }
+ return $ret
+ } else {
+ # just the 'root' of the zip archive. This obviously exists and
+ # is a directory.
+ return [list {}]
+ }
+}
+
+proc vfs::tar::_close {fd} {
+ variable $fd.toc
+ unset -nocomplain $fd.toc
+ ::close $fd
+}
diff --git a/src/vfs/critcl-3.3.1.vfs/lib/vfs1.4.1/tclprocvfs.tcl b/src/vfs/critcl-3.3.1.vfs/lib/vfs1.4.1/tclprocvfs.tcl
new file mode 100644
index 00000000..99845fa3
--- /dev/null
+++ b/src/vfs/critcl-3.3.1.vfs/lib/vfs1.4.1/tclprocvfs.tcl
@@ -0,0 +1,206 @@
+
+package provide vfs::ns 0.5.1
+
+package require vfs 1.0
+
+# Thanks to jcw for the idea here. This is a 'file system' which
+# is actually a representation of the Tcl command namespace hierarchy.
+# Namespaces are directories, and procedures are files. Tcl allows
+# procedures with the same name as a namespace, which are hidden in
+# a filesystem representation.
+
+namespace eval vfs::ns {}
+
+proc vfs::ns::Mount {ns local} {
+ if {![namespace exists ::$ns]} {
+ error "No such namespace"
+ }
+ ::vfs::log "ns $ns mounted at $local"
+ vfs::filesystem mount $local [list vfs::ns::handler $ns]
+ vfs::RegisterMount $local [list vfs::ns::Unmount]
+ return $local
+}
+
+proc vfs::ns::Unmount {local} {
+ vfs::filesystem unmount $local
+}
+
+proc vfs::ns::handler {ns cmd root relative actualpath args} {
+ regsub -all / $relative :: relative
+ if {$cmd == "matchindirectory"} {
+ eval [list $cmd $ns $relative $actualpath] $args
+ } else {
+ eval [list $cmd $ns $relative] $args
+ }
+}
+
+# If we implement the commands below, we will have a perfect
+# virtual file system for namespaces.
+
+proc vfs::ns::stat {ns name} {
+ ::vfs::log "stat $name"
+ if {[namespace exists ::${ns}::${name}]} {
+ return [list type directory size 0 mode 0777 \
+ ino -1 depth 0 name $name atime 0 ctime 0 mtime 0 dev -1 \
+ uid -1 gid -1 nlink 1]
+ } elseif {[llength [info procs ::${ns}::${name}]]} {
+ return [list type file]
+ } else {
+ return -code error "could not read \"$name\": no such file or directory"
+ }
+}
+
+proc vfs::ns::access {ns name mode} {
+ ::vfs::log "access $name $mode"
+ if {[namespace exists ::${ns}::${name}]} {
+ return 1
+ } elseif {[llength [info procs ::${ns}::${name}]]} {
+ if {$mode & 2} {
+ error "read-only"
+ }
+ return 1
+ } else {
+ error "No such file"
+ }
+}
+
+proc vfs::ns::exists {ns name} {
+ if {[namespace exists ::${ns}::${name}]} {
+ return 1
+ } elseif {[llength [info procs ::${ns}::${name}]]} {
+ return 1
+ } else {
+ return 0
+ }
+}
+
+proc vfs::ns::open {ns name mode permissions} {
+ ::vfs::log "open $name $mode $permissions"
+ # return a list of two elements:
+ # 1. first element is the Tcl channel name which has been opened
+ # 2. second element (optional) is a command to evaluate when
+ # the channel is closed.
+ switch -- $mode {
+ "" -
+ "r" {
+ set nfd [vfs::memchan]
+ fconfigure $nfd -translation binary
+ puts -nonewline $nfd [_generate ::${ns}::${name}]
+ fconfigure $nfd -translation auto
+ seek $nfd 0
+ return [list $nfd]
+ }
+ default {
+ return -code error "illegal access mode \"$mode\""
+ }
+ }
+}
+
+proc vfs::ns::_generate {p} {
+ lappend a proc $p
+ set argslist [list]
+ foreach arg [info args $p] {
+ if {[info default $p $arg v]} {
+ lappend argslist [list $arg $v]
+ } else {
+ lappend argslist $arg
+ }
+ }
+ lappend a $argslist [info body $p]
+}
+
+proc vfs::ns::matchindirectory {ns path actualpath pattern type} {
+ ::vfs::log "matchindirectory $path $actualpath $pattern $type"
+ set res [list]
+
+ set ns ::[string trim $ns :]
+ set nspath ${ns}::${path}
+ if {![namespace exists $nspath]} {return {}}
+ set slash 1
+ if {[::vfs::matchDirectories $type]} {
+ # add matching directories to $res
+ if {[string length $pattern]} {
+ eval [linsert [namespace children $nspath $pattern] 0 lappend res]
+ } elseif {[namespace exists $nspath]} {
+ lappend res $nspath
+ }
+ }
+
+ if {[::vfs::matchFiles $type]} {
+ # add matching files to $res
+ if {[string length $pattern]} {
+ eval [linsert [info procs ${nspath}::$pattern] 0 lappend res]
+ } elseif {[llength [info procs $nspath]]} {
+ lappend res $nspath
+ set slash 0
+ }
+ }
+
+ # There is a disconnect between 8.4 and 8.5 with the / handling
+ # Make sure actualpath gets just one trailing /
+ if {$slash && ![string match */ $actualpath]} { append actualpath / }
+
+ set realres [list]
+ foreach r $res {
+ regsub "^(::)?${ns}(::)?${path}(::)?" $r $actualpath rr
+ lappend realres $rr
+ }
+ #::vfs::log $realres
+
+ return $realres
+}
+
+proc vfs::ns::createdirectory {ns name} {
+ ::vfs::log "createdirectory $name"
+ namespace eval ::${ns}::${name} {}
+}
+
+proc vfs::ns::removedirectory {ns name recursive} {
+ ::vfs::log "removedirectory $name"
+ namespace delete ::${ns}::${name}
+}
+
+proc vfs::ns::deletefile {ns name} {
+ ::vfs::log "deletefile $name"
+ rename ::${ns}::${name} {}
+}
+
+proc vfs::ns::fileattributes {ns name args} {
+ ::vfs::log "fileattributes $args"
+ switch -- [llength $args] {
+ 0 {
+ # list strings
+ return [list -args -body]
+ }
+ 1 {
+ # get value
+ set index [lindex $args 0]
+ switch -- $index {
+ 0 {
+ ::info args ::${ns}::${name}
+ }
+ 1 {
+ ::info body ::${ns}::${name}
+ }
+ }
+ }
+ 2 {
+ # set value
+ set index [lindex $args 0]
+ set val [lindex $args 1]
+ switch -- $index {
+ 0 {
+ error "read-only"
+ }
+ 1 {
+ error "unimplemented"
+ }
+ }
+ }
+ }
+}
+
+proc vfs::ns::utime {what name actime mtime} {
+ ::vfs::log "utime $name"
+ error ""
+}
diff --git a/src/vfs/critcl-3.3.1.vfs/lib/vfs1.4.1/template/chrootvfs.tcl b/src/vfs/critcl-3.3.1.vfs/lib/vfs1.4.1/template/chrootvfs.tcl
new file mode 100644
index 00000000..2162fde8
--- /dev/null
+++ b/src/vfs/critcl-3.3.1.vfs/lib/vfs1.4.1/template/chrootvfs.tcl
@@ -0,0 +1,127 @@
+#/usr/bin/env tclsh
+
+if 0 {
+########################
+
+chrootvfs.tcl --
+
+Written by Stephen Huntley (stephen.huntley@alum.mit.edu)
+License: Tcl license
+Version 1.5
+
+A chroot virtual filesystem.
+
+This virual filesystem has an effect similar to a "chroot" command; it makes the named existing directory appear
+to be the top of the filesystem and makes the rest of the real filesystem invisible.
+
+This vfs does not block access by the "exec" command to the real filesystem outside the chroot directory,
+or that of the "open" command when its command pipeline syntax is used.
+
+At the end of this file is example code showing one way to set up a safe slave interpreter suitable for
+running a process safely with limited filesystem access: its file access commands are re-enabled, the exec
+command remains disabled, the open command is aliased so that it can only open files and can't spawn new
+processes, and mounted volumes besides the volume on which the chroot directory resides are aliased so
+that they act as mirrors of the chroot directory.
+
+Such an interpreter should be advantageous for applications such as a web server: which requires some
+filesystem access but presents security threats that make access limitations desirable.
+
+ Install: This code requires the vfs::template package included in the Tclvfs distribution.
+
+ Usage: mount ?-volume?
+
+ examples:
+
+ mount $::env(HOME) /
+
+ mount {C:\My Music} C:/
+
+ mount -volume /var/www/htdocs chroot://
+
+########################
+}
+
+namespace eval ::vfs::template::chroot {
+
+package require vfs::template 1.5
+package provide vfs::template::chroot 1.5.2
+
+# read template procedures into current namespace. Do not edit:
+foreach templateProc [namespace eval ::vfs::template {info procs}] {
+ set infoArgs [info args ::vfs::template::$templateProc]
+ set infoBody [info body ::vfs::template::$templateProc]
+ proc $templateProc $infoArgs $infoBody
+}
+
+proc file_attributes {file {attribute {}} args} {eval file attributes \$file $attribute $args}
+
+catch {rename redirect_handler {}}
+catch {rename handler redirect_handler}
+
+proc handler args {
+ set path [lindex $args 0]
+ set to [lindex $args 2]
+ set volume [lindex $::vfs::template::mount($to) 1]
+ if {$volume != "-volume"} {set volume {}}
+ set startDir [pwd]
+
+ ::vfs::filesystem unmount $to
+
+ set err [catch {set rv [uplevel ::vfs::template::chroot::redirect_handler $args]} result] ; set errorCode $::errorCode
+
+ eval ::vfs::filesystem mount $volume [list $to] \[list [namespace current]::handler \[file normalize \$path\]\]
+ if {[pwd] != $startDir} {catch {cd $startDir}}
+ if {$err && ([lindex $errorCode 0] == "POSIX")} {vfs::filesystem posixerror $::vfs::posix([lindex $errorCode 1])}
+ if $err {return -code $err $result}
+ return $rv
+}
+
+
+# Example code to set up a safe interpreter with limited filesystem access:
+proc chroot_slave {} {
+ file mkdir /tmp
+ package require vfs::template
+ ::vfs::template::chroot::mount -volume /tmp C:/
+ set vols [lsort -unique [file volumes]]
+ foreach vol $vols {
+ if {$vol == "C:/"} {continue}
+ ::vfs::template::mount C:/ $vol
+ }
+ set slave [interp create -safe]
+ $slave expose cd
+ $slave expose encoding
+ $slave expose fconfigure
+ $slave expose file
+ $slave expose glob
+ $slave expose load
+ $slave expose pwd
+ $slave expose socket
+ $slave expose source
+
+ $slave alias exit exit_safe $slave
+ $slave alias open open_safe $slave
+
+ interp share {} stdin $slave
+ interp share {} stdout $slave
+ interp share {} stderr $slave
+}
+
+proc exit_safe {slave} {
+ interp delete $slave
+}
+
+proc open_safe {args} {
+ set slave [lindex $args 0]
+ set handle [lindex $args 1]
+ set args [lrange $args 1 end]
+ if {[string index $handle 0] != "|"} {
+ eval [eval list interp invokehidden $slave open $args]
+ } else {
+ error "permission denied"
+ }
+}
+
+
+}
+# end namespace ::vfs::template::chroot
+
diff --git a/src/vfs/critcl-3.3.1.vfs/lib/vfs1.4.1/template/collatevfs.tcl b/src/vfs/critcl-3.3.1.vfs/lib/vfs1.4.1/template/collatevfs.tcl
new file mode 100644
index 00000000..770f11e5
--- /dev/null
+++ b/src/vfs/critcl-3.3.1.vfs/lib/vfs1.4.1/template/collatevfs.tcl
@@ -0,0 +1,371 @@
+if 0 {
+########################
+
+collatevfs.tcl --
+
+Written by Stephen Huntley (stephen.huntley@alum.mit.edu)
+License: Tcl license
+Version 1.5.3
+
+A collate/broadcast/collect/catchup virtual filesystem. Requires the template vfs in templatevfs.tcl.
+
+Collate: reads from multiple specified directories and presents the results as one at the mount location.
+
+Broadcast: applies all writes in the mount location to multiple specified directories.
+
+Collect: copies any file read from or written to any of the above locations to specified directories.
+
+Catchup: If any specified directory is not available during any write action, the action is recorded in
+a catchup queue. With each subsequent write action, the queue is examined, and if any directory has
+become available, the action is performed, allowing offline directories to "catch up."
+
+Usage: mount ?-read -write -collect -catchup ?
+
+Each pathname in is meant to stand individually, the symbol is not meant to indicate a
+Tcl list. The sets of specified locations are independent; they can overlap or not as desired. Note each
+option flag is optional, one could for example use only the -read flag to create a read-only directory. Directories
+do not have to exist and may go missing after mount, non-reachable locations will be ignored.
+
+Options:
+
+-read
+When an individual file is opened for reading, each of the directories specified is searched in
+order for the file; the first file found with the appropriate name is opened. When a subdirectory listing is
+generated, the combined files of the corresponding subdirectory of all specified directories are listed together.
+
+-write
+When an individual file is opened for writing, each of the directories specified is searched in
+order for the file; the first file found with the appropriate name is opened. If the file doesn't exist,
+it is created in the first specified write location. When the file is closed, a copy of it is distributed to
+each specified write directory.
+
+-collect
+Auto-generates one or more file caches; a copy of any file opened for reading or writing in any of the above
+specified directories is made to each directory specified with the -collect flag. Collect locations are
+not included in file or directory listings, and are not searched for read access; so in order to make an
+active read cache, for example, one would have to include one directory location in both the -read and -collect sets.
+
+-catchup
+If this flag is included, the catchup function is activated, and a copy of the catchup queue is stored in a
+file in each of the specified directories. File writes, directory creations and file/directory deletes are
+stored in the catchup queue if any write location is offline; at the next write/creation/delete the queue is
+examined, and if any skipped action can be completed due to a location becoming available again, it
+will be. A catchup attempt will be made at mount time if this flag is included.
+
+The values of each option can be changed dynamically after mount by using the "file attributes" command on the
+mount virtual directory. Each option is editable as an attribute; i.e., "file attributes C:/collate -write C:/tmp"
+
+The collate vfs inherits the -cache and -volume options of the template vfs.
+
+
+Example use: specify parallel locations on a hard drive, on a CD-ROM mount and an ftp vfs as the read list.
+Files will be read first from the hard drive, if not found there the CD-ROM and ftp site will be searched in turn.
+The hard drive can be specified as the single write location, and no writes to the CD-ROM or
+ftp site will ever be attempted:
+
+mount -read C:/install/package/docs CDROM:/package/docs FTP:/pub/releases/package/docs -write C:/install/package/docs C:/collate/docs
+
+
+Example collect location use: specify a single hard drive location as a read and collect directory.
+Specify a ftp vfs as a secondary read directory. As ftp files are downloaded they are copied to the
+collect directory; the local copies are accessed first on subsequent reads: hence the collect
+specification produces a self-generating local cache:
+
+mount -read C:/install/package/images FTP:/pub/releases/package/images -collect C:/install/package/images C:/collate/images
+
+
+########################
+}
+
+package require vfs::template 1.5
+
+namespace eval ::vfs::template::collate {
+
+# read template procedures into current namespace. Do not edit:
+foreach templateProc [namespace eval ::vfs::template {info procs}] {
+ set infoArgs [info args ::vfs::template::$templateProc]
+ set infoBody [info body ::vfs::template::$templateProc]
+ proc $templateProc $infoArgs $infoBody
+}
+
+# edit following procedures:
+proc close_ {channel} {
+ upvar root root relative relative
+ foreach file [lrange [WriteFile $root $relative close] 1 end] {
+ if ![WriteTest $file] {continue}
+ file mkdir [file dirname $file]
+ set f [open $file w]
+ fconfigure $f -translation binary
+ seek $channel 0
+ fcopy $channel $f
+ close $f
+ }
+ return
+}
+proc file_atime {file time} {
+ upvar root root relative relative
+ foreach file [WriteFile $root $relative open] {
+ file atime $file $time
+ }
+}
+proc file_mtime {file time} {
+ upvar root root relative relative
+ foreach file [WriteFile $root $relative open] {
+ file mtime $file $time
+ }
+}
+proc file_attributes {file {attribute {}} args} {
+ upvar root root relative relative
+ if {($relative == {}) && ([string map {-read 1 -write 1 -collect 1 -catchup 1} $attribute] == 1)} {
+ set attribute [string range $attribute 1 end]
+ if {$args == {}} {eval return \$::vfs::template::collate::${attribute}(\$root)}
+ set ::vfs::template::collate::${attribute}($root) [lindex $args 0]
+ set ::vfs::template::collate::catchup [file isdirectory [lindex $::vfs::template::collate::catchupstore 0]]
+ return
+ }
+ if {$args != {}} {
+ foreach file [WriteFile $root $relative open] {
+ file attributes $file $attribute $args
+ }
+ return
+ }
+ set file [AcquireFile $root $relative]
+ set returnValue [eval file attributes \$file $attribute $args]
+ if {($relative == {}) && ($attribute == {})} {set returnValue [concat $returnValue [list -read $::vfs::template::collate::read($root) -write $::vfs::template::collate::write($root) -collect $::vfs::template::collate::collect($root) -catchup $::vfs::template::collate::catchupstore($root)]]}
+ return $returnValue
+}
+proc file_delete {file} {
+ upvar root root relative relative
+ foreach file [WriteFile $root $relative delete] {
+ file delete -force -- $file
+ }
+}
+proc file_executable {file} {
+ upvar root root relative relative
+ set file [AcquireFile $root $relative]
+ file executable $file
+}
+proc file_exists {file} {
+ upvar root root relative relative
+ expr ![catch {AcquireFile $root $relative}]
+}
+proc file_mkdir {file} {
+ upvar root root relative relative
+ foreach file [WriteFile $root $relative mkdir] {
+ file mkdir $file
+ }
+}
+proc file_readable {file} {
+ upvar root root relative relative
+ set file [AcquireFile $root $relative]
+ file readable $file
+}
+proc file_stat {file array} {
+ upvar root root relative relative
+ set file [AcquireFile $root $relative]
+ upvar $array fs ; file stat $file fs
+}
+proc file_writable {file} {
+ upvar root root relative relative
+ expr ![catch {WriteFile $root $relative open}]
+}
+proc glob_ {directory dir nocomplain tails types typeString dashes pattern} {
+ upvar root root relative relative
+ set allFiles {}
+ set newFiles {}
+ foreach path $::vfs::template::collate::read($root) {
+ if ![file exists $path] {continue}
+ set allFiles [concat $allFiles [glob -directory [file join $path $relative] -nocomplain -tails -types $typeString -- $pattern]]
+ }
+ set allFiles [lsort -unique $allFiles]
+ return $allFiles
+}
+proc open_ {file mode} {
+ upvar root root relative relative
+ if [string match w* $mode] {
+ set file [lindex [WriteFile $root $relative open] 0]
+ file mkdir [file dirname $file]
+ return [open $file $mode]
+ }
+ if [string match r* $mode] {
+ set file [AcquireFile $root $relative]
+ if {$mode == "r"} {
+ foreach cpath $::vfs::template::collate::collect($root) {
+ set cfile [file join $cpath $relative]
+ if {$file == $cfile} {continue}
+ if ![file exists $cpath] {continue}
+ file mkdir [::file dirname $cfile]
+ file copy -force -- $file $cfile
+ }
+ return [open $file r]
+ }
+ set wfile [lindex [WriteFile $root $relative open] 0]
+ file mkdir [file dirname $wfile]
+ if {$wfile != $file} {file copy -force -- $file $wfile}
+ return [open $wfile $mode]
+ }
+ if [string match a* $mode] {
+ set wfile [lindex [WriteFile $root $relative open] 0]
+ file mkdir [file dirname $wfile]
+ if ![catch {set file [AcquireFile $root $relative]}] {
+ if {$wfile != $file} {file copy -force -- $file $wfile}
+ }
+ return [open $wfile $mode]
+ }
+}
+
+proc MountProcedure {args} {
+ upvar volume volume
+
+# take real and virtual directories from command line args.
+ set to [lindex $args end]
+ if [string equal $volume {}] {set to [::file normalize $to]}
+
+# add custom handling for new vfs args here.
+
+ set ::vfs::template::collate::catchup($to) 0
+ set ::vfs::template::collate::read($to) {}
+ set ::vfs::template::collate::write($to) {}
+ set ::vfs::template::collate::collect($to) {}
+ set ::vfs::template::collate::catchupstore($to) {}
+
+ set args [lrange $args 0 end-1]
+ set argsIndex [llength $args]
+ for {set i 0} {$i < $argsIndex} {incr i} {
+ set arg [lindex $args $i]
+
+ switch -- $arg {
+ -read {
+ set type read
+ }
+ -write {
+ set type write
+ }
+ -collect {
+ set type collect
+ }
+ -catchup {
+ set ::vfs::template::collate::catchup($to) 1
+ set type catchupstore
+ }
+ default {
+ eval lappend ::vfs::template::collate::${type}(\$to) \[::file normalize \$arg\]
+ }
+ }
+ }
+
+ WriteFile $to {} mkdir
+
+# return two-item list consisting of real and virtual locations.
+ lappend pathto {}
+ lappend pathto $to
+ return $pathto
+}
+
+proc UnmountProcedure {path to} {
+# add custom unmount handling of new vfs elements here.
+ unset -nocomplain ::vfs::template::collate::read($to)
+ unset -nocomplain ::vfs::template::collate::write($to)
+ unset -nocomplain ::vfs::template::collate::collect($to)
+ unset -nocomplain ::vfs::template::collate::catchup($to)
+ unset -nocomplain ::vfs::template::collate::catchupstore($to)
+ return
+}
+
+proc AcquireFile {root relative} {
+ foreach path $::vfs::template::collate::read($root) {
+ set file [::file join $path $relative]
+ if [::file exists $file] {
+ return $file
+ }
+ }
+ vfs::filesystem posixerror $::vfs::posix(ENOENT) ; return -code error $::vfs::posix(ENOENT)
+}
+
+proc WriteFile {root relative action} {
+ set allWriteLocations {}
+ foreach awl [concat $::vfs::template::collate::write($root) $::vfs::template::collate::collect($root)] {
+ if {[lsearch $allWriteLocations $awl] < 0} {lappend allWriteLocations $awl}
+ }
+ if ![llength $allWriteLocations] {
+ vfs::filesystem posixerror $::vfs::posix(EROFS) ; return -code error $::vfs::posix(EROFS)
+ }
+ if {$vfs::template::collate::catchup($root) && ([file tail $relative] != ".vfs_catchup") && ($action != "open")} {
+ set catchupActivate 1
+ set addCatchup {}
+ set newCatchup {}
+ } else {
+ set catchupActivate 0
+ }
+ set returnValue {}
+ foreach path $allWriteLocations {
+ if {$catchupActivate && ![file exists $path]} {
+ append addCatchup "[list $action $path $relative]\n"
+ continue
+ }
+ set rvfile [file join $path $relative]
+ if {[lsearch $returnValue $rvfile] == -1} {lappend returnValue $rvfile}
+ }
+ if {$returnValue == {}} {vfs::filesystem posixerror $::vfs::posix(EROFS) ; return -code error $::vfs::posix(EROFS)}
+ if $catchupActivate {
+ set catchup {}
+ set ::vfs::template::vfs_retrieve 1
+
+ foreach store $::vfs::template::collate::catchupstore($root) {
+ set store [file join $store ".vfs_catchup"]
+ if [file readable $store] {
+ set f [open $store r]
+ unset ::vfs::template::vfs_retrieve
+ seek $f 0
+ set catchup [read $f]
+ close $f
+ break
+ }
+ }
+ catch {set currentRead [AcquireFile $root {}]} result
+ foreach {action path rel} $catchup {
+ if {$relative == $rel} {continue}
+ if ![file exists $path] {append newCatchup "[list $action $path $rel]\n" ; continue}
+ if {[lsearch $allWriteLocations $path] < 0} {continue}
+ switch -- $action {
+ close {
+ if {![info exists currentRead] || ([set source [file join $currentRead $rel]] == [set target [file join $path $rel]])} {
+ append newCatchup "[list $action $path $rel]\n" ; continue
+ }
+ if ![file exists $source] {continue}
+ file mkdir [file dirname $target]
+ file copy -force -- $source $target
+ }
+ delete {
+ file delete -force -- [file join $path $rel]
+ }
+ mkdir {
+ file mkdir [file join $path $rel]
+ }
+ }
+ }
+ append newCatchup $addCatchup
+ foreach path $::vfs::template::collate::catchupstore($root) {
+ set vfscatchup [file join $path ".vfs_catchup"]
+ set ::vfs::template::vfs_retrieve 1
+ set err [catch {
+ if {$newCatchup != {}} {
+ set f [open $vfscatchup w]
+ puts $f $newCatchup
+ close $f
+ } else {
+ file delete $vfscatchup
+ }
+ } result]
+ unset ::vfs::template::vfs_retrieve
+ }
+ }
+ return $returnValue
+}
+
+proc WriteTest {args} {
+ return 1
+}
+
+}
+# end namespace ::vfs::template::collate
diff --git a/src/vfs/critcl-3.3.1.vfs/lib/vfs1.4.1/template/deltavfs.tcl b/src/vfs/critcl-3.3.1.vfs/lib/vfs1.4.1/template/deltavfs.tcl
new file mode 100644
index 00000000..755a24e0
--- /dev/null
+++ b/src/vfs/critcl-3.3.1.vfs/lib/vfs1.4.1/template/deltavfs.tcl
@@ -0,0 +1,288 @@
+if 0 {
+########################
+
+deltavfs.tcl --
+
+Written by Stephen Huntley (stephen.huntley@alum.mit.edu)
+License: Tcl license
+Version 1.5.2
+
+A delta virtual filesystem. Requires the template vfs in templatevfs.tcl.
+
+Mount the delta vfs first, then mount the versioning vfs using the virtual location created by the
+delta vfs as its existing directory.
+
+As the versioning filesystem generates a new separate file for every file edit, this filesystem will
+invisibly generate and manage deltas of the separate versions to save space.
+
+
+Usage: mount
+
+
+The delta vfs inherits the -cache and -volume options of the template vfs.
+
+########################
+}
+
+package require vfs::template 1.5
+package require vfs::template::version 1.5
+
+package provide vfs::template::version::delta 1.5.2
+
+namespace eval ::vfs::template::version::delta {
+
+# read template procedures into current namespace. Do not edit:
+foreach templateProc [namespace eval ::vfs::template {info procs}] {
+ set infoArgs [info args ::vfs::template::$templateProc]
+ set infoBody [info body ::vfs::template::$templateProc]
+ proc $templateProc $infoArgs $infoBody
+}
+
+# edit following procedures:
+proc close_ {channel} {
+ upvar path path relative relative
+ set file [file join $path $relative]
+ set fileName $file
+ set f [open $fileName w]
+ fconfigure $f -translation binary
+ seek $f 0
+ seek $channel 0
+ fcopy $channel $f
+ close $f
+ Delta $fileName
+ return
+}
+proc file_atime {file time} {
+ set file [GetFileName $file]
+ file atime $file $time
+}
+proc file_mtime {file time} {
+ set file [GetFileName $file]
+ file mtime $file $time
+}
+proc file_attributes {file {attribute {}} args} {
+ set file [GetFileName $file]
+ eval file attributes \$file $attribute $args
+}
+proc file_delete {file} {
+ if [file isdirectory $file] {catch {file delete $file}}
+
+ set fileName [GetFileName $file]
+ set timeStamp [lindex [split [file tail $fileName] \;] 1]
+ if [string equal $timeStamp {}] {
+ catch {file delete $fileName} result
+ return
+ }
+ set targetFile [Reconstitute $fileName]
+ set referenceFiles [glob -directory [file dirname $fileName] -nocomplain *vfs&delta$timeStamp]
+ if {[lindex [file system $fileName] 0] != "tclvfs"} {append referenceFiles " [glob -directory [file dirname $fileName] -nocomplain -type hidden *vfs&delta$timeStamp]"}
+ foreach referenceFile $referenceFiles {
+ regsub {\;vfs&delta[0-9]*$} $referenceFile "" reconFile]
+ set f [open $referenceFile r]
+ fconfigure $f -translation binary
+ set signature [read $f]
+ close $f
+ tpatch $targetFile $signature $reconFile
+ file delete $referenceFile
+ }
+ close $targetFile
+
+ file delete -force -- $fileName
+}
+proc file_executable {file} {
+ set file [GetFileName $file]
+ file executable $file
+}
+proc file_exists {file} {
+ set file [GetFileName $file]
+ file exists $file
+}
+proc file_mkdir {file} {file mkdir $file}
+proc file_readable {file} {
+ set file [GetFileName $file]
+ file readable $file
+}
+proc file_stat {file array} {
+ upvar $array fs
+ set fileName [GetFileName $file]
+
+ set endtag [lindex [split $fileName \;] end]
+ if {[string first "vfs&delta" $endtag] || [string equal "vfs&delta" $endtag]} {file stat $fileName fs ; return}
+ set f [open $fileName r]
+ fconfigure $f -translation binary
+ set copyinstructions [read $f]
+ close $f
+ array set fileStats [lindex $copyinstructions 3]
+ unset copyinstructions
+ set size $fileStats(size)
+ file stat $fileName fs
+ set fs(size) $size
+ return
+}
+proc file_writable {file} {
+ set file [GetFileName $file]
+ file writable $file
+}
+proc glob_ {directory dir nocomplain tails types typeString dashes pattern} {
+ set globList [glob -directory $dir -nocomplain -tails -types $typeString -- $pattern]
+ set newGlobList {}
+ foreach gL $globList {
+ regsub {\;vfs&delta.*$} $gL "" gL
+ lappend newGlobList $gL
+ }
+ return $newGlobList
+}
+proc open_ {file mode} {
+ set fileName [GetFileName $file]
+
+ set newFile 0
+ if ![file exists $fileName] {set newFile 1}
+ set fileName $file
+ set channelID [Reconstitute $fileName]
+ if [string equal $channelID {}] {set channelID [open $fileName $mode] ; close $channelID ; set channelID [memchan]}
+ if $newFile {catch {file attributes $fileName -permissions $permissions}}
+ return $channelID
+}
+
+
+proc MountProcedure {args} {
+ upvar volume volume
+
+# take real and virtual directories from command line args.
+ set to [lindex $args end]
+ if [string equal $volume {}] {set to [::file normalize $to]}
+ set path [::file normalize [lindex $args end-1]]
+
+# make sure mount location exists:
+ ::file mkdir $path
+
+# add custom handling for new vfs args here.
+ package require trsync
+ namespace import -force ::trsync::tdelta ::trsync::tpatch
+
+# return two-item list consisting of real and virtual locations.
+ lappend pathto $path
+ lappend pathto $to
+ return $pathto
+}
+
+
+proc UnmountProcedure {path to} {
+# add custom unmount handling of new vfs elements here.
+
+ return
+}
+
+proc Delta {filename} {
+ set fileRoot [lindex [split [file tail $filename] \;] 0]
+ set fileNames [glob -nocomplain -path [file join [file dirname $filename] $fileRoot] *]
+ if {[lindex [file system $filename] 0] != "tclvfs"} {append fileNames " [glob -nocomplain -path [file join [file dirname $filename] $fileRoot] -type hidden *]"}
+ set nonDeltas {}
+ foreach fn $fileNames {
+ set endtag [lindex [split $fn \;] end]
+ if ![string first "vfs&delta" $endtag] {continue}
+ lappend nonDeltas $fn
+ set atimes($fn) [file atime $fn]
+ }
+ if {[set deltaIndex [llength $nonDeltas]] < 2} {return}
+ set nonDeltas [lsort -dictionary $nonDeltas]
+ incr deltaIndex -1
+ set i 0
+ while {$i < $deltaIndex} {
+ set referenceFile [lindex $nonDeltas $i]
+ set targetFile [lindex $nonDeltas [incr i]]
+ set signature [tdelta $referenceFile $targetFile $::trsync::blockSize 1 1]
+ set targetTimeStamp [lindex [split $targetFile \;] 1]
+
+ file stat $referenceFile fileStats
+ set signatureSize [string length $signature]
+ if {$signatureSize > $fileStats(size)} {
+ set fileName $referenceFile\;vfs&delta
+ file rename $referenceFile $fileName
+ continue
+ }
+
+ array set fileStats [file attributes $referenceFile]
+
+ set fileName $referenceFile\;vfs&delta$targetTimeStamp
+ set f [open $fileName w]
+ fconfigure $f -translation binary
+ puts -nonewline $f $signature
+ close $f
+ file delete $referenceFile
+ array set fileAttributes [file attributes $fileName]
+ if [info exists fileAttributes(-readonly)] {catch {file attributes $fileName -readonly 0}}
+ if [info exists fileAttributes(-permissions)] {catch {file attributes $fileName -permissions rw-rw-rw-}}
+ catch {file attributes $fileName -owner $fileStats(uid)}
+ catch {file attributes $fileName -group $fileStats(gid)}
+
+ catch {file mtime $fileName $fileStats(mtime)}
+ catch {file atime $fileName $fileStats(atime)}
+
+ foreach attr [array names fileStats] {
+ if [string first "-" $attr] {continue}
+ if [string equal [array get fileStats $attr] [array get fileAttributes $attr]] {continue}
+ if [string equal "-permissions" $attr] {continue}
+ catch {file attributes $fileName $attr $fileStats($attr)}
+ }
+ catch {file attributes $fileName -permissions $fileStats(mode)}
+ catch {file attributes $fileName -readonly $fileStats(-readonly)}
+ }
+ foreach fn [array names atimes] {
+ if ![file exists $fn] {continue}
+ file atime $fn $atimes($fn)
+ }
+}
+
+proc GetFileName {file} {
+ set isdir 0
+ if {([string first \; $file] == -1) && ![set isdir [file isdirectory $file]]} {return {}}
+ if $isdir {return $file}
+ set fileNames [glob -nocomplain -path $file *]
+ if {[lindex [file system $file] 0] != "tclvfs"} {append fileNames " [glob -nocomplain -path $file -type hidden *]"}
+ set fileName [lindex $fileNames 0]
+ if [set i [expr [lsearch -exact $fileNames $file] + 1]] {set fileName [lindex $fileNames [incr i -1]]}
+ return $fileName
+}
+
+proc Reconstitute {fileName} {
+ if ![catch {set channelID [open $fileName r]}] {return $channelID}
+ if ![catch {set channelID [open $fileName\;vfs&delta r]}] {return $channelID}
+ set targetFiles [glob -nocomplain -path $fileName *]
+ if {[lindex [file system $fileName] 0] != "tclvfs"} {append targetFiles " [glob -nocomplain -path $fileName -type hidden *]"}
+ set targetFile [lindex $targetFiles 0]
+
+ set targetFile [string trim $targetFile]
+ if [string equal $targetFile {}] {return}
+ set fileStack {}
+ while {[string first "\;vfs&delta" $targetFile] > -1} {
+ if ![regexp {\;vfs&delta([0-9]+)$} $targetFile trash targetTime] {break}
+ set fileStack "[list $targetFile] $fileStack"
+ set targetFiles [glob -directory [file dirname $fileName] *\;$targetTime*]
+ if {[lindex [file system $fileName] 0] != "tclvfs"} {append targetFiles " [glob -directory [file dirname $fileName] -nocomplain -type hidden *\;$targetTime*]"}
+ set targetFile [lindex $targetFiles 0]
+
+ set atimes($targetFile) [file atime $targetFile]
+ }
+ set targetFile [open $targetFile r]
+ foreach fs $fileStack {
+ set f [open $fs r]
+ fconfigure $f -translation binary
+ set copyInstructions [read $f]
+ close $f
+ set fileToConstruct [memchan]
+ tpatch $targetFile $copyInstructions $fileToConstruct
+ catch {close $targetFile}
+ set targetFile $fileToConstruct
+ }
+ foreach fn [array names atimes] {
+ file atime $fn $atimes($fn)
+ }
+ fconfigure $targetFile -translation auto
+ seek $targetFile 0
+ return $targetFile
+}
+
+}
+# end namespace ::vfs::template::version::delta
+
diff --git a/src/vfs/critcl-3.3.1.vfs/lib/vfs1.4.1/template/fishvfs.tcl b/src/vfs/critcl-3.3.1.vfs/lib/vfs1.4.1/template/fishvfs.tcl
new file mode 100644
index 00000000..3a87de27
--- /dev/null
+++ b/src/vfs/critcl-3.3.1.vfs/lib/vfs1.4.1/template/fishvfs.tcl
@@ -0,0 +1,535 @@
+#! /usr/bin/env tclsh
+
+if 0 {
+########################
+
+fishvfs.tcl --
+
+ A "FIles transferred over SHell" virtual filesystem
+ This is not an official "FISH" protocol client as described at:
+ http://mini.net/tcl/12792
+ but it utilizes the same concept of turning any computer that offers
+ access via ssh, rsh or similar shell into a file server.
+
+ Written by Stephen Huntley (stephen.huntley@alum.mit.edu)
+ License: Tcl license
+ Version 1.5.2
+
+ Usage: mount ?-volume? \
+ ?-cache ? \ # cache retention seconds
+ ?-exec? \ # location of executable
+ ?-transport ? \ # can be ssh, rsh or plink
+ ?-user ? \ # remote computer login name
+ ?-password ? \ # remote computer login password
+ ?-host ? \ # remote computer domain name
+ ?-port ? \ # override default port
+ ?