diff --git a/src/vfs/_vfscommon/modules/packageTrace-0.5.tm b/src/vfs/_vfscommon/modules/packageTrace-0.5.tm deleted file mode 100644 index 832746ca..00000000 --- a/src/vfs/_vfscommon/modules/packageTrace-0.5.tm +++ /dev/null @@ -1,385 +0,0 @@ - - -#JMN 2005 - Public Domain -# -#WARNING: This package does not robustly output xml. More testing & development required. - -#NOTE: the 'x' attribute on the 'info' tag may have its value truncated. -#It is a human-readable indicator only and should not be used to cross-reference to the corresponding 'require' tag using the 'p' attribute. -#Use the fact that the corresponding 'info' tag directly follows its 'require' tag. - - -#changes -#2021-09-17 -# - added variable ::packageTrace::showpresent with default 1 -# setting this to 0 will hide the tags which sometimes make the output too verbose. -# - changed t from an integer number of milliseconds to show fractional millis by using ([clock microseconds]-$t0)/1000.0 in the expr. - -package provide packageTrace [namespace eval packageTrace { - variable chan stderr - variable showpresent 1 - set version 0.5 -}] - - proc packageTrace::help {} { - return { -Enable package tracing using 'package require packageTrace' -Disable package tracing using 'package forget packageTrace; package require packageTrace' - (This 2nd 'package require packageTrace' will raise an error. This is deliberate.) -set packageTrace::chan to desired output channel. (default stderr) - -set packageTrace::showpresent 0 to skip output -} - } - - - -#The preferred source of the ::overtype:: functions is the 'overtype' package: http://mini.net/tcl/overtype -# - pasted here because packageTrace should have no extra dependencies. -# -namespace eval packageTrace_overtype {set version INLINE} -proc packageTrace_overtype::left {args} { - # @c overtype starting at left (overstrike) - # @c can/should we use something like this?: 'format "%-*s" $len $overtext - - if {[llength $args] < 2} { - error {usage: ?-overflow [1|0]? ?-ellipsis [1|0]? ?-ellipsistext ...? undertext overtext} - } - foreach {undertext overtext} [lrange $args end-1 end] break - - set opt(-ellipsis) 0 - set opt(-ellipsistext) {...} - set opt(-overflow) 0 - array set opt [lrange $args 0 end-2] - - - set len [string length $undertext] - set overlen [string length $overtext] - set diff [expr {$overlen - $len}] - if {$diff > 0} { - if {$opt(-overflow)} { - return $overtext - } else { - if {$opt(-ellipsis)} { - return [packageTrace_overtype::right [string range $overtext 0 [expr {$len -1}]] $opt(-ellipsistext)] - } else { - return [string range $overtext 0 [expr {$len -1}]] - } - } - } else { - - return "$overtext[string range $undertext $overlen end]" - } -} - -proc packageTrace_overtype::centre {args} { - if {[llength $args] < 2} { - error {usage: ?-bias [left|right]? ?-overflow [1|0]? undertext overtext} - } - foreach {undertext overtext} [lrange $args end-1 end] break - - set opt(-bias) left - set opt(-overflow) 0 - array set opt [lrange $args 0 end-2] - - - set olen [string length $overtext] - set ulen [string length $undertext] - set diff [expr {$ulen - $olen}] - if {$diff > 0} { - set half [expr {round(int($diff / 2))}] - if {[string match right $opt(-bias)]} { - if {[expr {2 * $half}] < $diff} { - incr half - } - } - - set rhs [expr {$diff - $half - 1}] - set lhs [expr {$half - 1}] - - set a [string range $undertext 0 $lhs] - set b $overtext - set c [string range $undertext end-$rhs end] - return $a$b$c - } else { - if {$diff < 0} { - if {$opt(-overflow)} { - return $overtext - } else { - return [string range $overtext 0 [expr {$ulen - 1}]] - } - } else { - return $overtext - } - } -} - -proc packageTrace_overtype::right {args} { - # @d !todo - implement overflow, length checks etc - - if {[llength $args] < 2} { - error {usage: ?-overflow [1|0]? undertext overtext} - } - #foreach {undertext overtext} [lrange $args end-1 end] break - lassign [lrange $args end-1 end] undertext overtext - - - set opt(-overflow) 0 - array set opt [lrange $args 0 end-2] - - - set olen [string length $overtext] - set ulen [string length $undertext] - - if {$opt(-overflow)} { - return [string range $undertext 0 end-$olen]$overtext - } else { - if {$olen > $ulen} { - set diff [expr {$olen - $ulen}] - return [string range $undertext 0 end-$olen][string range $overtext 0 end-$diff] - } else { - return [string range $undertext 0 end-$olen]$overtext - } - } -} - -#convenience function in case the sequence 'package forget packageTrace;package require packageTrace' is too unintuitive or weird. -proc ::packageTrace::unload {} { - package forget packageTrace - if {[catch {package require packageTrace}]} { - return 1 ;#yes - we get an error if we unloaded successfully - } else { - error "packageTrace was not unloaded" - } -} - - - -proc ::packageTrace::init {} { - uplevel 1 { - set ::packageTrace::level -1 - if {![llength [info commands tcl_findLibrary]]} { - eval $::auto_index(tcl_findLibrary) - } - package require commandstack - - - #rename tcl_findLibrary _tcl_findLibrary - set stackrecord [commandstack::rename_command tcl_findLibrary packageTrace] - set old_tcl_findLibrary [dict get $stackrecord implementation] - #set old_tcl_findLibrary [::commandstack::get_next_command package packageTrace] - - proc tcl_findLibrary [info args $old_tcl_findLibrary] { - set original [::commandstack::get_next_command tcl_findLibrary packageTrace] - - set marg [string repeat { } $::packageTrace::level] - - puts -nonewline $::packageTrace::chan "${marg} tcl_findLibrary $basename $version $patch $initScript $enVarName $varName \n" - uplevel 1 [list $original $basename $version $patch $initScript $enVarName $varName] - } - - - - set stackrecord [commandstack::rename_command package packageTrace] - set stored_target [dict get $stackrecord implementation] - set next_target [::commandstack::get_next_command package packageTrace] - if {$stored_target ne $next_target} { - error "(packageTrace::init) something went wrong renaming command 'package'" - } - - - - set f1 [string repeat { } 30] - #set f1a " " - set f1a "" - set f2 [packageTrace_overtype::left [string repeat { } 20] "PACKAGE"] - set f2a " " - set f3 [packageTrace_overtype::left [string repeat { } 13] "VERSION"] - set f4 [packageTrace_overtype::left [string repeat { } 10] "LOAD-ms"] - set f5 [packageTrace_overtype::left [string repeat { } 10] "MODULE"] - - puts -nonewline $::packageTrace::chan "-$f1$f1a$f2$f2a$f3$f4$f5\n" - unset f1 f1a f2 f2a f3 f4 f5 - - - proc package {sub args} [string map [list %next% $next_target] { - set ch $::packageTrace::chan - set next [::commandstack::get_next_command package packageTrace] - if {$next ne "%next%"} { - puts stderr "(packageTrace package) DEBUG - command changed since start: %next% is now $next" - } - - #cache $ch instead of using upvar, - #because namespace may be deleted during call. - - #!todo - optionally silence Tcl & Tk requires to reduce output? - #if {[lindex $args 0] eq "Tcl"} { - # return [$next $sub {*}$args] - #} - - if {$sub eq "require"} { - #columns - set c1 [string repeat { } 30] ;#tree col - set c1a " " - set c2 [string repeat { } 20] ;#package name col - set c2a " " ;# close require/present tags - set c3 [string repeat { } 13] ;#version col - set c4 [string repeat { } 10] ;#timing col - set c5 [string repeat { } 10] ;#module col - set c5a [string repeat { } 5] ;#close result tag col - - foreach a $args { - if {[string range $a 0 0] ne "-"} { - #assume 1st non-dashed argument is package name - set pkg $a - set pkg_ [lrange $args [lsearch $args $a] end] ;# e.g "Tcl 8.6" - break - } - } - - - incr ::packageTrace::level - set marg [string repeat { } $::packageTrace::level] - set margnext [string repeat { } [expr {$::packageTrace::level + 1}]] - - if {![catch {set ver [$next present {*}$args]}]} { - if {$::packageTrace::showpresent} { - #already loaded.. - set f1 [packageTrace_overtype::left $c1 "${marg} " - set f3 "" - set f4 "" - set f5 "" - puts -nonewline $ch $f1$c1a$f2$f2a$f3$f4$f5\n - } - } else { - set f1 [packageTrace_overtype::left $c1 "${marg} " - set f3 "" - set f4 "" - set f5 "" - puts -nonewline $ch $f1$c1a$f2$f2a$f3$f4$f5\n - - set errMsg "" - #set t0 [clock clicks -milliseconds] - set t0 [clock microseconds] - - if {[catch {set ver [$next require {*}$args]} errMsg]} { - set ver "" - # - #NOTE error must be raised at some point - see below - } - #set t [expr {[clock clicks -millisec]-$t0}] - set t [expr {([clock microseconds]-$t0)/1000.0}] - - - - - #jmn - set f1 [packageTrace_overtype::left $c1 "${margnext}"] ;#end of "] - set f1a "" - set f2 "" - set c2a "" - set f3 "" - set f4 "" - set f5 "" - set f5a "" - puts -nonewline $ch $f1$f1a$f2$c2a$f3$f4$f5$f5a\n - - - if {![string length $ver]} { - if {[lindex $args 0] eq "packageTrace"} { - namespace delete ::packageTrace_overtype - } - - #we must raise an error if original 'package require' would have - incr ::packageTrace::level -1 - error $errMsg - } - - } - incr ::packageTrace::level -1 - } elseif {[lsearch [list vcompare vsatisfies provide ifneeded] $sub] < 0} { - set ver [$next $sub {*}$args] - #puts -nonewline $ch " -- package $sub $args\n" - } else { - set ver [$next $sub {*}$args] - #puts $ch "*** here $sub $args" - } - return $ver - }] - } -} -proc packageTrace::deinit {} { - packageTrace::disable - #namespace delete packageTrace - #package forget packageTrace -} -proc packageTrace::disable {} { - ::commandstack::remove_renaming_package tcl_findLibrary packageTrace - ::commandstack::remove_renaming_package package packageTrace -} -proc packageTrace::enable {} { - #init doesn't clear state - so this is effectively an alias - tailcall packageTrace::init -} - -#clear state - reset to defaults -proc packageTrace::clear {} { - variable chan - set chan stderr - variable showpresent - set showpresent 1 -} -packageTrace::init - - - diff --git a/src/vfs/_vfscommon/modules/packagetrace-0.7.tm b/src/vfs/_vfscommon/modules/packagetrace-0.7.tm index a31f886a..6197ad83 100644 --- a/src/vfs/_vfscommon/modules/packagetrace-0.7.tm +++ b/src/vfs/_vfscommon/modules/packagetrace-0.7.tm @@ -86,6 +86,10 @@ set packagetrace::showpresent 0 to skip output "" { return $chan } + none { + set chan none + return none + } stderr - stdout { #note stderr stdout not necessarily in [chan names] (due to transforms etc?) but can still work set chan $ch diff --git a/src/vfs/_vfscommon/modules/packagetrace-0.8.tm b/src/vfs/_vfscommon/modules/packagetrace-0.8.tm new file mode 100644 index 00000000..6798eb8d --- /dev/null +++ b/src/vfs/_vfscommon/modules/packagetrace-0.8.tm @@ -0,0 +1,643 @@ + + +#JMN 2005 - Public Domain +# +#REVIEW: This package may not robustly output xml. More testing & development required. +# + +#NOTE: the 'x' attribute on the 'info' tag may have its value truncated. +#It is a human-readable indicator only and should not be used to cross-reference to the corresponding 'require' tag using the 'p' attribute. +#Use the fact that the corresponding 'info' tag directly follows its 'require' tag. + + +#changes +#2021-09-17 +# - added variable ::packagetrace::showpresent with default 1 +# setting this to 0 will hide the tags which sometimes make the output too verbose. +# - changed t from an integer number of milliseconds to show fractional millis by using ([clock microseconds]-$t0)/1000.0 in the expr. + +namespace eval packagetrace::class { + if {[info commands [namespace current]::tracer] eq ""} { + oo::class create tracer { + method get {} { + } + method test {} { + return tracertest + } + } + } +} + + +namespace eval packagetrace { + variable tracerlist [list] + variable chan stderr + variable showpresent 1 + variable output "" + + + proc help {} { + return { + REVIEW - documentation inaccurate +Enable package tracing using 'package require packagetrace' +Disable package tracing using 'package forget packagetrace; package require packagetrace' + (This 2nd 'package require packagetrace' will raise an error. This is deliberate.) +use packagetrace::channel to desired output channel or none. (default stderr) + +set packagetrace::showpresent 0 to skip output +} + } + + # == == == == == == == == == == == == == == == == == == == == == == == == == == == == == == == + # Maintenance - tm_version... functions - primary source is punk::lib module + # - these should be synced with code from latest punk::lib + # == == == == == == == == == == == == == == == == == == == == == == == == == == == == == == == + 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 + # == == == == == == == == == == == == == == == == == == == == == == == == == == == == == == == + + #convenience function in case the sequence 'package forget packagetrace;package require packagetrace' is too unintuitive or weird. + #REVIEW + proc unload {} { + package forget packagetrace + if {[catch {package require packagetrace}]} { + return 1 ;#yes - we get an error if we unloaded successfully + } else { + error "packagetrace was not unloaded" + } + } + proc emit {str} { + variable chan + variable output + append output $str + if {$chan ne "none"} { + puts -nonewline $chan $str + } + return + } + proc get {{as raw}} { + variable output + switch -- [string tolower $as] { + asxml { + if {[package provide tdom] eq ""} { + set previous_output $output + package require tdom + set output $previous_output + } + set d [dom parse $output] + return [$d asXML] + } + aslist { + if {[package provide tdom] eq ""} { + set previous_output $output + package require tdom + set output $previous_output + } + set d [dom parse $output] + return [$d asList] + } + default { + return $output + } + } + } + proc channel {{ch ""}} { + variable chan + switch -exact -- $ch { + "" { + return $chan + } + none { + set chan none + return none + } + stderr - stdout { + #note stderr stdout not necessarily in [chan names] (due to transforms etc?) but can still work + set chan $ch + return $ch + } + default { + if {$ch in [chan names]} { + set chan $ch + return $ch + } else { + error "chan '$ch' not in \[chan names\]: [chan names]" + } + } + } + } + proc init {} { + uplevel 1 { + set ::packagetrace::level -1 + if {![llength [info commands tcl_findLibrary]]} { + tcl::namespace::eval :: $::auto_index(tcl_findLibrary) + } + package require commandstack + + + set targetcommand [namespace which tcl_findLibrary] ;# normalize to presumably ::tcl_findLibrary + set stackrecord [commandstack::rename_command -renamer packagetrace $targetcommand [info args $targetcommand] { + set marg [string repeat { } $::packagetrace::level] + packagetrace::emit "${marg} tcl_findLibrary $basename $version $patch $initScript $enVarName $varName \n" + uplevel 1 [list $COMMANDSTACKNEXT $basename $version $patch $initScript $enVarName $varName] + }] + if {[dict get $stackrecord implementation] ne ""} { + set old_tcl_findLibrary [dict get $stackrecord implementation] + puts stderr "packagetrace::init renamed $targetcommand to $old_tcl_findLibrary and is providing an override" + } else { + puts stderr "packagetrace::init failed to rename $targetcommand" + } + + + + set package_command [namespace which package] + set stackrecord [commandstack::rename_command -renamer packagetrace $package_command {subcommand args} { + set tracerlist $::packagetrace::tracerlist + set tracer [lindex $tracerlist end] + if {$tracer eq ""} { + + } + set ch $::packagetrace::chan + set next $COMMANDSTACKNEXT + if {$next ne "$COMMANDSTACKNEXT_ORIGINAL"} { + puts stderr "(packagetrace package) DEBUG - command changed since start: $COMMANDSTACKNEXT_ORIGINAL is now $next" + } + + #cache $ch instead of using upvar, + #because namespace may be deleted during call. + + #!todo - optionally silence Tcl & Tk requires to reduce output? + #if {[lindex $args 0] eq "Tcl"} { + # return [$next $subcommand {*}$args] + #} + switch -exact -- [tcl::prefix::match {files forget ifneeded names prefer present provide require unknown vcompare versions vsatisfies} $subcommand] { + require { + #columns + set c1 [string repeat { } 30] ;#tree col + set c1a " " + set c2 [string repeat { } 20] ;#package name col + set c2a " " ;# close require/present tags + set c3 [string repeat { } 18] ;#version col - must handle v= "999999.0a1.0" without truncation + set c4 [string repeat { } 12] ;#timing col 5 chars of punct leaving remainder for value. + set c5 [string repeat { } 10] ;#module col + set c5a [string repeat { } 3] ;#close result tag col + + #we assume 'package require' API sticks to solo option flags like -exact and is relatively stable. + set argidx 0 + set is_exact 0 + foreach a $args { + if {[string range $a 0 0] ne "-"} { + #assume 1st non-dashed argument is package name + set pkg $a + set v_requirements [lrange $args $argidx+1 end] + #normalize + if {$is_exact} { + set req [lindex $v_requirements 0] ;#only one is allowed for -exact + set v_requirement $req-$req ;#translate to v-v normalised equiv of -exact + } else { + set reqs [list] + foreach req $v_requirements { + lappend reqs [::packagetrace::tm_version_required_canonical $v_requirement] ;#empty remains empty, v -> v-, leading zeros stripped from all segments. + } + set v_requirements $reqs ;#each normalised + } + set pkg_ [lrange $args $argidx end] ;# raw e.g "Tcl 8.6" or "Tcl 8.5 9" + break + } else { + if {$a eq "-exact"} { + set is_exact 1 + } + } + incr argidx + } + + + incr ::packagetrace::level + if {$::packagetrace::level == 0} { + set packagetrace::output "" + } + + + set marg [string repeat { } $::packagetrace::level] + set margnext [string repeat { } [expr {$::packagetrace::level + 1}]] + + if {![catch {set ver [$next present {*}$args]}]} { + if {$::packagetrace::showpresent} { + #already loaded.. + set f1 [packagetrace::overtype::left $c1 "${marg} " + #puts -nonewline $ch $f1$c1a$f2$f2a$f3$f4$f5\n + packagetrace::emit $f1$c1a$f2$f2a$f3$f4$f5$f5a\n + } + } else { + set f1 [packagetrace::overtype::left $c1 "${marg} " + #puts -nonewline $ch $f1$c1a$f2$f2a$f3$f4$f5\n + packagetrace::emit $f1$c1a$f2$f2a$f3$f4$f5$f5a\n + + set errMsg "" + #set t0 [clock clicks -milliseconds] + set t0 [clock microseconds] + + if {[catch {set ver [$next require {*}$args]} errMsg]} { + set ver "" + # + #NOTE error must be raised at some point - see below + } + #set t [expr {[clock clicks -millisec]-$t0}] + set t [expr {([clock microseconds]-$t0)/1000.0}] + + + + + #jmn + set f1 [packagetrace::overtype::left $c1 "${margnext} [expr {[string length $c4]}]} { + set f4 "[packagetrace::overtype::left [string range $c4 0 end-1] [string trimright $f4]]\"" + } + + if {[string length $ver]} { + set num "" + foreach c [split $ver ""] { + if {[string is digit $c] || $c eq "."} { + append num $c + } else { + break + } + } + set ver $num + + #review - scr not guaranteed to be valid tcl list - should parse properly? + set scr [$next ifneeded $pkg $ver] + if {[string range $scr end-2 end] ne ".tm"} { + set f5 $c5 + } else { + #!todo - optionally output module path instead of boolean? + #set f5 [packagetrace::overtype::left -ellipsis 1 -ellipsistext ... [string range $c5 0 end-1] "tm= \"[lindex $scr end]"] + set f5 [packagetrace::overtype::left -ellipsis 1 -ellipsistext ... [string range $c5 0 end-1] "tm= \"1"] + if {[string length [string trimright $f5]] <= [expr [string length $c5]-1]} { + set f5 [packagetrace::overtype::left $c5 [string trimright $f5]\"] + } + } + } else { + set f5 $c5 + } + + set f5a [packagetrace::overtype::left $c5a "/>"] ;#end of "] + set f1a "" + set f2 "" + set c2a "" + set f3 "" + set f4 "" + set f5 "" + set f5a "" + #puts -nonewline $ch $f1$f1a$f2$c2a$f3$f4$f5$f5a\n + packagetrace::emit $f1$f1a$f2$c2a$f3$f4$f5$f5a\n + + + if {![string length $ver]} { + if {[lindex $args 0] eq "packagetrace"} { + #REVIEW - what is going on here? + namespace delete ::packagetrace::overtype + } + + #we must raise an error if original 'package require' would have + incr ::packagetrace::level -1 + error $errMsg + } + + } + incr ::packagetrace::level -1 + return $ver + } + vcompare - vsatisifies - provide - ifneeded { + set result [$next $subcommand {*}$args] + #puts -nonewline $ch " -- package $subcommand $args\n" + return $result + } + default { + set result [$next $subcommand {*}$args] + #puts $ch "*** here $subcommand $args" + return $result + } + } + + }] + if {[set stored_target [dict get $stackrecord implementation]] ne ""} { + puts stderr "packagetrace::init renamed $package_command to $stored_target and is providing an override" + set f1 [string repeat { } 30] + #set f1a " " + set f1a "" + set f2 [packagetrace::overtype::left [string repeat { } 20] "PACKAGE"] + set f2a " " + set f3 [packagetrace::overtype::left [string repeat { } 15] "VERSION"] + set f4 [packagetrace::overtype::left [string repeat { } 12] "LOAD-ms"] + set f5 [packagetrace::overtype::left [string repeat { } 10] "MODULE"] + + #puts -nonewline $::packagetrace::chan "-$f1$f1a$f2$f2a$f3$f4$f5\n" + #packagetrace::emit "-$f1$f1a$f2$f2a$f3$f4$f5\n" + puts -nonewline stderr "-$f1$f1a$f2$f2a$f3$f4$f5\n" + unset f1 f1a f2 f2a f3 f4 f5 + } else { + puts stderr "packagetrace::init failed to rename $package_command" + } + } + } +} + + + +#The preferred source of the ::overtype:: functions is the 'overtype' package +# - pasted here because packagetrace should have no extra dependencies. +# - overtype package has better support for ansi and supports wide chars +namespace eval packagetrace::overtype {set version INLINE} + +namespace eval packagetrace::overtype { + proc left {args} { + # @c overtype starting at left (overstrike) + # @c can/should we use something like this?: 'format "%-*s" $len $overtext + + if {[llength $args] < 2} { + error {usage: ?-overflow [1|0]? ?-ellipsis [1|0]? ?-ellipsistext ...? undertext overtext} + } + foreach {undertext overtext} [lrange $args end-1 end] break + + set opt(-ellipsis) 0 + set opt(-ellipsistext) {...} + set opt(-overflow) 0 + array set opt [lrange $args 0 end-2] + + + set len [string length $undertext] + set overlen [string length $overtext] + set diff [expr {$overlen - $len}] + if {$diff > 0} { + if {$opt(-overflow)} { + return $overtext + } else { + if {$opt(-ellipsis)} { + return [right [string range $overtext 0 [expr {$len -1}]] $opt(-ellipsistext)] + } else { + return [string range $overtext 0 [expr {$len -1}]] + } + } + } else { + + return "$overtext[string range $undertext $overlen end]" + } + } + + proc centre {args} { + if {[llength $args] < 2} { + error {usage: ?-bias [left|right]? ?-overflow [1|0]? undertext overtext} + } + foreach {undertext overtext} [lrange $args end-1 end] break + + set opt(-bias) left + set opt(-overflow) 0 + array set opt [lrange $args 0 end-2] + + + set olen [string length $overtext] + set ulen [string length $undertext] + set diff [expr {$ulen - $olen}] + if {$diff > 0} { + set half [expr {round(int($diff / 2))}] + if {[string match right $opt(-bias)]} { + if {[expr {2 * $half}] < $diff} { + incr half + } + } + + set rhs [expr {$diff - $half - 1}] + set lhs [expr {$half - 1}] + + set a [string range $undertext 0 $lhs] + set b $overtext + set c [string range $undertext end-$rhs end] + return $a$b$c + } else { + if {$diff < 0} { + if {$opt(-overflow)} { + return $overtext + } else { + return [string range $overtext 0 [expr {$ulen - 1}]] + } + } else { + return $overtext + } + } + } + + proc right {args} { + if {[llength $args] < 2} { + error {usage: ?-overflow [1|0]? undertext overtext} + } + lassign [lrange $args end-1 end] undertext overtext + + set opt(-overflow) 0 + array set opt [lrange $args 0 end-2] + + set olen [string length $overtext] + set ulen [string length $undertext] + + if {$opt(-overflow)} { + return [string range $undertext 0 end-$olen]$overtext + } else { + if {$olen > $ulen} { + set diff [expr {$olen - $ulen}] + return [string range $undertext 0 end-$olen][string range $overtext 0 end-$diff] + } else { + return [string range $undertext 0 end-$olen]$overtext + } + } + } + +} + + + + + +proc packagetrace::deinit {} { + packagetrace::disable + #namespace delete packagetrace + #package forget packagetrace +} +proc packagetrace::disable {} { + ::commandstack::remove_rename {::tcl_findLibrary packagetrace} + ::commandstack::remove_rename {::package packagetrace} +} +proc packagetrace::enable {} { + #init doesn't clear state - so this is effectively an alias + tailcall packagetrace::init +} + +#clear state - reset to defaults +proc packagetrace::clear {} { + variable chan + set chan stderr + variable showpresent + set showpresent 1 +} + +package provide packagetrace [namespace eval packagetrace { + set version 0.8 +}] + + diff --git a/src/vfs/_vfscommon/modules/punk-0.1.tm b/src/vfs/_vfscommon/modules/punk-0.1.tm index 2d6e61da..4bd8aae0 100644 --- a/src/vfs/_vfscommon/modules/punk-0.1.tm +++ b/src/vfs/_vfscommon/modules/punk-0.1.tm @@ -213,6 +213,13 @@ namespace eval punk { proc objclone {obj} { append obj2 $obj {} } + proc set_clone {varname obj} { + #maintenance: also punk::lib::set_clone + #e.g 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] + } + interp alias "" strlen "" ::punk::strlen interp alias "" str_len "" ::punk::strlen interp alias "" objclone "" ::punk::objclone @@ -2121,8 +2128,8 @@ namespace eval punk { set level_script_complete 1 } {@V\*@*} - {@v\*@*} { - #dict value glob - return values - set active_key_type "dict" + #dict value glob - return values + set active_key_type dict set keyglob [string range $index 4 end] append script [tstr -return string -allowcommands { if {[catch {dict size $leveldata}]} { @@ -2132,7 +2139,7 @@ namespace eval punk { if {$get_not} { lappend INDEX_OPERATIONS globvalue-get-values-not append script \n [string map [list $keyglob] { - # set active_key_type "dict" index_operation: globvalue-get-values-not" + # set active_key_type "dict" ;# index_operation: globvalue-get-values-not set assigned [list] tcl::dict::for {k v} $leveldata { if {![string match $v]} { @@ -2144,7 +2151,7 @@ namespace eval punk { } else { lappend INDEX_OPERATIONS globvalue-get-values append script \n [string map [list $keyglob] { - # set active_key_type "dict" index_operation: globvalue-get-value + # set active_key_type "dict" ;#index_operation: globvalue-get-value set assigned [dict values $leveldata ] }] } @@ -2166,7 +2173,7 @@ namespace eval punk { } else { lappend INDEX_OPERATIONS globkeyvalue-get-pairs append script \n [string map [list $keyvalglob] { - # set active_key_type "dict" index_operation: globkeyvalue-get-pairs-not" + # set active_key_type "dict" ;# index_operation: globkeyvalue-get-pairs-not set assigned [dict create] tcl::dict::for {k v} $leveldata { if {[string match $k] || [string match $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 + ?

Defaults to nothing, regular bench invokation. + + # interps - dict (path -> version) + # files - list (of files) + + # Process arguments ...................................... + # Defaults first, then overides by the user + + set errors 1 ; # Propagate errors + set threads 0 ; # Do not use threads + set match {} ; # Do not exclude benchmarks based on glob pattern + set rmatch {} ; # Do not exclude benchmarks based on regex pattern + set iters 1000 ; # Limit #iterations for any benchmark + set pkgdirs {} ; # List of dirs to put in front of auto_path in the + # bench interpreters. Default: nothing. + + while {[string match "-*" [set opt [lindex $args 0]]]} { + set val [lindex $args 1] + switch -exact -- $opt { + -errors { + if {![string is boolean -strict $val]} { + return -code error "Expected boolean, got \"$val\"" + } + set errors $val + } + -threads { + ##nagelfar ignore + if {![string is integer -strict $val] || ($val < 0)} { + return -code error "Expected int >= 0, got \"$val\"" + } + set threads [format %d $val] + } + -match { + set match [lindex $args 1] + } + -rmatch { + set rmatch [lindex $args 1] + } + -iters { + ##nagelfar ignore + if {![string is integer -strict $val] || ($val <= 0)} { + return -code error "Expected int > 0, got \"$val\"" + } + set iters [format %d $val] + } + -pkgdir { + CheckPkgDirArg $val + lappend pkgdirs $val + } + default { + return -code error "Unknown option \"$opt\", should -errors, -threads, -match, -rmatch, or -iters" + } + } + set args [lrange $args 2 end] + } + if {[llength $args] != 2} { + return -code error "wrong\#args, should be: ?options? interp files" + } + foreach {interps files} $args break + + # Run the benchmarks ..................................... + + array set DATA {} + + if {![llength $pkgdirs]} { + # No user specified package directories => Simple run. + foreach {ip ver} $interps { + Invoke $ip $ver {} ;# DATA etc passed via upvar. + } + } else { + # User specified package directories. + foreach {ip ver} $interps { + foreach pkgdir $pkgdirs { + Invoke $ip $ver $pkgdir ;# DATA etc passed via upvar. + } + } + } + + # Benchmark data ... Structure, dict (key -> value) + # + # Key || Value + # ============ ++ ========================================= + # interp IP -> Version. Shell IP was used to run benchmarks. IP is + # the path to the shell. + # + # desc DESC -> "". DESC is description of an executed benchmark. + # + # usec DESC IP -> Result. Result of benchmark DESC when run by the + # shell IP. Usually time in microseconds, but can be + # a special code as well (ERR, BAD_RES). + # ============ ++ ========================================= + + return [array get DATA] +} + +# ::bench::locate -- +# +# Locate interpreters on the pathlist, based on a pattern. +# +# Arguments: +# ... +# +# Results: +# List of paths. + +proc ::bench::locate {pattern paths} { + # Cache of executables already found. + array set var {} + set res {} + + foreach path $paths { + foreach ip [glob -nocomplain [file join $path $pattern]] { + set ip [file normalize $ip] + + # Follow soft-links to the actual executable. + while {[string equal link [file type $ip]]} { + set link [file readlink $ip] + if {[string match relative [file pathtype $link]]} { + set ip [file join [file dirname $ip] $link] + } else { + set ip $link + } + } + + if { + [file executable $ip] && ![info exists var($ip)] + } { + if {[catch {exec $ip << "exit"} dummy]} { + log::debug "$ip: $dummy" + continue + } + set var($ip) . + lappend res $ip + } + } + } + + return $res +} + +# ::bench::versions -- +# +# Take list of interpreters, find their versions. +# Removes all interps for which it cannot do so. +# +# Arguments: +# List of interpreters (paths) +# +# Results: +# dictionary: interpreter -> version. + +proc ::bench::versions {interps} { + set res {} + foreach ip $interps { + if {[catch { + exec $ip << {puts [info patchlevel] ; exit} + } patchlevel]} { + log::debug "$ip: $patchlevel" + continue + } + + lappend res [list $patchlevel $ip] + } + + # -uniq 8.4-ism, replaced with use of array. + array set tmp {} + set resx {} + foreach item [lsort -dictionary -decreasing -index 0 $res] { + foreach {p ip} $item break + if {[info exists tmp($p)]} continue + set tmp($p) . + lappend resx $ip $p + } + + return $resx +} + +# ::bench::merge -- +# +# Take the data of several benchmark runs and merge them into +# one data set. +# +# Arguments: +# One or more data sets to merge +# +# Results: +# The merged data set. + +proc ::bench::merge {args} { + if {[llength $args] == 1} { + return [lindex $args 0] + } + + array set DATA {} + foreach data $args { + array set DATA $data + } + return [array get DATA] +} + +# ::bench::norm -- +# +# Normalize the time data in the dataset, using one of the +# columns as reference. +# +# Arguments: +# Data to normalize +# Index of reference column +# +# Results: +# The normalized data set. + +proc ::bench::norm {data col} { + + ##nagelfar ignore + if {![string is integer -strict $col]} { + return -code error "Ref.column: Expected integer, but got \"$col\"" + } + set col [format %d $col] + if {$col < 1} { + return -code error "Ref.column out of bounds" + } + + array set DATA $data + set ipkeys [array names DATA interp*] + + if {$col > [llength $ipkeys]} { + return -code error "Ref.column out of bounds" + } + incr col -1 + set refip [lindex [lindex [lsort -dict $ipkeys] $col] 1] + + foreach key [array names DATA] { + if {[string match "desc*" $key]} continue + if {[string match "interp*" $key]} continue + + foreach {_ desc ip} $key break + if {[string equal $ip $refip]} continue + + set v $DATA($key) + if {![string is double -strict $v]} continue + + if {![info exists DATA([list usec $desc $refip])]} { + # We cannot normalize, we do not keep the time value. + # The row will be shown, empty. + set DATA($key) "" + continue + } + set vref $DATA([list usec $desc $refip]) + + if {![string is double -strict $vref]} continue + + set DATA($key) [expr {$v/double($vref)}] + } + + foreach key [array names DATA [list * $refip]] { + if {![string is double -strict $DATA($key)]} continue + set DATA($key) 1 + } + + return [array get DATA] +} + +# ::bench::edit -- +# +# Change the 'path' of an interp to a user-defined value. +# +# Arguments: +# Data to edit +# Index of column to change +# The value replacing the current path +# +# Results: +# The changed data set. + +proc ::bench::edit {data col new} { + + ##nagelfar ignore + if {![string is integer -strict $col]} { + return -code error "Ref.column: Expected integer, but got \"$col\"" + } + set col [format %d $col] + if {$col < 1} { + return -code error "Ref.column out of bounds" + } + + array set DATA $data + set ipkeys [array names DATA interp*] + + if {$col > [llength $ipkeys]} { + return -code error "Ref.column out of bounds" + } + incr col -1 + set refip [lindex [lindex [lsort -dict $ipkeys] $col] 1] + + if {[string equal $new $refip]} { + # No change, quick return + return $data + } + + set refkey [list interp $refip] + set DATA([list interp $new]) $DATA($refkey) + unset DATA($refkey) + + foreach key [array names DATA [list * $refip]] { + if {![string equal [lindex $key 0] "usec"]} continue + foreach {__ desc ip} $key break + set DATA([list usec $desc $new]) $DATA($key) + unset DATA($key) + } + + return [array get DATA] +} + +# ::bench::del -- +# +# Remove the data for an interp. +# +# Arguments: +# Data to edit +# Index of column to remove +# +# Results: +# The changed data set. + +proc ::bench::del {data col} { + ##nagelfar ignore + if {![string is integer -strict $col]} { + return -code error "Ref.column: Expected integer, but got \"$col\"" + } + set col [format %d $col] + if {$col < 1} { + return -code error "Ref.column out of bounds" + } + + array set DATA $data + set ipkeys [array names DATA interp*] + + if {$col > [llength $ipkeys]} { + return -code error "Ref.column out of bounds" + } + incr col -1 + set refip [lindex [lindex [lsort -dict $ipkeys] $col] 1] + + unset DATA([list interp $refip]) + + # Do not use 'array unset'. Keep 8.2 clean. + foreach key [array names DATA [list * $refip]] { + if {![string equal [lindex $key 0] "usec"]} continue + unset DATA($key) + } + + return [array get DATA] +} + +# ### ### ### ######### ######### ######### ########################### +## Public API - Result formatting. + +# ::bench::out::raw -- +# +# Format the result of a benchmark run. +# Style: Raw data. +# +# Arguments: +# DATA dict +# +# Results: +# String containing the formatted DATA. + +proc ::bench::out::raw {data} { + return $data +} + +# ### ### ### ######### ######### ######### ########################### +## Internal commands + +proc ::bench::CheckPkgDirArg {path {expected {}}} { + # Allow empty string, special. + if {![string length $path]} return + + if {![file isdirectory $path]} { + return -code error \ + "The path \"$path\" is not a directory." + } + if {![file readable $path]} { + return -code error \ + "The path \"$path\" is not readable." + } +} + +proc ::bench::Invoke {ip ver pkgdir} { + variable self + # Import remainder of the current configuration/settings. + + upvar 1 DATA DATA match match rmatch rmatch \ + iters iters errors errors threads threads \ + files files + + if {[string length $pkgdir]} { + log::info "Benchmark $ver ($pkgdir) $ip" + set idstr "$ip ($pkgdir)" + } else { + log::info "Benchmark $ver $ip" + set idstr $ip + } + + set DATA([list interp $idstr]) $ver + + set cmd [list $ip [file join $self libbench.tcl] \ + -match $match \ + -rmatch $rmatch \ + -iters $iters \ + -interp $ip \ + -errors $errors \ + -threads $threads \ + -pkgdir $pkgdir \ + ] + + # Determine elapsed time per file, logged. + set start [clock seconds] + + array set tmp {} + + if {$threads} { + foreach f $files { lappend cmd $f } + if {[catch { + close [Process [open |$cmd r+]] + } output]} { + if {$errors} { + error $::errorInfo + } + } + } else { + foreach file $files { + log::info [file tail $file] + if {[catch { + close [Process [open |[linsert $cmd end $file] r+]] + } output]} { + if {$errors} { + error $::errorInfo + } else { + continue + } + } + } + } + + foreach desc [array names tmp] { + set DATA([list desc $desc]) {} + set DATA([list usec $desc $idstr]) $tmp($desc) + } + + unset tmp + set elapsed [expr {[clock seconds] - $start}] + + set hour [expr {$elapsed / 3600}] + set min [expr {$elapsed / 60}] + set sec [expr {$elapsed % 60}] + log::info " [format %.2d:%.2d:%.2d $hour $min $sec] elapsed" + return +} + + +proc ::bench::Process {pipe} { + while {1} { + if {[eof $pipe]} break + if {[gets $pipe line] < 0} break + # AK: FUTURE: Log all lines?! + #puts |$line| + set line [string trim $line] + if {[string equal $line ""]} continue + + Result + Feedback + # Unknown lines are printed. Future: Callback?! + log::info $line + } + return $pipe +} + +proc ::bench::Result {} { + upvar 1 line line + if {[lindex $line 0] ne "RESULT"} return + upvar 2 tmp tmp + foreach {_ desc result} $line break + set tmp($desc) $result + return -code continue +} + +proc ::bench::Feedback {} { + upvar 1 line line + if {[lindex $line 0] ne "LOG"} return + # AK: Future - Run through callback?! + log::info [lindex $line 1] + return -code continue +} + +# ### ### ### ######### ######### ######### ########################### +## Initialize internal data structures. + +namespace eval ::bench { + variable self [file join [pwd] [file dirname [info script]]] + + logger::init bench + logger::import -force -all -namespace log bench +} + +# ### ### ### ######### ######### ######### ########################### +## Ready to run + +package provide bench 0.6 diff --git a/src/vfs/critclxxx.vfs/lib/tcllib2.0/bench/bench_read.tcl b/src/vfs/critclxxx.vfs/lib/tcllib2.0/bench/bench_read.tcl new file mode 100644 index 00000000..5098b95f --- /dev/null +++ b/src/vfs/critclxxx.vfs/lib/tcllib2.0/bench/bench_read.tcl @@ -0,0 +1,162 @@ +# bench_read.tcl -- +# +# Management of benchmarks, reading results in various formats. +# +# Copyright (c) 2005 by Andreas Kupries +# library derived from runbench.tcl application (C) Jeff Hobbs. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# RCS: @(#) $Id: bench_read.tcl,v 1.3 2006/06/13 23:20:30 andreas_kupries Exp $ + +# ### ### ### ######### ######### ######### ########################### +## Requisites - Packages and namespace for the commands and data. + +package require Tcl 8.5 9 +package require csv + +namespace eval ::bench::in {} + +# ### ### ### ######### ######### ######### ########################### +## Public API - Result reading + +# ::bench::in::read -- +# +# Read a bench result in any of the raw/csv/text formats +# +# Arguments: +# path to file to read +# +# Results: +# DATA dictionary, internal representation of the bench results. + +proc ::bench::in::read {file} { + + set f [open $file r] + set head [gets $f] + + if {![string match "# -\\*- tcl -\\*- bench/*" $head]} { + return -code error "Bad file format, not a benchmark file" + } else { + regexp {bench/(.*)$} $head -> format + + switch -exact -- $format { + raw - csv - text { + set res [RD$format $f] + } + default { + return -code error "Bad format \"$val\", expected text, csv, or raw" + } + } + } + close $f + return $res +} + +# ### ### ### ######### ######### ######### ########################### +## Internal commands + +proc ::bench::in::RDraw {chan} { + return [string trimright [::read $chan]] +} + +proc ::bench::in::RDcsv {chan} { + # Lines Format + # First line is number of interpreters #n. int + # Next to 1+n is interpreter data. id,ver,path + # Beyond is benchmark results. id,desc,res1,...,res#n + + array set DATA {} + + # #Interp ... + + set nip [lindex [csv::split [gets $chan]] 0] + + # Interp data ... + + set iplist {} + for {set i 0} {$i < $nip} {incr i} { + foreach {__ ver ip} [csv::split [gets $chan]] break + + set DATA([list interp $ip]) $ver + lappend iplist $ip + } + + # Benchmark data ... + + while {[gets $chan line] >= 0} { + set line [string trim $line] + if {$line == {}} break + set line [csv::split $line] + set desc [lindex $line 1] + + set DATA([list desc $desc]) {} + foreach val [lrange $line 2 end] ip $iplist { + if {$val == {}} continue + set DATA([list usec $desc $ip]) $val + } + } + + return [array get DATA] +} + +proc ::bench::in::RDtext {chan} { + array set DATA {} + + # Interp data ... + + # Empty line - ignore + # "id: ver path" - interp data. + # Empty line - separator before benchmark data. + + set n 0 + set iplist {} + while {[gets $chan line] >= 0} { + set line [string trim $line] + if {$line == {}} { + incr n + if {$n == 2} break + continue + } + + regexp {[^:]+: ([^ ]+) (.*)$} $line -> ver ip + set DATA([list interp $ip]) $ver + lappend iplist $ip + } + + # Benchmark data ... + + # '---' -> Ignore. + # '|' column separators. Remove spaces around it. Then treat line + # as CSV data with a particular separator. + # Ignore the INTERP line. + + while {[gets $chan line] >= 0} { + set line [string trim $line] + if {$line == {}} continue + if {[string match "+---*" $line]} continue + if {[string match "*INTERP*" $line]} continue + + regsub -all "\\| +" $line {|} line + regsub -all " +\\|" $line {|} line + set line [csv::split [string trim $line |] |] + set desc [lindex $line 1] + + set DATA([list desc $desc]) {} + foreach val [lrange $line 2 end] ip $iplist { + if {$val == {}} continue + set DATA([list usec $desc $ip]) $val + } + } + + return [array get DATA] +} + +# ### ### ### ######### ######### ######### ########################### +## Initialize internal data structures. + +# ### ### ### ######### ######### ######### ########################### +## Ready to run + +package provide bench::in 0.2 diff --git a/src/vfs/critclxxx.vfs/lib/tcllib2.0/bench/bench_wcsv.tcl b/src/vfs/critclxxx.vfs/lib/tcllib2.0/bench/bench_wcsv.tcl new file mode 100644 index 00000000..321997f6 --- /dev/null +++ b/src/vfs/critclxxx.vfs/lib/tcllib2.0/bench/bench_wcsv.tcl @@ -0,0 +1,101 @@ +# bench_wtext.tcl -- +# +# Management of benchmarks, formatted text. +# +# Copyright (c) 2005 by Andreas Kupries +# library derived from runbench.tcl application (C) Jeff Hobbs. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# RCS: @(#) $Id: bench_wcsv.tcl,v 1.4 2007/01/21 23:29:06 andreas_kupries Exp $ + +# ### ### ### ######### ######### ######### ########################### +## Requisites - Packages and namespace for the commands and data. + +package require Tcl 8.5 9 +package require csv + +namespace eval ::bench::out {} + +# ### ### ### ######### ######### ######### ########################### +## Public API - Benchmark execution + +# ### ### ### ######### ######### ######### ########################### +## Public API - Result formatting. + +# ::bench::out::csv -- +# +# Format the result of a benchmark run. +# Style: CSV +# +# Arguments: +# DATA dict +# +# Results: +# String containing the formatted DATA. + +proc ::bench::out::csv {data} { + array set DATA $data + set CSV {} + + # 1st record: #shells + # 2nd record to #shells+1: Interpreter data (id, version, path) + # #shells+2 to end: Benchmark data (id,desc,result1,...,result#shells) + + # --- --- ---- + # #interpreters used + + set ipkeys [array names DATA interp*] + lappend CSV [csv::join [list [llength $ipkeys]]] + + # --- --- ---- + # Table 1: Interpreter information. + + set n 1 + set iplist {} + foreach key [lsort -dict $ipkeys] { + set ip [lindex $key 1] + lappend CSV [csv::join [list $n $DATA($key) $ip]] + set DATA($key) $n + incr n + lappend iplist $ip + } + + # --- --- ---- + # Table 2: Benchmark information + + set dlist {} + foreach key [lsort -dict -index 1 [array names DATA desc*]] { + lappend dlist [lindex $key 1] + } + + set n 1 + foreach desc $dlist { + set record {} + lappend record $n + lappend record $desc + foreach ip $iplist { + if {[catch { + lappend record $DATA([list usec $desc $ip]) + }]} { + lappend record {} + } + } + lappend CSV [csv::join $record] + incr n + } + + return [join $CSV \n] +} + +# ### ### ### ######### ######### ######### ########################### +## Internal commands + +# ### ### ### ######### ######### ######### ########################### +## Initialize internal data structures. + +# ### ### ### ######### ######### ######### ########################### +## Ready to run + +package provide bench::out::csv 0.1.3 diff --git a/src/vfs/critclxxx.vfs/lib/tcllib2.0/bench/bench_wtext.tcl b/src/vfs/critclxxx.vfs/lib/tcllib2.0/bench/bench_wtext.tcl new file mode 100644 index 00000000..8c16b21a --- /dev/null +++ b/src/vfs/critclxxx.vfs/lib/tcllib2.0/bench/bench_wtext.tcl @@ -0,0 +1,165 @@ +# bench_wtext.tcl -- +# +# Management of benchmarks, formatted text. +# +# Copyright (c) 2005 by Andreas Kupries +# library derived from runbench.tcl application (C) Jeff Hobbs. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# RCS: @(#) $Id: bench_wtext.tcl,v 1.4 2007/01/21 23:29:06 andreas_kupries Exp $ + +# ### ### ### ######### ######### ######### ########################### +## Requisites - Packages and namespace for the commands and data. + +package require Tcl 8.5 9 +package require struct::matrix +package require report + +namespace eval ::bench::out {} + +# ### ### ### ######### ######### ######### ########################### +## Public API - Result formatting. + +# ::bench::out::text -- +# +# Format the result of a benchmark run. +# Style: TEXT +# +# General structure like CSV, but nicely formatted and aligned +# columns. +# +# Arguments: +# DATA dict +# +# Results: +# String containing the formatted DATA. + +proc ::bench::out::text {data} { + array set DATA $data + set LINES {} + + # 1st line to #shells: Interpreter data (id, version, path) + # #shells+1 to end: Benchmark data (id,desc,result1,...,result#shells) + + lappend LINES {} + + # --- --- ---- + # Table 1: Interpreter information. + + set ipkeys [array names DATA interp*] + set n 1 + set iplist {} + set vlen 0 + foreach key [lsort -dict $ipkeys] { + lappend iplist [lindex $key 1] + incr n + set l [string length $DATA($key)] + if {$l > $vlen} {set vlen $l} + } + set idlen [string length $n] + + set dlist {} + set n 1 + foreach key [lsort -dict -index 1 [array names DATA desc*]] { + lappend dlist [lindex $key 1] + incr n + } + set didlen [string length $n] + + set n 1 + set record [list "" INTERP] + foreach ip $iplist { + set v $DATA([list interp $ip]) + lappend LINES " [PADL $idlen $n]: [PADR $vlen $v] $ip" + lappend record $n + incr n + } + + lappend LINES {} + + # --- --- ---- + # Table 2: Benchmark information + + set m [struct::matrix m] + $m add columns [expr {2 + [llength $iplist]}] + $m add row $record + + set n 1 + foreach desc $dlist { + set record [list $n] + lappend record $desc + + foreach ip $iplist { + if {[catch { + set val $DATA([list usec $desc $ip]) + }]} { + set val {} + } + if {[string is double -strict $val]} { + lappend record [format %.2f $val] + } else { + lappend record [format %s $val] + } + } + $m add row $record + incr n + } + + ::report::defstyle simpletable {} { + data set [split "[string repeat "| " [columns]]|"] + top set [split "[string repeat "+ - " [columns]]+"] + bottom set [top get] + top enable + bottom enable + + set c [columns] + justify 0 right + pad 0 both + + if {$c > 1} { + justify 1 left + pad 1 both + } + for {set i 2} {$i < $c} {incr i} { + justify $i right + pad $i both + } + } + ::report::defstyle captionedtable {{n 1}} { + simpletable + topdata set [data get] + topcapsep set [top get] + topcapsep enable + tcaption $n + } + + set r [report::report r [$m columns] style captionedtable] + lappend LINES [$m format 2string $r] + $m destroy + $r destroy + + return [join $LINES \n] +} + +# ### ### ### ######### ######### ######### ########################### +## Internal commands + +proc ::bench::out::PADL {max str} { + format "%${max}s" $str + #return "[PAD $max $str]$str" +} + +proc ::bench::out::PADR {max str} { + format "%-${max}s" $str + #return "$str[PAD $max $str]" +} + +# ### ### ### ######### ######### ######### ########################### +## Initialize internal data structures. + +# ### ### ### ######### ######### ######### ########################### +## Ready to run + +package provide bench::out::text 0.1.3 diff --git a/src/vfs/critclxxx.vfs/lib/tcllib2.0/bench/libbench.tcl b/src/vfs/critclxxx.vfs/lib/tcllib2.0/bench/libbench.tcl new file mode 100644 index 00000000..ebf9f716 --- /dev/null +++ b/src/vfs/critclxxx.vfs/lib/tcllib2.0/bench/libbench.tcl @@ -0,0 +1,561 @@ +# -*- tcl -*- +# libbench.tcl ?(