From b69d0e50f38f681836937befa8977ea106f525e8 Mon Sep 17 00:00:00 2001 From: Julian Noble Date: Mon, 22 Jun 2026 02:38:38 +1000 Subject: [PATCH] punk::path and punk::lib fixes --- src/bootsupport/modules/fauxlink-0.1.1.tm | 2 +- src/bootsupport/modules/funcl-0.1.tm | 11 +- src/bootsupport/modules/metaface-1.2.9.tm | 6364 +++++++++++ src/bootsupport/modules/oolib-0.1.3.tm | 200 + src/bootsupport/modules/overtype-1.7.4.tm | 992 +- src/bootsupport/modules/packagetest-0.1.8.tm | Bin 0 -> 12718 bytes src/bootsupport/modules/punk-0.1.1.tm | 9302 +++++++++++++++++ .../modules/punk/aliascore-0.1.0.tm | 1 + src/bootsupport/modules/punk/ansi-0.1.1.tm | 1178 ++- .../modules/punk/ansi/sauce-0.1.0.tm | 88 +- src/bootsupport/modules/punk/args-0.2.1.tm | 2 +- src/bootsupport/modules/punk/char-0.1.0.tm | 213 +- src/bootsupport/modules/punk/console-0.1.1.tm | 5 - src/bootsupport/modules/punk/du-0.1.0.tm | 33 +- src/bootsupport/modules/punk/lib-0.1.6.tm | 331 +- src/bootsupport/modules/punk/mix/cli-0.3.1.tm | 2 +- .../punk/mix/commandset/loadedlib-0.1.0.tm | 9 +- .../punk/mix/commandset/module-0.1.0.tm | 2 +- .../punk/mix/commandset/project-0.1.0.tm | 42 +- .../modules/punk/mix/util-0.1.0.tm | 11 +- src/bootsupport/modules/punk/mod-0.1.1.tm | 158 + src/bootsupport/modules/punk/nav/fs-0.1.0.tm | 2 +- src/bootsupport/modules/punk/ns-0.1.0.tm | 38 +- src/bootsupport/modules/punk/overlay-0.1.1.tm | 192 + src/bootsupport/modules/punk/path-0.1.0.tm | 929 +- src/bootsupport/modules/punk/pipe-1.0.tm | 5 +- src/bootsupport/modules/punk/repo-0.1.1.tm | 17 +- src/bootsupport/modules/punkapp-0.1.1.tm | 240 + src/bootsupport/modules/punkcheck-0.1.1.tm | 2458 +++++ .../modules/punkcheck/cli-0.1.0.tm | 32 +- src/bootsupport/modules/shellfilter-0.2.2.tm | 201 +- src/bootsupport/modules/shellrun-0.1.2.tm | 897 ++ src/bootsupport/modules/zipper-0.14.tm | Bin 9926 -> 9928 bytes src/bootsupport/modules/zzzload-0.1.0.tm | 25 +- src/make.tcl | 16 +- src/modules/punk/args-999999.0a1.0.tm | 2 +- src/modules/punk/path-999999.0a1.0.tm | 2 +- src/modules/punkcheck-999999.0a1.0.tm | 10 +- .../custom/_project/punk.basic/src/make.tcl | 16 +- .../src/bootsupport/modules/fauxlink-0.1.1.tm | 2 +- .../src/bootsupport/modules/funcl-0.1.tm | 11 +- .../src/bootsupport/modules/metaface-1.2.9.tm | 6364 +++++++++++ .../src/bootsupport/modules/oolib-0.1.3.tm | 200 + .../src/bootsupport/modules/overtype-1.7.4.tm | 992 +- .../bootsupport/modules/packagetest-0.1.8.tm | Bin 0 -> 12718 bytes .../src/bootsupport/modules/punk-0.1.1.tm | 9302 +++++++++++++++++ .../modules/punk/aliascore-0.1.0.tm | 1 + .../bootsupport/modules/punk/ansi-0.1.1.tm | 1178 ++- .../modules/punk/ansi/sauce-0.1.0.tm | 88 +- .../bootsupport/modules/punk/args-0.2.1.tm | 2 +- .../bootsupport/modules/punk/char-0.1.0.tm | 213 +- .../bootsupport/modules/punk/console-0.1.1.tm | 5 - .../src/bootsupport/modules/punk/du-0.1.0.tm | 33 +- .../src/bootsupport/modules/punk/lib-0.1.6.tm | 331 +- .../bootsupport/modules/punk/mix/cli-0.3.1.tm | 2 +- .../punk/mix/commandset/loadedlib-0.1.0.tm | 9 +- .../punk/mix/commandset/module-0.1.0.tm | 2 +- .../punk/mix/commandset/project-0.1.0.tm | 42 +- .../modules/punk/mix/util-0.1.0.tm | 11 +- .../src/bootsupport/modules/punk/mod-0.1.1.tm | 158 + .../bootsupport/modules/punk/nav/fs-0.1.0.tm | 2 +- .../src/bootsupport/modules/punk/ns-0.1.0.tm | 38 +- .../bootsupport/modules/punk/overlay-0.1.1.tm | 192 + .../bootsupport/modules/punk/path-0.1.0.tm | 929 +- .../src/bootsupport/modules/punk/pipe-1.0.tm | 5 +- .../bootsupport/modules/punk/repo-0.1.1.tm | 17 +- .../src/bootsupport/modules/punkapp-0.1.1.tm | 240 + .../bootsupport/modules/punkcheck-0.1.1.tm | 2458 +++++ .../modules/punkcheck/cli-0.1.0.tm | 32 +- .../bootsupport/modules/shellfilter-0.2.2.tm | 201 +- .../src/bootsupport/modules/shellrun-0.1.2.tm | 897 ++ .../src/bootsupport/modules/zipper-0.14.tm | Bin 9926 -> 9928 bytes .../src/bootsupport/modules/zzzload-0.1.0.tm | 25 +- .../_project/punk.project-0.1/src/make.tcl | 16 +- .../src/bootsupport/modules/fauxlink-0.1.1.tm | 2 +- .../src/bootsupport/modules/funcl-0.1.tm | 11 +- .../src/bootsupport/modules/metaface-1.2.9.tm | 6364 +++++++++++ .../src/bootsupport/modules/oolib-0.1.3.tm | 200 + .../src/bootsupport/modules/overtype-1.7.4.tm | 992 +- .../bootsupport/modules/packagetest-0.1.8.tm | Bin 0 -> 12718 bytes .../src/bootsupport/modules/punk-0.1.1.tm | 9302 +++++++++++++++++ .../modules/punk/aliascore-0.1.0.tm | 1 + .../bootsupport/modules/punk/ansi-0.1.1.tm | 1178 ++- .../modules/punk/ansi/sauce-0.1.0.tm | 88 +- .../bootsupport/modules/punk/args-0.2.1.tm | 2 +- .../bootsupport/modules/punk/char-0.1.0.tm | 213 +- .../bootsupport/modules/punk/console-0.1.1.tm | 5 - .../src/bootsupport/modules/punk/du-0.1.0.tm | 33 +- .../src/bootsupport/modules/punk/lib-0.1.6.tm | 331 +- .../bootsupport/modules/punk/mix/cli-0.3.1.tm | 2 +- .../punk/mix/commandset/loadedlib-0.1.0.tm | 9 +- .../punk/mix/commandset/module-0.1.0.tm | 2 +- .../punk/mix/commandset/project-0.1.0.tm | 42 +- .../modules/punk/mix/util-0.1.0.tm | 11 +- .../src/bootsupport/modules/punk/mod-0.1.1.tm | 158 + .../bootsupport/modules/punk/nav/fs-0.1.0.tm | 2 +- .../src/bootsupport/modules/punk/ns-0.1.0.tm | 38 +- .../bootsupport/modules/punk/overlay-0.1.1.tm | 192 + .../bootsupport/modules/punk/path-0.1.0.tm | 929 +- .../src/bootsupport/modules/punk/pipe-1.0.tm | 5 +- .../bootsupport/modules/punk/repo-0.1.1.tm | 17 +- .../src/bootsupport/modules/punkapp-0.1.1.tm | 240 + .../bootsupport/modules/punkcheck-0.1.1.tm | 2458 +++++ .../modules/punkcheck/cli-0.1.0.tm | 32 +- .../bootsupport/modules/shellfilter-0.2.2.tm | 201 +- .../src/bootsupport/modules/shellrun-0.1.2.tm | 897 ++ .../src/bootsupport/modules/zipper-0.14.tm | Bin 9926 -> 9928 bytes .../src/bootsupport/modules/zzzload-0.1.0.tm | 25 +- .../_project/punk.shell-0.1/src/make.tcl | 16 +- .../modules/packagetest-0.1.7.tm | Bin 12090 -> 12720 bytes .../modules/packagetest-0.1.8.tm | Bin 0 -> 12718 bytes src/vfs/_vfscommon.vfs/modules/punk-0.1.1.tm | 28 +- .../_vfscommon.vfs/modules/punk/ansi-0.1.1.tm | 3 +- .../_vfscommon.vfs/modules/punk/args-0.2.1.tm | 2 +- .../_vfscommon.vfs/modules/punk/char-0.1.0.tm | 12 +- .../_vfscommon.vfs/modules/punk/lib-0.1.6.tm | 328 +- .../modules/punk/mix/cli-0.3.1.tm | 2 +- .../punk/mix/commandset/module-0.1.0.tm | 2 +- .../punk/mix/commandset/project-0.1.0.tm | 42 +- .../modules/punk/mix/util-0.1.0.tm | 11 +- .../_vfscommon.vfs/modules/punk/ns-0.1.0.tm | 16 + .../_vfscommon.vfs/modules/punk/path-0.1.0.tm | 867 +- .../_vfscommon.vfs/modules/punkcheck-0.1.1.tm | 117 +- .../modules/shellfilter-0.2.2.tm | 201 +- .../modules/test/overtype-1.7.4.tm | Bin 14001 -> 14021 bytes .../modules/test/runtestmodules.tcl | 115 +- 126 files changed, 69875 insertions(+), 3895 deletions(-) create mode 100644 src/bootsupport/modules/metaface-1.2.9.tm create mode 100644 src/bootsupport/modules/oolib-0.1.3.tm create mode 100644 src/bootsupport/modules/packagetest-0.1.8.tm create mode 100644 src/bootsupport/modules/punk-0.1.1.tm create mode 100644 src/bootsupport/modules/punk/mod-0.1.1.tm create mode 100644 src/bootsupport/modules/punk/overlay-0.1.1.tm create mode 100644 src/bootsupport/modules/punkapp-0.1.1.tm create mode 100644 src/bootsupport/modules/punkcheck-0.1.1.tm create mode 100644 src/bootsupport/modules/shellrun-0.1.2.tm create mode 100644 src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/metaface-1.2.9.tm create mode 100644 src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/oolib-0.1.3.tm create mode 100644 src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/packagetest-0.1.8.tm create mode 100644 src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk-0.1.1.tm create mode 100644 src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mod-0.1.1.tm create mode 100644 src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/overlay-0.1.1.tm create mode 100644 src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punkapp-0.1.1.tm create mode 100644 src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punkcheck-0.1.1.tm create mode 100644 src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/shellrun-0.1.2.tm create mode 100644 src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/metaface-1.2.9.tm create mode 100644 src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/oolib-0.1.3.tm create mode 100644 src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/packagetest-0.1.8.tm create mode 100644 src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk-0.1.1.tm create mode 100644 src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mod-0.1.1.tm create mode 100644 src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/overlay-0.1.1.tm create mode 100644 src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punkapp-0.1.1.tm create mode 100644 src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punkcheck-0.1.1.tm create mode 100644 src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/shellrun-0.1.2.tm create mode 100644 src/vfs/_vfscommon.vfs/modules/packagetest-0.1.8.tm diff --git a/src/bootsupport/modules/fauxlink-0.1.1.tm b/src/bootsupport/modules/fauxlink-0.1.1.tm index 970e47da..2fc9c5fb 100644 --- a/src/bootsupport/modules/fauxlink-0.1.1.tm +++ b/src/bootsupport/modules/fauxlink-0.1.1.tm @@ -205,7 +205,7 @@ namespace eval fauxlink { # %2F "/" # %2f "/" # %7f (del) - #we exlude the forward slash because we already have + for that - and multiple ways to specify it obscure intention. + #we exclude the forward slash because we already have + for that - and multiple ways to specify it obscure intention. # set decode_map [dict merge $decode_map [dict create\ %09 \t\ diff --git a/src/bootsupport/modules/funcl-0.1.tm b/src/bootsupport/modules/funcl-0.1.tm index e8430fb0..f36a1f64 100644 --- a/src/bootsupport/modules/funcl-0.1.tm +++ b/src/bootsupport/modules/funcl-0.1.tm @@ -1,3 +1,6 @@ + +#experimental. + package provide funcl [namespace eval funcl { variable version set version 0.1 @@ -210,7 +213,7 @@ namespace eval funcl { } append body [join [lreverse $tails] " "] #puts stdout "tails: $tails" - + return $body } @@ -225,7 +228,7 @@ namespace eval funcl { # _fn 0 indicates next item is an unwrapped commandlist (terminal command) # #o_of is equivalent to o_of_n 1 (1 argument o combinator) - #last n args are passed to the prior function + #last n args are passed to the prior function #e.g for n=1 f a b = f(a(b)) #e.g for n=2, e f a b = e(f(a b)) proc o_of_n {n args} { @@ -235,7 +238,7 @@ namespace eval funcl { } set comp [list] ;#composition list set end [lindex $args end] - if {[lindex $end 0] in {_fn _call}]} { + if {[lindex $end 0] in {_fn _call}} { #is_funcl set endfunc [lindex $args end] } else { @@ -246,7 +249,7 @@ namespace eval funcl { set endfunc [list _call 1 3 [list {*}$end]] } } - + if {[llength $args] == 1} { return $endfunc } diff --git a/src/bootsupport/modules/metaface-1.2.9.tm b/src/bootsupport/modules/metaface-1.2.9.tm new file mode 100644 index 00000000..aabb5435 --- /dev/null +++ b/src/bootsupport/modules/metaface-1.2.9.tm @@ -0,0 +1,6364 @@ +package provide metaface [namespace eval metaface { + variable version + set version 1.2.9 +}] + +# 2025-09-29 - update outdated 'trace vinfo' to 'trace info variable' - both work for 8.6, but vinfo deprecated for tcl 9+ +# 2023-07 - add .. MetaMethods + + +#example datastructure: +#$_ID_ +#{ +#i +# { +# this +# { +# {16 ::p::16 item ::>x {}} +# } +# role2 +# { +# {17 ::p::17 item ::>y {}} +# {18 ::p::18 item ::>z {}} +# } +# } +#context {} +#} + +#$MAP +#invocantdata {16 ::p::16 item ::>x {}} +#interfaces {level0 +# { +# api0 {stack {123 999}} +# api1 {stack {333}} +# } +# level0_default api0 +# level1 +# { +# } +# level1_default {} +# } +#patterndata {patterndefaultmethod {}} + + +namespace eval ::p::predator {} +#temporary alternative to ::p::internals namespace. +# - place predator functions here until ready to replace internals. + + +namespace eval ::p::snap { + variable id 0 ;#ever-increasing non-reused snapshot-id to identify ::p::snapshot namespaces used to allow overlay-rollbacks. +} + + + + +# not called directly. Retrieved using 'info body ::p::predator::getprop_template' +#review - why use a proc instead of storing it as a string? +proc ::p::predator::getprop_template {_ID_ args} { + set OID [lindex [dict get $_ID_ i this] 0 0] + if {"%varspace%" eq ""} { + set ns ::p::${OID} + } else { + if {[string match "::*" "%varspace%"]} { + set ns "%varspace%" + } else { + set ns ::p::${OID}::%varspace% + } + } + + + if {[llength $args]} { + #lassign [lindex $invocant 0] OID alias itemCmd cmd + if {[array exists ${ns}::o_%prop%]} { + #return [set ${ns}::o_%prop%($args)] + if {[llength $args] == 1} { + return [set ::p::${OID}::o_%prop%([lindex $args 0])] + } else { + return [lindex [set ::p::${OID}::o_%prop%([lindex $args 0])] {*}[lrange $args 1 end]] + } + } else { + set val [set ${ns}::o_%prop%] + + set rType [expr {[scan [namespace tail $val] >%s rType] ? {object} : {unknown}}] + if {$rType eq "object"} { + #return [$val . item {*}$args] + return [$val {*}$args] + } else { + #treat as list? + return [lindex $val $args] + } + } + } else { + return [set ${ns}::o_%prop%] + } +} + + +proc ::p::predator::getprop_template_immediate {_ID_ args} { + if {[llength $args]} { + if {[array exists %ns%::o_%prop%]} { + return [set %ns%::o_%prop%($args)] + } else { + set val [set %ns%::o_%prop%] + set rType [expr {[scan [namespace tail $val] >%s rType] ? {object} : {unknown}}] + if {$rType eq "object"} { + #return [$val . item {*}$args] + #don't assume defaultmethod named 'item'! + return [$val {*}$args] + } else { + #treat as list? + return [lindex $val $args] + } + } + } else { + return [set %ns%::o_%prop%] + } +} + + + + + + + + +proc ::p::predator::getprop_array {_ID_ prop args} { + set OID [lindex [dict get $_ID_ i this] 0 0] + + #upvar 0 ::p::${OID}::o_${prop} prop + #1st try: assume array + if {[catch {array get ::p::${OID}::o_${prop}} result]} { + #treat as list (why?) + #!review + if {[info exists ::p::${OID}::o_${prop}]} { + array set temp [::list] + set i 0 + foreach element ::p::${OID}::o_${prop} { + set temp($i) $element + incr i + } + set result [array get temp] + } else { + error "unable to retrieve [set ::p::${OID}::o_${prop}] contents in 'array get' format" + } + } + return $result +} + +proc ::p::predator::setprop_template {prop _ID_ args} { + set OID [lindex [dict get $_ID_ i this] 0 0] + if {"%varspace%" eq ""} { + set ns ::p::${OID} + } else { + if {[string match "::*" "%varspace%"]} { + set ns "%varspace%" + } else { + set ns ::p::${OID}::%varspace% + } + } + + + if {[llength $args] == 1} { + #return [set ::p::${OID}::o_%prop% [lindex $args 0]] + return [set ${ns}::o_%prop% [lindex $args 0]] + + } else { + if {[array exists ${ns}::o_%prop%] || ![info exists ${ns}::o_%prop%]} { + #treat attempt to perform indexed write to nonexistant var, same as indexed write to array + + #2 args - single index followed by a value + if {[llength $args] == 2} { + return [set ${ns}::o_%prop%([lindex $args 0]) [lindex $args 1]] + } else { + #multiple indices + #return [set ::p::${OID}::o_%prop%([lrange $args 0 end-1]) [lindex $args end]] + return [lset ${ns}::o_%prop%([lindex $args 0]) {*}[lrange $args 1 end-1] [lindex $args end] ] + } + } else { + #treat as list + return [lset ${ns}::o_%prop% [lrange $args 0 end-1] [lindex $args end]] + } + } +} + +#-------------------------------------- +#property read & write traces +#-------------------------------------- + + +proc ::p::predator::propref_trace_read {get_cmd _ID_ refname prop indices vtraced idx op} { + + #puts stderr "\t-->propref_trace_read get_cmd:'$get_cmd' refname:'$refname' prop:'$prop' indices:'$indices' $vtraced idx:'$idx' " + + #set cmd ::p::${OID}::(GET)$prop ;#this is an interp alias to the head of the implementation command-chain. + + if {[llength $idx]} { + if {[llength $idx] == 1} { + set ${refname}($idx) [$get_cmd $_ID_ {*}$indices $idx] + } else { + lset ${refname}([lindex $idx 0]) [lrange $idx 1 end] [$get_cmd $_ID_ {*}$indices {*}$idx] + } + return ;#return value ignored - in a trace we can only return the value by setting the traced variable to a value + } else { + if {![info exists $refname]} { + set $refname [$get_cmd $_ID_ {*}$indices] + } else { + set newval [$get_cmd $_ID_ {*}$indices] + if {[set $refname] ne $newval} { + set $refname $newval + } + } + return + } +} + + + + +proc ::p::predator::propref_trace_write {_ID_ OID full_varspace refname vname idx op} { + #note 'vname' may be upvar-ed local - we need the fully qualified name so must use passed in $refname + #puts stdout "\t-->propref_trace_write $OID ref:'$refname' var:'$vname' idx:'$idx'" + + + #derive the name of the write command from the ref var. + set indices [lassign [split [namespace tail $refname] +] prop] + + + #assert - we will never have both a list in indices and an idx value + if {[llength $indices] && ($idx ne "")} { + #since Tcl has no nested arrays - we can't write to an idx within something like ${prop}+x + #review - are there any datastructures which would/should allow this? + #this assertion is really just here as a sanity check for now + error "propref_trace_write unexpected values. Didn't expect a refname of the form ${prop}+* as well as an idx value" + } + + #upvar #0 ::p::${OID}::_meta::map MAP + #puts "-->propref_trace_write map: $MAP" + + #temporarily deactivate refsync trace + #puts stderr -->1>--removing_trace_o_${field} +### trace remove variable ::p::${OID}::o_${prop} [::list write] [::list ::p::predator::propvar_write_TraceHandler $OID $prop] + + #we need to catch, and re-raise any error that we may receive when writing the property + # because we have to reinstate the propvar_write_TraceHandler after the call. + #(e.g there may be a propertywrite handler that deliberately raises an error) + + set excludesync_refs $refname + set cmd ::p::${OID}::(SET)$prop + + + set f_error 0 + if {[catch { + + if {![llength $indices]} { + if {[string length $idx]} { + $cmd $_ID_ $idx [set ${refname}($idx)] + #::p::predator::refsyncvar_write_manualupdate $OID $excludesync_refs $prop ::p::${OID}::o_${prop}($idx) [list] + ### ::p::predator::refsyncvar_write_manualupdate $OID $excludesync_refs $prop ::p::${OID}::o_${prop} [list $idx] + + } else { + $cmd $_ID_ [set $refname] + ### ::p::predator::refsyncvar_write_manualupdate $OID $excludesync_refs $prop ::p::${OID}::o_${prop} [list] + } + } else { + #puts " ++>> cmd:$cmd indices:'$indices' refname:'$refname'\n" + $cmd $_ID_ {*}$indices [set $refname] + ### ::p::predator::refsyncvar_write_manualupdate $OID $excludesync_refs $prop ::p::${OID}::o_${prop} $indices + } + + } result]} { + set f_error 1 + } + + + + + #::p::predator::propvar_write_TraceHandler $OID $prop ::p::${OID}::o_${prop} $indices write + #reactivate refsync trace + #puts stderr "****** reactivating refsync trace on o_$field" + #puts stderr -->2>--reactivating_trace_o_${field} + ### trace add variable ::p::${OID}::o_${prop} [::list write] [::list ::p::predator::propvar_write_TraceHandler $OID $prop] + + + if {$f_error} { + #!todo - review error & 'return' functions for proper way to throw error, preserving callstack info for debugging. + # ? return -code error $errMsg ? -errorinfo + + #!quick n dirty + #error $errorMsg + return -code error -errorinfo $::errorInfo $result + } else { + return $result + } +} + + + + + +proc ::p::predator::propref_trace_array {_ID_ OID refname vref idx op} { + #puts stderr "\t-->propref_trace_array OID:$OID refname:'$refname' var:'$vref' index:'$idx' operation:'$op'" + #NOTE - do not rely on $vref !!!! (can be upvared - so could be anything. e.g during 'parray' calls it is set to 'array') + + set indices [lassign [split [namespace tail $refname] +] prop] ;#make sure 'prop' is set + + #set updated_value [::p::predator::getprop_array $prop $_ID_] + #puts stderr "-->array_Trace updated_value:$updated_value" + if {[catch {array set $refname [::p::predator::getprop_array $_ID_ $prop ]} errm]} { + puts stderr "-->propref_trace_array error $errm" + array set $refname {} + } + + #return value ignored for +} + + +#-------------------------------------- +# +proc ::p::predator::object_array_trace {OID _ID_ vref idx op} { + upvar #0 ::p::${OID}::_meta::map MAP + lassign [dict get $MAP invocantdata] OID alias itemCmd + + + #don't rely on variable name passed by trace - may have been 'upvar'ed + set refvar ::p::${OID}::_ref::__OBJECT + + #puts "+=====>object_array_trace $map '$vref' '$idx' '$op' refvar: $refvar" + + set iflist [dict get $MAP interfaces level0] + + set plist [list] + + #!todo - get propertylist from cache on object(?) + foreach IFID [lreverse $iflist] { + dict for {prop pdef} [set ::p::${IFID}::_iface::o_properties] { + #lassign $pdef v + if {[catch {lappend plist $prop [set ::p::${OID}::o_${prop}]}]} { + if {[array exists ::p::${OID}::o_${prop}]} { + lappend plist $prop [array get ::p::${OID}::o_${prop}] + } else { + #ignore - array only represents properties that have been set. + #error "property $v is not set" + #!todo - unset corresponding items in $refvar if needed? + } + } + } + } + array set $refvar $plist +} + + +proc ::p::predator::object_read_trace {OID _ID_ vref idx op} { + upvar #0 ::p::${OID}::_meta::map MAP + lassign [dict get $MAP invocantdata] OID alias itemCmd + #don't rely on variable name passed by trace. + set refvar ::p::${OID}::_ref::__OBJECT + + #puts "\n\n+=====>object_read_trace map:'$MAP' '$vref' '$idx' '$op' refvar: $refvar\n\n" + + #!todo? - build a list of all interface properties (cache it on object??) + set iflist [dict get $MAP interfaces level0] + set IID "" + foreach id [lreverse $iflist] { + if {$idx in [dict keys [set ::p::${id}::_iface::o_properties]]} { + set IID $id + break + } + } + + if {[string length $IID]} { + #property + if {[catch {set ${refvar}($idx) [::p::${id}::_iface::(GET)$idx $_ID_]} errmsg]} { + puts stderr "\twarning: ::p::${id}::_iface::(GET)$idx retrieval failed (array?) errmsg:$errmsg" + } + } else { + #method + error "property '$idx' not found" + } +} + + +proc ::p::predator::object_unset_trace {OID _ID_ vref idx op} { + upvar #0 ::p::${OID}::_meta::map MAP + + lassign [dict get $MAP invocantdata] OID alias itemCmd + + #!todo - ??? + + if {![llength [info commands ::p::${OID}::$idx]]} { + error "no such method or property: '$idx'" + } else { + #!todo? - build a list of all interface properties (cache it on object??) + set iflist [dict get $MAP interfaces level0] + set found 0 + foreach id [lreverse $iflist] { + if {$idx in [dict keys [set ::p::${id}::_iface::o_properties]]} { + set found 1 + break + } + } + + if {$found} { + unset ::p::${OID}::o_$idx + } else { + puts stderr "\tWARNING: UNIMPLEMENTED CASE! (unset) object_unset_trace id:$OID objectcmd:[lindex [dict get $MAP invocantdata] 3] var:$vref prop:$idx" + } + } +} + + +proc ::p::predator::object_write_trace {OID _ID_ vref idx op} { + upvar #0 ::p::${OID}::_meta::map MAP + lassign [dict get $MAP invocantdata] OID alias itemCmd + #don't rely on variable name passed by trace. + set refvar ::p::${OID}::_ref::__OBJECT + #puts "+=====>object_write_trace $MAP '$vref' '$idx' '$op' refvar: $refvar" + + + if {![llength [info commands ::p::${OID}::$idx]]} { + #!todo - create new property in interface upon attempt to write to non-existant? + # - or should we require some different kind of object-reference for that? + array unset $refvar $idx ;#make sure 'array names' on the ref doesn't include this $idx + error "no such method or property: '$idx'" + } else { + #!todo? - build a list of all interface properties (cache it on object??) + set iflist [dict get $MAP interfaces level0] + set IID "" + foreach id [lreverse $iflist] { + if {$idx in [dict keys [set ::p::${id}::_iface::o_properties]]} { + set IID $id + break + } + } + + #$IID is now topmost interface in default iStack which has this property + + if {[string length $IID]} { + #write to defined property + + ::p::${IID}::_iface::(SET)$idx $_ID_ [set ${refvar}($idx)] + } else { + #!todo - allow write of method body back to underlying object? + #attempted write to 'method' ..undo(?) + array unset $refvar $idx ;#make sure 'array names' on the ref doesn't include this $idx + error "cannot write to method '$idx'" + #for now - disallow + } + } + +} + + + +proc ::p::predator::propref_trace_unset {_ID_ OID refname vref idx op} { + #note 'vref' may be upvar-ed local - we need the fully qualified name so must use passed in $refname + + set refindices [lassign [split [namespace tail $refname] +] prop] + #derive the name of any potential PropertyUnset command from the refname. i.e (UNSET)$prop + #if there is no PropertyUnset command - we unset the underlying variable directly + + trace remove variable ::p::${OID}::o_${prop} [::list unset] [::list ::p::predator::propvar_unset_TraceHandler $OID $prop] + + + if {[catch { + + #assert if refname is complex (prop+idx etc), we will not get a reference trace with an $idx value + #i.e + if {[llength $refindices] && [string length $idx]} { + puts stderr "\t !!!!! unexpected call to propref_trace_unset oid:'$OID' refname:'$refname' vref:'$vref' idx:'$idx' op:'$op'" + error "unexpected call to propref_trace_unset" + } + + + upvar #0 ::p::${OID}::_meta::map MAP + + set iflist [dict get $MAP interfaces level0] + #find topmost interface containing this $prop + set IID "" + foreach id [lreverse $iflist] { + if {$prop in [dict keys [set ::p::${id}::_iface::o_properties]]} { + set IID $id + break + } + } + if {![string length $IID]} { + error "propref_trace_unset failed to find property '$prop' on objectid $OID ([lindex [dict get $_ID_ i this] 0 3])" + } + + + + if {[string length $idx]} { + #eval "$_alias ${unset_}$field $idx" + #what happens to $refindices??? + + + #!todo varspace + + if {![llength $refindices]} { + #puts stdout "\t 1a@@@@ propref_trace_unset $OID ref:'$refname' var:'$vref' idx:'$idx'" + + if {![llength [info commands ::p::${IID}::_iface::(UNSET)$prop]]} { + unset ::p::${OID}::o_${prop}($idx) + } else { + ::p::${IID}::_iface::(UNSET)$prop $_ID_ $idx + } + + + #manually call refsync, passing it this refvar as an exclusion + ::p::predator::refsyncvar_unset_manualupdate $OID $refname $prop ::p::${OID}::o_${prop} $idx + } else { + #assert - won't get here + error 1a + + } + + } else { + if {[llength $refindices]} { + #error 2a + #puts stdout "\t 2a@@@@ propref_trace_unset $OID ref:'$refname' var:'$vref' idx:'$idx'" + + if {![llength [info commands ::p::${IID}::_iface::(UNSET)$prop]]} { + #review - what about list-type property? + #if {[array exists ::p::${OID}::o_${prop}]} ??? + unset ::p::${OID}::o_${prop}($refindices) + } else { + ::p::${IID}::_iface::(UNSET)$prop $_ID_ $refindices + } + + + + #manually call refsync, passing it this refvar as an exclusion + ::p::predator::refsyncvar_unset_manualupdate $OID $refname $prop ::p::${OID}::o_${prop} $refindices + + + } else { + #puts stdout "\t 2b@@@@ propref_trace_unset $OID ref:'$refname' var:'$vref' idx:'$idx'" + + #ref is not of form prop+x etc and no idx in the trace - this is a plain unset + if {![llength [info commands ::p::${IID}::_iface::(UNSET)$prop]]} { + unset ::p::${OID}::o_${prop} + } else { + ::p::${IID}::_iface::(UNSET)$prop $_ID_ "" + } + #manually call refsync, passing it this refvar as an exclusion + ::p::predator::refsyncvar_unset_manualupdate $OID $refname $prop ::p::${OID}::o_${prop} {} + + } + } + + + } errM]} { + #set ::LAST_UNSET_ERROR "$errM\n[set ::errorInfo]" + set ruler [string repeat - 80] + puts stderr "\t$ruler" + puts stdout "\t @@@@ERROR propref_trace_unset $OID ref:'$refname' var:'$vref' idx:'$idx'" + puts stderr "\t$ruler" + puts stderr $errM + puts stderr "\t$ruler" + + } else { + #puts stdout "\t @@@@ propref_trace_unset $OID ref:'$refname' var:'$vref' idx:'$idx'" + #puts stderr "*@*@*@*@ end propref_trace_unset - no error" + } + + trace add variable ::p::${OID}::o_${prop} [::list unset] [::list ::p::predator::propvar_unset_TraceHandler $OID $prop] + + +} + + + + +proc ::p::predator::refsyncvar_unset_manualupdate {OID triggeringRef prop vtraced vidx} { + #Do not use 'info exists' (avoid triggering read trace) - use info vars + if {[info vars ::p::${OID}::_ref::$prop] eq "::p::${OID}::_ref::$prop"} { + #puts " **> lappending '::p::REF::${OID}::$prop'" + lappend refvars ::p::${OID}::_ref::$prop + } + lappend refvars {*}[info vars ::p::${OID}::_ref::${prop}+*] + + if {[string length $triggeringRef]} { + set idx [lsearch -exact $refvars $triggeringRef] + if {$idx >= 0} { + set refvars [lreplace $refvars[set refvars {}] $idx $idx] ;#note inline K combinator [set refvars {}] + } + } + if {![llength $refvars]} { + #puts stderr " %%%%%%%%%% no refvars for propvar_unset_TraceHandler to update - short circuiting . $OID $triggeringRef $prop $vtraced $vidx" + return + } + + + #*usually* triggeringRef is not in the reflist because the triggeringRef is being unset + # - but this is not the case when we do an array unset of an element using a reference to the whole array e.g "array unset [>obj . arr .] b" + if {([string length $triggeringRef]) && ($triggeringRef in $refvars)} { + #puts stderr "\t@@@@@@@@@@ propvar_unset_TraceHandler unexpected situation. triggeringRef $triggeringRef in refvars:$refvars during unset ???" + puts stderr "\t@@@@@ propvar_unset_TraceHandler triggeringRef $triggeringRef is in refvars list - probably a call of form 'array unset \[>obj .arr .\] someindex'" + } + + + puts stderr "\t refsyncvar_unset_manualupdate OID:'$OID' triggeringRef:'$triggeringRef' prop:'$prop' vtraced:'$vtraced' vidx:'$vidx' " + + + + upvar $vtraced SYNCVARIABLE + + + #We are only interested in suppressing the 'setGet_TraceHandler' traces on refvars + array set traces [::list] + + #puts stderr "*-*-*-*-*-* refvars \n- [join $refvars "\n- "]" + + + foreach rv $refvars { + #puts "--refvar $rv" + foreach tinfo [trace info variable $rv] { + #puts "##trace $tinfo" + set ops {}; set cmd {} + lassign $tinfo ops cmd + #!warning - assumes traces with single operation per handler. + #write & unset traces on refvars need to be suppressed + #we also need to be able to read certain refvars without triggering retrieval of underlying value in order to detect if changed. + if {$ops in {read write unset array}} { + if {[string match "::p::predator::propref_trace_*" $cmd]} { + lappend traces($rv) $tinfo + trace remove variable $rv $ops $cmd + #puts stderr "*-*-*-*-*-* removing $ops trace on $rv -> $cmd" + } + } + } + } + + + if {[array exists SYNCVARIABLE]} { + #underlying variable is an array - we are presumably unsetting just an element + set vtracedIsArray 1 + } else { + #!? maybe the var was an array - but it's been unset? + set vtracedIsArray 0 + } + + #puts stderr "--------------------------------------------------\n\n" + #some things we don't want to repeat for each refvar in case there are lots of them.. + + #set triggeringRefIdx $vidx + + if {[string match "${prop}+*" [namespace tail $triggeringRef]]} { + set triggering_indices [lrange [split [namespace tail $triggeringRef] +] 1 end] + } else { + set triggering_indices [list] + } + + + #puts stderr ">>>...----refsync-trace = $vtraced $op refvars:$refvars" + #puts stderr ">>> [trace info variable $vtraced]" + #puts "--- unset branch refvar:$refvar" + + if {[llength $vidx]} { + #trace called with an index - must be an array + foreach refvar $refvars { + set reftail [namespace tail $refvar] + + if {[string match "${prop}+*" $reftail]} { + #!todo - add test + if {$vidx eq [lrange [split $reftail +] 1 end]} { + #unset if indices match + error "untested, possibly unused branch spuds1" + #puts "1111111111111111111111111" + unset $refvar + } + } else { + #test exists - #!todo - document which one + + #see if we succeeded in unsetting this element in the underlying variables + #(may have been blocked by a PropertyUnset body) + set element_exists [uplevel 1 [::list info exists ${vtraced}($vidx)]] + #puts "JJJJJJ vtraced:$vtraced vidx:$vidx element_exists:$element_exists" + if {$element_exists} { + #do nothing it wasn't actually unset + } else { + #puts "JJJJJ unsetting ${refvar}($vidx)" + unset ${refvar}($vidx) + } + } + } + + } else { + + foreach refvar $refvars { + set reftail [namespace tail $refvar] + + if {[string match "${prop}+*" $reftail]} { + #check indices of triggering refvar match this refvars indices + + if {$reftail eq [namespace tail $triggeringRef]} { + #!todo - add test + error "untested, possibly unused branch spuds2" + #puts "222222222222222222" + unset $refvar + } else { + + #error "untested - branch spuds2a" + + } + + } else { + #!todo -add test + #reference is directly to property var + error "untested, possibly unused branch spuds3" + #theoretically no other non-indexed ref.. so $triggeringRefIdx must contain non-zero-len string? + puts "\t33333333333333333333" + + if {[string length $triggeringRefIdx]} { + unset $refvar($triggeringRefIdx) + } + } + } + + } + + #!todo - understand. + #puts stderr "\n*****\n propvar_unset_TraceHandler $refvar unset $prop $args \n*****\n" + #catch {unset $refvar} ;#oops - Tcl_EventuallyFree called twice - abnormal program termination (tcl8.4?) + + + #reinstall the traces we stored at the beginning of this proc. + foreach rv [array names traces] { + foreach tinfo $traces($rv) { + set ops {}; set cmd {} + lassign $tinfo ops cmd + + #puts stderr "****** re-installing setGet trace '$ops' on variable $rv" + trace add variable $rv $ops $cmd + } + } + + + + + +} + + +proc ::p::predator::propvar_unset_TraceHandler {OID prop vtraced vidx op} { + + upvar $vtraced SYNCVARIABLE + + set refvars [::list] + #Do not use 'info exists' (avoid triggering read trace) - use info vars + if {[info vars ::p::${OID}::_ref::$prop] eq "::p::${OID}::_ref::$prop"} { + lappend refvars ::p::${OID}::_ref::$prop + } + lappend refvars {*}[info vars ::p::${OID}::_ref::${prop}+*] + + #short_circuit breaks unset traces for array elements (why?) + + + if {![llength $refvars]} { + #puts stderr "\t%%%%%%%%%% no refvars for propvar_unset_TraceHandler to update - short circuiting . OID:'$OID' prop:'$prop' vtraced:'$vtraced' vidx:'$vidx'" + return + } else { + puts stderr "\t****** [llength $refvars] refvars for propvar_unset_TraceHandler to update. OID:'$OID' prop:'$prop' vtraced:'$vtraced' vidx:'$vidx'" + } + + if {[catch { + + + + #We are only interested in suppressing the 'setGet_TraceHandler' traces on refvars + array set traces [::list] + + #puts stderr "*-*-*-*-*-* refvars \n- [join $refvars "\n- "]" + + + foreach rv $refvars { + #puts "--refvar $rv" + foreach tinfo [trace info variable $rv] { + #puts "##trace $tinfo" + set ops {}; set cmd {} + lassign $tinfo ops cmd + #!warning - assumes traces with single operation per handler. + #write & unset traces on refvars need to be suppressed + #we also need to be able to read certain refvars without triggering retrieval of underlying value in order to detect if changed. + if {$ops in {read write unset array}} { + if {[string match "::p::predator::propref_trace_*" $cmd]} { + lappend traces($rv) $tinfo + trace remove variable $rv $ops $cmd + #puts stderr "*-*-*-*-*-* removing $ops trace on $rv -> $cmd" + } + } + } + } + + + + + if {[array exists SYNCVARIABLE]} { + + #underlying variable is an array - we are presumably unsetting just an element + set vtracedIsArray 1 + } else { + #!? maybe the var was an array - but it's been unset? + set vtracedIsArray 0 + } + + #puts stderr "--------------------------------------------------\n\n" + #some things we don't want to repeat for each refvar in case there are lots of them.. + set triggeringRefIdx $vidx + + + #puts stderr ">>>...----refsync-trace = $vtraced $op refvars:$refvars" + #puts stderr ">>> [trace info variable $vtraced]" + #puts "--- unset branch refvar:$refvar" + + + if {[llength $vidx]} { + #trace called with an index - must be an array + foreach refvar $refvars { + set reftail [namespace tail $refvar] + + if {[string match "${prop}+*" $reftail]} { + #!todo - add test + if {$vidx eq [lrange [split $reftail +] 1 end]} { + #unset if indices match + error "untested, possibly unused branch spuds1" + #puts "1111111111111111111111111" + unset $refvar + } + } else { + #test exists - #!todo - document which one + + #see if we succeeded in unsetting this element in the underlying variables + #(may have been blocked by a PropertyUnset body) + set element_exists [uplevel 1 [::list info exists ${vtraced}($vidx)]] + #puts "JJJJJJ vtraced:$vtraced vidx:$vidx element_exists:$element_exists" + if {$element_exists} { + #do nothing it wasn't actually unset + } else { + #puts "JJJJJ unsetting ${refvar}($vidx)" + unset ${refvar}($vidx) + } + } + } + + + } else { + + foreach refvar $refvars { + set reftail [namespace tail $refvar] + unset $refvar + + } + + } + + + #!todo - understand. + #puts stderr "\n*****\n propvar_unset_TraceHandler $refvar unset $prop $args \n*****\n" + #catch {unset $refvar} ;#oops - Tcl_EventuallyFree called twice - abnormal program termination (tcl8.4?) + + + #reinstall the traces we stored at the beginning of this proc. + foreach rv [array names traces] { + foreach tinfo $traces($rv) { + set ops {}; set cmd {} + lassign $tinfo ops cmd + + #puts stderr "****** re-installing setGet trace '$ops' on variable $rv" + trace add variable $rv $ops $cmd + } + } + + } errM]} { + set ruler [string repeat * 80] + puts stderr "\t$ruler" + puts stderr "\t>>>>>>>$ propvar_unset_TraceHandler OID:'$OID' prop:'$prop' vtraced:'$vtraced' vidx:'$vidx' $op" + puts stderr "\t$ruler" + puts stderr $::errorInfo + puts stderr "\t$ruler" + + } + +} + +proc ::p::predator::refsyncvar_write_manualupdate {OID triggeringRef prop vtraced indices} { + error hmmmmm + upvar $vtraced SYNCVARIABLE + #puts stderr "\t>>>>>>>$ refsyncvar_write_manualupdate $OID '$triggeringRef' '$prop' vtraced:'$vtraced' indices:'$indices' " + set refvars [::list] + + #avoid info exists ::p::${OID}::_ref::$prop (info exists triggers read unnecessary read trace ) + if {[info vars ::p::${OID}::_ref::$prop] eq "::p::${OID}::_ref::$prop"} { + lappend refvars ::p::${OID}::_ref::$prop ;#this is the basic unindexed reference we normally get when getting a standard property ref (e.g set ref [>obj . prop .]) + } + lappend refvars {*}[info vars ::p::${OID}::_ref::${prop}+*] ;#add any indexed references + #assert triggeringRef is in the list + if {([string length $triggeringRef]) && ($triggeringRef ni $refvars)} { + error "@@@@@@@@@@ refsyncvar_write_manualupdate unexpected situation. triggeringRef $triggeringRef ni refvars:$refvars" + } + set refposn [lsearch -exact $refvars $triggeringRef] + #assert - due to test above, we know $triggeringRef is in the list so refposn > 0 + set refvars [lreplace $refvars[set refvars {}] $refposn $refposn] ;#note inline K combinator [set refvars {}] + if {![llength $refvars]} { + #puts stderr " %%%%%%%%%% no refvars for refsyncvar_write_manualupdate to update - short circuiting . OID:$OID prop:$prop" + return [list refs_updates [list]] + } + + #suppress the propref_trace_* traces on all refvars + array set traces [::list] + array set external_traces [::list] ;#e.g application/3rd party traces on "">obj . prop ." + #we do not support tracing of modifications to refs which occur from inside the pattern system. ie we disable them during refsync + #todo - after finished refsyncing - consider manually firing the external_traces in such a way that writes/unsets raise an error? + #(since an external trace should not be able to affect a change which occured from inside the object - but can affect values from application writes/unsets to the ref) + + foreach rv $refvars { + #puts "--refvar $rv" + foreach tinfo [trace info variable $rv] { + #puts "##trace $tinfo" + set ops {}; set cmd {} + lassign $tinfo ops cmd + #!warning - assumes traces with single operation per handler. + #write & unset traces on refvars need to be suppressed + #we also need to be able to read certain refvars without triggering retrieval of underlying value in order to detect if changed. + + if {[string match "::p::predator::propref_trace_*" $cmd]} { + lappend traces($rv) $tinfo + trace remove variable $rv $ops $cmd + #puts stderr "*-*-*-*-*-* removing $ops trace on $rv -> $cmd" + } else { + #all other traces are 'external' + lappend external_traces($rv) $tinfo + #trace remove variable $rv $ops $cmd + } + + } + } + #-------------------------------------------------------------------------------------------------------------------------- + if {([array exists SYNCVARIABLE]) || (![info exists SYNCVARIABLE])} { + if {![info exists SYNCVARIABLE]} { + error "WARNING: REVIEW why does $vartraced not exist here?" + } + #either the underlying variable is an array + # OR - underlying variable doesn't exist - so we treat the property as an array because of the indexed access pattern + set treat_vtraced_as_array 1 + } else { + set treat_vtraced_as_array 0 + } + + set refs_updated [list] + set refs_deleted [list] ;#unset due to index no longer being relevant + if {$treat_vtraced_as_array} { + foreach refvar $refvars { + #puts stdout "\n\n \tarrayvariable:'$vtraced' examining REFVAR:'$refvar'" + set refvar_tail [namespace tail $refvar] + if {[string match "${prop}+*" $refvar_tail]} { + #refvar to update is curried e.g ::p::${OID}::_ref::${prop}+x+y + set ref_indices [lrange [split $refvar_tail +] 1 end] + if {[llength $indices]} { + if {[llength $indices] == 1} { + if {[lindex $ref_indices 0] eq [lindex $indices 0]} { + #error "untested xxx-a" + set ${refvar} [set SYNCVARIABLE([lindex $indices 0])] + lappend refs_updated $refvar + } else { + #test exists + #error "xxx-ok single index" + #updating a different part of the property - nothing to do + } + } else { + #nested index + if {[lindex $ref_indices 0] eq [lindex $indices 0]} { + if {[llength $ref_indices] == 1} { + #error "untested xxx-b1" + set ${refvar} [lindex [set SYNCVARIABLE([lindex $indices 0])] [lrange $indices 1 end] ] + } else { + #assert llength $ref_indices > 1 + #NOTE - we cannot test index equivalence reliably/simply just by comparing indices + #compare by value + + if {![catch {lindex [set SYNCVARIABLE([lindex $indices 0])] [lrange $indices 1 end]} possiblyNewVal]} { + #puts stderr "\tYYYYYYYYY $refvar:'[set $refvar]'' / possiblyNewVal:'$possiblyNewVal'" + if {[set $refvar] ne $possiblyNewVal} { + set $refvar $possiblyNewVal + } + } else { + #fail to retrieve underlying value corrsponding to these $indices + unset $refvar + } + } + } else { + #test exists + #error "untested xxx-ok deepindex" + #updating a different part of the property - nothing to do + } + } + } else { + error "untested xxx-c" + + } + + } else { + #refvar to update is plain e.g ::p::${OID}::_ref::${prop} + if {[llength $indices]} { + if {[llength $indices] == 1} { + set ${refvar}([lindex $indices 0]) [set SYNCVARIABLE([lindex $indices 0])] + } else { + lset ${refvar}([lindex $indices 0]) {*}[lrange $indices 1 end] [lindex [set SYNCVARIABLE([lindex $indices 0])] {*}[lrange $indices 1 end]] + } + lappend refs_updated $refvar + } else { + error "untested yyy" + set $refvar $SYNCVARIABLE + } + } + } + } else { + #vtraced non array, but could be an array element e.g ::p::${OID}::_ref::ARR(x) + # + foreach refvar $refvars { + #puts stdout "\n\n \tsimplevariable:'$vtraced' examining REFVAR:'$refvar'" + set refvar_tail [namespace tail $refvar] + if {[string match "${prop}+*" $refvar_tail]} { + #refvar to update is curried e.g ::p::${OID}::_ref::${prop}+x+y + set ref_indices [lrange [split $refvar_tail +] 1 end] + + if {[llength $indices]} { + #see if this update would affect this curried ref + #1st see if we can short-circuit our comparison based on numeric-indices + if {[string is digit -strict [join [concat $ref_indices $indices] ""]]} { + #both sets of indices are purely numeric (no end end-1 etc) + set rlen [llength $ref_indices] + set ilen [llength $indices] + set minlen [expr {min($rlen,$ilen)}] + set matched_firstfew_indices 1 ;#assume the best + for {set i 0} {$i < $minlen} {incr i} { + if {[lindex $ref_indices $i] ne [lindex $indices $i]} { + break ;# + } + } + if {!$matched_firstfew_indices} { + #update of this refvar not required + #puts stderr "\t@@@1 SKIPPING refvar $refvar - indices don't match $ref_indices vs $indices" + break ;#break to next refvar in the foreach loop + } + } + #failed to short-circuit + + #just do a simple value comparison - some optimisations are possible, but perhaps unnecessary here + set newval [lindex $SYNCVARIABLE $ref_indices] + if {[set $refvar] ne $newval} { + set $refvar $newval + lappend refs_updated $refvar + } + + } else { + #we must be updating the entire variable - so this curried ref will either need to be updated or unset + set newval [lindex $SYNCVARIABLE $ref_indices] + if {[set ${refvar}] ne $newval} { + set ${refvar} $newval + lappend refs_updated $refvar + } + } + } else { + #refvar to update is plain e.g ::p::${OID}::_ref::${prop} + if {[llength $indices]} { + #error "untested zzz-a" + set newval [lindex $SYNCVARIABLE $indices] + if {[lindex [set $refvar] $indices] ne $newval} { + lset ${refvar} $indices $newval + lappend refs_updated $refvar + } + } else { + if {[set ${refvar}] ne $SYNCVARIABLE} { + set ${refvar} $SYNCVARIABLE + lappend refs_updated $refvar + } + } + + } + + } + } + #-------------------------------------------------------------------------------------------------------------------------- + + #!todo - manually fire $external_traces as appropriate - but somehow raise error if attempt to write/unset + + #reinstall the traces we stored at the beginning of this proc. + foreach rv [array names traces] { + if {$rv ni $refs_deleted} { + foreach tinfo $traces($rv) { + set ops {}; set cmd {} + lassign $tinfo ops cmd + + #puts stderr "****** re-installing trace '$ops' on variable $rv cmd:$cmd" + trace add variable $rv $ops $cmd + } + } + } + foreach rv [array names external_traces] { + if {$rv ni $refs_deleted} { + foreach tinfo $external_traces($rv) { + set ops {}; set cmd {} + lassign $tinfo ops cmd + #trace add variable $rv $ops $cmd + } + } + } + + + return [list updated_refs $refs_updated] +} + +#purpose: update all relevant references when context variable changed directly +proc ::p::predator::propvar_write_TraceHandler {OID prop vtraced vidx op} { + #note that $vtraced may have been upvared in calling scope - so could have any name! only use it for getting/setting values - don't rely on it's name in any other way. + #we upvar it here instead of using uplevel - as presumably upvar is more efficient (don't have to wory about whether uplevelled script is bytecompiled etc) and also makes code simpler + + upvar $vtraced SYNCVARIABLE + #puts stderr "\t>>>>>>>$ propvar_write_TraceHandler OID:$OID propertyname:'$prop' vtraced:'$vtraced' index:'$vidx' operation:$op" + #set t_info [trace info variable $vtraced] + #foreach t_spec $t_info { + # set t_ops [lindex $t_spec 0] + # if {$op in $t_ops} { + # puts stderr "\t!!!!!!!! propvar_write_Tracehandler [lindex $t_spec 1]" + # } + #} + + #puts stderr -*-*-[info vars ::p::_ref::${OID}::[lindex $prop 0]+*]-*-*- + #vtype = array | array-item | list | simple + + set refvars [::list] + + ############################ + #!!!NOTE!!! do not call 'info exists' on a propref here as it will trigger a read trace -which then pulls in the value from the (GET)prop function etc!!! + #This would be extra cpu work - and sets the propref prematurely (breaking proper property-trace functionality plus vwaits on proprefs) + #The alternative 'info vars' does not trigger traces + if {[info vars ::p::${OID}::_ref::$prop] eq "::p::${OID}::_ref::$prop"} { + #puts " **> lappending '::p::REF::${OID}::$prop'" + lappend refvars ::p::${OID}::_ref::$prop ;#this is the basic unindexed reference we normally get when getting a standard property ref (e.g set ref [>obj . prop .]) + } + ############################ + + #lappend refvars ::p::${OID}::_ref::$prop ;#this is the basic unindexed reference we normally get when getting a standard property ref (e.g set ref [>obj . prop .]) + lappend refvars {*}[info vars ::p::${OID}::_ref::${prop}+*] ;#add any indexed references + + + if {![llength $refvars]} { + #puts stderr "\t%%%%%%%%%% no refvars for propvar_write_TraceHandler to update - short circuiting . OID:$OID prop:$prop" + return + } + + + #puts stderr "*-*-*-*-*-* refvars \n- [join $refvars "\n- "]" + + #We are only interested in suppressing the pattern library's 'propref_trace_*' traces and 3rd party 'read' traces on refvars + array set predator_traces [::list] + #maintain two lists of external traces - as we need to temporarily deactivate all non-pattern read traces even if they are part of a more comprehensive trace.. + #ie for something like 'trace add variable someref {write read array} somefunc' + # we need to remove and immediately reinstall it as a {write array} trace - and at the end of this procedure - reinstall it as the original {write read array} trace + array set external_read_traces [::list] ;#pure read traces the library user may have added + array set external_readetc_traces [::list] ;#read + something else traces the library user may have added + foreach rv $refvars { + #puts "--refvar $rv" + foreach tinfo [trace info variable $rv] { + #puts "##trace $tinfo" + set ops {}; set cmd {} + lassign $tinfo ops cmd + #!warning - assumes traces with single operation per handler. + #write & unset traces on refvars need to be suppressed + #we also need to be able to read certain refvars without triggering retrieval of underlying value in order to detect if changed. + #if {$ops in {read write unset array}} {} + + if {[string match "::p::predator::propref_trace_*" $cmd]} { + lappend predator_traces($rv) $tinfo + trace remove variable $rv $ops $cmd + #puts stderr "*-*-*-*-*-* removing $ops trace on $rv -> $cmd" + } else { + #other traces + # puts "##trace $tinfo" + if {"read" in $ops} { + if {[llength $ops] == 1} { + #pure read - + lappend external_read_traces($rv) $tinfo + trace remove variable $rv $ops $cmd + } else { + #mixed operation trace - remove and reinstall without the 'read' + lappend external_readetc_traces($rv) $tinfo + set other_ops [lsearch -all -inline -not $ops "read"] + trace remove variable $rv $ops $cmd + #reinstall trace for non-read operations only + trace add variable $rv $other_ops $cmd + } + } + } + } + } + + + if {([array exists SYNCVARIABLE]) || (![info exists SYNCVARIABLE])} { + #either the underlying variable is an array + # OR - underlying variable doesn't exist - so we treat the property as an array because of the indexed access pattern + set vtracedIsArray 1 + } else { + set vtracedIsArray 0 + } + + #puts stderr "--------------------------------------------------\n\n" + + #puts stderr ">>>...----refsync-trace = $vtraced $op refvars:$refvars" + #puts stderr ">>> [trace info variable $vtraced]" + #puts "**write*********** propvar_write_TraceHandler $prop $vtraced $vidx $op" + #puts "**write*********** refvars: $refvars" + + #!todo? unroll foreach into multiple foreaches within ifs? + #foreach refvar $refvars {} + + + #puts stdout "propvar_write_TraceHandler examining REFVAR $refvar" + if {[string length $vidx]} { + #indexable + if {$vtracedIsArray} { + + foreach refvar $refvars { + #puts stderr " - - a refvar $refvar vidx: $vidx" + set tail [namespace tail $refvar] + if {[string match "${prop}+*" $tail]} { + #refvar is curried + #only set if vidx matches curried index + #!todo -review + set idx [lrange [split $tail +] 1 end] + if {$idx eq $vidx} { + set newval [set SYNCVARIABLE($vidx)] + if {[set $refvar] ne $newval} { + set ${refvar} $newval + } + #puts stderr "=a.1=> updated $refvar" + } + } else { + #refvar is simple + set newval [set SYNCVARIABLE($vidx)] + if {![info exists ${refvar}($vidx)]} { + #new key for this array + #puts stderr "\npropvar_write_TraceHandler------ about to call 'array set $refvar [::list $vidx [set SYNCVARIABLE($vidx)] ]' " + array set ${refvar} [::list $vidx [set SYNCVARIABLE($vidx)] ] + } else { + set oldval [set ${refvar}($vidx)] + if {$oldval ne $newval} { + #puts stderr "\npropvar_write_TraceHandler------ about to call 'array set $refvar [::list $vidx [set SYNCVARIABLE($vidx)] ]' " + array set ${refvar} [::list $vidx [set SYNCVARIABLE($vidx)] ] + } + } + #puts stderr "=a.2=> updated ${refvar} $vidx" + } + } + + } else { + + foreach refvar $refvars { + upvar $refvar internal_property_reference + #puts stderr " - - b vidx: $vidx" + + #!? could be object not list?? + #!!but what is the difference between an object, and a list of object names which happens to only contain one object?? + #For predictability - we probably need to autodetect type on 1st write to o_prop either list, array or object (and maintain after unset operations) + #There would still be an edge case of an initial write of a list of objects of length 1. + if {([llength [set $SYNCVARIABLE]] ==1) && ([string range [set $SYNCVARIABLE] 0 0] eq ">")} { + error "untested review!" + #the o_prop is object-shaped + #assumes object has a defaultmethod which accepts indices + set newval [[set $SYNCVARIABLE] {*}$vidx] + + } else { + set newval [lindex $SYNCVARIABLE {*}$vidx] + #if {[set $refvar] ne $newval} { + # set $refvar $newval + #} + if {$internal_property_reference ne $newval} { + set internal_property_reference $newval + } + + } + #puts stderr "=b=> updated $refvar" + } + + } + + } else { + #no vidx + + if {$vtracedIsArray} { + + foreach refvar $refvars { + set targetref_tail [namespace tail $refvar] + set targetref_is_indexed [string match "${prop}+*" $targetref_tail] + + + #puts stderr " - - c traced: $vtraced refvar:$refvar triggeringRef: $triggeringRef" + if {$targetref_is_indexed} { + #curried array item ref of the form ${prop}+x or ${prop}+x+y etc + + #unindexed write on a property that is acting as an array.. + + #case a) If the underlying variable is actually an array - it will error upon attempt to write it like this - that's ok. + + #case b) If the underlying variable doesn't exist - perhaps a PropertyWrite will accept the unindexed write (e.g by asigning a default for the missing index). + # we can't know here how this write affects other indexed traces on this property... hence we warn but do nothing. + puts stderr "\tc.1 WARNING: write to property without 'array set'. op:'$op' refvar:'$refvar' prop:'$prop' \n\traw: propvar_write_TraceHandler $OID $prop $vtraced $vidx $op" + } else { + #How do we know what to write to array ref? + puts stderr "\tc.2 WARNING: unimplemented/unused?" + #error no_tests_for_branch + + #warning - this would trigger 3rd party unset traces which is undesirable for what is really a 'bookkeeping' operation + #if this branch is actually useful - we probably need to step through the array and unset and set elements as appropriate + array unset ${refvar} + array set ${refvar} [array get SYNCVARIABLE] + } + } + + } else { + foreach refvar $refvars { + #puts stderr "\t\t_________________[namespace current]" + set targetref_tail [namespace tail $refvar] + upvar $refvar INTERNAL_REFERENCE_TO_PROPERTY__$targetref_tail + set targetref_is_indexed [string match "${prop}+*" $targetref_tail] + + if {$targetref_is_indexed} { + #puts "XXXXXXXXX vtraced:$vtraced" + #reference curried with index(es) + #we only set indexed refs if value has changed + # - this not required to be consistent with standard list-containing variable traces, + # as normally list elements can't be traced seperately anyway. + # + + #only bother checking a ref if no setVia index + # i.e some operation on entire variable so need to test synchronisation for each element-ref + set targetref_indices [lrange [split $targetref_tail +] 1 end] + set possiblyNewVal [lindex $SYNCVARIABLE {*}$targetref_indices] + #puts stderr "YYYYYYYYY \[set \$refvar\]: [set $refvar] / possiblyNewVal: $possiblyNewVal" + if {[set INTERNAL_REFERENCE_TO_PROPERTY__$targetref_tail] ne $possiblyNewVal} { + set INTERNAL_REFERENCE_TO_PROPERTY__$targetref_tail $possiblyNewVal + #puts stderr "=d1=> updated $refvar -> [uplevel 1 "lindex \[set $vtraced] $idx"]" + } + + } else { + #for consistency with standard traces on a list-containing variable, we perform the set even if the list value has not changed! + + #puts stderr "- d2 set" + #puts "refvar: [set $refvar]" + #puts "SYNCVARIABLE: $SYNCVARIABLE" + + #if {[set $refvar] ne $SYNCVARIABLE} { + # set $refvar $SYNCVARIABLE + #} + if {[set INTERNAL_REFERENCE_TO_PROPERTY__$targetref_tail] ne $SYNCVARIABLE} { + set INTERNAL_REFERENCE_TO_PROPERTY__$targetref_tail $SYNCVARIABLE + } + + } + } + + } + + } + + + + #reinstall the traces we stored at the beginning of this proc. + foreach rv [array names predator_traces] { + foreach tinfo $predator_traces($rv) { + set ops {}; set cmd {} + lassign $tinfo ops cmd + + #puts stderr "****** re-installing trace '$ops' on variable $rv cmd:$cmd" + trace add variable $rv $ops $cmd + } + } + + foreach rv [array names external_traces] { + foreach tinfo $external_traces($rv) { + set ops {}; set cmd {} + lassign $tinfo ops cmd + + #puts stderr "****** re-installing trace '$ops' on variable $rv cmd:$cmd" + trace add variable $rv $ops $cmd + } + } + + + +} + +# end propvar_write_TraceHandler + + + + + + + + + + + + + + + + +# + +#returns 0 if method implementation not present for interface +proc ::p::predator::method_chainhead {iid method} { + #Interface proc + # examine the existing command-chain + set candidates [info commands ::p::${iid}::_iface::$method.*] ;#rough grab (info commands only allows basic pattern globbing - not a regex) + set cmdchain [list] + + set re [string map [list %m% [string map {( \\( ) \\) . \\.} $method]] {^%m%.([0-9]+)$}] + set maxversion 0 + #loop and test because it is possible there are unrelated commands (having a matching prefix with . character) which were caught in the glob. + foreach test [lsort -dictionary $candidates] { + set c [namespace tail $test] + if {[regexp $re $c _match version]} { + lappend cmdchain $c + if {$version > $maxversion} { + set maxversion $version + } + } + } + return $maxversion +} + + + + + +#this returns a script that upvars vars for all interfaces on the calling object - +# - must be called at runtime from a method +proc ::p::predator::upvar_all {_ID_} { + #::set OID [lindex $_ID_ 0 0] + ::set OID [::lindex [::dict get $_ID_ i this] 0 0] + ::set decl {} + #[set ::p::${OID}::_meta::map] + #[dict get [lindex [dict get $_ID_ i this] 0 1] map] + + ::upvar #0 ::p::${OID}::_meta::map MAP + #puts stdout "\n\n -->-->-->--> _meta::map '$MAP' <-<-<-\n\n" + #set iflist [::lindex [dict get [lindex [dict get $_ID_ i this] 0 1] map] 1 0] + + ::foreach ifid [dict get $MAP interfaces level0] { + if {[::dict size [::set ::p::${ifid}::_iface::o_variables]]} { + ::array unset nsvars + ::array set nsvars [::list] + ::dict for {vname vinfo} [::set ::p::${ifid}::_iface::o_variables] { + ::set varspace [::dict get $vinfo varspace] + ::lappend nsvars($varspace) $vname + } + #nsvars now contains vars grouped by varspace. + + ::foreach varspace [::array names nsvars] { + if {$varspace eq ""} { + ::set ns ::p::${OID} + } else { + if {[::string match "::*" $varspace]} { + ::set ns $varspace + } else { + ::set ns ::p::${OID}::$varspace + } + } + + ::append decl "namespace upvar $ns " + ::foreach vname [::set nsvars($varspace)] { + ::append decl "$vname $vname " + } + ::append decl " ;\n" + } + ::array unset nsvars + } + } + ::return $decl +} + +#we need to use eval because it is potentially a multiline script returned by upvar_all (so can't just use {*} operator) +proc ::p::predator::runtime_vardecls {} { + set result "::eval \[::p::predator::upvar_all \$_ID_\]" + #set result "::apply { {_ID_} ::p::predator::upvar_all } \$_ID_" + + #set result "::apply \[::list {} \[::p::predator::upvar_all \$_ID_\] \[namespace current\]\]" + #set result "::interp eval {} \[::p::predator::upvar_all \$_ID_\]" + #puts stdout "\t>>>[info level -1]\n\t>>>>>>>>>>>>>>>>>>>>> '$result'" + return $result +} + + + + + + +#OBSOLETE!(?) - todo - move stuff out of here. +proc ::p::predator::compile_interface {IFID caller_ID_} { + upvar 0 ::p::${IFID}:: IFACE + + #namespace eval ::p::${IFID} { + # namespace ensemble create + #} + + #'namespace upvar' - from tip.tcl.tk #250: Efficient Access to Namespace Variables + + namespace upvar ::p::${IFID}::_iface o_propertyunset_handlers o_propertyunset_handlers o_variables o_variables o_properties o_properties o_methods o_methods o_unknown o_unknown o_varspace o_varspace o_varspaces o_varspaces + + #set varDecls {} + #if {[llength $o_variables]} { + # #puts "*********!!!! $vlist" + # append varDecls "namespace upvar ::p::\[lindex \$_ID_ 0 0 \] " + # foreach vdef $o_variables { + # append varDecls "[lindex $vdef 0] [lindex $vdef 0] " + # } + # append varDecls \n + #} + + #runtime gathering of vars from other interfaces. + #append varDecls [runtime_vardecls] + + set varDecls [runtime_vardecls] + + + + #implement methods + + #!todo - avoid globs on iface array? maintain list of methods in another slot? + #foreach {n mname} [array get IFACE m-1,name,*] {} + + + #namespace eval ::p::${IFID}::_iface "namespace export {*}$o_methods" ;#make methods available as interface ensemble. + + + + #implement property getters/setters/unsetters + #'setter' overrides + #pw short for propertywrite + foreach {n property} [array get IFACE pw,name,*] { + if {[string length $property]} { + #set property [lindex [split $n ,] end] + + #!todo - next_script + #set next [::p::next_script "\[set ::p::\${_ID_}::(self)]" $IFID $property] + + set maxversion [::p::predator::method_chainhead $IFID (SET)$property] + set chainhead [expr {$maxversion + 1}] + set THISNAME (SET)$property.$chainhead ;#first version will be (SET)$property.1 + + set next [::p::predator::next_script $IFID (SET)$property $THISNAME $caller_ID_] ;#?! caller_ID_ ?? + + set body $IFACE(pw,body,$property) + + + set processed [dict create {*}[::p::predator::expand_var_statements $body $o_varspace]] + if {[llength [dict get $processed varspaces_with_explicit_vars]]} { + foreach vs [dict get $processed varspaces_with_explicit_vars] { + if {[string length $vs] && ($vs ni $o_varspaces)} { + lappend o_varspaces $vs + } + } + set body [dict get $processed body] + } else { + set body $varDecls\n[dict get $processed body] + #puts stderr "\t\timplicit vardecls used for propertywrite $property on interface $IFID ##### \n $body" + } + + #set body [string map [::list @this@ "\[lindex \${_ID_} 0 3 \]" @next@ $next] $body\n] + set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata \] 3\]" @next@ $next] $body\n] + + + + set maxversion [::p::predator::method_chainhead $IFID $property] + set headid [expr {$maxversion + 1}] + + proc ::p::${IFID}::_iface::(SET)$property.$headid [concat _ID_ $IFACE(pw,arg,$property)] $body + + interp alias {} ::p::${IFID}::_iface::(SET)$property {} ::p::${IFID}::_iface::(SET)$property.$headid + + #proc ::p::${IFID}::___system___write_$property [concat _ID_ $IFACE(pw,arg,$property)] $body + } + } + #'unset' overrides + + dict for {property handler_info} $o_propertyunset_handlers { + + set body [dict get $handler_info body] + set arraykeypattern [dict get $handler_info arraykeypattern] ;#array element pattern for unsetting individual elements in an array + + set maxversion [::p::predator::method_chainhead $IFID (UNSET)$property] + set headid [expr {$maxversion + 1}] + + set THISNAME (UNSET)$property.$headid + + set next [::p::predator::next_script $IFID (UNSET)$property $THISNAME $caller_ID_] ;#?! caller_ID_ ??? + + + + + + set processed [dict create {*}[::p::predator::expand_var_statements $body $o_varspace]] + if {[llength [dict get $processed varspaces_with_explicit_vars]]} { + foreach vs [dict get $processed varspaces_with_explicit_vars] { + if {[string length $vs] && ($vs ni $o_varspaces)} { + lappend o_varspaces $vs + } + } + set body [dict get $processed body] + } else { + set body $varDecls\n[dict get $processed body] + #puts stderr "\t\timplicit vardecls used for property unset $property on interface $IFID ##### \n $body" + + } + #set body [string map [::list @this@ "\[lindex \$_ID_ 0 3 \]" @next@ $next] $body\n] + set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata \] 3\]" @next@ $next] $body\n] + + + + + #implement + #always take arraykeypattern argument even though usually empty string (only used for unsetting individual array elements) + if {[string trim $arraykeypattern] eq ""} { + set arraykeypattern "_dontcare_" + } + proc ::p::${IFID}::_iface::(UNSET)$property.$headid [concat _ID_ $arraykeypattern] $body + + + #chainhead pointer + interp alias {} ::p::${IFID}::_iface::(UNSET)$property {} ::p::${IFID}::_iface::(UNSET)$property.$headid + } + + + + interp alias {} ::p::${IFID}::(VIOLATE) {} ::p::internals::(VIOLATE) + + #the usual case will have no destructor - so use info exists to check. + + if {[info exists ::p::${IFID}::_iface::o_destructor_body]} { + #!todo - chained destructors (support @next@). + #set next [::p::next_script_destructor "\[lindex \$_ID_ 0 1\]" $IFID] + set next NEXT + + set body [set ::p::${IFID}::_iface::o_destructor_body] + + + set processed [dict create {*}[::p::predator::expand_var_statements $body $o_varspace]] + if {[llength [dict get $processed varspaces_with_explicit_vars]]} { + foreach vs [dict get $processed varspaces_with_explicit_vars] { + if {[string length $vs] && ($vs ni $o_varspaces)} { + lappend o_varspaces $vs + } + } + set body [dict get $processed body] + } else { + set body $varDecls\n[dict get $processed body] + #puts stderr "\t\t**********************implicit vardecls used for destructor on interface $IFID ##### \n $body" + } + #set body [::p::fixed_var_statements \n@IMPLICITDECLS@\n$body] + #set body [string map [::list @this@ "\[lindex \$_ID_ 0 3 \]" @next@ $next] $body\n] + set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata \] 3\]" @next@ $next] $body\n] + + + proc ::p::${IFID}::___system___destructor _ID_ $body + } + + + if {[info exists o_unknown]} { + #use 'apply' somehow? + interp alias {} ::p::${IFID}::_iface::(UNKNOWN) {} ::p::${IFID}::_iface::$o_unknown + + #namespace eval ::p::${IFID}::_iface [list namespace unknown $o_unknown] + } + + + return +} + + + + + + + +#'info args' - assuming arbitrary chain of 'interp aliases' +proc ::p::predator::command_info_args {cmd} { + if {[llength [set next [interp alias {} $cmd]]]} { + set curriedargs [lrange $next 1 end] + + if {[catch {set arglist [info args [lindex $next 0]]}]} { + set arglist [command_info_args [lindex $next 0]] + } + #trim curriedargs + return [lrange $arglist [llength $curriedargs] end] + } else { + info args $cmd + } +} + + +proc ::p::predator::do_next {_ID_ IFID mname nextArgs args} { + if {[llength $args]} { + tailcall ::p::${IFID}::_iface::$mname $_ID_ {*}$args + } else { + if {[llength $nextArgs] > 1} { + set argVals [::list] + set i 0 + foreach arg [lrange $nextArgs 1 end] { + upvar 1 $arg $i + if {$arg eq "args"} { + #need to check if 'args' is actually available in caller + if {[info exists $i]} { + set argVals [concat $argVals [set $i]] + } + } else { + lappend argVals [set $i] + } + } + tailcall ::p::${IFID}::_iface::$mname $_ID_ {*}$argVals + } else { + tailcall ::p::${IFID}::_iface::$mname $_ID_ + } + } +} + +#---------------------------------------------------------------------------------------------- +proc ::p::predator::next_script {IFID method caller caller_ID_} { + + if {$caller eq "(CONSTRUCTOR).1"} { + return [string map [list %cID% [list $caller_ID_] %ifid% $IFID %m% $method] {::p::predator::do_next_pattern_if $_ID_ %cID% %ifid% %m%}] + } elseif {$caller eq "$method.1"} { + #delegate to next interface lower down the stack which has a member named $method + return [string map [list %ifid% $IFID %m% $method] {::p::predator::do_next_if $_ID_ %ifid% %m%}] + } elseif {[string match "(GET)*.2" $caller]} { + # .1 is the getprop procedure, .2 is the bottom-most PropertyRead. + + #jmn + set prop [string trimright $caller 1234567890] + set prop [string range $prop 5 end-1] ;#string leading (GET) and trailing . + + if {$prop in [dict keys [set ::p::${IFID}::_iface::o_properties]]} { + #return [string map [list %ifid% $IFID %p% $prop ] {::p::%ifid%::_iface::(GET)%p%.1 $_ID_}] + return [string map [list %ifid% $IFID %m% (GET)$prop.1 %nargs% [list]] {::p::predator::do_next $_ID_ %ifid% %m% [list %nargs%]}] + } else { + #we can actually have a property read without a property or a method of that name - but it could also match the name of a method. + # (in which case it could return a different value depending on whether called via set [>obj . something .] vs >obj . something) + return [string map [list %ifid% $IFID %m% $method] {::p::predator::do_next_if $_ID_ %ifid% %m%}] + } + } elseif {[string match "(SET)*.2" $caller]} { + return [string map [list %ifid% $IFID %m% $method] {::p::predator::do_next_if $_ID_ %ifid% %m%}] + } else { + #this branch will also handle (SET)*.x and (GET)*.x where x >2 + + #puts stdout "............next_script IFID:$IFID method:$method caller:$caller" + set callerid [string range $caller [string length "$method."] end] + set nextid [expr {$callerid - 1}] + + if {[catch {set nextArgs [info args ::p::${IFID}::_iface::$method.$nextid]} errMsg]} { + #not a proc directly on this interface - presumably an alias made by something like linkcopy_interface. + #puts ">>>>>>>>::p::predator::next_script IFID:$IFID caller:$caller aaaa@ $method.$nextid" + set nextArgs [command_info_args ::p::${IFID}::_iface::$method.$nextid] + } + + return [string map [list %ifid% $IFID %m% $method.$nextid %nargs% $nextArgs] {::p::predator::do_next $_ID_ %ifid% %m% [list %nargs%]}] + } +} + +proc ::p::predator::do_next_if {_ID_ IFID method args} { + #puts "<>(::p::predator::do_next_if)<> '$_ID_' '$IFID' '$method' '$args' (((" + + #set invocants [dict get $_ID_ i] + #set this_invocantdata [lindex [dict get $invocants this] 0] + #lassign $this_invocantdata OID this_info + set OID [::p::obj_get_this_oid $_ID_] + ::p::map $OID MAP + lassign [dict get $MAP invocantdata] OID alias itemCmd cmd + set interfaces [dict get $MAP interfaces level0] + set patterninterfaces [dict get $MAP interfaces level1] + + set L0_posn [lsearch $interfaces $IFID] + if {$L0_posn == -1} { + error "(::p::predator::do_next_if) called with interface not present at level0 for this object" + } elseif {$L0_posn > 0} { + #set ifid_next [lindex $interfaces $L0_posn-1] ;#1 lower in the iStack + set lower_interfaces [lrange $interfaces 0 $L0_posn-1] + + foreach if_sub [lreverse $lower_interfaces] { + if {[string match "(GET)*" $method]} { + #do not test o_properties here! We need to call even if there is no underlying property on this interface + #(PropertyRead without Property is legal. It results in dispatch to subsequent interface rather than property variable for this interface) + # relevant test: higher_order_propertyread_chaining + return [::p::${if_sub}::_iface::$method $_ID_ {*}$args] + } elseif {[string match "(SET)*" $method]} { + #must be called even if there is no matching $method in o_properties + return [::p::${if_sub}::_iface::$method $_ID_ {*}$args] + } elseif {[string match "(UNSET)*" $method]} { + #review untested + #error "do_next_if (UNSET) untested" + #puts stderr "<>(::p::predator::do_next_if)<> (UNSET) called - dispatching to ::p::${if_sub}::_iface::$method with args:'$args'" + return [::p::${if_sub}::_iface::$method $_ID_ {*}$args] + + } elseif {$method in [dict keys [set ::p::${if_sub}::_iface::o_methods]]} { + if {[llength $args]} { + #puts stdout "<>(::p::predator::do_next_if)<> - - - calling ::p::${if_sub}::_iface::$method on sub interface $if_sub with $args" + + #return [::p::${if_sub}::_iface::$method $_ID_ {*}$args] + #tailcall ::p::${if_sub}::_iface::$method $_ID_ {*}$args + + #!todo - handle case where llength $args is less than number of args for subinterface command + #i.e remaining args will need to be upvared to get values from calling scope (auto-set any values not explicitly set) + + #handle case where next interface has different arguments (masking of sub interfaces in the stack with function with different arity/signature) + set head [interp alias {} ::p::${if_sub}::_iface::$method] + set nextArgs [info args $head] ;#!todo - fix... head not necessarily a proc + set argx [list] + foreach a $nextArgs { + lappend argx "\$a" + } + + #todo - handle func a b args called with func "x" ie short on named vars so b needs to be upvared + + if {([llength $args] == [llength $nextArgs]) || ([lindex $nextArgs end] eq "args")} { + tailcall apply [list $nextArgs [list ::p::${if_sub}::_iface::$method {*}$argx ]] $_ID_ {*}$args + } else { + #todo - upvars required for tail end of arglist + tailcall apply [list $nextArgs [list ::p::${if_sub}::_iface::$method {*}$argx ]] $_ID_ {*}$args + } + + } else { + #auto-set: upvar vars from calling scope + #!todo - robustify? alias not necessarily matching command name.. + set head [interp alias {} ::p::${if_sub}::_iface::$method] + + + set nextArgs [info args $head] ;#!todo - fix... head not necessarily a proc + if {[llength $nextArgs] > 1} { + set argVals [::list] + set i 0 + foreach arg [lrange $nextArgs 1 end] { + upvar 1 $arg $i + if {$arg eq "args"} { + #need to check if 'args' is actually available in caller + if {[info exists $i]} { + set argVals [concat $argVals [set $i]] + } + } else { + lappend argVals [set $i] + } + } + #return [$head $_ID_ {*}$argVals] + tailcall $head $_ID_ {*}$argVals + } else { + #return [$head $_ID_] + tailcall $head $_ID_ + } + } + } elseif {$method eq "(CONSTRUCTOR)"} { + #chained constructors will only get args if the @next@ caller explicitly provided them. + puts stdout "!!!<>(::p::predator::do_next_if)<> CONSTRUCTOR CHAINED CALL via do_next_if _ID_:$_ID_ IFID:$IFID method:$method args:$args!!!" + #return [::p::${if_sub}::_iface::(CONSTRUCTOR) $_ID_ {*}$args] + xtailcall ::p::${if_sub}::_iface::(CONSTRUCTOR) $_ID_ {*}$args + } + } + #no interfaces in the iStack contained a matching method. + return + } else { + #no further interfaces in this iStack + return + } +} + + +#only really makes sense for (CONSTRUCTOR) calls. +#_ID_ is the invocant data for the target. caller_ID_ is the invocant data for the calling(creating,cloning etc) pattern/class. +proc ::p::predator::do_next_pattern_if {_ID_ caller_ID_ IFID method args} { + #puts ")))) do_next_pattern_if _ID_:'$_ID_' IFID:'$IFID' method:'$method' args:'$args' (((" + + #set invocants [dict get $_ID_ i] + #set this_invocant [lindex [dict get $invocants this] 0] + #lassign $this_invocant OID this_info + #set OID [lindex [dict get $invocants this] 0 0] + #upvar #0 ::p::${OID}::_meta::map map + #lassign [lindex $map 0] OID alias itemCmd cmd + + + set caller_OID [lindex [dict get $caller_ID_ i this] 0 0] + upvar #0 ::p::${caller_OID}::_meta::map callermap + + #set interfaces [lindex $map 1 0] + set patterninterfaces [dict get $callermap interfaces level1] + + set L0_posn [lsearch $patterninterfaces $IFID] + if {$L0_posn == -1} { + error "do_next_pattern_if called with interface not present at level1 for this object" + } elseif {$L0_posn > 0} { + + set lower_interfaces [lrange $patterninterfaces 0 $L0_posn-1] + + foreach if_sub [lreverse $lower_interfaces] { + if {$method eq "(CONSTRUCTOR)"} { + #chained constructors will only get args if the @next@ caller explicitly provided them. + #puts stdout "!!! CONSTRUCTOR CHAINED CALL via do_next_pattern_if _ID_:$_ID_ IFID:$IFID method:$method args:$args!!!" + tailcall ::p::${if_sub}::_iface::(CONSTRUCTOR) $_ID_ {*}$args + } + } + #no interfaces in the iStack contained a matching method. + return + } else { + #no further interfaces in this iStack + return + } +} + + + + + +#------------------------------------------------------------------------------------------------ + + + + + +#------------------------------------------------------------------------------------- +####################################################### +####################################################### +####################################################### +####################################################### +####################################################### +####################################################### +####################################################### + + +#!todo - can we just call new_object somehow to create this? + + #until we have a version of Tcl that doesn't have 'creative writing' scope issues - + # - we should either explicity specify the whole namespace when setting variables or make sure we use the 'variable' keyword. + # (see http://mini.net/tcl/1030 'Dangers of creative writing') +namespace eval ::p::-1 { + #namespace ensemble create + + namespace eval _ref {} + namespace eval _meta {} + + namespace eval _iface { + variable o_usedby + variable o_open + variable o_constructor + variable o_variables + variable o_properties + variable o_methods + variable o_definition + variable o_varspace + variable o_varspaces + + array set o_usedby [list i0 1] ;#!todo - review + #'usedby' array the metaface is an exception. All objects use it - so we should list none of them rather than pointless updating of this value? + + set o_open 1 + set o_constructor [list] + set o_variables [list] + set o_properties [dict create] + set o_methods [dict create] + array set o_definition [list] + set o_varspace "" + set o_varspaces [list] + } +} + + +# + +#interp alias {} ::p::internals::>metaface {} ::p::internals::predator [list [list -1 ::p::internals::>metaface item {}] {{} {}}] +interp alias {} ::p::internals::>metaface {} ::p::internals::predator [list i [list this [list [list -1 ::p::internals::>metaface item {}]]] context {}] + + +upvar #0 ::p::-1::_iface::o_definition def + + +#! concatenate -> compose ?? +dict set ::p::-1::_iface::o_methods Concatenate {arglist {target args}} +proc ::p::-1::Concatenate {_ID_ target args} { + set invocants [dict get $_ID_ i] + #set invocant_alias [lindex [dict get $invocants this] 0] + #set invocant [lindex [interp alias {} $invocant_alias] 1] + set OID [lindex [dict get $invocants this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + + lassign [dict get $MAP invocantdata] OID alias itemCmd cmd + + if {![string match "::*" $target]} { + if {[set ns [uplevel 1 {namespace current}]] eq "::"} { + set target ::$target + } else { + set target ${ns}::$target + } + } + #add > character if not already present + set target [namespace qualifiers $target]::>[string trimleft [namespace tail $target] >] + set _target [string map {::> ::} $target] + + set ns [namespace qualifiers $target] + if {$ns eq ""} { + set ns "::" + } else { + namespace eval $ns {} + } + + if {![llength [info commands $target]]} { + #degenerate case - target does not exist + #Probably just 1st of a set of Concatenate calls - so simply delegate to 'Clone' + #review - should be 'Copy' so it has object state from namespaces and variables? + return [::p::-1::Clone $_ID_ $target {*}$args] + + #set TARGETMAP [::p::predator::new_object $target] + #lassign [lindex $TARGETMAP 0] target_ID target_cmd itemCmd + + } else { + #set TARGETMAP [lindex [interp alias {} [namespace origin $target]] 1] + set TARGETMAP [$target --] + + lassign [dict get $TARGETMAP invocantdata] target_ID target_cmd itemCmd + + #Merge lastmodified(?) level0 and level1 interfaces. + + } + + return $target +} + + + +#Object's Base-Interface proc with itself as curried invocant. +#interp alias {} ::p::-1::Create {} ::p::-1::_iface::Create $invocant +#namespace eval ::p::-1 {namespace export Create} +dict set ::p::-1::_iface::o_methods Define {arglist definitions} +#define objects in one step +proc ::p::-1::Define {_ID_ definitions} { + set invocants [dict get $_ID_ i] + #set invocant_alias [lindex [dict get $invocants this] 0] + #set invocant [lindex [interp alias {} $invocant_alias] 1] + set OID [lindex [dict get $invocants this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + + lassign [dict get $MAP invocantdata] OID alias default_method cmd + set interfaces [dict get $MAP interfaces level0] ;#level-0 interfaces + set patterns [dict get $MAP interfaces level1] ;#level-1 interfaces + + #!todo - change these to dicts; key=interface stack name value= a list of interfaces in the stack + #set IFID0 [lindex $interfaces 0] + #set IFID1 [lindex $patterns 0] ;#1st pattern + + #set IFID_TOP [lindex $interfaces end] + set IFID_TOP [::p::predator::get_possibly_new_open_interface $OID] + + #set ns ::p::${OID} + + #set script [string map [list %definitions% $definitions] { + # if {[lindex [namespace path] 0] ne "::p::-1"} { + # namespace path [list ::p::-1 {*}[namespace path]] + # } + # %definitions% + # namespace path [lrange [namespace path] 1 end] + # + #}] + + set script [string map [list %id% $_ID_ %definitions% $definitions] { + set ::p::-1::temp_unknown [namespace unknown] + + namespace unknown [list ::apply {{funcname args} {::p::predator::redirect $funcname [list %id%] {*}$args}}] + + #namespace unknown [list ::apply { {funcname args} {if {![llength [info commands ::p::-1::$funcname]]} {::unknown $funcname {*}$args } else {::p::-1::$funcname [list %id%] {*}$args} }} ] + + %definitions% + + + namespace unknown ${::p::-1::temp_unknown} + return + }] + + + + #uplevel 1 $script ;#this would run the script in the global namespace + #run script in the namespace of the open interface, this allows creating of private helper procs + #namespace inscope ::p::${IFID_TOP}::_iface $script ;#do not use tailcall here! Define belongs on the callstack + #namespace inscope ::p::${OID} $script + namespace eval ::p::${OID} $script + #return $cmd +} + + +proc ::p::predator::redirect {func args} { + #todo - review tailcall - tests? + if {![llength [info commands ::p::-1::$func]]} { + #error "invalid command name \"$func\"" + tailcall uplevel 1 [list ::unknown $func {*}$args] + } else { + tailcall uplevel 1 [list ::p::-1::$func {*}$args] + } +} + + +#'immediate' constructor - this is really like a (VIOLATE) call.. todo - review. +dict set ::p::-1::_iface::o_methods Construct {arglist {argpairs body args}} +proc ::p::-1::Construct {_ID_ argpairs body args} { + set OID [::p::obj_get_this_oid $_ID_] + ::p::map $OID MAP + + set interfaces [dict get $MAP interfaces level0] + set iid_top [lindex $interfaces end] + namespace upvar ::p::${iid_top}::_iface o_varspaces o_varspaces o_varspace o_varspace + + set ARGSETTER {} + foreach {argname argval} $argpairs { + append ARGSETTER "set $argname $argval\n" + } + #$_self (VIOLATE) $ARGSETTER$body + + set body $ARGSETTER\n$body + + + set processed [dict create {*}[::p::predator::expand_var_statements $body $o_varspace]] + if {[llength [dict get $processed varspaces_with_explicit_vars]]} { + foreach vs [dict get $processed varspaces_with_explicit_vars] { + if {[string length $vs] && ($vs ni $o_varspaces)} { + lappend o_varspaces $vs + } + } + set body [dict get $processed body] + } else { + set varDecls [::p::predator::runtime_vardecls] ;#dynamic vardecls can access vars from all interfaces of invocant object. + set body $varDecls\n[dict get $processed body] + # puts stderr "\t runtime_vardecls in Construct $varDecls" + } + + set next "\[error {next not implemented}\]" + #set body [string map [::list @this@ "\[lindex \$_ID_ 0 3 \]"] $body\n] + set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata \] 3\]" @next@ $next] $body\n] + + + #namespace eval ::p::${iid_top} $body + + #return [apply [list {_ID_ args} $body ::p::${iid_top}::_iface] $_ID_] + #does this handle Varspace before constructor? + return [apply [list {_ID_ args} $body ::p::${OID} ] $_ID_ {*}$args] +} + + + + + +#hacked optimized version of ::p::-1::Create for creating ::p::ifaces::>* objects +namespace eval ::p::3 {} +proc ::p::3::_create {child {OID "-2"}} { + #puts stderr "::p::3::_create $child $OID" + set _child [string map {::> ::} $child] + if {$OID eq "-2"} { + #set childmapdata [::p::internals::new_object $child] + #set child_ID [lindex [dict get $childmapdata invocantdata] 0 ] + set child_ID [lindex [dict get [::p::internals::new_object $child] invocantdata] 0] + upvar #0 ::p::${child_ID}::_meta::map CHILDMAP + } else { + set child_ID $OID + #set _childmap [::p::internals::new_object $child "" $child_ID] + ::p::internals::new_object $child "" $child_ID + upvar #0 ::p::${child_ID}::_meta::map CHILDMAP + } + + #-------------- + + set oldinterfaces [dict get $CHILDMAP interfaces] + dict set oldinterfaces level0 [list 2] + set modifiedinterfaces $oldinterfaces + dict set CHILDMAP interfaces $modifiedinterfaces + + #-------------- + + + + + #puts stderr ">>>> creating alias for ::p::$child_ID" + #puts stderr ">>>::p::3::_create $child $OID >>>[interp alias {} ::p::$child_ID]" + + #interp alias ::p::$child_ID already exists at this point - so calling here will do nothing! + #interp alias {} ::p::$child_ID {} ::p::internals::predator [dict create i [dict create this [list [list $child_ID {} ]]]] + #puts stderr ">>>[interp alias {} ::p::$child_ID]" + + + + #--------------- + namespace upvar ::p::2::_iface o_methods o_methods o_properties o_properties + foreach method [dict keys $o_methods] { + #todo - change from interp alias to context proc + interp alias {} ::p::${child_ID}::$method {} ::p::2::_iface::$method + } + #namespace eval ::p::${child_ID} [list namespace export {*}$o_methods] + #implement property even if interface already compiled because we need to create defaults for each new child obj. + # also need to add alias on base interface + #make sure we are only implementing properties from the current CREATOR + dict for {prop pdef} $o_properties { + #lassign $pdef prop default + interp alias {} ::p::${child_ID}::$prop {} ::p::2::_iface::(GET)$prop + interp alias {} ::p::${child_ID}::(GET)$prop {} ::p::2::_iface::(GET)$prop + + } + ::p::2::_iface::(CONSTRUCTOR) [dict create i [dict create this [list [dict get $CHILDMAP invocantdata]]] context {}] + #--------------- + #namespace eval ::p::${child_ID} "namespace ensemble create -command $_child" + return $child +} + +#configure -prop1 val1 -prop2 val2 ... +dict set ::p::-1::_iface::o_methods Configure {arglist args} +proc ::p::-1::Configure {_ID_ args} { + + #!todo - add tests. + set OID [::p::obj_get_this_oid $_ID_] + ::p::map $OID MAP + + lassign [dict get $MAP invocantdata] OID alias itemCmd this + + if {![expr {([llength $args] % 2) == 0}]} { + error "expected even number of Configure args e.g '-property1 value1 -property2 value2'" + } + + #Do a separate loop to check all the arguments before we run the property setting loop + set properties_to_configure [list] + foreach {argprop val} $args { + if {!([string range $argprop 0 0] eq "-") || ([string length $argprop] < 2)} { + error "expected Configure args in the form: '-property1 value1 -property2 value2'" + } + lappend properties_to_configure [string range $argprop 1 end] + } + + #gather all valid property names for all level0 interfaces in the relevant interface stack + set valid_property_names [list] + set iflist [dict get $MAP interfaces level0] + foreach id [lreverse $iflist] { + set interface_property_names [dict keys [set ::p::${id}::_iface::o_properties]] + foreach if_prop $interface_property_names { + if {$if_prop ni $valid_property_names} { + lappend valid_property_names $if_prop + } + } + } + + foreach argprop $properties_to_configure { + if {$argprop ni $valid_property_names} { + error "Configure failed - no changes made. Unable to find property '$argprop' on object $this OID:'$OID' valid properties: $valid_property_names" + } + } + + set top_IID [lindex $iflist end] + #args ok - go ahead and set all properties + foreach {prop val} $args { + set property [string range $prop 1 end] + #------------ + #don't use property ref unnecessarily - leaves property refs hanging around which traces need to update + #ie don't do this here: set [$this . $property .] $val + #------------- + ::p::${top_IID}::_iface::(SET)$property $_ID_ $val ;#equivalent to [$this . (SET)$property $val] + } + return +} + + + + + + +dict set ::p::-1::_iface::o_methods AddPatternInterface {arglist iid} +proc ::p::-1::AddPatternInterface {_ID_ iid} { + #puts stderr "!!!!!!!!!!!!!!! ::p::-1::AddPatternInterface $_ID_ $iid" + if {![string is integer -strict $iid]} { + error "adding interface by name not yet supported. Please use integer id" + } + + set invocants [dict get $_ID_ i] + #set invocant_alias [lindex [dict get $invocants this] 0] + #set invocant [lindex [interp alias {} $invocant_alias] 1] + #lassign [lindex $invocant 0] OID alias itemCmd cmd + + set OID [lindex [dict get $invocants this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + set existing_ifaces [dict get $MAP interfaces level1] ;#pattern interfaces + + + + #it is theoretically possible to have the same interface present multiple times in an iStack. + # #!todo -review why/whether this is useful. should we disallow it and treat as an error? + + lappend existing_ifaces $iid + #lset map {1 1} $existing_ifaces + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level1 $existing_ifaces + dict set MAP interfaces $extracted_sub_dict + + #lset invocant {1 1} $existing_ifaces + +} + + +#!todo - update usedby ?? +dict set ::p::-1::_iface::o_methods AddInterface {arglist iid} +proc ::p::-1::AddInterface {_ID_ iid} { + #puts stderr "::p::-1::AddInterface _ID_:$_ID_ iid:$iid" + if {![string is integer -strict $iid]} { + error "adding interface by name not yet supported. Please use integer id" + } + + + lassign [dict get $_ID_ i this] list_of_invocants_for_role_this ;#Although there is normally only 1 'this' element - it is a 'role' and the structure is nonetheless a list. + set this_invocant [lindex $list_of_invocants_for_role_this 0] + + lassign $this_invocant OID _etc + + upvar #0 ::p::${OID}::_meta::map MAP + set existing_ifaces [dict get $MAP interfaces level0] + + lappend existing_ifaces $iid + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level0 $existing_ifaces + dict set MAP interfaces $extracted_sub_dict + return [dict get $extracted_sub_dict level0] +} + + + +# The 'Create' method on the meta-interface has 2 variants (CreateNew & CreateOverlay) provided to enhance code clarity for the application using the pattern module. +# The 'Create' method could be used in all instances - but 'CreateNew' is designed for the case where the target/child object does not yet exist +# and 'CreateOverlay' for the case where the target/child object already exists. +# If the application writer follows the convention of using 'CreateNew' & 'CreateOverlay' instead of 'Create' - it should be more obvious where a particular object first comes into existence, +# and it should reduce errors where the author was expecting to overlay an existing object, but accidentally created a new object. +# 'CreateNew' will raise an error if the target already exists +# 'CreateOverlay' will raise an error if the target object does not exist. +# 'Create' will work in either case. Creating the target if necessary. + + +#simple form: +# >somepattern .. Create >child +#simple form with arguments to the constructor: +# >somepattern .. Create >child arg1 arg2 etc +#complex form - specify more info about the target (dict keyed on childobject name): +# >somepattern .. Create {>child {-id 1}} +#or +# >somepattern .. Create [list >child {-id 1 -somethingelse etc} >child2 {}] +#complex form - with arguments to the contructor: +# >somepattern .. Create [list >child {-id 1}] arg1 arg2 etc +dict set ::p::-1::_iface::o_methods Create {arglist {target_spec args}} +proc ::p::-1::Create {_ID_ target_spec args} { + #$args are passed to constructor + if {[llength $target_spec] ==1} { + set child $target_spec + set targets [list $child {}] + } else { + set targets $target_spec + } + + set OID [::p::obj_get_this_oid $_ID_] + ::p::map $OID MAP + set invocants [dict get $_ID_ i] + set invocant_roles [dict keys $invocants] ;#usually the only invocant role present will be 'this' (single dispatch case) + + foreach {child target_spec_dict} $targets { + #puts ">>>::p::-1::Create $_ID_ $child $args <<<" + + + + #set invocant_alias [lindex [dict get $invocants this] 0] + #set invocant [lindex [interp alias {} $invocant_alias] 1] + + + #puts ">>Create _ID_:$_ID_ child:$child args:$args map:$map OID:$OID" + + #child should already be fully ns qualified (?) + #ensure it is has a pattern-object marker > + #puts stderr ".... $child (nsqual: [namespace qualifiers $child])" + + + lassign [dict get $MAP invocantdata] OID alias parent_defaultmethod cmd + set interfaces [dict get $MAP interfaces level0] ;#level-0 interfaces + set patterns [dict get $MAP interfaces level1] ;#level-1 interfaces + #puts "parent: $OID -> child:$child Patterns $patterns" + + #todo - change to dict of interface stacks + set IFID0 [lindex $interfaces 0] + set IFID1 [lindex $patterns 0] ;#1st pattern + + #upvar ::p::${OID}:: INFO + + if {![string match {::*} $child]} { + if {[set ns [uplevel 1 {namespace current}]] eq "::"} { + set child ::$child + } else { + set child ${ns}::$child + } + } + + + #add > character if not already present + set child [namespace qualifiers $child]::>[string trimleft [namespace tail $child] >] + set _child [string map {::> ::} $child] + + set ns [namespace qualifiers $child] + if {$ns eq ""} { + set ns "::" + } else { + namespace eval $ns {} + } + + + #maintain a record of interfaces created so that we can clean-up if we get an error during any of the Constructor calls. + set new_interfaces [list] + + if {![llength $patterns]} { + ##puts stderr "===> WARNING: no level-1 interfaces (patterns) on object $cmd when creating $child" + #lappend patterns [::p::internals::new_interface $OID] + + #lset invocant {1 1} $patterns + ##update our command because we changed the interface list. + #set IFID1 [lindex $patterns 0] + + #set patterns [list [::p::internals::new_interface $OID]] + + #set patterns [list [::p::internals::new_interface]] + + #set patterns [list [set iid [expr {$::p::ID + 1}]]] ;#PREDICT the next object's id + #set patterns [list [set iid [incr ::p::ID]]] + set patterns [list [set iid [::p::get_new_object_id]]] + + #--------- + #set iface [::p::>interface .. Create ::p::ifaces::>$iid] + #::p::-1::Create [list {caller ::p::3}] ::p::ifaces::>$iid + + #lappend new_interfaces [::p::3::_create ::p::ifaces::>$iid] ;#interface creation + lappend new_interfaces [::p::3::_create ::p::ifaces::>$iid $iid] + + #--------- + + #puts "??> p::>interface .. Create ::p::ifaces::>$iid" + #puts "??> [::p::ifaces::>$iid --]" + #set [$iface . UsedBy .] + } + set parent_patterndefaultmethod [dict get $MAP patterndata patterndefaultmethod] + + #if {![llength [info commands $child]]} {} + + if {[namespace which $child] eq ""} { + #normal case - target/child does not exist + set is_new_object 1 + + if {[dict exists $target_spec_dict -id]} { + set childmapdata [::p::internals::new_object $child "" [dict get $target_spec_dict -id]] + } else { + set childmapdata [::p::internals::new_object $child] + } + lassign [dict get $childmapdata invocantdata] child_ID child_alias child_defaultmethod + upvar #0 ::p::${child_ID}::_meta::map CHILDMAP + + #child initially uses parent's level1 interface as it's level0 interface + # child has no level1 interface until PatternMethods or PatternProperties are added + # (or applied via clone; or via create with a parent with level2 interface) + #set child_IFID $IFID1 + + #lset CHILDMAP {1 0} [list $IFID1] + #lset CHILDMAP {1 0} $patterns + + set extracted_sub_dict [dict get $CHILDMAP interfaces] + dict set extracted_sub_dict level0 $patterns + dict set CHILDMAP interfaces $extracted_sub_dict + + #why write back when upvared??? + #review + set ::p::${child_ID}::_meta::map $CHILDMAP + + #::p::predator::remap $CHILDMAP + + #interp alias {} $child {} ::p::internals::predator $CHILDMAP + + #set child_IFID $IFID1 + + #upvar ::p::${child_ID}:: child_INFO + + #!todo review + #set n ::p::${child_ID} + #if {![info exists ${n}::-->PATTERN_ANCHOR]} { + # #puts stdout "### target:'$child' Creating ${n}::-->PATTERN_ANCHOR (unset trace to delete namespace '$n'" + # #!todo - keep an eye on tip.tcl.tk #140 - 'Tracing Namespace Modification' - may be able to do away with this hack + # set ${n}::-->PATTERN_ANCHOR "objects within this namespace will be deleted when this var is unset" + # trace add variable ${n}::-->PATTERN_ANCHOR {unset} [list ::p::meta::clear_ns $n] + #} + + set ifaces_added $patterns + + } else { + #overlay/mixin case - target/child already exists + set is_new_object 0 + + #set CHILDMAP [lindex [interp alias {} [namespace origin $child]] 1] + set childmapdata [$child --] + + + #puts stderr " *** $cmd .. Create -> target $child already exists!!!" + #puts " **** CHILDMAP: $CHILDMAP" + #puts " ****" + + #puts stderr " ---> Properties: [$child .. Properties . names]" + #puts stderr " ---> Methods: [$child .. Properties . names]" + + lassign [dict get $childmapdata invocantdata] child_ID child_alias child_default child_cmd + upvar #0 ::p::${child_ID}::_meta::map CHILDMAP + + #set child_IFID [lindex $CHILDMAP 1 0 end] + #if {$child_IFID != [set child_IFID [::p::internals::expand_interface $child_IFID]]} { + # lset CHILDMAP {1 0} [concat [lindex $CHILDMAP 1 0] $child_IFID] + # interp alias {} $child_cmd {} ::p::internals::predator $CHILDMAP + #} + ##!todo? - merge only 'open' parent interfaces onto 'open' target interfaces + #::p::merge_interface $IFID1 $child_IFID + + + set existing_interfaces [dict get $CHILDMAP interfaces level0] + set ifaces_added [list] + foreach p $patterns { + if {$p ni $existing_interfaces} { + lappend ifaces_added $p + } + } + + if {[llength $ifaces_added]} { + #lset CHILDMAP {1 0} [concat [lindex $CHILDMAP 1 0] $ifaces_added] + set extracted_sub_dict [dict get $CHILDMAP interfaces] + dict set extracted_sub_dict level0 [concat $existing_interfaces $ifaces_added] + dict set CHILDMAP interfaces $extracted_sub_dict + #set ::p::${child_ID}::_meta::map $CHILDMAP ;#why? + #::p::predator::remap $CHILDMAP + } + } + + #do not overwrite the child's defaultmethod value if the parent_patterndefaultmethod is empty + if {$parent_patterndefaultmethod ne ""} { + set child_defaultmethod $parent_patterndefaultmethod + set CHILD_INVOCANTDATA [dict get $CHILDMAP invocantdata] + lset CHILD_INVOCANTDATA 2 $child_defaultmethod + dict set CHILDMAP invocantdata $CHILD_INVOCANTDATA + #update the child's _ID_ + interp alias {} $child_alias {} ;#first we must delete it + interp alias {} $child_alias {} ::p::internals::predator [list i [list this [list $CHILD_INVOCANTDATA] ] context {}] + + #! object_command was initially created as the renamed alias - so we have to do it again + rename $child_alias $child + trace add command $child rename [list $child .. Rename] + } + #!todo - review - dont we already have interp alias entries for every method/prop? + #namespace eval ::p::${child_ID} "namespace ensemble create -command $_child" + + + + + + set constructor_failure 0 ;#flag to indicate abortion due to error during a constructor call. + + + + #------------------------------------------------------------------------------------ + #create snapshot of the object-namespaces variables to allow object state to be rolledback if any Constructor calls fail. + # - All variables under the namespace - not just those declared as Variables or Properties + # - use a namespace. For the usual case of success, we just namespace delete, and remove the COW traces. + # - presumably this snapshot should be reasonably efficient even if variables hold large amounts of data, as Tcl implements Copy-On-Write. + + #NOTE - do not use the objectID as the sole identifier for the snapshot namespace. + # - there may be multiple active snapshots for a single object if it overlays itself during a constructor, + # and it may be that a failure of an inner overlay is deliberately caught and not considered reason to raise an error for the initial constructor call. + # - we will use an ever-increasing snapshotid to form part of ns_snap + set ns_snap "::p::snap::[incr ::p::snap::id]_$child_ID" ;#unique snapshot namespace for this call to Create. + + #!todo - this should look at child namespaces (recursively?) + #!todo - this should examine any namespaces implied by the default 'varspace' value for all interfaces. + # (some of these namespaces might not be descendants of the object's ::p::${child_ID} namespace) + + namespace eval $ns_snap {} + foreach vname [info vars ::p::${child_ID}::*] { + set shortname [namespace tail $vname] + if {[array exists $vname]} { + array set ${ns_snap}::${shortname} [array get $vname] + } elseif {[info exists $vname]} { + set ${ns_snap}::${shortname} [set $vname] + } else { + #variable exists without value (e.g created by 'variable' command) + namespace eval $ns_snap [list variable $shortname] ;#create the variable without value, such that it is present, but does not 'info exist' + } + } + #------------------------------------------------------------------------------------ + + + + + + + + + + #puts "====>>> ifaces_added $ifaces_added" + set idx 0 + set idx_count [llength $ifaces_added] + set highest_constructor_IFID "" + foreach IFID $ifaces_added { + incr idx + #puts "--> adding iface $IFID " + namespace upvar ::p::${IFID}::_iface o_usedby o_usedby o_open o_open o_methods o_methods o_properties o_properties o_variables o_variables o_unknown o_unknown o_varspace o_varspace o_varspaces o_varspaces + + if {[llength $o_varspaces]} { + foreach vs $o_varspaces { + #ensure all varspaces for the interface exists so that the 'namespace upvar' entries in methods etc will work. + if {[string match "::*" $vs]} { + namespace eval $vs {} ;#an absolute path to a namespace which may not be under the object's namespace at all. + } else { + namespace eval ::p::${child_ID}::$vs {} + } + } + } + + if {$IFID != 2} { + #>ifinfo interface always has id 2 and is used by all interfaces - no need to add everything to its usedby list. + if {![info exists o_usedby(i$child_ID)]} { + set o_usedby(i$child_ID) $child_alias + } + + #compile and close the interface only if it is shared + if {$o_open} { + ::p::predator::compile_interface $IFID $_ID_ ;#params: IFID , caller_ID_ + set o_open 0 + } + } + + + package require struct::set + + set propcmds [list] + foreach cmd [info commands ::p::${IFID}::_iface::(GET)*] { + set cmd [namespace tail $cmd] + #may contain multiple results for same prop e.g (GET)x.3 + set cmd [string trimright $cmd 0123456789] + set cmd [string trimright $cmd .] ;#do separately in case cmd name also contains numerals + lappend propcmds [string range $cmd 5 end] ;#don't worry about dupes here. + } + set propcmds [struct::set union $propcmds] ;#a way to get rid of dupes. + #$propcmds now holds all Properties as well as PropertyReads with no corresponding Property on this interface. + foreach property $propcmds { + #puts "\n\n ::p::${child_ID}::$property --->>>>>>>>>>>> ::p::${IFID}::_iface::(GET)$property \n" + interp alias {} ::p::${child_ID}::(GET)$property {} ::p::${IFID}::_iface::(GET)$property ;#used by property reference traces + interp alias {} ::p::${child_ID}::$property {} ::p::${IFID}::_iface::(GET)$property + } + + set propcmds [list] + foreach cmd [info commands ::p::${IFID}::_iface::(SET)*] { + set cmd [namespace tail $cmd] + #may contain multiple results for same prop e.g (GET)x.3 + set cmd [string trimright $cmd 0123456789] + set cmd [string trimright $cmd .] ;#do separately in case cmd name also contains numerals + lappend propcmds [string range $cmd 5 end] ;#don't worry about dupes here. + } + set propcmds [struct::set union $propcmds] ;#a way to get rid of dupes. + #$propcmds now holds all Properties as well as PropertyReads with no corresponding Property on this interface. + foreach property $propcmds { + interp alias {} ::p::${child_ID}::(SET)$property {} ::p::${IFID}::_iface::(SET)$property ;#used by property reference traces + } + + + foreach method [dict keys $o_methods] { + set arglist [dict get $o_methods $method arglist] + set argvals "" + foreach argspec $arglist { + if {[llength $argspec] == 2} { + set a [lindex $argspec 0] + } else { + set a $argspec + } + + if {$a eq "args"} { + append argvals " \{*\}\$args" + } else { + append argvals " \$$a" + } + } + set argvals [string trimleft $argvals] + + #interp alias {} ::p::${child_ID}::$method {} ::p::${IFID}::_iface::$method + + #this proc directly on the object is not *just* a forwarding proc + # - it provides a context in which the 'uplevel 1' from the running interface proc runs + #This (in 2018) is faster than a namespace alias forward to an interface proc which used apply to run in the dynamically calculated namespace (it seems the dynamic namespace stopped it from byte-compiling?) + + #proc calls the method in the interface - which is an interp alias to the head of the implementation chain + + proc ::p::${child_ID}::$method [list _ID_ {*}$arglist] [subst { + ::p::${IFID}::_iface::$method \$_ID_ $argvals + }] + + #proc ::p::${child_ID}::$method [list _ID_ {*}$arglist] [string map [list @m@ $method @ID@ $IFID @argvals@ $argvals] { + # ::p::@ID@::_iface::@m@ $_ID_ @argvals@ + #}] + + } + + #namespace eval ::p::${child_ID} [list namespace export {*}$o_methods] + + #implement property even if interface already compiled because we need to create defaults for each new child obj. + # also need to add alias on base interface + #make sure we are only implementing properties from the current CREATOR + dict for {prop pdef} $o_properties { + set varspace [dict get $pdef varspace] + if {![string length $varspace]} { + set ns ::p::${child_ID} + } else { + if {[string match "::*" $varspace]} { + set ns $varspace + } else { + set ns ::p::${child_ID}::$varspace + } + } + if {[dict exists $pdef default]} { + if {![info exists ${ns}::o_$prop]} { + #apply CREATORS defaults - don't trash existing state for matching property (only apply if var unset) + set ${ns}::o_$prop [dict get $pdef default] + } + } + #! May be replaced by a method with the same name + if {$prop ni [dict keys $o_methods]} { + interp alias {} ::p::${child_ID}::$prop {} ::p::${IFID}::_iface::(GET)$prop + } + interp alias {} ::p::${child_ID}::(GET)$prop {} ::p::${IFID}::_iface::(GET)$prop + interp alias {} ::p::${child_ID}::(SET)$prop {} ::p::${IFID}::_iface::(SET)$prop + } + + + + #variables + #foreach vdef $o_variables { + # if {[llength $vdef] == 2} { + # #there is a default value defined. + # lassign $vdef v default + # if {![info exists ::p::${child_ID}::$v]} { + # set ::p::${child_ID}::$v $default + # } + # } + #} + dict for {vname vdef} $o_variables { + if {[dict exists $vdef default]} { + #there is a default value defined. + set varspace [dict get $vdef varspace] + if {$varspace eq ""} { + set ns ::p::${child_ID} + } else { + if {[string match "::*" $varspace]} { + set ns $varspace + } else { + set ns ::p::${child_ID}::$varspace + } + } + set ${ns}::$vname [dict get $vdef default] + } + } + + #!todo - review. Write tests for cases of multiple constructors! + + #We don't want to the run constructor for each added interface with the same set of args! + #run for last one - rely on constructor authors to use @next@ properly? + if {[llength [set ::p::${IFID}::_iface::o_constructor]]} { + set highest_constructor_IFID $IFID + } + + if {$idx == $idx_count} { + #we are processing the last interface that was added - now run the latest constructor found + if {$highest_constructor_IFID ne ""} { + #at least one interface has a constructor + if {[llength [set ::p::${highest_constructor_IFID}::_iface::o_constructor]]} { + #puts ">>!! running constructor ifid:$highest_constructor_IFID child: $CHILDMAP" + if {[catch {::p::${highest_constructor_IFID}::_iface::(CONSTRUCTOR) [dict create i [dict create this [list [dict get $CHILDMAP invocantdata] ] ]] {*}$args} constructor_error]} { + set constructor_failure 1 + set constructor_errorInfo $::errorInfo ;#cache it immediately. + break + } + } + } + } + + if {[info exists o_unknown]} { + interp alias {} ::p::${IFID}::_iface::(UNKNOWN) {} ::p::${IFID}::_iface::$o_unknown + interp alias {} ::p::${child_ID}::(UNKNOWN) {} ::p::${child_ID}::$o_unknown + + #interp alias {} ::p::${IFID}::_iface::(UNKNOWN) {} ::p::${child_ID}::$o_unknown + #namespace eval ::p::${IFID}::_iface [list namespace unknown $o_unknown] + #namespace eval ::p::${child_ID} [list namespace unknown $o_unknown] + } + } + + if {$constructor_failure} { + if {$is_new_object} { + #is Destroy enough to ensure that no new interfaces or objects were left dangling? + $child .. Destroy + } else { + #object needs to be returned to a sensible state.. + #attempt to rollback all interface additions and object state changes! + puts "!!!!!!!!!!!!!!!!>>>constructor rollback object $child_ID \n\n\n\n" + #remove variables from the object's namespace - which don't exist in the snapshot. + set snap_vars [info vars ${ns_snap}::*] + puts "ns_snap '$ns_snap' vars'${snap_vars}'" + foreach vname [info vars ::p::${child_ID}::*] { + set shortname [namespace tail $vname] + if {"${ns_snap}::$shortname" ni "$snap_vars"} { + #puts "--- >>>>> unsetting $shortname " + unset -nocomplain $vname + } + } + + #restore variables from snapshot - but try to do so with minimal writes (don't want to trigger any unnecessary traces) + #values of vars may also have Changed + #todo - consider traces? what is the correct behaviour? + # - some application traces may have fired before the constructor error occurred. + # Should the rollback now also trigger traces? + #probably yes. + + #we need to test both source and dest var for arrayness - as the failed constructor could have changed the variable type, not just the value + foreach vname $snap_vars { + #puts stdout "@@@@@@@@@@@ restoring $vname" + #flush stdout + + + set shortname [namespace tail $vname] + set target ::p::${child_ID}::$shortname + if {$target in [info vars ::p::${child_ID}::*]} { + set present 1 ;#variable exists in one of 3 forms; array, simple, or 'declared only' + } else { + set present 0 + } + + if {[array exists $vname]} { + #restore 'array' variable + if {!$present} { + array set $target [array get $vname] + } else { + if {[array exists $target]} { + #unset superfluous elements + foreach key [array names $target] { + if {$key ni [array names $vname]} { + array unset $target $key + } + } + #.. and write only elements that have changed. + foreach key [array names $vname] { + if {[set ${target}($key)] ne [set ${vname}($key)]} { + set ${target}($key) [set ${vname}($key)] + } + } + } else { + #target has been changed to a simple variable - unset it and recreate the array. + unset $target + array set $target [array get $vname] + } + } + } elseif {[info exists $vname]} { + #restore 'simple' variable + if {!$present} { + set $target [set $vname] + } else { + if {[array exists $target]} { + #target has been changed to array - unset it and recreate the simple variable. + unset $target + set $target [set $vname] + } else { + if {[set $target] ne [set $vname]} { + set $target [set $vname] + } + } + } + } else { + #restore 'declared' variable + if {[array exists $target] || [info exists $target]} { + unset -nocomplain $target + } + namespace eval ::p::${child_ID} [list variable $shortname] + } + } + } + namespace delete $ns_snap + return -code error -errorinfo "oid:${child_ID} constructor_failure for IFID:${IFID}\n$constructor_errorInfo" $constructor_error + } + namespace delete $ns_snap + + } + + return $child +} + +dict set ::p::-1::_iface::o_methods Clone {arglist {clone args}} +#A cloned individual doesn't have the scars of its parent. i.e values (state) not *copied* +# (new 'clean' object with same structure. values as set by constructor or *specified by defaults*) +# Also: Any 'open' interfaces on the parent become closed on clone! +proc ::p::-1::Clone {_ID_ clone args} { + set OID [::p::obj_get_this_oid $_ID_] + ::p::map $OID MAP + + set invocants [dict get $_ID_ i] + lassign [dict get $MAP invocantdata] OID alias parent_defaultmethod cmd + + set _cmd [string map {::> ::} $cmd] + set tail [namespace tail $_cmd] + + + #obsolete? + ##set IFID0 [lindex $map 1 0 end] + #set IFID0 [lindex [dict get $MAP interfaces level0] end] + ##set IFID1 [lindex $map 1 1 end] + #set IFID1 [lindex [dict get $MAP interfaces level1] end] + + + if {![string match "::*" $clone]} { + if {[set ns [uplevel 1 {namespace current}]] eq "::"} { + set clone ::$clone + } else { + set clone ${ns}::$clone + } + } + + + set clone [namespace qualifiers $clone]::>[string trimleft [namespace tail $clone] >] + set _clone [string map {::> ::} $clone] + + + set cTail [namespace tail $_clone] + + set ns [namespace qualifiers $clone] + if {$ns eq ""} { + set ns "::" + } + + namespace eval $ns {} + + + #if {![llength [info commands $clone]]} {} + if {[namespace which $clone] eq ""} { + set clonemapdata [::p::internals::new_object $clone] + } else { + #overlay/mixin case - target/clone already exists + #set CLONEMAP [lindex [interp alias {} [namespace origin $clone]] 1] + set clonemapdata [$clone --] + } + set clone_ID [lindex [dict get $clonemapdata invocantdata] 0] + + upvar #0 ::p::${clone_ID}::_meta::map CLONEMAP + + + #copy patterndata element of MAP straight across + dict set CLONEMAP patterndata [dict get $MAP patterndata] + set CLONE_INVOCANTDATA [dict get $CLONEMAP invocantdata] + lset CLONE_INVOCANTDATA 2 $parent_defaultmethod + dict set CLONEMAP invocantdata $CLONE_INVOCANTDATA + lassign $CLONE_INVOCANTDATA clone_ID clone_alias clone_defaultmethod clone + + #update the clone's _ID_ + interp alias {} $clone_alias {} ;#first we must delete it + interp alias {} $clone_alias {} ::p::internals::predator [list i [list this [list $CLONE_INVOCANTDATA] ] context {}] + + #! object_command was initially created as the renamed alias - so we have to do it again + rename $clone_alias $clone + trace add command $clone rename [list $clone .. Rename] + + + + + #obsolete? + #upvar ::p::${clone_ID}:: clone_INFO + #upvar ::p::${IFID0}:: IFACE ;#same interface on predecessor(self) and clone. + #upvar ::p::${OID}:: INFO + + + array set clone_INFO [array get INFO] + + array set ::p::${clone_ID}::_iface::o_usedby [list] ;#'usedby' + + + #!review! + #if {![catch {set itemCmd $IFACE(m-1,name,item)}]} { + #puts "***************" + #puts "clone" + #parray IFINFO + #puts "***************" + #} + + #we need the parent(s) in order to 'clone'??? - probably, as the defs are usually there unless the object was created with ad-hoc methods/props directly from ::>pattern + + + #clone's interface maps must be a superset of original's + foreach lev {0 1} { + #set parent_ifaces [lindex $map 1 $lev] + set parent_ifaces [dict get $MAP interfaces level$lev] + + #set existing_ifaces [lindex $CLONEMAP 1 $lev] + set existing_ifaces [dict get $CLONEMAP interfaces level$lev] + + set added_ifaces_$lev [list] + foreach ifid $parent_ifaces { + if {$ifid ni $existing_ifaces} { + + #interface must not remain extensible after cloning. + if {[set ::p::${ifid}::_iface::o_open]} { + ::p::predator::compile_interface $ifid $_ID_ + set ::p::${ifid}::_iface::o_open 0 + } + + + + lappend added_ifaces_$lev $ifid + #clone 'uses' all it's predecessor's interfaces, so update each interface's 'usedby' list. + set ::p::${ifid}::_iface::o_usedby(i$clone_ID) $clone + } + } + set extracted_sub_dict [dict get $CLONEMAP interfaces] + dict set extracted_sub_dict level$lev [concat $existing_ifaces [set added_ifaces_$lev]] + dict set CLONEMAP interfaces $extracted_sub_dict + #lset CLONEMAP 1 $lev [concat $existing_ifaces [set added_ifaces_$lev]] + } + + #interp alias {} ::p::${IFID0}::(VIOLATE) {} ::p::internals::(VIOLATE) + + + #foreach *added* level0 interface.. + foreach ifid $added_ifaces_0 { + namespace upvar ::p::${ifid}::_iface o_methods o_methods o_properties o_properties o_variables o_variables o_constructor o_constructor o_unknown o_unknown + + + dict for {prop pdef} $o_properties { + #lassign $pdef prop default + if {[dict exists $pdef default]} { + set varspace [dict get $pdef varspace] + if {$varspace eq ""} { + set ns ::p::${clone_ID} + } else { + if {[string match "::*" $varspace]} { + set ns $varspace + } else { + set ns ::p::${clone_ID}::$varspace + } + } + + if {![info exists ${ns}::o_$prop]} { + #apply CREATORS defaults - don't trash existing state for matching property (only apply if var unset) + set ${ns}::o_$prop [dict get $pdef default] + } + } + + #! May be replaced by method of same name + if {[namespace which ::p::${clone_ID}::$prop] eq ""} { + interp alias {} ::p::${clone_ID}::$prop {} ::p::${ifid}::_iface::(GET)$prop + } + interp alias {} ::p::${clone_ID}::(GET)$prop {} ::p::${ifid}::_iface::(GET)$prop + interp alias {} ::p::${clone_ID}::(SET)$prop {} ::p::${ifid}::_iface::(SET)$prop + } + + #variables + dict for {vname vdef} $o_variables { + if {[dict exists $vdef default]} { + set varspace [dict get $vdef varspace] + if {$varspace eq ""} { + set ns ::p::${clone_ID} + } else { + if {[string match "::*" $varspace]} { + set ns $varspace + } else { + set ns ::p::${clone_ID}::$varspace + } + } + if {![info exists ${ns}::$vname]} { + set ::p::${clone_ID}::$vname [dict get $vdef default] + } + } + } + + + #update the clone object's base interface to reflect the new methods. + #upvar 0 ::p::${ifid}:: IFACE + #set methods [list] + #foreach {key mname} [array get IFACE m-1,name,*] { + # set method [lindex [split $key ,] end] + # interp alias {} ::p::${clone_ID}::$method {} ::p::${ifid}::_iface::$method $CLONEMAP + # lappend methods $method + #} + #namespace eval ::p::${clone_ID} [list namespace export {*}$methods] + + + foreach method [dict keys $o_methods] { + + set arglist [dict get $o_methods $method arglist] + set argvals "" + foreach argspec $arglist { + if {[llength $argspec] == 2} { + set a [lindex $argspec 0] + } else { + set a $argspec + } + + if {$a eq "args"} { + append argvals " \{*\}\$args" + } else { + append argvals " \$$a" + } + } + set argvals [string trimleft $argvals] + #interp alias {} ::p::${clone_ID}::$method {} ::p::${ifid}::_iface::$method + + #this proc directly on the object is not *just* a forwarding proc + # - it provides a context in which the 'uplevel 1' from the running interface proc runs + #This (in 2018) is faster than a namespace alias forward to an interface proc which used apply to run in the dynamically calculated namespace (it seems the dynamic namespace stopped it from byte-compiling?) + + #proc calls the method in the interface - which is an interp alias to the head of the implementation chain + proc ::p::${clone_ID}::$method [list _ID_ {*}$arglist] [subst { + ::p::${ifid}::_iface::$method \$_ID_ $argvals + }] + + } + #namespace eval ::p::${clone_ID} [list namespace export {*}$o_methods] + + + if {[info exists o_unknown]} { + #interp alias {} ::p::${IID}::_iface::(UNKNOWN) {} ::p::${clone_ID}::$o_unknown + interp alias {} ::p::${IID}::_iface::(UNKNOWN) {} ::p::${IID}::_iface::$o_unknown + interp alias {} ::p::${clone_ID}::(UNKNOWN) {} ::p::${clone_ID}::$o_unknown + + #namespace eval ::p::${IID}::_iface [list namespace unknown $o_unknown] + #namespace eval ::p::${clone_ID} [list namespace unknown $o_unknown] + + } + + + #2021 + #Consider >parent with constructor that sets height + #.eg >parent .. Constructor height { + # set o_height $height + #} + #>parent .. Create >child 5 + # - >child has height 5 + # now when we peform a clone operation - it is the >parent's constructor that will run. + # A clone will get default property and var values - but not other variable values unless the constructor sets them. + #>child .. Clone >fakesibling 6 + # - >sibling has height 6 + # Consider if >child had it's own constructor created with .. Construct prior to the clone operation. + # The >child's constructor didn't run - even though we created a >fakesibling - because the paren'ts one ran instead. + # If we now add a constructor to >fakesibling - and put @next@ for constructor chaining... + # when we now do >sibling .. Create >grandchild + # - The constructor on >sibling runs first but chains to >child - the cloner aunt/uncle of the >grandchild + # (while the calling order can't be changed - the positioning of @next@ tag in the contructor can allow code to run before and/or after the chained constructors and chaining can be disabled by providing a constructor without this tag.) + # However - the args supplied in the >clone operation don't get either constructor running on the >grandchild + #(though other arguments can be manually passed) + # #!review - does this make sense? What if we add + # + #constructor for each interface called after properties initialised. + #run each interface's constructor against child object, using the args passed into this clone method. + if {[llength [set constructordef [set o_constructor]]]} { + #error + puts "!!!!!> running constructor for ifid:$ifid on clone:$clone_ID" + ::p::${ifid}::_iface::(CONSTRUCTOR) [dict create i [dict create this [list [dict get $CLONEMAP invocantdata]] ]] {*}$args + + } + + } + + + return $clone + +} + + + +interp alias {} ::p::-1::constructor {} ::p::-1::Constructor ;#for Define compatibility (snit?) +dict set ::p::-1::_iface::o_methods Constructor {arglist {arglist body}} +proc ::p::-1::Constructor {_ID_ arglist body} { + set invocants [dict get $_ID_ i] + #set invocant_alias [lindex [dict get $invocants this] 0] + #set invocant [lindex [interp alias {} $invocant_alias] 1] + #lassign [lindex $invocant 0 ] OID alias itemCmd cmd + + set OID [lindex [dict get $_ID_ i this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + + set patterns [dict get $MAP interfaces level1] + set iid_top [lindex $patterns end] ;#!todo - choose 'open' interface to expand. + set iface ::p::ifaces::>$iid_top + + if {(![string length $iid_top]) || ([$iface . isClosed])} { + #no existing pattern - create a new interface + set iid_top [expr {$::p::ID + 1}] ;#PREDICT the next object's id + #set iid_top [::p::get_new_object_id] + + #the >interface constructor takes a list of IDs for o_usedby + set iface [::p::>interface .. Create ::p::ifaces::>$iid_top [list $OID]] + + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level1 [concat $patterns $iid_top] + dict set MAP interfaces $extracted_sub_dict + #lset map {1 1} [concat $patterns $iid_top] + + #::p::predator::remap $invocant + } + set IID $iid_top + + namespace upvar ::p::${IID}::_iface o_open o_open o_constructor o_constructor o_varspace o_varspace o_varspaces o_varspaces + + + # examine the existing command-chain + set maxversion [::p::predator::method_chainhead $IID (CONSTRUCTOR)] + set headid [expr {$maxversion + 1}] + set THISNAME (CONSTRUCTOR).$headid ;#first version will be $method.1 + + set next [::p::predator::next_script $IID (CONSTRUCTOR) $THISNAME $_ID_] + + #set varspaces [::pattern::varspace_list] + set processed [dict create {*}[::p::predator::expand_var_statements $body $o_varspace]] + + if {[llength [dict get $processed varspaces_with_explicit_vars]]} { + foreach vs [dict get $processed varspaces_with_explicit_vars] { + if {[string length $vs] && ($vs ni $o_varspaces)} { + lappend o_varspaces $vs + } + } + set body [dict get $processed body] + } else { + set varDecls [::p::predator::runtime_vardecls] + set body $varDecls\n[dict get $processed body] + #puts stderr "\t runtime_vardecls in Constructor $varDecls" + } + + #set body [string map [::list @this@ "\[lindex \$_ID_ 0 3]" @next@ $next] $body\n] + set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata \] 3\]" @next@ $next] $body\n] + + #puts stderr ---- + #puts stderr $body + #puts stderr ---- + + proc ::p::${IID}::_iface::(CONSTRUCTOR).$headid [concat _ID_ $arglist] $body + interp alias {} ::p::${IID}::_iface::(CONSTRUCTOR) {} ::p::${IID}::_iface::(CONSTRUCTOR).$headid + + + + set o_constructor [list $arglist $body] + set o_open 1 + + return +} + + + +dict set ::p::-1::_iface::o_methods UsedBy {arglist {}} +proc ::p::-1::UsedBy {_ID_} { + return [array get ::p::[lindex [dict get $_ID_ i this] 0 0]::_iface::o_usedby] +} + + +dict set ::p::-1::_iface::o_methods Ready {arglist {}} +proc ::p::-1::Ready {_ID_} { + return [expr {![set ::p::[lindex [dict get $_ID_ i this] 0 0]::_iface::o_open]}] +} + + + +dict set ::p::-1::_iface::o_methods Destroy {arglist {{force 1}}} + +#'force' 1 indicates object command & variable will also be removed. +#'force' 0 is used when the containing namespace is being destroyed anyway - so no need to destroy cmd & var. +#this is necessary for versions of Tcl that have problems with 'unset' being called multiple times. (e.g Tcl 8.5a4) +# +proc ::p::-1::Destroy {_ID_ {force 1}} { + #puts stdout "\t\tDestroy called with _ID_:$_ID_ force:$force caller:[info level 1]" + set invocants [dict get $_ID_ i] + set OID [lindex [dict get $invocants this] 0 0] + + if {$OID eq "null"} { + puts stderr "warning - review code. Destroy called on object with null OID. _ID_:$_ID_" + return + } + + upvar #0 ::p::${OID}::_meta::map MAP + + lassign [dict get $MAP invocantdata] OID alias itemCmd cmd + + + #puts ">>>>>Explicit Destroy $cmd [clock format [clock seconds] -format %H:%M:%S] info-level-1'[info level 1]'<<<<<" ;flush stdout + + #explicit Destroy - remove traces + #puts ">>TRACES: [trace info variable $cmd]" + #foreach tinfo [trace info variable $cmd] { + # trace remove variable $cmd {*}$tinfo + #} + #foreach tinfo [trace info command $cmd] { + # trace remove command $cmd {*}$tinfo + #} + + + set _cmd [string map {::> ::} $cmd] + + #set ifaces [lindex $map 1] + set iface_stacks [dict get $MAP interfaces level0] + #set patterns [lindex $map 2] + set pattern_stacks [dict get $MAP interfaces level1] + + + + set ifaces $iface_stacks + + + set patterns $pattern_stacks + + + #set i 0 + #foreach iflist $ifaces { + # set IFID$i [lindex $iflist 0] + # incr i + #} + + + set IFTOP [lindex $ifaces end] + + set DESTRUCTOR ::p::${IFTOP}::___system___destructor + #may be a proc, or may be an alias + if {[namespace which $DESTRUCTOR] ne ""} { + set temp_ID_ [dict create i [dict create this [list [dict get $MAP invocantdata]]] context {}] + + if {[catch {$DESTRUCTOR $temp_ID_} prob]} { + #!todo - ensure correct calling order of interfaces referencing the destructor proc + + + #!todo - emit destructor errors somewhere - logger? + #puts stderr "underlying proc already removed??? ---> $prob" + #puts stderr "--------Destructor Error on interface $IFID0 of Object $OID-------------" + #puts stderr $::errorInfo + #puts stderr "---------------------" + } + } + + + #remove ourself from each interfaces list of referencers + #puts stderr "--- $ifaces" + + foreach var {ifaces patterns} { + + foreach i [set $var] { + + if {[string length $i]} { + if {$i == 2} { + #skip the >ifinfo interface which doesn't maintain a usedby list anyway. + continue + } + + if {[catch { + + upvar #0 ::p::${i}::_iface::o_usedby usedby + + array unset usedby i$OID + + #puts "\n***>>***" + #puts "IFACE: $i usedby: $usedby" + #puts "***>>***\n" + + #remove interface if no more referencers + if {![array size usedby]} { + #puts " **************** DESTROYING unused interface $i *****" + #catch {namespace delete ::p::$i} + + #we happen to know where 'interface' object commands are kept: + + ::p::ifaces::>$i .. Destroy + + } + + } errMsg]} { + #warning + puts stderr "warning: error during destruction of object:$OID (removing usedby reference for interface $i) ([lindex [dict get $MAP invocantdata] 3]) \n $errMsg" + } + } + + } + + } + + set ns ::p::${OID} + #puts "-- destroying objects below namespace:'$ns'" + ::p::internals::DestroyObjectsBelowNamespace $ns + #puts "--.destroyed objects below '$ns'" + + + #set ns ::p::${OID}::_sub + #call .. Destroy on each thing that looks like a pattern object anywhere below our 'user-area' namespace + #( ::p::OBJECT::$OID ) + #puts "\n******** [clock format [clock seconds] -format %H:%M:%S] destroyingobjectsbelownamespace ns: $ns *****\n" + #::p::internals::DestroyObjectsBelowNamespace $ns + + #same for _meta objects (e.g Methods,Properties collections) + #set ns ::p::${OID}::_meta + #::p::internals::DestroyObjectsBelowNamespace $ns + + + + #foreach obj [info commands ${ns}::>*] { + # #Assume it's one of ours, and ask it to die. + # catch {::p::meta::Destroy $obj} + # #catch {$cmd .. Destroy} + #} + #just in case the user created subnamespaces.. kill objects there too. + #foreach sub [namespace children $ns] { + # ::p::internals::DestroyObjectsBelowNamespace $sub + #} + + + #!todo - fix. info vars on the namespace is not enough to detect references which were never set to a value! + #use info commands ::p::${OID}::_ref::* to find all references - including variables never set + #remove variable traces on REF vars + #foreach rv [info vars ::p::${OID}::_ref::*] { + # foreach tinfo [trace info variable $rv] { + # #puts "-->removing traces on $rv: $tinfo" + # trace remove variable $rv {*}$tinfo + # } + #} + + #!todo - write tests + #refs create aliases and variables at the same place + #- but variable may not exist if it was never set e.g if it was only used with info exists + foreach rv [info commands ::p::${OID}::_ref::*] { + foreach tinfo [trace info variable $rv] { + #puts "-->removing traces on $rv: $tinfo" + trace remove variable $rv {*}$tinfo + } + } + + + + + + + + #if {[catch {namespace delete $nsMeta} msg]} { + # puts stderr "-----&&&&&&&&&&&&&& ERROR deleting NS $nsMeta : $msg " + #} else { + # #puts stderr "------ -- -- -- -- deleted $nsMeta " + #} + + + #!todo - remove + #temp + #catch {interp alias "" ::>$OID ""} + + if {$force} { + #rename $cmd {} + + #removing the alias will remove the command - even if it's been renamed + interp alias {} $alias {} + + #if {[catch {rename $_cmd {} } why]} { + # #!todo - work out why some objects don't have matching command. + # #puts stderr "\t rename $_cmd {} failed" + #} else { + # puts stderr "\t rename $_cmd {} SUCCEEDED!!!!!!!!!!" + #} + + } + + set refns ::p::${OID}::_ref + #puts "[clock format [clock seconds] -format %H:%M:%S] - tidying up namespace $refns" + #puts "- children: [llength [namespace children $refns]]" + #puts "- vars : [llength [info vars ${refns}::*]]" + #puts "- commands: [llength [info commands ${refns}::*]]" + #puts "- procs : [llength [info procs ${refns}::*]]" + #puts "- aliases : [llength [lsearch -all -inline [interp aliases {}] ${refns}::*]]" + #puts "- matching command: [llength [info commands ${refns}]]" + #puts "[clock format [clock seconds] -format %H:%M:%S] - tidyup DONE $refns" + + + #foreach v [info vars ${refns}::*] { + # unset $v + #} + #foreach p [info procs ${refns}::*] { + # rename $p {} + #} + #foreach a [lsearch -all -inline [interp aliases {}] ${refns}::*] { + # interp alias {} $a {} + #} + + + #set ts1 [clock seconds] + #puts "[clock format $ts1 -format %H:%M:%S] $cmd about to delete $refns." + #puts "- children: [llength [namespace children $refns]]" + #puts "- vars : [llength [info vars ${refns}::*]]" + + #puts "- commands: [llength [info commands ${refns}::*]]" + #puts "- procs : [llength [info procs ${refns}::*]]" + #puts "- aliases : [llength [lsearch -all -inline [interp aliases {}] ${refns}::*]]" + #puts "- exact command: [info commands ${refns}]" + + + + + #puts "--delete ::p::${OID}::_ref" + if {[namespace exists ::p::${OID}::_ref]} { + #could just catch.. but would rather know if there's some other weird reason the namespace can't be deleted. + namespace delete ::p::${OID}::_ref:: + } + set ts2 [clock seconds] + #puts "[clock format $ts2 -format %H:%M:%S] $cmd deleted $refns. ELAPSED: [expr {$ts2 - $ts1}]" + + + #delete namespace where instance variables reside + #catch {namespace delete ::p::$OID} + namespace delete ::p::$OID + + #puts "...... destroyed $cmd [clock format [clock seconds] -format %H:%M:%S] <<<<<" ;flush stdout + return +} + + +interp alias {} ::p::-1::destructor {} ::p::-1::Destructor ;#for Define compatibility + + +dict set ::p::-1::_iface::o_methods Destructor {arglist {args}} +#!todo - destructor arguments? e.g to be able to mark for destruction on next sweep of some collector as opposed to immediate destruction? +#install a Destructor on the invocant's open level1 interface. +proc ::p::-1::Destructor {_ID_ args} { + set OID [::p::obj_get_this_oid $_ID_] + ::p::map $OID MAP + + #lassign [lindex $map 0] OID alias itemCmd cmd + + set patterns [dict get $MAP interfaces level1] + + if {[llength $args] > 2} { + error "too many arguments to 'Destructor' - expected at most 2 (arglist body)" + } + + set existing_IID [lindex $patterns end] ;#!todo - get 'open' interface. + + if {$existing_IID != [set IID [::p::internals::expand_interface $existing_IID]]} { + array unset ::p::${existing_IID}::_iface::o_usedby i$OID + error "NOT TESTED" + set ::p::${IID}::_iface::o_usedby(i$OID) $cmd + + set posn [lsearch $patterns $existing_IID] + + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level1 [concat [lreplace $patterns $posn $posn] $IID] + dict set MAP interfaces $extracted_sub_dict + #lset map {1 1} [concat [lreplace $patterns $posn $posn] $IID] + + #::p::predator::remap $invocant + } + + + set ::p::${IID}::_iface::o_destructor_body [lindex $args end] + + if {[llength $args] > 1} { + #!todo - allow destructor args(?) + set arglist [lindex $args 0] + } else { + set arglist [list] + } + + set ::p::${IID}::_iface::o_destructor_args $arglist + + return +} + + + + + +interp alias {} ::p::-1::method {} ::p::-1::PatternMethod ;#for Define compatibility (with snit) + + +dict set ::p::-1::_iface::o_methods PatternMethod {arglist {method arglist body}} +proc ::p::-1::PatternMethod {_ID_ method arglist body} { + set OID [::p::obj_get_this_oid $_ID_] + ::p::map $OID MAP + lassign [dict get $MAP invocantdata] OID alias default_method object_command _wrapped + + set patterns [dict get $MAP interfaces level1] + set iid_top [lindex $patterns end] ;#!todo - get 'open' interface. + set iface ::p::ifaces::>$iid_top + + if {(![string length $iid_top]) || ([$iface . isClosed])} { + #no existing pattern - create a new interface + set iid_top [expr {$::p::ID + 1}] ;#PREDICT the next object's id + set iface [::p::>interface .. Create ::p::ifaces::>$iid_top $OID] + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level1 [concat $patterns $iid_top] + dict set MAP interfaces $extracted_sub_dict + } + set IID $iid_top + + + namespace upvar ::p::${IID}::_iface o_methods o_methods o_definition o_definition o_varspace o_varspace o_varspaces o_varspaces + + + # examine the existing command-chain + set maxversion [::p::predator::method_chainhead $IID $method] + set headid [expr {$maxversion + 1}] + set THISNAME $method.$headid ;#first version will be $method.1 + + set next [::p::predator::next_script $IID $method $THISNAME $_ID_] + + + set processed [dict create {*}[::p::predator::expand_var_statements $body $o_varspace]] + if {[llength [dict get $processed varspaces_with_explicit_vars]]} { + foreach vs [dict get $processed varspaces_with_explicit_vars] { + if {[string length $vs] && ($vs ni $o_varspaces)} { + lappend o_varspaces $vs + } + } + set body [dict get $processed body] + } else { + set varDecls [::p::predator::runtime_vardecls] ;#dynamic vardecls can access vars from all interfaces of invocant object. + #puts stdout "!!!>!>>>>>$THISNAME VarDecls: $varDecls" + set body $varDecls\n[dict get $processed body] + #puts stderr "\t object $OID runtime_vardecls in PatternMethod $method $varDecls" + } + + + set body [::p::predator::wrap_script_in_apply_object_namespace $o_varspace $body[set body {}] $arglist] + + #set body [string map [::list @this@ "\[lindex \${_ID_} 0 3]" @next@ $next] $body\n] + set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata\] 3\]" @next@ $next] $body[set body {}]\n] + #puts "\t\t--------------------" + #puts "\n" + #puts $body + #puts "\n" + #puts "\t\t--------------------" + proc ::p::${IID}::_iface::$THISNAME [concat _ID_ $arglist] $body + + + + #pointer from method-name to head of the interface's command-chain + interp alias {} ::p::${IID}::_iface::$method {} ::p::${IID}::_iface::$THISNAME + + + + if {$method in [dict keys $o_methods]} { + #error "patternmethod '$method' already present in interface $IID" + set msg "WARNING: patternmethod '$method' already exists on objectid $OID ($object_command). Replacing previous version. (no chaining support here yet...)" + if {[string match "*@next@*" $body]} { + append msg "\n EXTRA-WARNING: method contains @next@" + } + + puts stdout $msg + } else { + dict set o_methods $method [list arglist $arglist] + } + + #::p::-1::update_invocant_aliases $_ID_ + return +} + +#MultiMethod +#invocant_signature records the rolenames and aritys as a dispatch signature to support multimethods which act on any number of invocants +# e.g1 $obj .. MultiMethod add {these 2} $arglist $body +# e.g2 $obj .. MultiMethod add {these n} $arglist $body +# +# e.g3 $collidabletemplate .. MultiMethod collision {vehicles 2 cameras 0..n} $arglist $body +# +# for e.g3 - all vehicles & cameras involved would need to have the interface containing the method named 'collision', with the matching invocant_signature. +# (it is possible for the object, or even the same interface to contain another method named 'collision' with a different signature) +# !todo - review rules for when invocants participating in a multimethod with a particular signature, have different implementations (method from different interfaces) +# - can we avoid the overhead of checking for this at dispatch-time, and simply use which ever implementation we first encounter? +# - should we warn about or enforce a same-implementation rule for all multimethod conflicts found at the time an object-conglomeration is formed? +# - should there be before and after hooks for all invocants involved in a multimethod so they can each add behaviour independent of the shared multimethod code? +# (and how would we define the call order? - presumably as it appears in the conglomerate) +# (or could that be done with a more general method-wrapping mechanism?) +#...should multimethods use some sort of event mechanism, and/or message-passing system? +# +dict set ::p::-1::_iface::o_methods MultiMethod {arglist {method invocant_signature arglist body args}} +proc ::p::-1::MultiMethod {_ID_ method invocant_signature arglist body args} { + set invocants [dict get $_ID_ i] + + error "not implemented" +} + +dict set ::p::-1::_iface::o_methods DefaultMethod {arglist {{methodname "noargsupplied--9e40ec8b-bc31-4400-98b8-d48ee23746c4"}}} +# we could use . to indicate no methodname - as this is one of a few highly confusing names for a method (also for example .. , # -- ) +#we can create a method named "." by using the argprotect operator -- +# e.g >x .. Method -- . {args} $body +#It can then be called like so: >x . . +#This is not guaranteed to work and is not in the test suite +#for now we'll just use a highly unlikely string to indicate no argument was supplied +proc ::p::-1::DefaultMethod {_ID_ {methodname "noargsupplied--9e40ec8b-bc31-4400-98b8-d48ee23746c4"} } { + set non_argument_magicstring "noargsupplied--9e40ec8b-bc31-4400-98b8-d48ee23746c4" + set OID [lindex [dict get $_ID_ i this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + lassign [dict get $MAP invocantdata] OID alias default_method object_command _wrapped + if {$methodname eq $non_argument_magicstring} { + return $default_method + } else { + set extracted_value [dict get $MAP invocantdata] + lset extracted_value 2 $methodname + dict set MAP invocantdata $extracted_value ;#write modified value back + #update the object's command alias to match + interp alias {} $alias {} ;#first we must delete it + interp alias {} $alias {} ::p::internals::predator [list i [list this [list $extracted_value ] ] context {}] + + #! $object_command was initially created as the renamed alias - so we have to do it again + rename $alias $object_command + trace add command $object_command rename [list $object_command .. Rename] + return $methodname + } +} + +dict set ::p::-1::_iface::o_methods PatternDefaultMethod {arglist {{methodname "noargsupplied--9e40ec8b-bc31-4400-98b8-d48ee23746c4"}}} +proc ::p::-1::PatternDefaultMethod {_ID_ {methodname "noargsupplied--9e40ec8b-bc31-4400-98b8-d48ee23746c4"} } { + set non_argument_magicstring "noargsupplied--9e40ec8b-bc31-4400-98b8-d48ee23746c4" + set OID [lindex [dict get $_ID_ i this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + set extracted_patterndata [dict get $MAP patterndata] + set pattern_default_method [dict get $extracted_patterndata patterndefaultmethod] + if {$methodname eq $non_argument_magicstring} { + return $pattern_default_method + } else { + dict set extracted_patterndata patterndefaultmethod $methodname + dict set MAP patterndata $extracted_patterndata + return $methodname + } +} + + +dict set ::p::-1::_iface::o_methods Method {arglist {method arglist bodydef args}} +proc ::p::-1::Method {_ID_ method arglist bodydef args} { + set invocants [dict get $_ID_ i] + + set OID [lindex [dict get $_ID_ i this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + + + set invocant_signature [list] ; + ;# we sort when calculating the sig.. so a different key order will produce the same signature - !todo - this is probably desirable but review anyway. + foreach role [lsort [dict keys $invocants]] { + lappend invocant_signature $role [llength [dict get $invocants $role]] + } + #note: it's expected that by far the most common 'invocant signature' will be {this 1} - which corresponds to a standard method dispatch on a single invocant object - the 'subject' (aka 'this') + + + + lassign [dict get $MAP invocantdata] OID alias default_method object_command + set interfaces [dict get $MAP interfaces level0] + + + + ################################################################################# + if 0 { + set iid_top [lindex $interfaces end] ;#!todo - get 'open' interface + set prev_open [set ::p::${iid_top}::_iface::o_open] + + set iface ::p::ifaces::>$iid_top + + set f_new 0 + if {![string length $iid_top]} { + set f_new 1 + } else { + if {[$iface . isClosed]} { + set f_new 1 + } + } + if {$f_new} { + #create a new interface + set iid_top [expr {$::p::ID + 1}] ;#PREDICT the next object's id + set iface [::p::>interface .. Create ::p::ifaces::>$iid_top $OID] + + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level0 [concat $interfaces $iid_top] + dict set MAP interfaces $extracted_sub_dict + + } + set IID $iid_top + + } + ################################################################################# + + set IID [::p::predator::get_possibly_new_open_interface $OID] + + #upvar 0 ::p::${IID}:: IFACE + + namespace upvar ::p::${IID}::_iface o_methods o_methods o_definition o_definition o_varspace o_varspace o_varspaces o_varspaces + + + #Interface proc + # examine the existing command-chain + set maxversion [::p::predator::method_chainhead $IID $method] + set headid [expr {$maxversion + 1}] + set THISNAME $method.$headid ;#first version will be $method.1 + + if {$method ni [dict keys $o_methods]} { + dict set o_methods $method [list arglist $arglist] + } + + #next_script will call to lower interface in iStack if we are $method.1 + set next [::p::predator::next_script $IID $method $THISNAME $_ID_] ;#last parameter is caller_ID_ + #puts ">!>>$THISNAME>>>>> next: '$next'<<<<<<" + + + #implement + #----------------------------------- + set processed [dict create {*}[::p::predator::expand_var_statements $bodydef $o_varspace]] + if {[llength [dict get $processed varspaces_with_explicit_vars]]} { + foreach vs [dict get $processed varspaces_with_explicit_vars] { + if {[string length $vs] && ($vs ni $o_varspaces)} { + lappend o_varspaces $vs + } + } + set body [dict get $processed body] + set varDecls "" + } else { + set varDecls [::p::predator::runtime_vardecls] ;#dynamic vardecls can access vars from all interfaces of invocant object. + set body $varDecls\n[dict get $processed body] + } + + + set body [::p::predator::wrap_script_in_apply_object_namespace $o_varspace $body $arglist] + + + + #set body [string map [::list @this@ "\[lindex \$_ID_ 0 3 \]" @next@ $next] $body\n] + set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata \] 3\]" @next@ $next] $body\n] + + #if {[string length $varDecls]} { + # puts stdout "\t---------------------------------------------------------------" + # puts stdout "\t----- efficiency warning - implicit var declarations used -----" + # puts stdout "\t-------- $object_command .. Method $method $arglist ---------" + # puts stdout "\t[string map [list \n \t\t\n] $body]" + # puts stdout "\t--------------------------" + #} + #invocants are stored as a nested dict in the Invocant Data parameter (_ID_) under the key 'i', and then the invocant_role + # while 'dict get $_ID_ i this' should always return a single invocant, all roles theoretically return a list of invocants fulfilling that position. + #(as specified by the @ operator during object conglomeration) + #set body [string map [::list @this@ "\[dict get \$_ID_ i this \]" @next@ $next] $body\n] + + #puts stdout "\t\t----------------------------" + #puts stdout "$body" + #puts stdout "\t\t----------------------------" + + proc ::p::${IID}::_iface::$THISNAME [concat _ID_ $arglist] $body + + #----------------------------------- + + #pointer from method-name to head of override-chain + interp alias {} ::p::${IID}::_iface::$method {} ::p::${IID}::_iface::$THISNAME + + + #point to the interface command only. The dispatcher will supply the invocant data + #interp alias {} ::p::${OID}::$method {} ::p::${IID}::_iface::$method + set argvals "" + foreach argspec $arglist { + if {[llength $argspec] == 2} { + set a [lindex $argspec 0] + } else { + set a $argspec + } + if {$a eq "args"} { + append argvals " \{*\}\$args" + } else { + append argvals " \$$a" + } + } + set argvals [string trimleft $argvals] + #this proc directly on the object is not *just* a forwarding proc + # - it provides a context in which the 'uplevel 1' from the running interface proc runs + #This (in 2018) is faster than a namespace alias forward to an interface proc which used apply to run in the dynamically calculated namespace (it seems the dynamic namespace stopped it from byte-compiling?) + + #we point to the method of the same name in the interface - which is an interp alias to the head of the implementation chain + + proc ::p::${OID}::$method [list _ID_ {*}$arglist] [subst { + ::p::${IID}::_iface::$method \$_ID_ $argvals + }] + + if 0 { + if {[llength $argvals]} { + proc ::p::${OID}::$method [list _ID_ {*}$arglist] [string map [list @ID@ [list $_ID_] @iid@ $IID @m@ $method @argl@ $arglist @argv@ $argvals] { + apply {{_ID_ @argl@} {::p::@iid@::_iface::@m@ $_ID_ @argl@}} @ID@ @argv@ + }] + } else { + + proc ::p::${OID}::$method [list _ID_ {*}$arglist] [string map [list @ID@ [list $_ID_] @iid@ $IID @m@ $method @argl@ $arglist] { + apply [list {_ID_ @argl@} {::p::@iid@::_iface::@m@ $_ID_ @argl@} [namespace current]] @ID@ + }] + + } + } + + + #proc ::p::${OID}::$method [list _ID_ {*}$arglist] [subst { + # ::p::${IID}::_iface::$method \$_ID_ $argvals + #}] + + #todo - for o_varspaces + #install ::p::${OID}::${varspace}::$method with interp alias from ::p::${OID}::$method + #- this should work correctly with the 'uplevel 1' procs in the interfaces + + + if {[string length $o_varspace]} { + if {[string match "::*" $o_varspace]} { + namespace eval $o_varspace {} + } else { + namespace eval ::p::${OID}::$o_varspace {} + } + } + + + #if the metainfo collection exists, update it. Don't worry if nonexistant as it will be created if needed. + set colMethods ::p::${OID}::_meta::>colMethods + + if {[namespace which $colMethods] ne ""} { + if {![$colMethods . hasKey $method]} { + $colMethods . add [::p::internals::predator $_ID_ . $method .] $method + } + } + + #::p::-1::update_invocant_aliases $_ID_ + return + #::>pattern .. Create [::>pattern .. Namespace]::>method_??? + #return $method_object +} + + +dict set ::p::-1::_iface::o_methods V {arglist {{glob *}}} +proc ::p::-1::V {_ID_ {glob *}} { + set invocants [dict get $_ID_ i] + #set invocant_alias [lindex [dict get $invocants this] 0] + #set invocant [lindex [interp alias {} $invocant_alias] 1] + + set OID [lindex [dict get $invocants this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + + lassign [dict get $MAP invocantdata] OID alias itemCmd cmd + set ifaces [dict get $MAP interfaces level0] ;#level 0 interfaces + + + + set vlist [list] + foreach IID $ifaces { + dict for {vname vdef} [set ::p::${IID}::_iface::o_variables] { + if {[string match $glob $vname]} { + lappend vlist $vname + } + } + } + return $vlist +} + +#experiment from http://wiki.tcl.tk/4884 +proc p::predator::pipeline {args} { + set lambda {return -level 0} + foreach arg $args { + set lambda [list apply [dict get { + toupper {{lambda input} {string toupper [{*}$lambda $input]}} + tolower {{lambda input} {string tolower [{*}$lambda $input]}} + totitle {{lambda input} {string totitle [{*}$lambda $input]}} + prefix {{lambda pre input} {string cat $pre [{*}$lambda $input]}} + suffix {{lambda suf input} {string cat [{*}$lambda $input] $suf}} + } [lindex $arg 0]] $lambda[set lambda {}] {*}[lrange $arg 1 end]] + } + return $lambda +} + +proc ::p::predator::get_apply_arg_0_oid {} { + set apply_args [lrange [info level 0] 2 end] + puts stderr ">>>>> apply_args:'$apply_args'<<<<" + set invocant [lindex $apply_args 0] + return [lindex [dict get $invocant i this] 0 0] +} +proc ::p::predator::get_oid {} { + #puts stderr "---->> [info level 1] <<-----" + set _ID_ [lindex [info level 1] 1] ;#something like ::p::17::_iface::method.1 {i {this { {16 ::p::16 item ::>thing {} } } }} arg1 arg2 + tailcall lindex [dict get $_ID_ i this] 0 0 +} + +#todo - make sure this is called for all script installations - e.g propertyread etc etc +#Add tests to check code runs in correct namespace +#review - how does 'Varspace' command affect this? +proc ::p::predator::wrap_script_in_apply_object_namespace {varspace body arglist} { + #use 'lindex $a 0' to make sure we only get the variable name. (arglist may have defaultvalues) + set arglist_apply "" + append arglist_apply "\$_ID_ " + foreach a $arglist { + if {$a eq "args"} { + append arglist_apply "{*}\$args" + } else { + append arglist_apply "\$[lindex $a 0] " + } + } + #!todo - allow fully qualified varspaces + if {[string length $varspace]} { + if {[string match ::* $varspace]} { + return "tailcall apply \[list \[list _ID_ $arglist\] \{$body\} $varspace \] $arglist_apply" + } else { + #return "uplevel 1 \[list apply \[list \[list _ID_ $arglist\] \{$body\} ::p::@OID@::$varspace \] $arglist_apply \]\n" + return "tailcall apply \[list \[list _ID_ $arglist\] \{$body\} ::p::@OID@::$varspace \] $arglist_apply" + } + } else { + #return "uplevel 1 \[list apply \[list \[list _ID_ $arglist\] \{$body\} ::p::@OID@ \] $arglist_apply \]\n" + #return "tailcall try \[list apply \[list \[list _ID_ $arglist\] \{$body\} ::p::@OID@ \] $arglist_apply \]" + + set script "tailcall apply \[list \{_ID_" + + if {[llength $arglist]} { + append script " $arglist" + } + append script "\} \{" + append script $body + append script "\} ::p::@OID@\] " + append script $arglist_apply + #puts stderr "\n88888888888888888888888888\n\t$script\n" + #puts stderr "\n77777777777777777777777777\n\ttailcall apply \[list \[list _ID_ $arglist\] \{$body\} ::p::@OID@ \] $arglist_apply" + #return $script + + + #----------------------------------------------------------------------------- + # 2018 candidates + # + #return "tailcall apply \[list \[list _ID_ $arglist\] \{$body\} ::p::@OID@ \] $arglist_apply" ;#ok - but doesn't seem to be bytecompiled + #return "tailcall apply \[list {_ID_ $arglist} {$body} ::p::@OID@ \] $arglist_apply" ;#ok - but doesn't seem to be bytecompiled + + #this has problems with @next@ arguments! (also script variables will possibly interfere with each other) + #faster though. + #return "uplevel 1 \{$body\}" + return "uplevel 1 [list $body]" + #----------------------------------------------------------------------------- + + #set script "apply \[list \[list _ID_ $arglist\] \{$body\}\] $arglist_apply" + #return "uplevel 1 \{$script\}" + + #return "puts stderr --\[info locals\]-- ;apply \[list {_ID_ $arglist} {$body} ::p::\[p::predator::get_oid\] \] $arglist_apply" ;#fail + #return "apply \[list {_ID_ $arglist} {$body} ::p::\[p::predator::get_oid\] \] $arglist_apply" ;#fail + + + + #return "tailcall apply { {_ID_ $arglist} {$body} ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\] } $arglist_apply" ;#wrong + + #return "tailcall apply \[list {_ID_ $arglist} {apply { {_ID_ $arglist} {$body}} $arglist_apply } ::p::@OID@ \] $arglist_apply" ;#wrong ns + + + #experiment with different dispatch mechanism (interp alias with 'namespace inscope') + #----------- + #return "apply { {_ID_ $arglist} {$body}} $arglist_apply" + + + #return "uplevel 1 \{$body\}" ;#do nothing + + #---------- + + #return "tailcall namespace inscope ::p::@OID@ \{apply \{\{_ID_ $arglist\} \{$body\}\}\} $arglist_apply" ;#wrong! doesn't evaluate in the correct namespace (wrong _ID_ ??) + + #return "tailcall apply \{\{_ID_ $arglist\} \{namespace inscope ::p::@OID@ \{$body\}\} \} $arglist_apply" ;#wrong - _ID_ now not available in $body + + #return "tailcall apply \{\{ns _ID_ $arglist\} \{ apply \[list {_ID_ $arglist} \{$body\} \$ns \] $arglist_apply \} \} ::p::@OID@ $arglist_apply" ;#no quicker + + #return "tailcall " + + } +} + + +#Handle 'var' and 'varspace' declarations in method/constructor/destructor/propertyread etc bodies. +#expand 'var' statements inline in method bodies +#The presence of a var statement in any code-branch will cause the processor to NOT insert the implicit default var statements. +# +#concept of 'varspace' to allow separation and/or sharing of contexts for cooperating interfaces +#WARNING: within methods etc, varspace statements affect all following var statements.. i.e varspace not affected by runtime code-branches! +# e.g if 1 {varspace x} else {varspace y} will always leave 'varspace y' in effect for following statements. +#Think of var & varspace statments as a form of compile-time 'macro' +# +#caters for 2-element lists as arguments to var statement to allow 'aliasing' +#e.g var o_thing {o_data mydata} +# this will upvar o_thing as o_thing & o_data as mydata +# +proc ::p::predator::expand_var_statements {rawbody {varspace ""}} { + set body {} + + #keep count of any explicit var statments per varspace in 'numDeclared' array + # don't initialise numDeclared. We use numDeclared keys to see which varspaces have var statements. + + #default varspace is "" + #varspace should only have leading :: if it is an absolute namespace path. + + + foreach ln [split $rawbody \n] { + set trimline [string trim $ln] + + if {$trimline eq "var"} { + #plain var statement alone indicates we don't have any explicit declarations in this branch + # and we don't want implicit declarations for the current varspace either. + #!todo - implement test + + incr numDeclared($varspace) + + #may be further var statements e.g - in other code branches + #return [list body $rawbody varspaces_with_explicit_vars 1] + } elseif {([string range $trimline 0 2] eq "var") && ([string is space [string index $trimline 3]])} { + + #append body " upvar #0 " + #append body " namespace upvar ::p::\[lindex \$_ID_ 0 0 \]${varspace} " + #append body " namespace upvar ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]${varspace} " + + if {$varspace eq ""} { + append body " namespace upvar ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\] " + } else { + if {[string match "::*" $varspace]} { + append body " namespace upvar $varspace " + } else { + append body " namespace upvar ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::${varspace} " + } + } + + #any whitespace before or betw var names doesn't matter - about to use as list. + foreach varspec [string range $trimline 4 end] { + lassign [concat $varspec $varspec] var alias ;#var == alias if varspec only 1 element. + ##append body "::p::\[lindex \$_ID_ 0 0 \]::${varspace}$var $alias " + #append body "::p::\[lindex \$_ID_ 0 0 \]${varspace}$var $alias " + + append body "$var $alias " + + } + append body \n + + incr numDeclared($varspace) + } elseif {([string range $trimline 0 7] eq "varspace") && ([string is space -strict [string index $trimline 8]])} { + # 2021 REVIEW - why do we even need 'varspace x' commands in bodies? - just use 'namespace eval x' ??? + #it is assumed there is a single word following the 'varspace' keyword. + set varspace [string trim [string range $trimline 9 end]] + + if {$varspace in [list {{}} {""}]} { + set varspace "" + } + if {[string length $varspace]} { + #set varspace ::${varspace}:: + #no need to initialize numDeclared($varspace) incr will work anyway. + #if {![info exists numDeclared($varspace)]} { + # set numDeclared($varspace) 0 + #} + + if {[string match "::*" $varspace]} { + append body "namespace eval $varspace {} \n" + } else { + append body "namespace eval ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::$varspace {} \n" + } + + #puts "!!!! here~! namespace eval ::p::\[lindex \$_ID_ 0 0\]$varspace {} " + #append body "namespace eval ::p::\[lindex \$_ID_ 0 0\]$varspace {} \n" + #append body "namespace eval ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]$varspace {} \n" + + #append body "puts \"varspace: created ns ::p::\[lindex \$_ID_ 0 0\]$varspace \"\n" + } + #!review - why? why do we need the magic 'default' name instead of just using the empty string? + #if varspace argument was empty string - leave it alone + } else { + append body $ln\n + } + } + + + + set varspaces [array names numDeclared] + return [list body $body varspaces_with_explicit_vars $varspaces] +} + + + + +#Interface Variables +dict set ::p::-1::_iface::o_methods IV {arglist {{glob *}}} +proc ::p::-1::IV {_ID_ {glob *}} { + set invocants [dict get $_ID_ i] + + set OID [lindex [dict get $invocants this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + lassign [dict get $MAP invocantdata] OID alias itemCmd cmd + set ifaces [dict get $MAP interfaces level0] ;#level 0 interfaces + + + #!todo - test + #return [dict keys ::p::${OID}::_iface::o_variables $glob] + + set members [list] + foreach vname [dict keys [set ::p::${OID}::_iface::o_variables]] { + if {[string match $glob $vname]} { + lappend members $vname + } + } + return $members +} + +dict set ::p::-1::_iface::o_methods MetaMethods {arglist {{glob *}}} +proc ::p::-1::MetaMethods {_ID_ {glob *}} { + upvar ::p::-1::_iface::o_methods metaface_methods + set metamethod_names [lsort [dict keys $metaface_methods]] + if {$glob ne "*"} { + set metamethod_names [lsearch -all -inline $metamethod_names $glob] + } + return $metamethod_names +} + + +dict set ::p::-1::_iface::o_methods Methods {arglist {{idx ""}}} +proc ::p::-1::Methods {_ID_ {idx ""}} { + set invocants [dict get $_ID_ i] + set this_invocant [lindex [dict get $invocants this] 0] + lassign $this_invocant OID _etc + #set map [dict get $this_info map] + set OID [lindex [dict get $_ID_ i this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + + + lassign [dict get $MAP invocantdata] OID alias itemCmd cmd + set ifaces [dict get $MAP interfaces level0] ;#level 0 interfaces + + set col ::p::${OID}::_meta::>colMethods + + if {[namespace which $col] eq ""} { + patternlib::>collection .. Create $col + foreach IID $ifaces { + foreach m [dict keys [set ::p::${IID}::_iface::o_methods]] { + if {![$col . hasIndex $m]} { + #todo - create some sort of lazy-evaluating method object? + #set arglist [dict get [set ::p::${IID}::iface::o_methods] $m arglist] + $col . add [::p::internals::predator $_ID_ . $m .] $m + } + } + } + } + if {[string length $idx]} { + return [$col . item $idx] + } else { + return $col + } +} + +dict set ::p::-1::_iface::o_methods M {arglist {{glob *}}} +proc ::p::-1::M {_ID_ {glob *}} { + set invocants [dict get $_ID_ i] + set this_invocant [lindex [dict get $invocants this] 0] + lassign $this_invocant OID _etc + #set map [dict get $this_info map] + set OID [lindex [dict get $_ID_ i this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + lassign [dict get $MAP invocantdata] OID alias itemCmd cmd + set ifaces [dict get $MAP interfaces level0] ;#level 0 interfaces + set members [list] + foreach IID $ifaces { + lappend members {*}[dict keys [set ::p::${IID}::_iface::o_methods] $glob] + } + return $members +} + +#PatternMethods +dict set ::p::-1::_iface::o_methods PM {arglist {{glob *}}} +proc ::p::-1::PM {_ID_ {glob *}} { + set invocants [dict get $_ID_ i] + set this_invocant [lindex [dict get $invocants this] 0] + lassign $this_invocant OID _etc + #set OID [lindex [dict get $_ID_ i this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + #lassign [dict get $MAP invocantdata] OID alias itemCmd cmd + set ifaces [dict get $MAP interfaces level1] ;#level 1 interfaces + set members [list] + foreach IID $ifaces { + lappend members {*}[dict keys [set ::p::${IID}::_iface::o_methods] $glob] + } + return [lsort $members] +} + + +#review +#Interface Methods +dict set ::p::-1::_iface::o_methods IM {arglist {{glob *}}} +proc ::p::-1::IM {_ID_ {glob *}} { + set invocants [dict get $_ID_ i] + set this_invocant [lindex [dict get $invocants this] 0] + lassign $this_invocant OID _etc + #set map [dict get $this_info map] + set OID [lindex [dict get $_ID_ i this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + + lassign [dict get $MAP invocantdata] OID alias itemCmd cmd + set ifaces [dict get $MAP interfaces level0] ;#level 0 interfaces + + return [dict keys [set ::p::${OID}::_iface::o_methods] $glob] + +} + + + +dict set ::p::-1::_iface::o_methods InterfaceStacks {arglist {}} +proc ::p::-1::InterfaceStacks {_ID_} { + upvar #0 ::p::[lindex [dict get $_ID_ i this] 0 0]::_meta::map MAP + return [dict get $MAP interfaces level0] +} + + +dict set ::p::-1::_iface::o_methods PatternStacks {arglist {}} +proc ::p::-1::PatternStacks {_ID_} { + set OID [lindex [dict get $_ID_ i this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + return [dict get $MAP interfaces level1] +} + + +#!todo fix. need to account for references which were never set to a value +dict set ::p::-1::_iface::o_methods DeletePropertyReferences {arglist {}} +proc ::p::-1::DeletePropertyReferences {_ID_} { + set OID [lindex [dict get $_ID_ i this] 0 0] + set cleared_references [list] + set refvars [info vars ::p::${OID}::_ref::*] + #unsetting vars will clear traces anyway - but we wish to avoid triggering the 'unset' traces - so we will explicitly remove all traces 1st. + foreach rv $refvars { + foreach tinfo [trace info variable $rv] { + set ops {}; set cmd {} + lassign $tinfo ops cmd + trace remove variable $rv $ops $cmd + } + unset $rv + lappend cleared_references $rv + } + + + return [list deleted_property_references $cleared_references] +} + +dict set ::p::-1::_iface::o_methods DeleteMethodReferences {arglist {}} +proc ::p::-1::DeleteMethodReferences {_ID_} { + set OID [lindex [dict get $_ID_ i this] 0 0] + set cleared_references [list] + + set iflist [dict get $MAP interfaces level0] + set iflist_reverse [lreferse $iflist] + #set iflist [dict get $MAP interfaces level0] + + + set refcommands [info commands ::p::${OID}::_ref::*] + foreach c $refcommands { + set reftail [namespace tail $c] + set field [lindex [split $c +] 0] + set field_is_a_method 0 + foreach IFID $iflist_reverse { + if {$field in [dict keys [set ::p::${IFID}::_iface::o_methods]]} { + set field_is_a_method 1 + break + } + } + if {$field_is_a_method} { + #what if it's also a property? + interp alias {} $c {} + lappend cleared_references $c + } + } + + + return [list deleted_method_references $cleared_references] +} + + +dict set ::p::-1::_iface::o_methods DeleteReferences {arglist {}} +proc ::p::-1::DeleteReferences {_ID_} { + set OID [lindex [dict get $_ID_ i this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + lassign [dict get $MAP invocantdata] OID alias default_method this + + set result [dict create] + dict set result {*}[$this .. DeletePropertyReferences] + dict set result {*}[$this .. DeleteMethodReferences] + + return $result +} + +## +#Digest +# +#!todo - review +# -> a variable containing empty string is the same as a non existant variable as far as digest is concerned.. is that bad? (probably!) +# +#!todo - write tests - check that digest changes when properties of contained objects change value +# +#!todo - include method/property/interfaces in digest calc, or provide a separate more comprehensive digest method? +# +dict set ::p::-1::_iface::o_methods Digest {arglist {args}} +proc ::p::-1::Digest {_ID_ args} { + set invocants [dict get $_ID_ i] + # md5 c-version is faster than md4 tcl version... and more likely to be required in the interp for some other purpose anyway. + #set this_invocant [lindex [dict get $invocants this] 0] + #lassign $this_invocant OID _etc + set OID [lindex [dict get $_ID_ i this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + lassign [dict get $MAP invocantdata] _OID alias default_method this + + + set interface_ids [dict get $MAP interfaces level0] + set IFID0 [lindex $interface_ids end] + + set known_flags {-recursive -algorithm -a -indent} + set defaults {-recursive 1 -algorithm md5 -indent ""} + if {[dict exists $args -a] && ![dict exists $args -algorithm]} { + dict set args -algorithm [dict get $args -a] + } + + set opts [dict merge $defaults $args] + foreach key [dict keys $opts] { + if {$key ni $known_flags} { + error "unknown option $key. Expected only: $known_flags" + } + } + + set known_algos {"" raw RAW none NONE md5 MD5 sha256 SHA256} + if {[dict get $opts -algorithm] ni $known_algos} { + error "call to Digest with unknown -algorithm [dict get $opts -algorithm]. Expected one of: $known_algos" + } + set algo [string tolower [dict get $opts -algorithm]] + + # append comma for each var so that all changes in adjacent vars detectable. + # i.e set x 34; set y 5 + # must be distinguishable from: + # set x 3; set y 45 + + if {[dict get $opts -indent] ne ""} { + set state "" + set indent "[dict get $opts -indent]" + } else { + set state "---\n" + set indent " " + } + append state "${indent}object_command: $this\n" + set indent "${indent} " + + #append state "[lindex [interp alias {} $alias] 1]\n" ;#at the very least, include the object's interface state. + append state "${indent}interfaces: [dict get $MAP interfaces]\n";#at the very least, include the object's interface state. + + + #!todo - recurse into 'varspaces' + set varspaces_found [list] + append state "${indent}interfaces:\n" + foreach IID $interface_ids { + append state "${indent} - interface: $IID\n" + namespace upvar ::p::${IID}::_iface o_varspace local_o_varspace o_varspaces local_o_varspaces + append state "${indent} varspaces:\n" + foreach vs $local_o_varspaces { + if {$vs ni $varspaces_found} { + lappend varspaces_found $vs + append state "${indent} - varspace: $vs\n" + } + } + } + + append state "${indent}vars:\n" + foreach var [info vars ::p::${OID}::*] { + append state "${indent} - [namespace tail $var] : \"" + if {[catch {append state "[set $var]"}]} { + append state "[array get $var]" + } + append state "\"\n" + } + + if {[dict get $opts -recursive]} { + append state "${indent}sub-objects:\n" + set subargs $args + dict set subargs -indent "$indent " + foreach obj [info commands ::p::${OID}::>*] { + append state "[$obj .. Digest {*}$subargs]\n" + } + + append state "${indent}sub-namespaces:\n" + set subargs $args + dict set subargs -indent "$indent " + foreach ns [namespace children ::p::${OID}] { + append state "${indent} - namespace: $ns\n" + foreach obj [info commands ${ns}::>*] { + append state "[$obj .. Digest {*}$subargs]\n" + } + } + } + + if {$algo in {"" raw none}} { + return $state + } else { + if {$algo eq "md5"} { + package require md5 + return [::md5::md5 -hex $state] + } elseif {$algo eq "sha256"} { + package require sha256 + return [::sha2::sha256 -hex $state] + } elseif {$algo eq "blowfish"} { + package require patterncipher + patterncipher::>blowfish .. Create >b1 + set [>b1 . key .] 12341234 + >b1 . encrypt $state -final 1 + set result [>b1 . ciphertext] + >b1 .. Destroy + + } elseif {$algo eq "blowfish-binary"} { + + } else { + error "can't get here" + } + + } +} + + +dict set ::p::-1::_iface::o_methods Variable {arglist {varname args}} +proc ::p::-1::Variable {_ID_ varname args} { + set invocants [dict get $_ID_ i] + + #set invocant_alias [lindex [dict get $invocants this] 0] + #set invocant [lindex [interp alias {} $invocant_alias] 1] + + set OID [lindex [dict get $invocants this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + #this interface itself is always a co-invocant + lassign [dict get $MAP invocantdata] OID alias itemCmd cmd + set interfaces [dict get $MAP interfaces level0] + + #set existing_IID [lindex $map 1 0 end] + set existing_IID [lindex $interfaces end] + + set prev_openstate [set ::p::${existing_IID}::_iface::o_open] + + if {$existing_IID != [set IID [::p::internals::expand_interface $existing_IID]]} { + #IID changed + #remove ourself from the usedby list of the previous interface + array unset ::p::${existing_IID}::_iface::o_usedby i$OID + set ::p::${IID}::_iface::o_usedby(i$OID) $cmd + + set posn [lsearch $interfaces $existing_IID] + + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level0 [concat [lreplace $interfaces $posn $posn] $IID] + dict set MAP interfaces $extracted_sub_dict + #lset map {1 0} [concat [lreplace $interfaces $posn $posn] $IID] + + + #update original object command + set ::p::${IID}::_iface::o_open 0 + } else { + set ::p::${IID}::_iface::o_open $prev_openstate + } + + set varspace [set ::p::${IID}::_iface::o_varspace] ;#varspace at the time this Variable was added (may differ from default for interface) + + if {[llength $args]} { + #!assume var not already present on interface - it is an error to define twice (?) + #lappend ::p::${IID}::_iface::o_variables [list $varname [lindex $args 0]] + dict set ::p::${IID}::_iface::o_variables $varname [list default [lindex $args 0] varspace $varspace] + + + #Implement if there is a default + #!todo - correct behaviour when overlaying on existing object with existing var of this name? + #if {[string length $varspace]} { + # set ::p::${OID}::${varspace}::$varname [lindex $args 0] + #} else { + set ::p::${OID}::$varname [lindex $args 0] + #} + } else { + #lappend ::p::${IID}::_iface::o_variables [list $varname] + dict set ::p::${IID}::_iface::o_variables $varname [list varspace $varspace] + } + + #varspace '_iface' + + return +} + + +#interp alias {} ::p::-1::variable {} ::p::-1::PatternVariable ;#for Define compatibility + +dict set ::p::-1::_iface::o_methods PatternVariable {arglist {varname args}} +proc ::p::-1::PatternVariable {_ID_ varname args} { + set invocants [dict get $_ID_ i] + + #set invocant_alias [lindex [dict get $invocants this] 0] + #set invocant [lindex [interp alias {} $invocant_alias] 1] + ##this interface itself is always a co-invocant + #lassign [lindex $invocant 0 ] OID alias itemCmd cmd + + set OID [lindex [dict get $invocants this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + + + + set patterns [dict get $MAP interfaces level1] + set iid_top [lindex $patterns end] ;#!todo - get 'open' interface. + set iface ::p::ifaces::>$iid_top + + if {(![string length $iid_top]) || ([$iface . isClosed])} { + #no existing pattern - create a new interface + set iid_top [expr {$::p::ID + 1}] ;#PREDICT the next object's id + set iface [::p::>interface .. Create ::p::ifaces::>$iid_top $OID] + + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level1 [concat $patterns $iid_top] + dict set MAP interfaces $extracted_sub_dict + #lset map {1 1} [concat $patterns $iid_top] + } + set IID $iid_top + + set varspace [set ::p::${IID}::_iface::o_varspace] ;#record varspace against each variable, because default varspace for interface can be modified. + + + if {[llength $args]} { + #lappend ::p::${IID}::_iface::o_variables [list $varname [lindex $args 0]] + dict set ::p::${IID}::_iface::o_variables $varname [list default [lindex $args 0] varspace $varspace] + } else { + dict set ::p::${IID}::_iface::o_variables $varname [list varspace $varspace] + } + + return +} + +dict set ::p::-1::_iface::o_methods Varspaces {arglist args} +proc ::p::-1::Varspaces {_ID_ args} { + set invocants [dict get $_ID_ i] + set OID [lindex [dict get $_ID_ i this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + + if {![llength $args]} { + #query + set iid_top [lindex [dict get $MAP interfaces level0] end] + set iface ::p::ifaces::>$iid_top + if {![string length $iid_top]} { + error "Cannot query Varspaces because no top level interface on object:[lindex [dict get $MAP invocantdata] 3] " + } elseif {[$iface . isClosed]} { + error "Cannot query Varspaces because top level interface (id:$iid_top) is closed on object:[lindex [dict get $MAP invocantdata] 3] " + } + return [set ::p::${iid_top}::_iface::o_varspaces] + } + set IID [::p::predator::get_possibly_new_open_interface $OID] + namespace upvar ::p::${IID}::_iface o_varspace o_varspace o_varspaces o_varspaces + + set varspaces $args + foreach vs $varspaces { + if {[string length $vs] && ($vs ni $o_varspaces)} { + if {[string match ::* $vs]} { + namespace eval $vs {} + } else { + namespace eval ::p::${OID}::$vs {} + } + lappend o_varspaces $vs + } + } + return $o_varspaces +} + +#set or query Varspace. Error to query a closed interface, but if interface closed when writing, itwill create a new open interface +dict set ::p::-1::_iface::o_methods Varspace {arglist args} +# set the default varspace for the interface, so that new methods/properties refer to it. +# varspace may be switched in between various additions of methods/properties so that different methods/properties are using different varspaces. +proc ::p::-1::Varspace {_ID_ args} { + set OID [::p::obj_get_this_oid $_ID_] + ::p::map $OID MAP + + if {![llength $args]} { + #query + set iid_top [lindex [dict get $MAP interfaces level0] end] + set iface ::p::ifaces::>$iid_top + if {![string length $iid_top]} { + error "Cannot query Varspace because no top level interface on object:[lindex [dict get $MAP invocantdata] 3] " + } elseif {[$iface . isClosed]} { + error "Cannot query Varspace because top level interface (id:$iid_top) is closed on object:[lindex [dict get $MAP invocantdata] 3] " + } + return [set ::p::${iid_top}::_iface::o_varspace] + } + set varspace [lindex $args 0] + + #set interfaces [dict get $MAP interfaces level0] + #set iid_top [lindex $interfaces end] + + set IID [::p::predator::get_possibly_new_open_interface $OID] + + + #namespace upvar ::p::${IID}::_iface o_variables o_variables o_properties o_properties o_methods o_methods o_varspace o_varspace + namespace upvar ::p::${IID}::_iface o_varspace o_varspace o_varspaces o_varspaces + + if {[string length $varspace]} { + #ensure namespace exists !? do after list test? + if {[string match ::* $varspace]} { + namespace eval $varspace {} + } else { + namespace eval ::p::${OID}::$varspace {} + } + if {$varspace ni $o_varspaces} { + lappend o_varspaces $varspace + } + } + set o_varspace $varspace +} + + +proc ::p::predator::get_possibly_new_open_interface {OID} { + #we need to re-upvar MAP rather than using a parameter - as we need to write back to it + upvar #0 ::p::${OID}::_meta::map MAP + set interfaces [dict get $MAP interfaces level0] + set iid_top [lindex $interfaces end] + + + set iface ::p::ifaces::>$iid_top + if {(![string length $iid_top]) || ([$iface . isClosed])} { + #no existing pattern - create a new interface + set iid_top [expr {$::p::ID + 1}] ;#PREDICT the next object's id + #puts stderr ">>>>creating new interface $iid_top" + set iface [::p::>interface .. Create ::p::ifaces::>$iid_top $OID] + + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level0 [concat $interfaces $iid_top] + dict set MAP interfaces $extracted_sub_dict + } + + return $iid_top +} + + + + + + + + + + +################################################################################################################################################### + +################################################################################################################################################### +dict set ::p::-1::_iface::o_methods PatternVarspace {arglist {varspace args}} +# set the default varspace for the interface, so that new methods/properties refer to it. +# varspace may be switched in between various additions of methods/properties so that different methods/properties are using different varspaces. +proc ::p::-1::PatternVarspace {_ID_ varspace args} { + set invocants [dict get $_ID_ i] + set OID [lindex [dict get $_ID_ i this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + + set patterns [dict get $MAP interfaces level1] + set iid_top [lindex $patterns end] + + set iface ::p::ifaces::>$iid_top + if {(![string length $iid_top]) || ([$iface . isClosed])} { + #no existing pattern - create a new interface + set iid_top [expr {$::p::ID + 1}] ;#PREDICT the next object's id + set iface [::p::>interface .. Create ::p::ifaces::>$iid_top $OID] + + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level1 [concat $patterns $iid_top] + dict set MAP interfaces $extracted_sub_dict + } + set IID $iid_top + + namespace upvar ::p::${IID}::_iface o_varspace o_varspace o_varspaces o_varspaces + if {[string length $varspace]} { + if {$varspace ni $o_varspaces} { + lappend o_varspaces $varspace + } + } + #o_varspace is the currently active varspace + set o_varspace $varspace +} +################################################################################################################################################### + +#get varspace and default from highest interface - return all interface ids which define it +dict set ::p::-1::_iface::o_methods GetPropertyInfo {arglist {{propnamepattern *}}} +proc ::p::-1::GetPropertyInfo {_ID_ {propnamepattern *}} { + set OID [lindex [dict get $_ID_ i this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + set interfaces [dict get $MAP interfaces level0] + + array set propinfo {} + set found_property_names [list] + #start at the lowest and work up (normal storage order of $interfaces) + foreach iid $interfaces { + set propinfodict [set ::p::${iid}::_iface::o_properties] + set matching_propnames [dict keys $propinfodict $propnamepattern] + foreach propname $matching_propnames { + if {$propname ni $found_property_names} { + lappend found_property_names $propname + } + lappend propinfo($propname,interfaces) $iid + ;#These 2 values for this $propname are overwritten for each iid in the outer loop - we are only interested in the last one + if {[dict exists $propinfodict $propname default]} { + set propinfo($propname,default) [dict get $propinfodict $propname default] + } + set propinfo($propname,varspace) [dict get $propinfodict $propname varspace] + } + } + + set resultdict [dict create] + foreach propname $found_property_names { + set fields [list varspace $propinfo($propname,varspace)] + if {[array exists propinfo($propname,default)]} { + lappend fields default [set propinfo($propname,default)] + } + lappend fields interfaces $propinfo($propname,interfaces) + dict set resultdict $propname $fields + } + return $resultdict +} + + +dict set ::p::-1::_iface::o_methods GetTopPattern {arglist args} +proc ::p::-1::GetTopPattern {_ID_ args} { + set OID [::p::obj_get_this_oid $_ID_] + ::p::map $OID MAP + + set interfaces [dict get $MAP interfaces level1] + set iid_top [lindex $interfaces end] + if {![string length $iid_top]} { + lassign [dict get $MAP invocantdata] OID _alias _default_method object_command + error "No installed level1 interfaces (patterns) for object $object_command" + } + return ::p::ifaces::>$iid_top +} + + + +dict set ::p::-1::_iface::o_methods GetTopInterface {arglist args} +proc ::p::-1::GetTopInterface {_ID_ args} { + set OID [::p::obj_get_this_oid $_ID_] + ::p::map $OID MAP + + set iid_top [lindex [dict get $MAP interfaces level0] end] + if {![string length $iid_top]} { + lassign [dict get $MAP invocantdata] OID _alias _default_method object_command + error "No installed level0 interfaces for object $object_command" + } + return ::p::ifaces::>$iid_top +} + + +dict set ::p::-1::_iface::o_methods GetExpandableInterface {arglist args} +proc ::p::-1::GetExpandableInterface {_ID_ args} { + +} + + + + + +################################################################################################################################################### + +################################################################################################################################################### +dict set ::p::-1::_iface::o_methods Property {arglist {property args}} +proc ::p::-1::Property {_ID_ property args} { + #puts stderr "::p::-1::Property called with _ID_: '$_ID_' property:$property args:$args" + #set invocants [dict get $_ID_ i] + #set invocant_roles [dict keys $invocants] + if {[llength $args] > 1} { + error ".. Property expects 1 or 2 arguments only. (>object .. Property propertyname ?default?)" + } + set OID [::p::obj_get_this_oid $_ID_] + ::p::map $OID MAP + + set interfaces [dict get $MAP interfaces level0] + set iid_top [lindex $interfaces end] + + set prev_openstate [set ::p::${iid_top}::_iface::o_open] + + set iface ::p::ifaces::>$iid_top + + + if {(![string length $iid_top]) || ([$iface . isClosed])} { + #create a new interface + set iid_top [expr {$::p::ID + 1}] ;#PREDICT the next object's id + set iface [::p::>interface .. Create ::p::ifaces::>$iid_top $OID] + + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level0 [concat $interfaces $iid_top] + dict set MAP interfaces $extracted_sub_dict + } + set IID $iid_top + + + namespace upvar ::p::${IID}::_iface o_variables o_variables o_properties o_properties o_methods o_methods o_varspace o_varspace + + + set maxversion [::p::predator::method_chainhead $IID (GET)$property] + set headid [expr {$maxversion + 1}] + set THISNAME (GET)$property.$headid ;#first version will be (GET)$property.1 + + + if {$headid == 1} { + #implementation + #interp alias {} ::p::${IID}::_iface::(GET)$property.1 {} ::p::predator::getprop $property + + #if {$o_varspace eq ""} { + # set ns ::p::${OID} + #} else { + # if {[string match "::*" $o_varspace]} { + # set ns $o_varspace + # } else { + # set ns ::p::${OID}::$o_varspace + # } + #} + #proc ::p::${IID}::_iface::(GET)$property.1 {_ID_ args} [string map [list %prop% $property %varspace% $o_varspace %ns% $ns] [info body ::p::predator::getprop_template_immediate]] + + proc ::p::${IID}::_iface::(GET)$property.1 {_ID_ args} [string map [list %prop% $property %varspace% $o_varspace ] [info body ::p::predator::getprop_template]] + + + #interp alias {} ::p::${IID}::_iface::(SET)$property.1 {} ::p::predator::setprop $property + proc ::p::${IID}::_iface::(SET)$property.1 {_ID_ args} [string map [list %prop% $property %varspace% $o_varspace] [info body ::p::predator::setprop_template]] + + + #chainhead pointers + interp alias {} ::p::${IID}::_iface::(GET)$property {} ::p::${IID}::_iface::(GET)$property.1 + interp alias {} ::p::${IID}::_iface::(SET)$property {} ::p::${IID}::_iface::(SET)$property.1 + + + } + + if {($property ni [dict keys $o_methods])} { + interp alias {} ::p::${IID}::_iface::$property {} ::p::${IID}::_iface::(GET)$property + } + + + + #installation on object + + #namespace eval ::p::${OID} [list namespace export $property] + + + + #obsolete? + #if {$property ni [P $_ID_]} { + #only link objects (GET)/(SET) for this property if property not present on any of our other interfaces + #interp alias {} ::p::${OID}::(GET)$property {} ::p::${IID}::_iface::(GET)$property $invocant + #interp alias {} ::p::${OID}::(SET)$property {} ::p::${IID}::_iface::(SET)$property $invocant + #} + + #link main (GET)/(SET) to this interface + interp alias {} ::p::${OID}::(GET)$property {} ::p::${IID}::_iface::(GET)$property + interp alias {} ::p::${OID}::(SET)$property {} ::p::${IID}::_iface::(SET)$property + + #Only install property if no method of same name already installed here. + #(Method takes precedence over property because property always accessible via 'set' reference) + #convenience pointer to chainhead pointer. + if {$property ni [M $_ID_]} { + interp alias {} ::p::${OID}::$property {} ::p::${IID}::_iface::(GET)$property + } else { + #property with same name as method - we need to make sure the refMisuse_traceHandler is fixed + + + } + + + set varspace [set ::p::${IID}::_iface::o_varspace] + + + + #Install the matching Variable + #!todo - which should take preference if Variable also given a default? + #if {[set posn [lsearch -index 0 $o_variables o_$property]] >= 0} { + # set o_variables [lreplace $o_variables $posn $posn o_$property] + #} else { + # lappend o_variables [list o_$property] + #} + dict set o_variables o_$property [list varspace $varspace] + + + + + if {[llength $args]} { + #should store default once only! + #set IFINFO(v,default,o_$property) $default + + set default [lindex $args end] + + dict set o_properties $property [list default $default varspace $varspace] + + #if {[set posn [lsearch -index 0 $o_properties $property]] >= 0} { + # set o_properties [lreplace $o_properties $posn $posn [list $property $default]] + #} else { + # lappend o_properties [list $property $default] + #} + + if {$varspace eq ""} { + set ns ::p::${OID} + } else { + if {[string match "::*" $varspace]} { + set ns $varspace + } else { + set ns ::p::${OID}::$o_varspace + } + } + + set ${ns}::o_$property $default + #set ::p::${OID}::o_$property $default + } else { + + #if {[set posn [lsearch -index 0 $o_properties $property]] >= 0} { + # set o_properties [lreplace $o_properties $posn $posn [list $property]] + #} else { + # lappend o_properties [list $property] + #} + dict set o_properties $property [list varspace $varspace] + + + #variable ::p::${OID}::o_$property + } + + + + + + #if the metainfo collection exists, update it. Don't worry if nonexistant as it will be created if needed. + #!todo - mark interface dirty (not ready?) instead? - would need all colProperties methods to respect dirty flag & synchronize as needed. (object filter?) + #catch {::p::OBJECT::${OID}::colProperties add [::p::internals::predator $invocant . $property .] $property} + + set colProperties ::p::${OID}::_meta::>colProperties + if {[namespace which $colProperties] ne ""} { + if {![$colProperties . hasKey $property]} { + $colProperties . add [::p::internals::predator $_ID_ . $property .] $property + } + } + + return +} +################################################################################################################################################### + + + +################################################################################################################################################### + +################################################################################################################################################### +interp alias {} ::p::-1::option {} ::p::-1::PatternProperty ;#for Define compatibility +dict set ::p::-1::_iface::o_methods PatternProperty {arglist {property args}} +proc ::p::-1::PatternProperty {_ID_ property args} { + set OID [::p::obj_get_this_oid $_ID_] + ::p::map $OID MAP + + set patterns [dict get $MAP interfaces level1] + set iid_top [lindex $patterns end] + + set iface ::p::ifaces::>$iid_top + + if {(![string length $iid_top]) || ([$iface . isClosed])} { + set iid_top [expr {$::p::ID + 1}] ;#PREDICT the next object's id + set iface [::p::>interface .. Create ::p::ifaces::>$iid_top $OID] + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level1 [concat $patterns $iid_top] + dict set MAP interfaces $extracted_sub_dict + #lset map {1 1} [concat $patterns $iid_top] + } + set IID $iid_top + + namespace upvar ::p::${IID}::_iface o_properties o_properties o_variables o_variables o_varspace o_varspace + + + set maxversion [::p::predator::method_chainhead $IID (GET)$property] + set headid [expr {$maxversion + 1}] + set THISNAME (GET)$property.$headid ;#first version will be (GET)$property.1 + + + + if {$headid == 1} { + #implementation + #interp alias {} ::p::${IID}::_iface::(GET)$property.1 {} ::p::predator::getprop $property + proc ::p::${IID}::_iface::(GET)$property.1 {_ID_ args} [string map [list %prop% $property %varspace% $o_varspace] [info body ::p::predator::getprop_template]] + #interp alias {} ::p::${IID}::_iface::(SET)$property.1 {} ::p::predator::setprop $property + proc ::p::${IID}::_iface::(SET)$property.1 {_ID_ args} [string map [list %prop% $property %varspace% $o_varspace] [info body ::p::predator::setprop_template]] + + + #chainhead pointers + interp alias {} ::p::${IID}::_iface::(GET)$property {} ::p::${IID}::_iface::(GET)$property.1 + interp alias {} ::p::${IID}::_iface::(SET)$property {} ::p::${IID}::_iface::(SET)$property.1 + + } + + if {($property ni [dict keys [set ::p::${IID}::_iface::o_methods]])} { + interp alias {} ::p::${IID}::_iface::$property {} ::p::${IID}::_iface::(GET)$property + } + + set varspace [set ::p::${IID}::_iface::o_varspace] + + #Install the matching Variable + #!todo - which should take preference if Variable also given a default? + #if {[set posn [lsearch -index 0 $o_variables o_$property]] >= 0} { + # set o_variables [lreplace $o_variables $posn $posn o_$property] + #} else { + # lappend o_variables [list o_$property] + #} + dict set o_variables o_$property [list varspace $varspace] + + set argc [llength $args] + + if {$argc} { + if {$argc == 1} { + set default [lindex $args 0] + dict set o_properties $property [list default $default varspace $varspace] + } else { + #if more than one arg - treat as a dict of options. + if {[dict exists $args -default]} { + set default [dict get $args -default] + dict set o_properties $property [list default $default varspace $varspace] + } else { + #no default value + dict set o_properties $property [list varspace $varspace] + } + } + #! only set default for property... not underlying variable. + #lappend ::p::${IID}::_iface::o_variables [list o_$property [lindex $args 0]] + } else { + dict set o_properties $property [list varspace $varspace] + } + return +} +################################################################################################################################################### + + + + + + + + + + + + + + + + + +################################################################################################################################################### + +################################################################################################################################################### +dict set ::p::-1::_iface::o_methods PatternPropertyRead {arglist {property args}} +proc ::p::-1::PatternPropertyRead {_ID_ property args} { + set invocants [dict get $_ID_ i] + + set this_invocant [lindex [dict get $_ID_ i this] 0] ;#assume only one 'this' + set OID [lindex $this_invocant 0] + #set OID [lindex [dict get $_ID_ i this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + lassign [dict get $MAP invocantdata] OID alias defaut_command cmd + + set patterns [dict get $MAP interfaces level1] + set existing_IID [lindex $patterns end] + + set idxlist [::list] + if {[llength $args] == 1} { + set body [lindex $args 0] + } elseif {[llength $args] == 2} { + lassign $args idxlist body + } else { + error "wrong # args: should be \"property body\" or \"property idxlist body\"" + } + + + if {$existing_IID != [set IID [::p::internals::expand_interface $existing_IID]]} { + #remove ourself from the usedby list of the previous interface + array unset ::p::${existing_IID}::_iface::o_usedby i$OID + set ::p::${IID}::_iface::o_usedby(i$OID) $cmd + + set posn [lsearch $patterns $existing_IID] + + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level1 [concat [lreplace $patterns $posn $posn] $IID] + dict set MAP interfaces $extracted_sub_dict + #lset map {1 1} [concat [lreplace $patterns $posn $posn] $IID] + + } else { + set prev_open [set ::p::${existing_IID}::_iface::o_open] + set ::p::${IID}::_iface::o_open $prev_open + } + + namespace upvar ::p::${IID}::_iface o_varspaces o_varspaces o_varspace o_varspace + + set maxversion [::p::predator::method_chainhead $IID (GET)$property] + set headid [expr {$maxversion + 1}] + if {$headid == 1} { + set headid 2 ;#reserve 1 for the getprop of the underlying property + } + + set THISNAME (GET)$property.$headid ;#first version will be (GET)$property.1 + set next [::p::predator::next_script $IID (GET)$property $THISNAME $_ID_] ;#last parameter is caller_ID_ + + + #implement + #----------------------------------- + + + set processed [dict create {*}[::p::predator::expand_var_statements $body $o_varspace]] + if {[llength [dict get $processed varspaces_with_explicit_vars]]} { + foreach vs [dict get $processed varspaces_with_explicit_vars] { + if {[string length $vs] && ($vs ni $o_varspaces)} { + lappend o_varspaces $vs + } + } + set body [dict get $processed body] + } else { + + set varDecls [::p::predator::runtime_vardecls] ;#dynamic vardecls can access vars from all interfaces of invocant object. + set body $varDecls[dict get $processed body] + } + #set body [string map [::list @this@ "\[lindex \$_ID_ 0 3 \]" @next@ $next] $body\n] + set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata \] 3\]" @next@ $next] $body\n] + + + #implementation + if {![llength $idxlist]} { + proc ::p::${IID}::_iface::(GET)$property.$headid {_ID_ args} $body + } else { + #what are we trying to achieve here? .. + proc ::p::${IID}::_iface::(GET)$property.$headid [linsert $idxlist 0 _ID_] $body + } + + + #----------------------------------- + + + #adjust chain-head pointer to point to new head. + interp alias {} ::p::${IID}::_iface::(GET)$property {} ::p::${IID}::_iface::(GET)$property.$headid + + return +} +################################################################################################################################################### + + + + + + + + + + + + +################################################################################################################################################### + +################################################################################################################################################### +dict set ::p::-1::_iface::o_methods PropertyRead {arglist {property args}} +proc ::p::-1::PropertyRead {_ID_ property args} { + set OID [::p::obj_get_this_oid $_ID_] + ::p::map $OID MAP + + #assert $OID ne "null" - dispatcher won't call PropertyRead on a non-object(?) (presumably the call would be to 'Method' instead) + lassign [dict get $MAP invocantdata] OID alias default_command cmd + + set interfaces [dict get $MAP interfaces level0] + set existing_IID [lindex $interfaces end] + + + set idxlist [::list] + if {[llength $args] == 1} { + set body [lindex $args 0] + } elseif {[llength $args] == 2} { + lassign $args idxlist body + } else { + error "wrong # args: should be \"property body\" or \"property idxlist body\"" + } + + + if {$existing_IID != [set IID [::p::internals::expand_interface $existing_IID]]} { + #remove ourself from the usedby list of the previous interface + array unset ::p::${existing_IID}::_iface::o_usedby i$OID + set ::p::${IID}::_iface::o_usedby(i$OID) $cmd + + set posn [lsearch $interfaces $existing_IID] + + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level0 [concat [lreplace $interfaces $posn $posn] $IID] + dict set MAP interfaces $extracted_sub_dict + + set ::p::${IID}::_iface::o_open 0 + } else { + set prev_open [set ::p::${existing_IID}::_iface::o_open] + set ::p::${IID}::_iface::o_open $prev_open + } + namespace upvar ::p::${IID}::_iface o_varspaces o_varspaces o_varspace o_varspace + + #array set ::p::${IID}:: [::list pr,body,$property $body pr,arg,$property $idxlist pr,name,$property $property pr,iface,$property $cmd] + + + set maxversion [::p::predator::method_chainhead $IID (GET)$property] + set headid [expr {$maxversion + 1}] + if {$headid == 1} { + set headid 2 + } + set THISNAME (GET)$property.$headid ;#first version will be (GET)$property.2 - even if corresponding property is missing (we reserve $property.1 for the property itself) + + set next [::p::predator::next_script $IID (GET)$property $THISNAME $_ID_] + + #implement + #----------------------------------- + + set processed [dict create {*}[::p::predator::expand_var_statements $body $o_varspace]] + if {[llength [dict get $processed varspaces_with_explicit_vars]]} { + foreach vs [dict get $processed varspaces_with_explicit_vars] { + if {[string length $vs] && ($vs ni $o_varspaces)} { + lappend o_varspaces $vs + } + } + set body [dict get $processed body] + } else { + set varDecls [::p::predator::runtime_vardecls] ;#dynamic vardecls can access vars from all interfaces of invocant object. + set body $varDecls[dict get $processed body] + } + #set body [string map [::list @this@ "\[lindex \$_ID_ 0 3 \]" @next@ $next] $body\n] + set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata \] 3\]" @next@ $next] $body\n] + + proc ::p::${IID}::_iface::$THISNAME [concat _ID_ $idxlist] $body + + #----------------------------------- + + + + #pointer from prop-name to head of override-chain + interp alias {} ::p::${IID}::_iface::(GET)$property {} ::p::${IID}::_iface::(GET)$property.$headid + + + interp alias {} ::p::${OID}::(GET)$property {} ::p::${IID}::_iface::(GET)$property ;#the reference traces will call this one - in case there is both a property and a method with this name. + if {$property ni [M $_ID_]} { + interp alias {} ::p::${OID}::$property {} ::p::${IID}::_iface::(GET)$property + } +} +################################################################################################################################################### + + + + + + + + + + + + + + +################################################################################################################################################### + +################################################################################################################################################### +dict set ::p::-1::_iface::o_methods PropertyWrite {arglist {property argname body}} +proc ::p::-1::PropertyWrite {_ID_ property argname body} { + set invocants [dict get $_ID_ i] + set OID [lindex [dict get $invocants this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + lassign [dict get $MAP invocantdata] OID alias default_command cmd + + set interfaces [dict get $MAP interfaces level0] + set existing_IID [lindex $interfaces end] ;#!todo - get 'open' interface. + + + + if {$existing_IID != [set IID [::p::internals::expand_interface $existing_IID]]} { + #remove ourself from the usedby list of the previous interface + array unset ::p::${existing_IID}::_iface::o_usedby i$OID + set ::p::${IID}::_iface::o_usedby(i$OID) $cmd + + set posn [lsearch $interfaces $existing_IID] + + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level0 [concat [lreplace $interfaces $posn $posn] $IID] + dict set MAP interfaces $extracted_sub_dict + #lset map {1 0} [concat [lreplace $interfaces $posn $posn] $IID] + + set ::p::${IID}::_iface::o_open 0 + } else { + set prev_open [set ::p::${existing_IID}::_iface::o_open] + set ::p::${IID}::_iface::o_open $prev_open + } + namespace upvar ::p::${IID}::_iface o_varspaces o_varspaces o_varspace o_varspace + + #pw short for propertywrite + #array set ::p::${IID}:: [::list pw,body,$property $body pw,arg,$property $argname pw,name,$property $property pw,iface,$property $cmd] + array set ::p::${IID}:: [::list pw,body,$property $body pw,arg,$property $argname pw,name,$property $property] + + + set maxversion [::p::predator::method_chainhead $IID (SET)$property] + set headid [expr {$maxversion + 1}] + + set THISNAME (SET)$property.$headid + + set next [::p::predator::next_script $IID (SET)$property $THISNAME $_ID_] + + #implement + #----------------------------------- + + set processed [dict create {*}[::p::predator::expand_var_statements $body $o_varspace]] + if {[llength [dict get $processed varspaces_with_explicit_vars]]} { + foreach vs [dict get $processed varspaces_with_explicit_vars] { + if {[string length $vs] && ($vs ni $o_varspaces)} { + lappend o_varspaces $vs + } + } + set body [dict get $processed body] + } else { + set varDecls [::p::predator::runtime_vardecls] ;#dynamic vardecls can access vars from all interfaces of invocant object. + set body $varDecls[dict get $processed body] + } + #set body [string map [::list @this@ "\[lindex \$_ID_ 0 3 \]" @next@ $next] $body\n] + set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata \] 3\]" @next@ $next] $body\n] + + + proc ::p::${IID}::_iface::$THISNAME [list _ID_ $argname] $body + + #----------------------------------- + + + + #pointer from method-name to head of override-chain + interp alias {} ::p::${IID}::_iface::(SET)$property {} ::p::${IID}::_iface::(SET)$property.$headid +} +################################################################################################################################################### + + + + + + + + + + + + + + +################################################################################################################################################### + +################################################################################################################################################### +dict set ::p::-1::_iface::o_methods PatternPropertyWrite {arglist {property argname body}} +proc ::p::-1::PatternPropertyWrite {_ID_ property argname body} { + set invocants [dict get $_ID_ i] + set OID [lindex [dict get $invocants this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + lassign [dict get $MAP invocantdata] OID alias default_command cmd + + + set patterns [dict get $MAP interfaces level1] + set existing_IID [lindex $patterns end] ;#!todo - get 'open' interface. + + + if {$existing_IID != [set IID [::p::internals::expand_interface $existing_IID]]} { + #remove ourself from the usedby list of the previous interface + array unset ::p::${existing_IID}::_iface::o_usedby i$OID + set ::p::${IID}::_iface::o_usedby(i$OID) $cmd + + set existing_ifaces [lindex $map 1 1] + set posn [lsearch $existing_ifaces $existing_IID] + + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level1 [concat [lreplace $existing_ifaces $posn $posn] $IID] + dict set MAP interfaces $extracted_sub_dict + #lset map {1 1} [concat [lreplace $existing_ifaces $posn $posn] $IID] + + #set ::p::${IID}::_iface::o_open 0 + } else { + } + + #pw short for propertywrite + array set ::p::${IID}:: [::list pw,body,$property $body pw,arg,$property $argname pw,name,$property $property pw,iface,$property $cmd] + + + return + +} +################################################################################################################################################### + + + + + + + +################################################################################################################################################### + +################################################################################################################################################### +dict set ::p::-1::_iface::o_methods PropertyUnset {arglist {property arraykeypattern body}} +proc ::p::-1::PropertyUnset {_ID_ property arraykeypattern body} { + set invocants [dict get $_ID_ i] + set OID [lindex [dict get $invocants this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + lassign [dict get $MAP invocantdata] OID alias default_command cmd + + + set interfaces [dict get $MAP interfaces level0] + set existing_IID [lindex $interfaces end] ;#!todo - choose 'open' interface to expand. + + + + if {$existing_IID != [set IID [::p::internals::expand_interface $existing_IID]]} { + #remove ourself from the usedby list of the previous interface + array unset ::p::${existing_IID}::_iface::o_usedby i$OID + set ::p::${IID}::_iface::o_usedby(i$OID) $cmd + + set posn [lsearch $interfaces $existing_IID] + + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level0 [concat [lreplace $interfaces $posn $posn] $IID] + dict set MAP interfaces $extracted_sub_dict + } else { + set prev_open [set ::p::${existing_IID}::_iface::o_open] + set ::p::${IID}::_iface::o_open $prev_open + } + namespace upvar ::p::${IID}::_iface o_varspaces o_varspaces o_varspace o_varspace o_propertyunset_handlers propertyunset_handlers + #upvar ::p::${IID}::_iface::o_propertyunset_handlers propertyunset_handlers + dict set propertyunset_handlers $property [list body $body arraykeypattern $arraykeypattern] + + set maxversion [::p::predator::method_chainhead $IID (UNSET)$property] + set headid [expr {$maxversion + 1}] + + set THISNAME (UNSET)$property.$headid + + set next [::p::predator::next_script $IID (UNSET)$property $THISNAME $_ID_] + + + set processed [dict create {*}[::p::predator::expand_var_statements $body $o_varspace]] + if {[llength [dict get $processed varspaces_with_explicit_vars]]} { + foreach vs [dict get $processed varspaces_with_explicit_vars] { + if {[string length $vs] && ($vs ni $o_varspaces)} { + lappend o_varspaces $vs + } + } + set body [dict get $processed body] + } else { + set varDecls [::p::predator::runtime_vardecls] ;#dynamic vardecls can access vars from all interfaces of invocant object. + set body $varDecls[dict get $processed body] + } + #set body [string map [::list @this@ "\[lindex \$_ID_ 0 3 \]" @next@ $next] $body\n] + set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata \] 3\]" @next@ $next] $body\n] + + #note $arraykeypattern actually contains the name of the argument + if {[string trim $arraykeypattern] eq ""} { + set arraykeypattern _dontcare_ ;# + } + proc ::p::${IID}::_iface::(UNSET)$property.$headid [list _ID_ $arraykeypattern] $body + +#----------------------------------- + + +#pointer from method-name to head of override-chain +interp alias {} ::p::${IID}::_iface::(UNSET)$property {} ::p::${IID}::_iface::(UNSET)$property.$headid + +} +################################################################################################################################################### + + + + + + + + +################################################################################################################################################### + +################################################################################################################################################### +dict set ::p::-1::_iface::o_methods PatternPropertyUnset {arglist {property arraykeypattern body}} +proc ::p::-1::PatternPropertyUnset {_ID_ property arraykeypattern body} { + set invocants [dict get $_ID_ i] + set OID [lindex [dict get $invocants this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + lassign [dict get $MAP invocantdata] OID alias itemCmd cmd + + + set patterns [dict get $MAP interfaces level1] + set existing_IID [lindex $patterns end] ;#!todo - choose 'open' interface to expand. + + + if {$existing_IID != [set IID [::p::internals::expand_interface $existing_IID]]} { + #remove ourself from the usedby list of the previous interface + array unset ::p::${existing_IID}::_iface::o_usedby i$OID + set ::p::${IID}::_iface::o_usedby(i$OID) $cmd + + set posn [lsearch $patterns $existing_IID] + + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level1 [concat [lreplace $patterns $posn $posn] $IID] + dict set MAP interfaces $extracted_sub_dict + #set ::p::${IID}::_iface::o_open 0 + } + + + upvar ::p::${IID}::_iface::o_propertyunset_handlers propertyunset_handlers + dict set propertyunset_handlers $property [list body $body arraykeypattern $arraykeypattern] + + return +} +################################################################################################################################################### + + + +#lappend ::p::-1::_iface::o_methods Implements +#!todo - some way to force overriding of any abstract (empty) methods from the source object +#e.g leave interface open and raise an error when closing it if there are unoverridden methods? + + + + + +#implementation reuse - sugar for >object .. Clone >target +dict set ::p::-1::_iface::o_methods Extends {arglist {pattern}} +proc ::p::-1::Extends {_ID_ pattern} { + if {!([string range [namespace tail $pattern] 0 0] eq ">")} { + error "'Extends' expected a pattern object" + } + set invocants [dict get $_ID_ i] + set OID [lindex [dict get $invocants this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + lassign [dict get $MAP invocantdata] OID alias itemCmd object_command + + + tailcall $pattern .. Clone $object_command +} +#implementation reuse - sugar for >pattern .. Create >target +dict set ::p::-1::_iface::o_methods PatternExtends {arglist {pattern}} +proc ::p::-1::PatternExtends {_ID_ pattern} { + if {!([string range [namespace tail $pattern] 0 0] eq ">")} { + error "'PatternExtends' expected a pattern object" + } + set invocants [dict get $_ID_ i] + set OID [lindex [dict get $invocants this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + lassign [dict get $MAP invocantdata] OID alias itemCmd object_command + + + tailcall $pattern .. Create $object_command +} + + +dict set ::p::-1::_iface::o_methods Extend {arglist {{idx ""}}} +proc ::p::-1::Extend {_ID_ {idx ""}} { + puts stderr "Extend is DEPRECATED - use Expand instead" + tailcall ::p::-1::Expand $_ID_ $idx +} + +#set the topmost interface on the iStack to be 'open' +dict set ::p::-1::_iface::o_methods Expand {arglist {{idx ""}}} +proc ::p::-1::Expand {_ID_ {idx ""}} { + set invocants [dict get $_ID_ i] + set OID [lindex [dict get $invocants this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + set interfaces [dict get $MAP interfaces level0] ;#level 0 interfaces + set iid_top [lindex $interfaces end] + set iface ::p::ifaces::>$iid_top + + if {![string length $iid_top]} { + #no existing interface - create a new one + set iid_top [expr {$::p::ID + 1}] ;#PREDICT the next object's id + set iface [::p::>interface .. Create ::p::ifaces::>$iid_top $OID] + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level0 [list $iid_top] + dict set MAP interfaces $extracted_sub_dict ;#write new interface into map + $iface . open + return $iid_top + } else { + if {[$iface . isOpen]} { + #already open.. + #assume ready to expand.. shared or not! + return $iid_top + } + lassign [dict get $MAP invocantdata] OID alias itemCmd cmd + + if {[$iface . refCount] > 1} { + if {$iid_top != [set IID [::p::internals::expand_interface $iid_top ]]} { + #!warning! not exercised by test suites! + + #remove ourself from the usedby list of the previous interface + array unset ::p::${iid_top}::_iface::o_usedby i$OID + set ::p::${IID}::_iface::o_usedby(i$OID) $cmd + + #remove existing interface & add + set posn [lsearch $interfaces $iid_top] + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level0 [concat [lreplace $interfaces $posn $posn] $IID] + dict set MAP interfaces $extracted_sub_dict + #lset map {1 0} [concat [lreplace $interfaces $posn $posn] $IID] + + + set iid_top $IID + set iface ::p::ifaces::>$iid_top + } + } + } + + $iface . open + return $iid_top +} + +dict set ::p::-1::_iface::o_methods PatternExtend {arglist {{idx ""}}} +proc ::p::-1::PatternExtend {_ID_ {idx ""}} { + puts stderr "PatternExtend is DEPRECATED - use PatternExpand instead" + tailcall ::p::-1::PatternExpand $_ID_ $idx +} + + + +#set the topmost interface on the pStack to be 'open' if it's not shared +# if shared - 'copylink' to new interface before opening for extension +dict set ::p::-1::_iface::o_methods PatternExpand {arglist {{idx ""}}} +proc ::p::-1::PatternExpand {_ID_ {idx ""}} { + set OID [::p::obj_get_this_oid $_ID_] + ::p::map $OID MAP + #puts stderr "no tests written for PatternExpand " + lassign [dict get $MAP invocantdata] OID alias itemCmd cmd + + set ifaces [dict get $MAP interfaces level1] ;#level 1 interfaces + set iid_top [lindex $ifaces end] + set iface ::p::ifaces::>$iid_top + + if {![string length $iid_top]} { + #no existing interface - create a new one + set iid_top [expr {$::p::ID + 1}] ;#PREDICT the next object's id + set iface [::p::>interface .. Create ::p::ifaces::>$iid_top $OID] + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level1 [list $iid_top] + dict set MAP interfaces $extracted_sub_dict + #lset map {1 1} [list $iid_top] + $iface . open + return $iid_top + } else { + if {[$iface . isOpen]} { + #already open.. + #assume ready to expand.. shared or not! + return $iid_top + } + + if {[$iface . refCount] > 1} { + if {$iid_top != [set IID [::p::internals::expand_interface $iid_top]]} { + #!WARNING! not exercised by test suite! + #remove ourself from the usedby list of the previous interface + array unset ::p::${iid_top}::_iface::o_usedby i$OID + set ::p::${IID}::_iface::o_usedby(i$OID) $cmd + + set posn [lsearch $ifaces $iid_top] + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level1 [concat [lreplace $ifaces $posn $posn] $IID] + dict set MAP interfaces $extracted_sub_dict + #lset map {1 1} [concat [lreplace $ifaces $posn $posn] $IID] + + set iid_top $IID + set iface ::p::ifaces::>$iid_top + } + } + } + + $iface . open + return $iid_top +} + + + + + +dict set ::p::-1::_iface::o_methods Properties {arglist {{idx ""}}} +proc ::p::-1::Properties {_ID_ {idx ""}} { + set OID [lindex [dict get $_ID_ i this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + set ifaces [dict get $MAP interfaces level0] ;#level 0 interfaces + + set col ::p::${OID}::_meta::>colProperties + + if {[namespace which $col] eq ""} { + patternlib::>collection .. Create $col + foreach IID $ifaces { + dict for {prop pdef} [set ::p::${IID}::_iface::o_properties] { + if {![$col . hasIndex $prop]} { + $col . add [::p::internals::predator $_ID_ . $prop .] $prop + } + } + } + } + + if {[string length $idx]} { + return [$col . item $idx] + } else { + return $col + } +} + +dict set ::p::-1::_iface::o_methods P {arglist {{glob *}}} +proc ::p::-1::P {_ID_ {glob *}} { + set invocants [dict get $_ID_ i] + set this_invocant [lindex [dict get $invocants this] 0] + lassign $this_invocant OID _etc + set OID [lindex [dict get $_ID_ i this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + set interfaces [dict get $MAP interfaces level0] ;#level 0 interfaces + + set members [list] + foreach IID $interfaces { + lappend members {*}[dict keys [set ::p::${IID}::_iface::o_properties] $glob] + } + return [lsort $members] +} + +#PatternProperties +dict set ::p::-1::_iface::o_methods PP {arglist {{glob *}}} +proc ::p::-1::PP {_ID_ {glob *}} { + set invocants [dict get $_ID_ i] + set this_invocant [lindex [dict get $invocants this] 0] + lassign $this_invocant OID _etc + set OID [lindex [dict get $_ID_ i this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + set interfaces [dict get $MAP interfaces level1] ;#level 1 interfaces + + set members [list] + foreach IID $interfaces { + lappend members {*}[dict keys [set ::p::${IID}::_iface::o_properties] $glob] + } + return [lsort $members] +} + + + +#Interface Properties +dict set ::p::-1::_iface::o_methods IP {arglist {{glob *}}} +proc ::p::-1::IP {_ID_ {glob *}} { + set invocants [dict get $_ID_ i] + set OID [lindex [dict get $invocants this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + set ifaces [dict get $MAP interfaces level0] ;#level 0 interfaces + set members [list] + + foreach m [dict keys [set ::p::${OID}::_iface::o_properties]] { + if {[string match $glob [lindex $m 0]]} { + lappend members [lindex $m 0] + } + } + return $members +} + + +#used by rename.test - theoretically should be on a separate interface! +dict set ::p::-1::_iface::o_methods CheckInvocants {arglist {args}} +proc ::p::-1::CheckInvocants {_ID_ args} { + #check all invocants in the _ID_ are consistent with data stored in their MAP variable + set status "ok" ;#default to optimistic assumption + set problems [list] + + set invocant_dict [dict get $_ID_ i] + set invocant_roles [dict keys $invocant_dict] + + foreach role $invocant_roles { + set invocant_list [dict get $invocant_dict $role] + foreach aliased_invocantdata $invocant_list { + set OID [lindex $aliased_invocantdata 0] + set map_invocantdata [dict get [set ::p::${OID}::_meta::map] invocantdata] + #we use lrange to make sure the lists are in canonical form + if {[lrange $map_invocantdata 0 end] ne [lrange $aliased_invocantdata 0 end]} { + set status "not-ok" + lappend problems [list type "invocant_data_mismatch" invocant_role $role oid $OID command_invocantdata $aliased_invocantdata map_invocantdata $map_invocantdata] + } + } + + } + + + set result [dict create] + dict set result status $status + dict set result problems $problems + + return $result +} + + +#get or set t +dict set ::p::-1::_iface::o_methods Namespace {arglist {args}} +proc ::p::-1::Namespace {_ID_ args} { + #set invocants [dict get $_ID_ i] + #set this_invocant [lindex [dict get $invocants this] 0] + #lassign $this_invocant OID this_info + set OID [lindex [dict get $_ID_ i this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + set IID [lindex [dict get $MAP interfaces level0] end] + + namespace upvar ::p::${IID}::_iface o_varspace active_varspace + + if {[string length $active_varspace]} { + set ns ::p::${OID}::$active_varspace + } else { + set ns ::p::${OID} + } + + #!todo - review.. 'eval' & 'code' subcommands make it too easy to violate the object? + # - should .. Namespace be usable at all from outside the object? + + + if {[llength $args]} { + #special case some of the namespace subcommands. + + #delete + if {[string match "d*" [lindex $args 0]]} { + error "Don't destroy an object's namespace like this. Use '>object .. Destroy' to remove an object." + } + #upvar,ensemble,which,code,origin,expor,import,forget + if {[string range [lindex $args 0] 0 1] in [list "up" "en" "wh" "co" "or" "ex" "im" "fo"]} { + return [namespace eval $ns [list namespace {*}$args]] + } + #current + if {[string match "cu*" [lindex $args 0]]} { + return $ns + } + + #children,eval,exists,inscope,parent,qualifiers,tail + return [namespace {*}[linsert $args 1 $ns]] + } else { + return $ns + } +} + + + + + + + + + + +dict set ::p::-1::_iface::o_methods PatternUnknown {arglist {args}} +proc ::p::-1::PatternUnknown {_ID_ args} { + set invocants [dict get $_ID_ i] + set OID [lindex [dict get $invocants this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + lassign [dict get $MAP invocantdata] OID alias itemCmd cmd + set patterns [dict get $MAP interfaces level1] + set existing_IID [lindex $patterns end] ;#!todo - choose 'open' interface to expand. + + if {$existing_IID != [set IID [::p::internals::expand_interface $existing_IID]]} { + #remove ourself from the usedby list of the previous interface + array unset ::p::${existing_IID}::_iface::o_usedby i$OID + set ::p::${IID}::_iface::o_usedby(i$OID) $cmd + + set posn [lsearch $patterns $existing_IID] + + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level1 [concat [lreplace $patterns $posn $posn] $IID] + dict set MAP interfaces $extracted_sub_dict + #lset map {1 1} [concat [lreplace $patterns $posn $posn] $IID] + #::p::predator::remap $invocant + } + + set handlermethod [lindex $args 0] + + + if {[llength $args]} { + set ::p::${IID}::_iface::o_unknown $handlermethod + return + } else { + set ::p::${IID}::_iface::o_unknown $handlermethod + } + +} + + + +dict set ::p::-1::_iface::o_methods Unknown {arglist {args}} +proc ::p::-1::Unknown {_ID_ args} { + set invocants [dict get $_ID_ i] + set OID [lindex [dict get $invocants this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + + set interfaces [dict get $MAP interfaces level0] + set existing_IID [lindex $interfaces end] ;#!todo - choose 'open' interface to expand. + + set prev_open [set ::p::${existing_IID}::_iface::o_open] + + if {$existing_IID != [set IID [::p::internals::expand_interface $existing_IID]]} { + #remove ourself from the usedby list of the previous interface + array unset ::p::${existing_IID}::_iface::o_usedby i$OID + set ::p::${IID}::_iface::o_usedby(i$OID) $cmd + + set posn [lsearch $interfaces $existing_IID] + + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level0 [concat [lreplace $interfaces $posn $posn] $IID] + dict set MAP interfaces $extracted_sub_dict + #lset map {1 0} [concat [lreplace $interfaces $posn $posn] $IID] + + set ::p::${IID}::_iface::o_open 0 + } else { + set ::p::${IID}::_iface::o_open $prev_open + } + + set handlermethod [lindex $args 0] + + if {[llength $args]} { + set ::p::${IID}::_iface::o_unknown $handlermethod + #set ::p::${IID}::(unknown) $handlermethod + + + #interp alias {} ::p::${IID}::_iface::(UNKNOWN) {} ::p::${OID}::$handlermethod + interp alias {} ::p::${IID}::_iface::(UNKNOWN) {} ::p::${IID}::_iface::$handlermethod + interp alias {} ::p::${OID}::(UNKNOWN) {} ::p::${OID}::$handlermethod + + #namespace eval ::p::${IID}::_iface [list namespace unknown $handlermethod] + #namespace eval ::p::${OID} [list namespace unknown $handlermethod] + + return + } else { + set ::p::${IID}::_iface::o_unknown $handlermethod + } + +} + + +#useful on commandline - can just uparrow and add to it to become ' .. As varname' instead of editing start and end of commandline to make it 'set varname []' +# should also work for non-object results +dict set ::p::-1::_iface::o_methods As {arglist {varname}} +proc ::p::-1::As {_ID_ varname} { + set invocants [dict get $_ID_ i] + #puts stdout "invocants: $invocants" + #!todo - handle multiple invocants with other roles, not just 'this' + + set OID [lindex [dict get $_ID_ i this] 0 0] + if {$OID ne "null"} { + upvar #0 ::p::${OID}::_meta::map MAP + lassign [dict get $MAP invocantdata] OID alias itemCmd cmd + tailcall set $varname $cmd + } else { + #puts stdout "info level 1 [info level 1]" + set role_members [dict get $_ID_ i this] + if {[llength $role_members] == 1} { + set member [lindex $role_members 0] + lassign $member _OID namespace default_method stackvalue _wrapped + tailcall set $varname $stackvalue + } else { + #multiple invocants - return all results as a list + set resultlist [list] + foreach member $role_members { + lassign $member _OID namespace default_method stackvalue _wrapped + lappend resultlist $stackvalue + } + tailcall set $varname $resultlist + } + } +} + +#!todo - AsFileStream ?? +dict set ::p::-1::_iface::o_methods AsFile {arglist {filename args}} +proc ::p::-1::AsFile {_ID_ filename args} { + dict set default -force 0 + dict set default -dumpmethod ".. Digest -algorithm raw" ;#how to serialize/persist an object + set opts [dict merge $default $args] + set force [dict get $opts -force] + set dumpmethod [dict get $opts -dumpmethod] + + + if {[file pathtype $filename] eq "relative"} { + set filename [pwd]/$filename + } + set filedir [file dirname $filename] + if {![sf::file_writable $filedir]} { + error "(method AsFile) ERROR folder $filedir is not writable" + } + if {[file exists $filename]} { + if {!$force} { + error "(method AsFile) ERROR file $filename already exists. Use -force 1 to overwrite" + } + if {![sf::file_writable $filename]} { + error "(method AsFile) ERROR file $filename is not writable - check permissions" + } + } + set fd [open $filename w] + fconfigure $fd -translation binary + + set invocants [dict get $_ID_ i] + set OID [lindex [dict get $_ID_ i this] 0 0] + if {$OID ne "null"} { + upvar #0 ::p::${OID}::_meta::map MAP + lassign [dict get $MAP invocantdata] OID alias itemCmd cmd + #tailcall set $varname $cmd + set object_data [$cmd {*}$dumpmethod] + puts -nonewline $fd $object_data + close $fd + return [list status 1 bytes [string length $object_data] filename $filename] + } else { + #puts stdout "info level 1 [info level 1]" + set role_members [dict get $_ID_ i this] + if {[llength $role_members] == 1} { + set member [lindex $role_members 0] + lassign $member _OID namespace default_method stackvalue _wrapped + puts -nonewline $fd $stackvalue + close $fd + #tailcall set $varname $stackvalue + return [list status 1 bytes [string length $stackvalue] filename $filename] + } else { + #multiple invocants - return all results as a list + set resultlist [list] + foreach member $role_members { + lassign $member _OID namespace default_method stackvalue _wrapped + lappend resultlist $stackvalue + } + puts -nonewline $fd $resultset + close $fd + return [list status 1 bytes [string length $resultset] filename $filename] + #tailcall set $varname $resultlist + } + } + +} + + + +dict set ::p::-1::_iface::o_methods Object {arglist {}} +proc ::p::-1::Object {_ID_} { + set invocants [dict get $_ID_ i] + set OID [lindex [dict get $invocants this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + lassign [dict get $MAP invocantdata] OID alias itemCmd cmd + + set result [string map [list ::> ::] $cmd] + if {![catch {info level -1} prev_level]} { + set called_by "(called by: $prev_level)" + } else { + set called_by "(called by: interp?)" + + } + + puts stdout "\n\nWARNING: '.. Object' calls are now obsolete. Please adjust your code. $called_by ( [info level 1])\n\n" + puts stdout " (returning $result)" + + return $result +} + +#todo: make equivalent to >pattern = cmdname, >pattern . x = cmdname , >pattern # apiname = cmdname +dict set ::p::-1::_iface::o_methods MakeAlias {arglist {cmdname}} +proc ::p::-1::MakeAlias {_ID_cmdname } { + set OID [::p::obj_get_this_oid $_ID_] + upvar #0 ::p::${OID}::_meta::map MAP + lassign [dict get $MAP invocantdata] OID alias itemCmd cmd + + error "concept probably won't work - try making dispatcher understand trailing '= cmdname' " +} +dict set ::p::-1::_iface::o_methods ID {arglist {}} +proc ::p::-1::ID {_ID_} { + set OID [lindex [dict get $_ID_ i this] 0 0] + return $OID +} + +dict set ::p::-1::_iface::o_methods IFINFO {arglist {}} +proc ::p::-1::IFINFO {_ID_} { + puts stderr "--_ID_: $_ID_--" + set OID [::p::obj_get_this_oid $_ID_] + upvar #0 ::p::${OID}::_meta::map MAP + + puts stderr "-- MAP: $MAP--" + + set interfaces [dict get $MAP interfaces level0] + set IFID [lindex $interfaces 0] + + if {![llength $interfaces]} { + puts stderr "No interfaces present at level 0" + } else { + foreach IFID $interfaces { + set iface ::p::ifaces::>$IFID + puts stderr "$iface : [$iface --]" + puts stderr "\tis open: [set ::p::${IFID}::_iface::o_open]" + set variables [set ::p::${IFID}::_iface::o_variables] + puts stderr "\tvariables: $variables" + } + } + +} + + + + +dict set ::p::-1::_iface::o_methods INVOCANTDATA {arglist {}} +proc ::p::-1::INVOCANTDATA {_ID_} { + #same as a call to: >object .. + return $_ID_ +} + +#obsolete? +dict set ::p::-1::_iface::o_methods UPDATEDINVOCANTDATA {arglist {}} +proc ::p::-1::UPDATEDINVOCANTDATA {_ID_} { + #package require dictutils + set updated_ID_ $_ID_ + array set updated_roles [list] + + set invocants [dict get $_ID_ i] + set invocant_roles [dict keys $invocants] + foreach role $invocant_roles { + + set role_members [dict get $invocants $role] + foreach member [dict get $invocants $role] { + #each member is a 2-element list consisting of the OID and a dictionary + #each member is a 5-element list + #set OID [lindex $member 0] + #set object_dict [lindex $member 1] + lassign $member OID alias itemcmd cmd wrapped + + set MAP [set ::p::${OID}::_meta::map] + #if {[dictutils::equal {apply {{key v1 v2} {expr {$v1 eq $v2}}}} $mapvalue [dict get $object_dict map]]} {} + + if {[dict get $MAP invocantdata] eq $member} + #same - nothing to do + + } else { + package require overtype + puts stderr "---------------------------------------------------------" + puts stderr "UPDATEDINVOCANTDATA WARNING: invocantdata in _ID_ not equal to invocantdata in _meta::map - returning updated version" + set col1 [string repeat " " [expr {[string length [dict get $MAP invocantdata]] + 2}]] + puts stderr "[overtype::left $col1 {_ID_ map value}]: $member" + puts stderr "[overtype::left $col1 ::p::${OID}::_meta::map]: [dict get $MAP invocantdata]" + puts stderr "---------------------------------------------------------" + #take _meta::map version + lappend updated_roles($role) [dict get $MAP invocantdata] + } + + } + + #overwrite changed roles only + foreach role [array names updated_roles] { + dict set updated_ID_ i $role [set updated_roles($role)] + } + + return $updated_ID_ +} + + + +dict set ::p::-1::_iface::o_methods INFO {arglist {}} +proc ::p::-1::INFO {_ID_} { + set result "" + append result "_ID_: $_ID_\n" + + set invocants [dict get $_ID_ i] + set invocant_roles [dict keys $invocants] + append result "invocant roles: $invocant_roles\n" + set total_invocants 0 + foreach key $invocant_roles { + incr total_invocants [llength [dict get $invocants $key]] + } + + append result "invocants: ($total_invocants invocant(s) in [llength $invocant_roles] role(s)) \n" + foreach key $invocant_roles { + append result "\t-------------------------------\n" + append result "\trole: $key\n" + set role_members [dict get $invocants $key] ;#usually the role 'this' will have 1 member - but roles can have any number of invocants + append result "\t Raw data for this role: $role_members\n" + append result "\t Number of invocants in this role: [llength $role_members]\n" + foreach member $role_members { + #set OID [lindex [dict get $invocants $key] 0 0] + set OID [lindex $member 0] + append result "\t\tOID: $OID\n" + if {$OID ne "null"} { + upvar #0 ::p::${OID}::_meta::map MAP + append result "\t\tmap:\n" + foreach key [dict keys $MAP] { + append result "\t\t\t$key\n" + append result "\t\t\t\t [dict get $MAP $key]\n" + append result "\t\t\t----\n" + } + lassign [dict get $MAP invocantdata] _OID namespace default_method cmd _wrapped + append result "\t\tNamespace: $namespace\n" + append result "\t\tDefault method: $default_method\n" + append result "\t\tCommand: $cmd\n" + append result "\t\tCommand Alias: [::pattern::which_alias $cmd]\n" + append result "\t\tLevel0 interfaces: [dict get $MAP interfaces level0]\n" + append result "\t\tLevel1 interfaces: [dict get $MAP interfaces level1]\n" + } else { + lassign $member _OID namespace default_method stackvalue _wrapped + append result "\t\t last item on the predator stack is a value not an object" + append result "\t\t Value is: $stackvalue" + + } + } + append result "\n" + append result "\t-------------------------------\n" + } + + + + return $result +} + + + + +dict set ::p::-1::_iface::o_methods Rename {arglist {args}} +proc ::p::-1::Rename {_ID_ args} { + set OID [::p::obj_get_this_oid $_ID_] + if {![llength $args]} { + error "Rename expected \$newname argument" + } + + #Rename operates only on the 'this' invocant? What if there is more than one 'this'? should we raise an error if there is anything other than a single invocant? + upvar #0 ::p::${OID}::_meta::map MAP + + + + #puts ">>.>> Rename. _ID_: $_ID_" + + if {[catch { + + if {([llength $args] == 3) && [lindex $args 2] eq "rename"} { + + #appears to be a 'trace command rename' firing + #puts "\t>>>> rename trace fired $MAP $args <<<" + + lassign $args oldcmd newcmd + set extracted_invocantdata [dict get $MAP invocantdata] + lset extracted_invocantdata 3 $newcmd + dict set MAP invocantdata $extracted_invocantdata + + + lassign $extracted_invocantdata _oid alias _default_method object_command _wrapped + + #Write the same info into the _ID_ value of the alias + interp alias {} $alias {} ;#first we must delete it + interp alias {} $alias {} ::p::internals::predator [list i [list this [list $extracted_invocantdata ] ] context {}] + + + + #! $object_command was initially created as the renamed alias - so we have to do it again + uplevel 1 [list rename $alias $object_command] + trace add command $object_command rename [list $object_command .. Rename] + + } elseif {[llength $args] == 1} { + #let the rename trace fire and we will be called again to do the remap! + uplevel 1 [list rename [lindex [dict get $MAP invocantdata] 3] [lindex $args 0]] + } else { + error "Rename expected \$newname argument ." + } + + } errM]} { + puts stderr "\t@@@@@@ rename error" + set ruler "\t[string repeat - 80]" + puts stderr $ruler + puts stderr $errM + puts stderr $ruler + + } + + return + + +} + +proc ::p::obj_get_invocants {_ID_} { + return [dict get $_ID_ i] +} +#The invocant role 'this' is special and should always have only one member. +# dict get $_ID_ i XXX will always return a list of invocants that are playing role XXX +proc ::p::obj_get_this_oid {_ID_} { + return [lindex [dict get $_ID_ i this] 0 0] +} +proc ::p::obj_get_this_ns {_ID_} { + return [lindex [dict get $_ID_ i this] 0 1] +} + +proc ::p::obj_get_this_cmd {_ID_} { + return [lindex [dict get $_ID_ i this] 0 3] +} +proc ::p::obj_get_this_data {_ID_} { + lassign [dict get [set ::p::[lindex [dict get $_ID_ i this] 0 0]::_meta::map] invocantdata] OID ns _unknown cmd + #set this_invocant_data {*}[dict get $_ID_ i this] + return [list oid $OID ns $ns cmd $cmd] +} +proc ::p::map {OID varname} { + tailcall upvar #0 ::p::${OID}::_meta::map $varname +} + + + diff --git a/src/bootsupport/modules/oolib-0.1.3.tm b/src/bootsupport/modules/oolib-0.1.3.tm new file mode 100644 index 00000000..e44e2a8d --- /dev/null +++ b/src/bootsupport/modules/oolib-0.1.3.tm @@ -0,0 +1,200 @@ +#JMN - api should be kept in sync with package patternlib where possible +# + +namespace eval oolib { + oo::class create collection { + variable o_data ;#dict + #variable o_alias + constructor {} { + set o_data [dict create] + } + method info {} { + return [dict info $o_data] + } + method count {} { + return [dict size $o_data] + } + method isEmpty {} { + expr {[dict size $o_data] == 0} + } + method names {{globOrIdx {}}} { + if {[llength $globOrIdx]} { + if {[string is integer -strict $globOrIdx]} { + set idx $globOrIdx + if {$idx < 0} { + set idx "end-[expr {abs($idx + 1)}]" + } + if {[catch {lindex [dict keys $o_data] $idx} result]} { + error "[self object] no such index : '$idx'" + } else { + return $result + } + } else { + #glob + return [lsearch -glob -all -inline [dict keys $o_data] $globOrIdx] + } + } else { + return [dict keys $o_data] + } + } + #like names but without globbing + method keys {} { + dict keys $o_data + } + method key {{posn 0}} { + if {$posn < 0} { + set posn "end-[expr {abs($posn + 1)}]" + } + if {[catch {lindex [dict keys $o_data] $posn} result]} { + error "[self object] no such index : '$posn'" + } else { + return $result + } + } + method hasKey {key} { + dict exists $o_data $key + } + method get {} { + return $o_data + } + method items {} { + return [dict values $o_data] + } + method item {key} { + if {[string is integer -strict $key]} { + if {$key >= 0} { + set valposn [expr {(2*$key) +1}] + return [lindex $o_data $valposn] + } else { + set key "end-[expr {abs($key + 1)}]" + return [lindex $o_data $key] + #return [lindex [dict keys $o_data] $key] + } + } + if {[dict exists $o_data $key]} { + return [dict get $o_data $key] + } + } + #inverse lookup + method itemKeys {value} { + set value_indices [lsearch -all [dict values $o_data] $value] + set keylist [list] + foreach i $value_indices { + set idx [expr {(($i + 1) *2) -2}] + lappend keylist [lindex $o_data $idx] + } + return $keylist + } + method search {value args} { + set matches [lsearch {*}$args [dict values $o_data] $value] + if {"-inline" in $args} { + return $matches + } else { + set keylist [list] + foreach i $matches { + set idx [expr {(($i + 1) *2) -2}] + lappend keylist [lindex $o_data $idx] + } + return $keylist + } + } + #review - see patternlib. Is the intention for aliases to be configurable independent of whether the target exists? + #review - what is the point of alias anyway? - why slow down other operations when a variable can hold a keyname perfectly well? + #method alias {newAlias existingKeyOrAlias} { + # if {[string is integer -strict $newAlias]} { + # error "[self object] collection key alias cannot be integer" + # } + # if {[string length $existingKeyOrAlias]} { + # set o_alias($newAlias) $existingKeyOrAlias + # } else { + # unset o_alias($newAlias) + # } + #} + #method aliases {{key ""}} { + # if {[string length $key]} { + # set result [list] + # foreach {n v} [array get o_alias] { + # if {$v eq $key} { + # lappend result $n $v + # } + # } + # return $result + # } else { + # return [array get o_alias] + # } + #} + ##if the supplied index is an alias, return the underlying key; else return the index supplied. + #method realKey {idx} { + # if {[catch {set o_alias($idx)} key]} { + # return $idx + # } else { + # return $key + # } + #} + method add {value key} { + if {[string is integer -strict $key]} { + error "[self object] collection key must not be an integer. Use another structure if integer keys required" + } + if {[dict exists $o_data $key]} { + error "[self object] col_processors object error: key '$key' already exists in collection" + } + dict set o_data $key $value + return [expr {[dict size $o_data] - 1}] ;#return index of item + } + method remove {idx {endRange ""}} { + if {[string length $endRange]} { + error "[self object] collection error: ranged removal not yet implemented.. remove one item at a time" + } + if {[string is integer -strict $idx]} { + if {$idx < 0} { + set idx "end-[expr {abs($idx+1)}]" + } + set key [lindex [dict keys $o_data] $idx] + set posn $idx + } else { + set key $idx + set posn [lsearch -exact [dict keys $o_data] $key] + if {$posn < 0} { + error "[self object] no such index: '$idx' in this collection" + } + } + dict unset o_data $key + return + } + method clear {} { + set o_data [dict create] + return + } + method reverse_the_collection {} { + #named slightly obtusely because reversing the data when there may be references held is a potential source of bugs + #the name reverse_the_collection should make it clear that the object is being modified in place as opposed to simply 'reverse' which may imply a view/copy. + #todo - consider implementing a get_reverse which provides an interface to the same collection without affecting original references, yet both allowing delete/edit operations. + set dictnew [dict create] + foreach k [lreverse [dict keys $o_data]] { + dict set dictnew $k [dict get $o_data $k] + } + set o_data $dictnew + return + } + #review - cmd as list vs cmd as script? + method map {cmd} { + set seed [list] + dict for {k v} $o_data { + lappend seed [uplevel #0 [list {*}$cmd $v]] + } + return $seed + } + method objectmap {cmd} { + set seed [list] + dict for {k v} $o_data { + lappend seed [uplevel #0 [list $v {*}$cmd]] + } + return $seed + } + } +} + +package provide oolib [namespace eval oolib { + variable version + set version 0.1.3 +}] diff --git a/src/bootsupport/modules/overtype-1.7.4.tm b/src/bootsupport/modules/overtype-1.7.4.tm index 04d0e96b..1ca40672 100644 --- a/src/bootsupport/modules/overtype-1.7.4.tm +++ b/src/bootsupport/modules/overtype-1.7.4.tm @@ -253,7 +253,6 @@ tcl::namespace::eval overtype { coloured as this doesn't affect the display width. Default is \uFFFD - the unicode replacement char.} - -experimental -default 0 -cp437 -default 0 -type boolean -looplimit -default \uFFEF\ -type integer -help\ "internal failsafe - experimental" @@ -263,7 +262,8 @@ tcl::namespace::eval overtype { -wrap -default 0 -type boolean -info -default 0 -type boolean -help\ "When set to 1, return a dictionary (experimental)" - -binarytext -default "" -type string -choices {"" bios ice} + -format -default ansi -type string -choices {ansi binarytext-bios binarytext-ice xbin} -help\ + "Format of new data being applied as an overlay" -console -default {stdin stdout stderr} -type list @values -min 1 -max 2 @@ -328,7 +328,6 @@ tcl::namespace::eval overtype { -transparent 0 -exposed1 \uFFFD -exposed2 \uFFFD - -experimental 0 -cp437 0 -looplimit \uFFEF -crm_mode 0 @@ -336,7 +335,7 @@ tcl::namespace::eval overtype { -insert_mode 0 -wrap 0 -info 0 - -binarytext "" + -format ansi -console {stdin stdout stderr} }] #expand_right is perhaps consistent with the idea of the page_size being allowed to grow horizontally.. @@ -353,11 +352,11 @@ tcl::namespace::eval overtype { foreach {k v} $argsflags { switch -- $k { -looplimit - -width - -height - -startcolumn - -startrow - -bias - -ellipsis - -ellipsistext - -ellipsiswhitespace - - -transparent - -exposed1 - -exposed2 - -experimental + - -transparent - -exposed1 - -exposed2 - -expand_right - -appendlines - -reverse_mode - -crm_mode - -insert_mode - -cp437 - - -info - -binarytext - -console { + - -info - -format - -console { tcl::dict::set opts $k $v } -wrap - -autowrap_mode { @@ -379,6 +378,7 @@ tcl::namespace::eval overtype { set opt_height [tcl::dict::get $opts -height] set opt_startcolumn [tcl::dict::get $opts -startcolumn] set opt_startrow [tcl::dict::get $opts -startrow] + #review -appendlines - this needs thought regarding interaction with terminal height concept and scrolling set opt_appendlines [tcl::dict::get $opts -appendlines] set opt_transparent [tcl::dict::get $opts -transparent] set opt_ellipsistext [tcl::dict::get $opts -ellipsistext] @@ -397,7 +397,7 @@ tcl::namespace::eval overtype { # -- --- --- --- --- --- set opt_cp437 [tcl::dict::get $opts -cp437] set opt_info [tcl::dict::get $opts -info] - set opt_binarytext [tcl::dict::get $opts -binarytext] + set opt_format [tcl::dict::get $opts -format] set opt_console [tcl::dict::get $opts -console] @@ -416,26 +416,18 @@ tcl::namespace::eval overtype { #} #-------------------------------------------------------------------------- - # ---------------------------- - # -experimental dev flag to set flags etc - # ---------------------------- - set data_mode 0 - set edit_mode 0 - set opt_experimental [tcl::dict::get $opts -experimental] - foreach o $opt_experimental { - switch -- $o { - data_mode { - set data_mode 1 - } - edit_mode { - set edit_mode 1 - } - } - } - # ---------------------------- + #--------------------------------------------------------- + #underblock is expected to be pre-rendered - ie any ANSI codes have already been processed and rendered into the text. + #This is because the underblock is used as the basis for calculating the layout of the output + #- so it needs to be in a form where we can determine the width of each line and how many lines there are. set underblock [tcl::string::map {\r\n \n} $underblock] - set overblock [tcl::string::map {\r\n \n} $overblock] + + #do not split the overblock into lines at this stage - it may contain binary data. + #REVIEW - xbin (or binarytext?) may contain binary data which could be corrupted by mapping \r\n to \n. + #set overblock [tcl::string::map {\r\n \n} $overblock] + #--------------------------------------------------------- + if {$opt_startrow > 1} { set down [expr {$opt_startrow -1}] #when vt52? @@ -471,12 +463,17 @@ tcl::namespace::eval overtype { } insert_mode $opt_insert_mode {*}{ } autowrap_mode $opt_autowrap_mode {*}{ } cp437 $opt_cp437 {*}{ + } row 1 {*}{ + } col 1 {*}{ + } topmargin 1 {*}{ + } bottommargin $renderheight {*}{ } ] #modes #e.g insert_mode can be toggled by insert key or ansi IRM sequence CSI 4 h|l #opt_startcolumn ?? - DECSLRM ? set vtstate $initial_state + dict set vtstate col $opt_startcolumn # -- --- --- --- #REVIEW - do we need ansi resets in the underblock? @@ -484,7 +481,6 @@ tcl::namespace::eval overtype { set blankline [string repeat \u0000 $renderwidth] set underlines [lrepeat $renderheight $blankline] } else { - #---- #this splits into lines - only to rejoin - which is inefficient. #It also has code to handle joining multiple blocks - but we only have one in this case. @@ -498,16 +494,8 @@ tcl::namespace::eval overtype { } else { set underlines [split $underblock \n] } - } - #if {$underblock eq ""} { - # set blank "\x1b\[0m\x1b\[0m" - # #set underlines [list "\x1b\[0m\x1b\[0m"] - # set underlines [lrepeat $renderheight $blank] - #} else { - # #lines_as_list -ansiresets 1 will do nothing if -ansiresets 1 isn't specified - REVIEW - # set underlines [lines_as_list -ansiresets 1 $underblock] - #} + #underlines are not necessarily processed in order - depending on cursor-moves applied from overtext # -- --- --- --- #todo - reconsider the 'line' as the natural chunking mechanism for the overlay. @@ -529,95 +517,82 @@ tcl::namespace::eval overtype { #overblock height/width isn't useful in the presence of an ansi input overlay with movements. The number of lines may bear little relationship to the output height #lassign [blocksize $overblock] _w overblock_width _h overblock_height - set scheme 4 - switch -- $scheme { - 0 { - #one big chunk - set inputchunks [list mixed $overblock] - } - 1 { - #todo - set inputchunks [punk::ansi::ta::split_codes $overblock] - } - 2 { - #todo - #split into lines if possible first - then into plaintext/ansi-sequence chunks ? - set inputchunks [list ""] ;#put an empty plaintext split in for starters - set i 1 - set lines [split $overblock \n] - foreach ln $lines { - if {$i < [llength $lines]} { - append ln \n - } - set sequence_split [punk::ansi::ta::split_codes_single $ln] ;#use split_codes Not split_codes_single? - set lastpt [lindex $inputchunks end] - lset inputchunks end [tcl::string::cat $lastpt [lindex $sequence_split 0]] - lappend inputchunks {*}[lrange $sequence_split 1 end] - incr i - } - } - 3 { - #todo - #it turns out line based chunks are faster than the above.. probably because some of those end up doing the regex splitting twice - set lflines [list] - set inputchunks [split $overblock \n] - foreach ln $inputchunks { - append ln \n - lappend lflines $ln + set inputchunks [list] + switch -- $opt_format { + ansi { + #ansi is commonly but not always line-based. + #some ansi is a string of data with ansi movements and no linefeeds. + set overblock [tcl::string::map {\r\n \n} $overblock] + foreach ln [split $overblock \n] { + lappend inputchunks [list mixed $ln\n] } - if {[llength $lflines]} { - lset lflines end [tcl::string::range [lindex $lflines end] 0 end-1] + if {[llength $inputchunks]} { + #strip trailing newline from last line. + lset inputchunks end 1 [tcl::string::range [lindex $inputchunks end 1] 0 end-1] } - #set inputchunks $lflines[unset lflines] - set inputchunks [lindex [list $lflines [unset lflines]] 0] - } - 4 { - set inputchunks [list] - switch -- $opt_binarytext { - "" { - foreach ln [split $overblock \n] { - lappend inputchunks [list mixed $ln\n] - } - if {[llength $inputchunks]} { - lset inputchunks end 1 [tcl::string::range [lindex $inputchunks end 1] 0 end-1] - } + binarytext-bios { + #16 fg, 8 fg + possible blink + set input "" + set ansisplit [list ""] + set charpair 0 + foreach {ch at} [split $overblock ""] { + #review - does binarytext only apply to cp437??? we need to know the original encoding + if {[catch {punk::ansi::colour::byteAnsi $at} code]} { + puts stderr "renderspace err at charpair: $charpair [punk::ansi::ansistring VIEW ${ch}${at}]" + #append input [punk::ansi::a+ brightred White] \uFFef + set code [punk::ansi::a+ brightred White] } - bios { - #16 fg, 8 fg + possible blink - set input "" - set ansisplit [list ""] - set charpair 0 - foreach {ch at} [split $overblock ""] { - #review - does binarytext only apply to cp437??? we need to know the original encoding - set at [encoding convertto cp437 $at] - if {[catch {punk::ansi::colour::byteAnsi $at} code]} { - puts stderr "renderspace err at charpair: $charpair [punk::ansi::ansistring VIEW ${ch}${at}]" - #append input [punk::ansi::a+ brightred White] \uFFef - set code [punk::ansi::a+ brightred White] - set ch \uFFeF - } - append input $code $ch - lappend ansisplit $code $ch - incr charpair - } - #lappend inputchunks [list mixed $input] - lappend inputchunks [list ansisplit $ansisplit] + if {[catch {encoding convertfrom cp437 $ch} ch]} { + puts stderr "renderspace err at charpair: $charpair [punk::ansi::ansistring VIEW ${ch}${at}]" + set ch \uFFeF } - ice { - #16 fg, 16 bg (no blink) - set input "" - foreach {ch at} [split $overblock ""] { - set at [encoding convertto cp437 $at] - append input [punk::ansi::colour::byteAnsiIce $at]$ch - } - lappend inputchunks [list mixed $input] + append input $code $ch + lappend ansisplit $code $ch + incr charpair + } + #lappend inputchunks [list mixed $input] + lappend inputchunks [list ansisplit $ansisplit] + } + binarytext-ice { + #16 fg, 16 bg (no blink) + set input "" + foreach {ch at} [split $overblock ""] { + if {$at ne ""} { + append input [punk::ansi::colour::byteAnsiIce $at] } + set ch [encoding convertfrom cp437 $ch] + append input $ch } + lappend inputchunks [list mixed $input] } - } + xbin { + set parse_dict [punk::ansi::xbin::parse $overblock] + set ansisplit [dict get $parse_dict ansisplit] + set xbin_header_info [dict get $parse_dict header] + set flags [dict get $xbin_header_info flags] + set xbin_width [dict get $xbin_header_info width] + set xbin_height [dict get $xbin_header_info height] + puts stdout "xbin dimensions ${xbin_width}x${xbin_height} decoded [dict get $parse_dict decoded_cells] of [dict get $parse_dict expected_cells] expected cells" + puts stdout "xbin flags $flags" + set warnings [dict get $parse_dict warnings] + foreach w $warnings { + puts stderr "xbin warning: $w" + } + puts stdout "xbin decoded" + flush stdout + lappend inputchunks [list ansisplit $ansisplit] + } + } + #we have a list of 2 element input chunks {overtext_type overtext} in $inputchunks + #- each chunk is either a string of text with embedded ANSI codes (type 'mixed') + #- or a list of alternating ANSI code and text segments (type 'ansisplit') + #For ansi files each chunk may commonly correspond to a line of text - but this is not necessarily the case, as ANSI cursor movements and other codes may be present which affect the layout in ways that can't be determined until processing. + #for binary files - there may be no newlines at all - just a stream of bytes with ANSI codes interspersed to control the layout and colours. + #The chunks are processed in order, with the output of each chunk being rendered onto the current 'underlay' of the output, + #and then becoming the new 'underlay' for the next chunk to render onto. set replay_codes_underlay [tcl::dict::create 1 ""] @@ -631,13 +606,6 @@ tcl::namespace::eval overtype { set outputlines $underlines set overidx 0 - #underlines are not necessarily processed in order - depending on cursor-moves applied from overtext - set row 1 - #if {$data_mode} { - # set col [_get_row_append_column $row] - #} else { - set col $opt_startcolumn - #} set instruction_stats [tcl::dict::create] @@ -655,7 +623,10 @@ tcl::namespace::eval overtype { continue } #puts "----->[ansistring VIEW -lf 1 -vt 1 -nul 1 $overtext]<----" - set undertext [lindex $outputlines [expr {$row -1}]] + set undertext [lindex $outputlines [dict get $vtstate row]-1] + if {[tcl::dict::exists $replay_codes_underlay [dict get $vtstate row]]} { + set undertext [tcl::dict::get $replay_codes_underlay [dict get $vtstate row]]$undertext + } #renderline pads each underly line to width with spaces and should track where end of data is @@ -690,19 +661,17 @@ tcl::namespace::eval overtype { #} ###################### - set renderedrow $row + #remember the row we are just about to render. + set renderedrow [dict get $vtstate row] if {$renderedrow > $renderedrow_max} { set renderedrow_max $renderedrow } - if {[tcl::dict::exists $replay_codes_underlay $row]} { - set undertext [tcl::dict::get $replay_codes_underlay $row]$undertext - } #review insert_mode. As an 'overtype' function whose main function is not interactive keystrokes - insert is secondary - #but even if we didn't want it as an option to the function call - to process ansi adequately we need to support IRM (insertion-replacement mode) ESC [ 4 h|l - set renderopts [list -experimental $opt_experimental {*}{ + set renderopts [list {*}{ } -cp437 $opt_cp437 {*}{ } -info 1 {*}{ } -crm_mode [tcl::dict::get $vtstate crm_mode] {*}{ @@ -715,8 +684,8 @@ tcl::namespace::eval overtype { } -exposed1 $opt_exposed1 {*}{ } -exposed2 $opt_exposed2 {*}{ } -expand_right $opt_expand_right {*}{ - } -cursor_column $col {*}{ - } -cursor_row $row {*}{ + } -cursor_column [tcl::dict::get $vtstate col] {*}{ + } -cursor_row [tcl::dict::get $vtstate row] {*}{ } -overtext_type $overtext_type {*}{ } ] @@ -747,6 +716,8 @@ tcl::namespace::eval overtype { set visualwidth [tcl::dict::get $rinfo visualwidth] ;#column width of what is 'rendered' for the line set insert_lines_above [tcl::dict::get $rinfo insert_lines_above] set insert_lines_below [tcl::dict::get $rinfo insert_lines_below] + + #review - this assumes lines are rendered in order - but this isn't always true. tcl::dict::set replay_codes_underlay [expr {$renderedrow+1}] [tcl::dict::get $rinfo replay_codes_underlay] #lset replay_codes_overlay [expr $overidx+1] [tcl::dict::get $rinfo replay_codes_overlay] @@ -785,7 +756,7 @@ tcl::namespace::eval overtype { #-- todo - detect looping properly - if {$row > 1 && $overtext ne "" && $unapplied eq $overtext && $post_render_row == $row && $instruction eq ""} { + if {[dict get $vtstate row] > 1 && $overtext ne "" && $unapplied eq $overtext && $post_render_row == [dict get $vtstate row] && $instruction eq ""} { puts stderr "overtype::renderspace loop?" puts [ansistring VIEW $rinfo] break @@ -811,25 +782,23 @@ tcl::namespace::eval overtype { tcl::dict::incr instruction_stats $instruction_type switch -- $instruction_type { reset { - #reset the 'renderspace terminal' (not underlying terminal) - set row 1 - set col 1 + #reset the 'renderspace virtual terminal' (not underlying terminal) set vtstate [tcl::dict::merge $vtstate $initial_state] #todo - clear screen } {} { #end of supplied line input #lf included in data - set row $post_render_row - set col $post_render_col + dict set vtstate row $post_render_row + #dict set vtstate col $post_render_col if {![llength $unapplied_list]} { if {$overflow_right ne ""} { - incr row + dict incr vtstate row } } else { puts stderr "renderspace end of input line - has unapplied: [ansistring VIEW $unapplied] (review)" } - set col $opt_startcolumn + dict set vtstate col $opt_startcolumn } up { @@ -843,87 +812,42 @@ tcl::namespace::eval overtype { #puts stderr "up $post_render_row" #puts stderr "$rinfo" - #puts stdout "1 row:$row col $col" - set row $post_render_row - #data_mode (naming?) determines if we move to end of existing data or not. - #data_mode 0 means ignore existing line length and go to exact column - #set by -experimental flag - if {$data_mode == 0} { - set col $post_render_col - } else { - #This doesn't really work if columns are pre-filled with spaces..we can't distinguish them from data - #we need renderline to return the number of the maximum column filled (or min if we ever do r-to-l) - set existingdata [lindex $outputlines [expr {$post_render_row -1}]] - set lastdatacol [punk::ansi::printing_length $existingdata] - if {$lastdatacol < $renderwidth} { - set col [expr {$lastdatacol+1}] - } else { - set col $renderwidth - } - } - - #puts stdout "2 row:$row col $col" - #puts stdout "-----------------------" - #puts stdout $rinfo - #flush stdout + dict set vtstate row $post_render_row + dict set vtstate col $post_render_col } down { - if {$data_mode == 0} { + #cursor down. Will not force scroll if at bottom of screen. + if {$post_render_row > [llength $outputlines]} { #renderline doesn't know how far down we can go.. - if {$post_render_row > [llength $outputlines]} { - if {$opt_appendlines} { - set diff [expr {$post_render_row - [llength $outputlines]}] - set bce_line \x1b\[0m$replay_codes_overlay[string repeat \u0000 $renderwidth] - if {$diff > 0} { - lappend outputlines {*}[lrepeat $diff $bce_line] - #lappend outputlines {*}[lrepeat $diff ""] - } - lappend outputlines $bce_line - #lappend outputlines "" - } - } - set row $post_render_row - set col $post_render_col - } else { - puts stderr "renderspace down - data_mode 1 - review" - if {$post_render_row > [llength $outputlines]} { - if {$opt_appendlines} { - set diff [expr {$post_render_row - [llength $outputlines]}] - set bce_line \x1b\[0m$replay_codes_overlay[string repeat \u0000 $renderwidth] - if {$diff > 0} { - lappend outputlines {*}[lrepeat $diff $bce_line] - #lappend outputlines {*}[lrepeat $diff ""] - } - lappend outputlines $bce_line - #lappend outputlines "" + set post_render_row [llength $outputlines] + } + dict set vtstate row $post_render_row + dict set vtstate col $post_render_col + } + down_scrolling { + #todo - scrolling region. take account of decstbm. + + #renderline doesn't know how far down we can go.. + if {$post_render_row > [llength $outputlines]} { + if {$opt_appendlines} { + set diff [expr {$post_render_row - [llength $outputlines]}] + set bce_line \x1b\[0m$replay_codes_overlay[string repeat \u0000 $renderwidth] + if {$diff > 0} { + lappend outputlines {*}[lrepeat $diff $bce_line] } + lappend outputlines $bce_line } - # ---- - # review - set col $post_render_col - #just because it's out of range of the renderwidth - doesn't mean a move down should jump to within the range - 2025 - #---- - - #set existingdata [lindex $outputlines [expr {$post_render_row -1}]] - #set lastdatacol [punk::ansi::printing_length $existingdata] - - #set col [expr {$lastdatacol+1}] - - #if {$lastdatacol < $renderwidth} { - # set col [expr {$lastdatacol+1}] - #} else { - # set col $renderwidth - #} - } + dict set vtstate row $post_render_row + dict set vtstate col $post_render_col } restore_cursor { #testfile belinda.ans uses this #puts stdout "[a+ blue bold]CURSOR_RESTORE[a]" if {[tcl::dict::exists $cursor_saved_position row]} { - set row [tcl::dict::get $cursor_saved_position row] - set col [tcl::dict::get $cursor_saved_position column] + dict set vtstate row [tcl::dict::get $cursor_saved_position row] + dict set vtstate col [tcl::dict::get $cursor_saved_position column] #puts stdout "restoring: row $row col $col [ansistring VIEW $cursor_saved_attributes] [a] unapplied [ansistring VIEWCODES $unapplied]" #set nextprefix $cursor_saved_attributes #lset replay_codes_overlay [expr $overidx+1] $cursor_saved_attributes @@ -971,6 +895,47 @@ tcl::namespace::eval overtype { set overflow_handled 1 } + decstbm { + #scrolling region - CSI r + #renderline will have rendered the line based on the current vtstate row/col + #- but the scrolling region change may have caused a move to be rendered to the output which changes the row/col for the next line + #- so we need to update our vtstate cursor position. + lassign $instruction _ margin_top margin_bottom + + set margins_valid 1 ;#default assumption + #todo - validate margins. A valid scrolling region requires at least two lines. + if {$margin_top eq ""} {set margin_top 1} + if {$margin_bottom eq ""} {set margin_bottom $screen_rows} + if {![string is integer -strict $margin_top] || $margin_top < 1} { + puts stderr "DECSTBM invalid margin_top '$margin_top' [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + set margins_valid 0 + } + if {![string is integer -strict $margin_bottom] || $margin_bottom < 1} { + puts stderr "DECSTBM invalid margin_bottom '$margin_bottom' [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + set margins_valid 0 + } + if {$margin_bottom - $margin_top < 1} { + puts stderr "DECSTBM invalid margins - bottom '$margin_bottom' must be greater than top '$margin_top' [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + set margins_valid 0 + } + if {$margins_valid} { + #todo - return these for the caller to process.. + puts stderr "overtype::renderspace DECSTBM set top and bottom margin not implemented" + #Also moves the cursor to col 1 line 1 of the page + #review - examine DECOM state to determine new cursor position? + dict set vtstate row 1 + dict set vtstate col 1 + + #incr idx_over + #priv::render_to_unapplied $overlay_grapheme_control_list $gci + #set instruction [list decstbm $margin_top $margin_bottom] + dict set vtstate topmargin $margin_top + dict set vtstate bottommargin $margin_bottom + } else { + puts stderr "overtype::renderspace DECSTBM invalid margins - ignoring [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + #don't update the vtstate margins. + } + } move { ######## if {$post_render_row > [llength $outputlines]} { @@ -982,67 +947,95 @@ tcl::namespace::eval overtype { if {$diff > 0} { lappend outputlines {*}[lrepeat $diff $bce_line] } - set row $post_render_row + dict set vtstate row $post_render_row } else { - set row [llength $outputlines] + dict set vtstate row [llength $outputlines] } } else { - set row $post_render_row + dict set vtstate row $post_render_row } ####### - set col $post_render_col + dict set vtstate col $post_render_col #overflow + unapplied? } + clear_to_end_display { + #ED 0 + #review - needs to operate within top and bottom margins if set (decstbm) - but for now we assume full screen clear + #Current row already partially erased by renderline. + if {$post_render_row > [llength $outputlines]} { + dict set vtstate row [llength $outputlines] + } else { + dict set vtstate row $post_render_row + } + dict set vtstate col $post_render_col + set overflow_right "" + + set start_idx [expr {[dict get $vtstate row]}] + if {$start_idx < 0} {set start_idx 0} + for {set i $start_idx} {$i < [llength $outputlines]} {incr i} { + lset outputlines $i \x1b\[0m$replay_codes_overlay[string repeat \u0000 $renderwidth]\x1b\[0m + } + } + clear_to_start_display { + #ED 1 + #Current row already partially erased by renderline. + if {$post_render_row > [llength $outputlines]} { + dict set vtstate row [llength $outputlines] + } else { + dict set vtstate row $post_render_row + } + dict set vtstate col $post_render_col + set overflow_right "" + + set stop_idx [expr {[dict get $vtstate row] - 1}] + if {$stop_idx >= [llength $outputlines]} { + set stop_idx [expr {[llength $outputlines] - 1}] + } + for {set i 0} {$i < $stop_idx} {incr i} { + lset outputlines $i \x1b\[0m$replay_codes_overlay[string repeat \u0000 $renderwidth]\x1b\[0m + } + } clear_and_move { - #e.g 2J + #ED 2J if {$post_render_row > [llength $outputlines]} { - set row [llength $outputlines] + dict set vtstate row [llength $outputlines] } else { - set row $post_render_row + dict set vtstate row $post_render_row } - set col $post_render_col + dict set vtstate col $post_render_col set overflow_right "" ;#if we're clearing - any overflow due to insert_mode is irrelevant - set clearedlines [list] - foreach ln $outputlines { - lappend clearedlines \x1b\[0m$replay_codes_overlay[string repeat \u0000 $renderwidth]\x1b\[0m - - #set lineparts [punk::ansi::ta::split_codes $ln] - #set numcells 0 - #foreach {pt _code} $lineparts { - # if {$pt ne ""} { - # foreach grapheme [punk::char::grapheme_split $pt] { - # switch -- $grapheme { - # " " - - - _ - ! - @ - # - $ - % - ^ - & - * - = - + - : - . - , - / - | - ? - - # a - b - c - d - e - f - g - h - i - j - k - l - m - n - o - p - q - r - s - t - u - v - w - x - y - - # z - A - B - C - D - E - F - G - H - I - J - K - L - M - N - O - P - Q - R - S - T - U - V - W - X - Y - Z - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 { - # incr numcells 1 - # } - # default { - # if {$grapheme eq "\u0000"} { - # #review - # incr numcells 1 - # } elseif {$grapheme eq "\t"} { - # #set tstops [lsort -integer -unique [punk::console::get_tabstops]] - # puts stderr "tab at numcells: $numcells - REVIEW renderspace" - # set nexttabstop [expr {((int($numcells / 8) + 1) * 8)}] - # incr numcells [expr {$nexttabstop - $numcells}] - # } else { - # incr numcells [grapheme_width_cached $grapheme] - # } - # } - # } - - # } - # } - #} - ##replays/resets each line - #lappend clearedlines \x1b\[0m$replay_codes_overlay[string repeat \u0000 $numcells]\x1b\[0m + for {set i 0} {$i < [llength $outputlines]} {incr i} { + lset outputlines $i \x1b\[0m$replay_codes_overlay[string repeat \u0000 $renderwidth]\x1b\[0m } - set outputlines $clearedlines #todo - determine background/default to be in effect - DECECM ? puts stderr "replay_codes_overlay: [ansistring VIEW $replay_codes_overlay]" - #lset outputlines 0 $replay_codes_overlay[lindex $outputlines 0] - + } + delete_lines { + #DL n + set delete_count [lindex $instruction 1] + set r $renderedrow + puts stderr "delete_lines $delete_count at row $r" + if {$delete_count > 0} { + #set outputlines [lreplace $outputlines [dict get $vtstate row] [expr {[dict get $vtstate row] + $delete_count - 1}]] + set delidx_first [expr {$r - 1}] ;#convert to 0-based index + set delidx_last [expr {$delidx_first + ($delete_count - 1)}] ;#inclusive index of last line to delete + #if delete_count is 1 - we are only deleting the current line. + ledit outputlines $delidx_first $delidx_last + } + dict set vtstate row $renderedrow + if {[llength $outputlines] < [dict get $vtstate row]} { + dict set vtstate row [llength $outputlines] + } + #we need to ensure 'unapplied' data is still applied to the current line after deletion. + #Any overflow on the current line should be abandoned. + if {[llength $unapplied_ansisplit]} { + #set inputchunks [linsert $inputchunks 0 $nextprefix] + #JMN - assume backwards compat ledit available from punk::lib (for tcl <9) + ledit inputchunks -1 -1 [list ansisplit $unapplied_ansisplit] + } + incr overidx + incr loop + continue } lf_start { #raw newlines @@ -1051,9 +1044,9 @@ tcl::namespace::eval overtype { #test - treating as newline below... #append rendered $overflow_right #set overflow_right "" - set row $renderedrow - incr row - if {$row > [llength $outputlines]} { + + dict set vtstate row [expr {$renderedrow + 1}] + if {[dict get $vtstate row] > [llength $outputlines]} { #lappend outputlines "" # BCE lappend outputlines \x1b\[0m$replay_codes_overlay[string repeat \u0000 $renderwidth] @@ -1062,137 +1055,88 @@ tcl::namespace::eval overtype { # ---------------------- } lf_mid { - set edit_mode 0 - if {$edit_mode} { - #set inputchunks [linsert $inputchunks 0 $overflow_right$unapplied] - #JMN - #ledit inputchunks -1 -1 $overflow_right$unapplied - - set pt_ansi_pt [punk::ansi::ta::split_codes_single $overflow_right] - #join the trailing and leading pt parts of the 2 lists - ledit pt_ansi_pt end end "[lindex $pt_ansi_pt end][lindex $unapplied_ansisplit 0]" - lappend pt_ansi_pt [lrange $unapplied_ansisplit 1 end] - - ledit inputchunks -1 -1 [list ansisplit $pt_ansi_pt] ;#combined overflow_right and unapplied - in ansisplit form - + if {$overflow_right ne ""} { + if {$opt_expand_right} { + append rendered $overflow_right set overflow_right "" - set unapplied "" - set unapplied_list [list] - set unapplied_ansisplit [list] - - set row $post_render_row - #set col $post_render_col - set col $opt_startcolumn - if {$row > [llength $outputlines]} { - #lappend outputlines {*}[lrepeat 1 ""] - lappend outputlines \x1b\[0m$replay_codes_overlay[string repeat \u0000 $renderwidth] - } } else { - if 1 { - if {$overflow_right ne ""} { - if {$opt_expand_right} { - append rendered $overflow_right - set overflow_right "" - } else { - #review - we should really make renderline do the work...? - set overflow_width [punk::ansi::printing_length $overflow_right] - if {$visualwidth + $overflow_width <= $renderwidth} { - append rendered $overflow_right - set overflow_right "" - } else { - if {[tcl::dict::get $vtstate autowrap_mode]} { - #set outputlines [linsert $outputlines $renderedrow $overflow_right] - #ledit outputlines $renderedrow $renderedrow-1 $overflow_right - puts stderr "REVIEW wrap overflow_right to next line: $overflow_right" - #this looks wrong - ledit outputlines $renderedrow -1 $overflow_right - set overflow_right "" - set row [expr {$renderedrow + 2}] - } else { - set overflow_right "" ;#abandon - } + #review - we should really make renderline do the work...? + set overflow_width [punk::ansi::printing_length $overflow_right] + if {$visualwidth + $overflow_width <= $renderwidth} { + append rendered $overflow_right + set overflow_right "" + } else { + if {[tcl::dict::get $vtstate autowrap_mode]} { + #set outputlines [linsert $outputlines $renderedrow $overflow_right] + #ledit outputlines $renderedrow $renderedrow-1 $overflow_right + puts stderr "REVIEW wrap overflow_right to next line: $overflow_right" + #this looks wrong + ledit outputlines $renderedrow -1 $overflow_right + set overflow_right "" + #review - why are we setting this here when we override it below? + dict set vtstate row [expr {$renderedrow + 2}] + } else { + set overflow_right "" ;#abandon + } - if {0 && $visualwidth < $renderwidth} { - puts stderr "visualwidth: $visualwidth < renderwidth:$renderwidth" - error "incomplete - abandon?" - set overflowparts [punk::ansi::ta::split_codes $overflow_right] - set remaining_overflow $overflowparts - set filled 0 - foreach {pt code} $overflowparts { - lpop remaining_overflow 0 - if {$pt ne ""} { - set graphemes [punk::char::grapheme_split $pt] - set add "" - set addlen $visualwidth - foreach g $graphemes { - set w [overtype::grapheme_width_cached $g] - if {$addlen + $w <= $renderwidth} { - append add $g - incr addlen $w - } else { - set filled 1 - break - } - } - append rendered $add - } - if {!$filled} { - lpop remaining_overflow 0 ;#pop code - } + if {0 && $visualwidth < $renderwidth} { + puts stderr "visualwidth: $visualwidth < renderwidth:$renderwidth" + error "incomplete - abandon?" + set overflowparts [punk::ansi::ta::split_codes $overflow_right] + set remaining_overflow $overflowparts + set filled 0 + foreach {pt code} $overflowparts { + lpop remaining_overflow 0 + if {$pt ne ""} { + set graphemes [punk::char::grapheme_split $pt] + set add "" + set addlen $visualwidth + foreach g $graphemes { + set w [overtype::grapheme_width_cached $g] + if {$addlen + $w <= $renderwidth} { + append add $g + incr addlen $w + } else { + set filled 1 + break } - set overflow_right [join $remaining_overflow ""] } + append rendered $add + } + if {!$filled} { + lpop remaining_overflow 0 ;#pop code } } - } - set row $post_render_row - set col $opt_startcolumn - if {$row > [llength $outputlines]} { - #lappend outputlines {*}[lrepeat 1 ""] - # BCE - #puts "row: $row > outputlines: [llength $outputlines] overlay replay:[ansistring VIEW $replay_codes_overlay]" - lappend outputlines \x1b\[0m$replay_codes_overlay[string repeat \u0000 $renderwidth] - } - } else { - #old version - known to work with various ansi graphics - e.g fruit.ans - # - but fails to limit lines to renderwidth when expand_right == 0 - append rendered $overflow_right - set overflow_right "" - set row $post_render_row - set col $opt_startcolumn - if {$row > [llength $outputlines]} { - lappend outputlines {*}[lrepeat 1 ""] + set overflow_right [join $remaining_overflow ""] } } } + } + dict set vtstate row $post_render_row + dict set vtstate col $opt_startcolumn + if {[dict get $vtstate row] > [llength $outputlines]} { + #lappend outputlines {*}[lrepeat 1 ""] + # BCE + #puts "row: $row > outputlines: [llength $outputlines] overlay replay:[ansistring VIEW $replay_codes_overlay]" + lappend outputlines \x1b\[0m$replay_codes_overlay[string repeat \u0000 $renderwidth] + } } lf_overflow { - #linefeed after renderwidth e.g at column 81 for an 80 col width - #we may also have other control sequences that came after col 80 e.g cursor save - - if 0 { - set lhs [overtype::left -width 40 -wrap 1 "" [ansistring VIEWSTYLE -nul 1 -lf 1 -vt 1 $rendered]] - set lhs [textblock::frame -title "rendered $visualwidth cols" -subtitle "row-$renderedrow" $lhs] - set rhs "" - - #assertion - there should be no overflow.. - puts $lhs - } - if {![tcl::dict::get $vtstate insert_mode]} { - assert {$overflow_right eq ""} lf_overflow should not get data in overflow_right when not insert_mode - } + #linefeed after renderwidth e.g at column 81 for an 80 col width + #we may also have other control sequences that came after col 80 e.g cursor save - set row $post_render_row - #set row $renderedrow - #incr row - #only add newline if we're at the bottom - if {$row > [llength $outputlines]} { - #lappend outputlines {*}[lrepeat 1 ""] - # BCE - lappend outputlines \x1b\[0m$replay_codes_overlay[string repeat \u0000 $renderwidth] - } - set col $opt_startcolumn + if {![tcl::dict::get $vtstate insert_mode]} { + assert {$overflow_right eq ""} lf_overflow should not get data in overflow_right when not insert_mode + } + dict set vtstate row $post_render_row + #only add newline if we're at the bottom + if {[dict get $vtstate row] > [llength $outputlines]} { + #lappend outputlines {*}[lrepeat 1 ""] + # BCE + lappend outputlines \x1b\[0m$replay_codes_overlay[string repeat \u0000 $renderwidth] + } + dict set vtstate col $opt_startcolumn } newlines_above { #we get a newlines_above instruction when received at column 1 @@ -1202,76 +1146,53 @@ tcl::namespace::eval overtype { puts "--->newlines_above" puts "rinfo: $rinfo" #renderline doesn't advance the row for us - the caller has the choice to implement or not - set row $post_render_row - set col $post_render_col + set temp_row $post_render_row if {$insert_lines_above > 0} { - set row $renderedrow + set temp_row $renderedrow #set outputlines [linsert $outputlines $renderedrow-1 {*}[lrepeat $insert_lines_above ""]] #ledit outputlines $renderedrow-1 $renderedrow-2 {*}[lrepeat $insert_lines_above ""] # BCE (background color erase) set bce_line \x1b\[0m$replay_codes_overlay[string repeat \u0000 $renderwidth] ledit outputlines $renderedrow-1 -1 {*}[lrepeat $insert_lines_above $bce_line] #ledit outputlines $renderedrow-1 -1 {*}[lrepeat $insert_lines_above ""] - incr row [expr {$insert_lines_above -1}] ;#we should end up on the same line of text (at a different index), with new empties inserted above + incr temp_row [expr {$insert_lines_above -1}] ;#we should end up on the same line of text (at a different index), with new empties inserted above #? set row $post_render_row #can renderline tell us? } + dict set vtstate row $temp_row + dict set vtstate col $post_render_col } newlines_below { #obsolete? - use for ANSI insert lines sequence - if {$data_mode == 0} { - puts --->nl_below - set row $post_render_row - set col $post_render_col - if {$insert_lines_below == 1} { - #set lhs [overtype::left -width 40 -wrap 1 "" [ansistring VIEWSTYLE -lf 1 -vt 1 $rendered]] - #set lhs [textblock::frame -title rendered -subtitle "row-$renderedrow" $lhs] - #set rhs "" - #if {$overflow_right ne ""} { - # set rhs [overtype::left -width 40 -wrap 1 "" [ansistring VIEWSTYLE -lf 1 -vt 1 $overflow_right]] - # set rhs [textblock::frame -title overflow_right $rhs] - #} - #puts [textblock::join $lhs $rhs] - - #rendered - append rendered $overflow_right - # + puts --->nl_below + set temp_row $post_render_row + set temp_col $post_render_col + if {$insert_lines_below == 1} { + #set lhs [overtype::left -width 40 -wrap 1 "" [ansistring VIEWSTYLE -lf 1 -vt 1 $rendered]] + #set lhs [textblock::frame -title rendered -subtitle "row-$renderedrow" $lhs] + #set rhs "" + #if {$overflow_right ne ""} { + # set rhs [overtype::left -width 40 -wrap 1 "" [ansistring VIEWSTYLE -lf 1 -vt 1 $overflow_right]] + # set rhs [textblock::frame -title overflow_right $rhs] + #} + #puts [textblock::join $lhs $rhs] + #rendered + append rendered $overflow_right + # - set overflow_right "" - set row $renderedrow - #only add newline if we're at the bottom - if {$row > [llength $outputlines]} { - set bce_line \x1b\[0m$replay_codes_overlay[string repeat \u0000 $renderwidth] - lappend outputlines {*}[lrepeat $insert_lines_below $bce_line] - #lappend outputlines {*}[lrepeat $insert_lines_below ""] - } - incr row $insert_lines_below - set col $opt_startcolumn - } - } else { - set row $post_render_row - if {$post_render_row > [llength $outputlines]} { - if {$opt_appendlines} { - set diff [expr {$post_render_row - [llength $outputlines]}] - set bce_line \x1b\[0m$replay_codes_overlay[string repeat \u0000 $renderwidth] - - if {$diff > 0} { - lappend outputlines {*}[lrepeat $diff $bce_line] - #lappend outputlines {*}[lrepeat $diff ""] - } - lappend outputlines $bce_line - #lappend outputlines "" - } - } else { - set existingdata [lindex $outputlines [expr {$post_render_row -1}]] - set lastdatacol [punk::ansi::printing_length $existingdata] - if {$lastdatacol < $renderwidth} { - set col [expr {$lastdatacol+1}] - } else { - set col $renderwidth - } + set overflow_right "" + set temp_row $renderedrow + #only add newline if we're at the bottom + if {$temp_row > [llength $outputlines]} { + set bce_line \x1b\[0m$replay_codes_overlay[string repeat \u0000 $renderwidth] + lappend outputlines {*}[lrepeat $insert_lines_below $bce_line] + #lappend outputlines {*}[lrepeat $insert_lines_below ""] } + incr temp_row $insert_lines_below + set temp_col $opt_startcolumn } + dict set vtstate row $temp_row + dict set vtstate col $temp_col } wrapmoveforward { #doesn't seem to be used by fruit.ans testfile @@ -1305,8 +1226,8 @@ tcl::namespace::eval overtype { set c $post_render_col } #puts stderr "wrapmoveforward - moving from row $row col $col to row $r col $c" - set row $r - set col $c + dict set vtstate row $r + dict set vtstate col $c } wrapmovebackward { set c $renderwidth @@ -1334,8 +1255,8 @@ tcl::namespace::eval overtype { } else { puts stderr "Wrapmovebackward - but postrendercol >= 1???" } - set row $r - set col $c + dict set vtstate row $r + dict set vtstate col $c } overflow { #normal single-width grapheme overflow @@ -1351,13 +1272,13 @@ tcl::namespace::eval overtype { #example trigger: textblock::frame -width 80 [ansicat us-pump_up_the_jam-355.ans 355x100] - set row $post_render_row ;#renderline will not advance row when reporting overflow char + set r $post_render_row ;#renderline will not advance row when reporting overflow char #puts stderr "overflow autowrap - wrap to next line row: $row autowrap: [tcl::dict::get $vtstate autowrap_mode] renderwidth: $renderwidth visualwidth: $visualwidth [ansistring VIEW $unapplied]" if {[tcl::dict::get $vtstate autowrap_mode]} { - incr row - set col $opt_startcolumn ;#whether wrap or not - next data is at column 1 ?? + incr r + set c $opt_startcolumn ;#whether wrap or not - next data is at column 1 ?? } else { - set col $post_render_col + set c $post_render_col #The overflow can only be triggered by a grapheme (todo cluster?) - but our unapplied could contain SGR codes prior to the grapheme that triggered overflow - so we need to skip beyond any SGRs #There may be more than one, because although the stack leading up to overflow may have been merged - codes between the last column and the overflowing grapheme will remain separate #We don't expect any movement or other ANSI codes - as if they came before the grapheme, they would have triggered a different instruction to 'overflow' @@ -1410,9 +1331,12 @@ tcl::namespace::eval overtype { set overflow_handled 1 #handled by dropping overflow if any } + dict set vtstate row $r + dict set vtstate col $c } overflow_splitchar { - set row $post_render_row ;#renderline will not advance row when reporting overflow char + set r $post_render_row ;#renderline will not advance row when reporting overflow char + set c $post_render_col #2nd half of grapheme would overflow - treggering grapheme is returned in unapplied. There may also be overflow_right from earlier inserts #todo - consider various options .. re-render a single trailing space or placeholder on same output line, etc @@ -1434,8 +1358,8 @@ tcl::namespace::eval overtype { #review - inefficient to re-split (return unapplied_tagged instead of unapplied_ansisplit?) set unapplied_ansisplit [punk::ansi::ta::split_codes_single $unapplied] } else { - set col $opt_startcolumn - incr row + set c $opt_startcolumn + incr r } } else { set overflow_handled 1 @@ -1458,13 +1382,14 @@ tcl::namespace::eval overtype { set unapplied_ansisplit [punk::ansi::ta::split_codes_single $unapplied] } } - + dict set vtstate row $r + dict set vtstate col $c } vt { #can vt add a line like a linefeed can? - set row $post_render_row - set col $post_render_col + dict set vtstate row $post_render_row + dict set vtstate col $post_render_col } set_window_title { set newtitle [lindex $instruction 1] @@ -1547,19 +1472,6 @@ tcl::namespace::eval overtype { lappend nextprefix_list {*}[lrange $unapplied_ansisplit 1 end] } - if 0 { - if {$nextprefix ne ""} { - set nextoveridx [expr {$overidx+1}] - if {$nextoveridx >= [llength $inputchunks]} { - lappend inputchunks $nextprefix - } else { - #lset overlines $nextoveridx $nextprefix[lindex $overlines $nextoveridx] - #set inputchunks [linsert $inputchunks $nextoveridx $nextprefix] - ledit inputchunks $nextoveridx -1 $nextprefix - } - } - } - if {[llength $nextprefix_list]} { #set inputchunks [linsert $inputchunks 0 $nextprefix] #JMN - assume backwards compat ledit available from punk::lib (for tcl <9) @@ -1578,7 +1490,6 @@ tcl::namespace::eval overtype { set debugmsg "" append debugmsg "${Y}${sep_header}${RST}" \n append debugmsg "looplimit $looplimit reached\n" - append debugmsg "data_mode:$data_mode\n" append debugmsg "opt_appendlines:$opt_appendlines\n" append debugmsg "prev_row :[tcl::dict::get $renderopts -cursor_row]\n" append debugmsg "prev_col :[tcl::dict::get $renderopts -cursor_column]\n" @@ -2258,7 +2169,6 @@ tcl::namespace::eval overtype { Default is \uFFFD - the unicode replacement char.} -cursor_restore_attributes -default "" -cp437 -default 0 -type boolean - -experimental -default {} -overtext_type -type string -choices {mixed plain ansisplit} -default mixed @values -min 2 -max 2 undertext -type string -help\ @@ -2303,8 +2213,10 @@ tcl::namespace::eval overtype { #At the moment we return a reset at the end of the renderline result instead of the replay codes. proc renderline {args} { - #todo - fix 'unapplied' mechanism.This is particularly inefficient for long lines, or data such as binarytext which is not line-based. - #All unapplied data is re-split/reprocessed repeatedly for each line! This is very wasteful and slow. + #------------------------------------------------------------------------------------------------------------------------------------- + #todo - fix 'unapplied' mechanism.This is particularly inefficient for long lines, or data such as binarytext/xbin which is not line-based. + #All unapplied data is re-split/reprocessed repeatedly for each line! This is very wasteful and very slow. + #------------------------------------------------------------------------------------------------------------------------------------- # ## ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### # renderline written from a left-right line orientation perspective as a first-shot at getting something useful. @@ -2374,7 +2286,6 @@ tcl::namespace::eval overtype { -exposed2 \uFFFD -cursor_restore_attributes "" -cp437 0 - -experimental {} -overtext_type mixed }] #-overtext_type plain|mixed|ansisplit @@ -2390,7 +2301,7 @@ tcl::namespace::eval overtype { set argsflags [lrange $args 0 end-2] tcl::dict::for {k v} $argsflags { switch -- $k { - -experimental - -cp437 - -width - -expand_right - -transparent - -startcolumn - -cursor_column - -cursor_row + -cp437 - -width - -expand_right - -transparent - -startcolumn - -cursor_column - -cursor_row - -crm_mode - -insert_mode - -autowrap_mode - -reverse_mode - -etabs - -info - -exposed1 - -exposed2 - -cursor_restore_attributes - -overtext_type { tcl::dict::set opts $k $v @@ -3863,6 +3774,7 @@ tcl::namespace::eval overtype { } B { #CUD - Cursor Down + #CSI n B #Row move - down lassign [split $param {;}] num modifierkey set replay_codes_overlay [punk::ansi::codetype::sgr_merge [lindex $overlay_grapheme_control_stacks $gci]] @@ -4189,10 +4101,34 @@ tcl::namespace::eval overtype { if {$param eq ""} {set param 0} switch -exact -- $param { 0 { - #clear from cursor to end of screen + #ED 0 - clear from cursor to end of screen (including cursor position) + #Current-line part can be done here; remaining lines are handled by caller. + set replay_codes_overlay [punk::ansi::codetype::sgr_merge [lindex $overlay_grapheme_control_stacks $gci]] + incr idx_over + if {[llength $outcols] && $idx < [llength $outcols]} { + priv::render_erasechar $idx [expr {[llength $outcols] - $idx}] + } + priv::render_to_unapplied $overlay_grapheme_control_list $gci + set instruction clear_to_end_display + break } 1 { - #clear from cursor to beginning of screen + #ED 1 - clear from start of screen to cursor + #Current-line part can be done here; previous lines are handled by caller. + set replay_codes_overlay [punk::ansi::codetype::sgr_merge [lindex $overlay_grapheme_control_stacks $gci]] + incr idx_over + if {[llength $outcols] && $idx >= 0} { + set count [expr {$idx + 1}] + if {$count > [llength $outcols]} { + set count [llength $outcols] + } + if {$count > 0} { + priv::render_erasechar 0 $count + } + } + priv::render_to_unapplied $overlay_grapheme_control_list $gci + set instruction clear_to_start_display + break } 2 { #clear entire screen CSI 2J @@ -4210,7 +4146,8 @@ tcl::namespace::eval overtype { break } 3 { - #clear entire screen. presumably cursor doesn't move - otherwise it would be same as 2J ? + #clear entire screen. As well as scrollback buffer if supported (unimplemented) + puts stderr "overtype::renderline ED 3 - clear entire screen and scrollback buffer if supported (unimplemented) [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" } default { @@ -4271,8 +4208,79 @@ tcl::namespace::eval overtype { } M { #CSI Pn M - DL - Delete Line - puts stderr "overtype::renderline DL - Delete Line - not implemented [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + if {$param eq "" || $param eq "0"} {set param 1}; #param=number of chars to delete + if {![string is integer -strict $param] || $param < 0} { + puts stderr "overtype::renderline DCH bad param '$param' - assuming 1 [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + set param 1 + } + priv::render_to_unapplied $overlay_grapheme_control_list $gci + #The current line will be deleted by the calling function - along with more below if param > 1 + #we clear the outcols so that the result for this line is empty. + ledit outcols 0 end + ledit understacks 0 end + ledit understacks_gx 0 end + #puts stderr "overtype::renderline DL - Delete Line - not implemented [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + #todo - rename insert_lines_below to affect_lines_below or something equally generic (use for multiple instructions) + set instruction [list delete_lines $param] + break + } + P { + #DCH - Delete Character(s) + #Deletes Pn characters from cursor position, shifts line left, + #and fills vacated rightmost cells with erased cells. + if {$param eq "" || $param eq "0"} {set param 1}; #param=number of chars to delete + if {![string is integer -strict $param] || $param < 0} { + puts stderr "overtype::renderline DCH bad param '$param' - assuming 1 [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + set param 1 + } + set orig_len [llength $outcols] + for {set di 0} {$di < $param} {incr di} { + priv::render_delchar $idx + } + #Maintain line width by padding erased cells at right edge. + set removed [expr {$orig_len - [llength $outcols]}] + for {set fi 0} {$fi < $removed} {incr fi} { + lappend outcols \u0000 + lappend understacks [list $replay_codes_overlay] + lappend understacks_gx [list] + #review - should we be appending gx0state here? or just empty list? + #- presumably we should be appending gx0state from the end of the line - which may be different from current gx0state if there are codes in the line that change it - but we don't want to track those changes as we delete chars - so maybe we should be appending the gx0state from the end of the line before deletion started? + #lappend understacks_gx [list $gx0state] + } + #cursor position doesn't change. + } + @ { + #ICH - Insert Character(s) + #Inserts Pn blank characters at the cursor position, shifts line right, + #and fills vacated leftmost cells with erased cells. + #The characters shifted beyond the right margin are lost. + if {$param eq "" || $param eq "0"} {set param 1}; #param=number of chars to insert + if {![string is integer -strict $param] || $param < 1} { + puts stderr "overtype::renderline ICH bad param '$param' - assuming 1 [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + set param 1 + } + set orig_len [llength $outcols] + if {$overflow_idx != -1 && $param > [llength $outcols]} { + #since characters at rhs are lost, we can't insert more than the width. + set param $orig_len + } + set this_sgrstack [lindex $overlay_grapheme_control_stacks $gci] + set this_gxstack [lindex $overstacks_gx $idx_over] + + #use space for inserted blanks; helper handles tab reflow + priv::render_insertgraphemes $idx [lrepeat $param " "] $this_sgrstack $this_gxstack + #Keep line width fixed unless expand-right mode is active. + if {$overflow_idx != -1} { + if {[llength $outcols] > $orig_len} { + #truncate + ledit outcols $orig_len end + ledit understacks $orig_len end + ledit understacks_gx $orig_len end + } + } + + #cursor position doesn't change. } T { #CSI Pn T - SD Pan Up (empty lines introduced at top) @@ -4328,16 +4336,36 @@ tcl::namespace::eval overtype { #This control function sets the top and bottom margins for the current page. You cannot perform scrolling outside the margins lassign [split $param {;}] margin_top margin_bottom - #todo - return these for the caller to process.. - puts stderr "overtype::renderline DECSTBM set top and bottom margin not implemented" - #Also moves the cursor to col 1 line 1 of the page - set cursor_column 1 - set cursor_row 1 + set margins_valid 1 ;#default assumption + #todo - validate margins. A valid scrolling region requires at least two lines. + if {$margin_top eq ""} {set margin_top 1} + if {$margin_bottom eq ""} {set margin_bottom $screen_rows} + if {![string is integer -strict $margin_top] || $margin_top < 1} { + puts stderr "DECSTBM invalid margin_top '$margin_top' [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + set margins_valid 0 + } + if {![string is integer -strict $margin_bottom] || $margin_bottom < 1} { + puts stderr "DECSTBM invalid margin_bottom '$margin_bottom' [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + set margins_valid 0 + } + if {$margin_bottom - $margin_top < 1} { + puts stderr "DECSTBM invalid margins - bottom '$margin_bottom' must be greater than top '$margin_top' [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + set margins_valid 0 + } + if {$margins_valid} { + #todo - return these for the caller to process.. + puts stderr "overtype::renderline DECSTBM set top and bottom margin not implemented" + #Also moves the cursor to col 1 line 1 of the page + set cursor_column 1 + set cursor_row 1 - incr idx_over - priv::render_to_unapplied $overlay_grapheme_control_list $gci - set instruction move ;#own instruction? decstbm? - break + incr idx_over + priv::render_to_unapplied $overlay_grapheme_control_list $gci + set instruction [list decstbm $margin_top $margin_bottom] + break + } else { + puts stderr "overtype::renderline DECSTBM invalid margins - ignoring [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + } } s { #code conflict between ansi emulation and DECSLRM - REVIEW @@ -4833,12 +4861,12 @@ tcl::namespace::eval overtype { } D { #\x84 - #index (IND) + #index (IND) ESC D #vt102-docs: "Moves cursor down one line in same column. If cursor is at bottom margin, screen performs a scroll-up" puts stderr "renderline ESC D not fully implemented" incr cursor_row priv::render_to_unapplied $overlay_grapheme_control_list $gci - set instruction down + set instruction down_scrolling #retain cursor_column break } @@ -4872,7 +4900,7 @@ tcl::namespace::eval overtype { } #ensure rest of *overlay* is emitted to remainder priv::render_to_unapplied $overlay_grapheme_control_list $gci - set instruction up ;#need instruction for scroll-down? + set instruction up ;#need instruction for screen to scroll-down? #retain cursor_column break } @@ -5398,17 +5426,9 @@ tcl::namespace::eval overtype { set in_tab_expansion [dict create idx $i remaining [expr {$this_tab_width -1}]] set this_char \t } elseif {$ch eq "\u0000"} { - if {$cp437_glyphs} { - #map all nulls including at tail to space - set this_char " " - } else { - set this_char " " - #if {$trailing_nulls && $i < $first_tail_null_posn} { - # append outstring " " ;#map inner nulls to space - #} else { - # append outstring \u0000 - #} - } + #map all nulls including at tail to space + set this_char " " + #review } else { set this_char $ch } diff --git a/src/bootsupport/modules/packagetest-0.1.8.tm b/src/bootsupport/modules/packagetest-0.1.8.tm new file mode 100644 index 0000000000000000000000000000000000000000..5ab00010b2b5f414f3b827e86433879339478f1c GIT binary patch literal 12718 zcmch6cRZEh|F>Ns8QG)TNGV&x&WLOxlzp7R;W&pgtdLcdnM%^2B9xJ`A{mvDk+eu9 zGl?iA4LsL34@-83_91Z) zj(|X+iI6uD?TyBx&?s5R67565644|G4c35Ht`sbejKxD>FNP!y5r~j4hNP+riy{*s zF9HQmhWy-Nq2Q4>kifj?L`Ym4M@AFz2r||ejSGM%cz7R)0Fm7hWC-m~CL)kzGzt>; zBA~npC>d`A(i7o^mhnXsNmv3N!Vqwx&t*Kb?_eck|v~1 z_M-l=#3U>RI%tnXkdf}tL8>$H1fmxLhYdtS_E2{t_tTIG+GiA@g;yq8ccIGc_GZXe1d#SR2w=DY~%hs2PmIq49121thc` zAq@>k9xNuJ$rK_UIvBj%+sn7<{MXwwA^Sy#|4m8wL^xnD6iH|=vlxC2f8ZtBkc7@Z z7wA9|K+K9uRyK9v;Dal_#t?{T1gL+1pc!-!Uc6btU+S-pTeMtf1xT1PWIilZ1evcg zSm<9XY+)A;lr(_uIY0TYXd}FIWkXheI-dtC`fP>V5MPE>aPE@;mIIU`Kz?WliNJ#_ zhC2mNmPqg>VgW$o0+uNYdlH94kkHO^!0SvxyLqAU0C4PKfWx~1WW*8te%0CUdI2^4 zm+G982Wk|6D2$;bs^gZ)BO`IDs$?&?O_0bdh+2pt4(aR#i-9DT3to=)@L8}?)Gdpw zpU?#Khh&ac!R((xtVg3{Kqz1~ z1$V-QMzZXTUjA&Rve9hQ+K`@lT_!p@xm^uUfv*K$nbMG3sx2a*eL)=MR`Rf8F>{|XsM9- zopY#36}GYv6al}94CfWJX%Ro$1QaghBJSMkK%>Nd!QW7IcR|a^cVj5*c!X zsjnBzM8G!+jY9;GAi%)=uy_=~j|6$+5M+RXfN}%+iYMS@s67e+OpsbxvwiL`YX=)a z=cRZ7{uBUO6c94!eK|Q009dy<1`9e4cn&HA0pdyaBM?2Qe0MnyT#{^5zkuF=0@N4s zL<5EGmnX>IVO2~{ZZ4JNKzh#=nizz~!UYX}%?bZoVo}oo1)3a|jE1x=4CgazQG)&| z@_AQ7elP%l`vH+m0rw&JHiRdD(0QY%K9QMkm2(00#1s6$ePl`Q!YN9ikRdWLfa*B% z%HDxBqgKxR6=lWfz>DCI_%eU};;GOt@BFKd0ocK}IJ6gR4+->U_-yig=n;?~kpN=s zMnRKE&}IaYjKzTa9t1!U0ryk5Fu|1tM1E23f}9~y(9o`x(`rs_ptv^$umZ7vsQ){r z|Mb9rBH{0j1|Ui#n*Ozq{L&W03<6hKK!33R)CLZm=)&c4xoW>c^2@ki;ad5&xuC$p zH`Qw-GJwM0cTf_ze`;!KE=t{bY=zX}uz*|e?|RULFrdwWOTGi%6{O<4NvbRDUA$>t z5Q&0BqS0W=-~g}*=39%A{CB?nE=TB>c}wrK3+62TUSgUqjO;MrQ@q`X2o#k$f@ud4 z)HN2MAAo<5c5|SQ!Gas%9QeY8{O^O7(~AWa{{Chzri(Ltc^Ki=y{u)!e)!eD!L;Ll zOtU2}m=g#sM3)*4814Vd!{-AJB1a9{Tu%Y5&wkNQ$A3F-3D{8Za~iFn&p#_5`TxEp{9Tp(2| zYAbH0BMaFAzCooiNI>*KJB58ir3GGKR0BT%jwC@cU=j(MA9y#HIDpy!k_}S@611E< z!ezO<@FeD@KfeLypCtwFU%=u&82c}){=)`9<;Ns9NbGms!jsouVt$bY;I}#R7BUum zFC;eTpdbt8>J6q22w#B3)Oq3DsP>P+-vTl%e9zAbynq^@ip2~ufNIT+c;`eep6nus zAU%JHmzj4vwT9q4o%21&R_gc|1-S+Q=7^_&;LneEy{U)`VnwaMU!@3NeQ;nbAp7^? zgSGub(|te=b#M%(%Mf5ofL6ev2dB*!47hs1BmziBEX;>t+WmX1yckFqs*gHN_6CN6 zf}9^S1A?}o>c17710f0E$`!L3w&9<30xy6+)O#ihvR|l?g)78@7SQs9{p*3Sy#FBM z|KD^P_^{tfThC*;1O_1SpC$HBg<(1W9}pcrW@S|W`5{{>!`S^b~6d6{pP9vU1x zKVkWEGClu4432*QAN>D2ziI^JGyve=Lr(zNXJpm2&sk$erOFyam+g3>lE2H%hH_laDbF7=JJF9%) zX`R^vqVFz?%{;4F4Rgm`#uInnoa!#9cpFA5Ph+Tet2~?Y1Oq0p{NQ(u1P)TGu+0=l z2%G-Md0t6I^V|2{j%;a+$^9H7Z+b<#_qDLw{nVRP?cM!7J%~@$x6d6`nMevfrQ+sx zRyoL}(68y?{?tPC3Ayolh8|w2tvkbPy-S+gQz~D+%y&|YQH%{&yD%VMm*KyeNxZs; zmyad%8#XD5_8|>1B{!vhCS+PeC)n@H@qzn0dZn3zFK9JwRCh!Rxx8g0$Lw_CkgeS; zT{5C6{Vej!9<8t+*gGvOBIYh9$J#@U+s?+y1tfnAwKL3CnW&7EQSRGY#>{)1PtxRP z_HJB{U`c%KeWl5dJetvKl-sYE;5+Lk2$kG!{M{J=`!hOu>VFPzof^xYz4(#0JGjwF z{m@6}dnX80=rMm<^*7h#!@3DO1gjt4y|ov~@#W#B(ASQ>w1MH0WR&M!S{a3v1e2^!{i<+Xg}Yp`M3vrvqe3X6G6v z_ieuLll4I$@24NkzFX2(yKbxP$a2WWcW1g-?9g+fC}pw9tlr9Uu`s+$XwfI{# zJ~l>&-ADAZmakAqZ&|L003hd0|z>aveY`zPMt6!fV2crjwH72V^Es4~_QeVS*8 zp?W^%rDqQ9aXTH_(@2XAu_MS2KhF7}cK(x^oa^J99ES>8JF!Kr@L6r*von|Z+4Xa6v$z(8 zsa@O(>pQmHA%Zhy_an=pHb1QXj&m|ik>vyZ>87TfEo;4)rxZu1lB-$y*9qkW$y? zeT(*Fmlge>HJcvmGI`7*lYk%HlS{Wb;Vu zw>X)tHp#?3mQsi^4ydUj+zr(fp2}@}LO!-vc>IpXaQ%~K+WPYLR)e_#MYs4_uITdkf=(XblZc_1(K4^S@i*5BMf$VFUz0$FxM-2vP z-JK#*3UA6ExRSKiEuB&C%*HPt44D%q6t`#@M^n)Hy=w{^WNut{jcwH9^mccmw{}CF ze}mX)!oirJLUPrb@|+qM>3IHqyXBgD_Kd^4Qrt(|!gH^XAKTg2O`+~*#NyE>5Tuj0 zQ2CUiLydlh{BkbgsePsbeU&G;hW6gsDCpSW(z;EUX^at-sKZ$<#47nNif2~M$WJlE z1|jR*l2h*>sMCvMR!Er{n8Kb+=0_Pr4Q7R}LPcpKnrm(-yRfRC`(#}4I-C=|aa9=m z`MuJY)i$?rAAr>h?+jX7ym%zUIbQ0~;BIb5)w^PvDl{Aeey-6Y!|u43d@_Jk1n zBatJbn?-;fI<{xE9$!pz$GMJD924AlItNr@llx|7{#_vXQw7sj>flBdq`ZDI1!Y0NyL!7DI%?)8Vm z&JC7nQcabY4Vt}KRiefrdq#E){|x;-_M(F(q7s1@%nEv*(MVD92TZkxcv;Ii%0i_g zpso_y%`zICq3y$}=_S2ndXLh)yNcG=SfuvVrE->^>J#uX@;}3?ZKuQISw|Xs{c~b? zIw4)6dwQZJfzVlB`h0^FD;+{;tCN8AnRwHgHj_u|t#8mI-8p;aqv$>3TSo>`x#V=1 z!uTHE5O6(}WxIc${B~ETleF}u#6;$(${7qK=6c}OX|a2k!s6Hr59T^O{29NF{P>Mj zBdgL6;~vrv=NR0p*U;7zClx2ZACzmVc83P7=}Wpwhb&Kcwvz968p&E`$DC577b};c zu}YNV#q4rx_tjDI+BLf)+gSPVdXn^Di+131oDE(qq+WcSUrjt)o?XjOu=M-K?hfyc zlZro9pZ!s-VZ;|^wAy}H`*q~B(NoP?O|2-SLIakw2o{#a>htSsrpa3d(q9$2f?n1t z)89ecB0qUIC0Zw$Xa94H;{rbnvj@etowMr3*j?J*ai%!RmZ^6P@hDSoSU>>giiY?J{=v@z(ux4?A((nJfmUEn~aIOqhi@ zuQAJUBr=X0iZ@(*uYCL+Q<$Mmx^N%!?Ix#6*N10EG;-xX=Ut$%|7g(PEVgMR?*X>? zc83^KN^ARWi{p-;%=U&i8tCC2$8uFOHcC7we4^Eumlc;59dTDZkCjJ2!2qjgJ)>NB z>3d~$frjs$qdL}s`kw|TQyiO%L-9Kz4C^f;yFA#M2QF0YC{H0_d*~3zq9Yc{=13>@ zw9Df>bX77YCrK&+3g60&Ayd@h>4q3qT9gxA&-;$hS)rJxtpk}&clgojW@E}~Ojk1m zuViYq*WA_2j#gmiO%%IFso36hU zXYyy8iV6D>UY3l8_7^x8HfhF$M#zTJ*Gg83hZiYI>n$O+S>8)glDCfrC+Dj2W@K?s?dIQmj6+@T1~s*H>(VV z%Vv^S)$=8#3cfRWSbKcAaYg#V4c-&87k)m?F?xhC-9GEIY40={``vMGVD|GYEf-#F zs}y3D)s-lkx8sO|se3XbSJL&Q>>$EL$F_m$VUsY~T z-)1(gcz{9D7RKk9PrCcLKbpKY7%_d^V%yHvufiiDg7;e`w)K!EV(q(Xb}}o09uayEY7d|IYv5<@40!qp4o?Ycp?HxH3L-+iQ3D8@-Qq z)m{ZRq;$*sd=bCcdq&F5XeT|5FP8Pu1;bU1eNJ{4Dz9r)G&Jc|D)>x%e|{~2P|%6r zL@(1&?)AynWmMZ_<6ik|d5y*eFqkd!y6>%s zLKZ$8$$TXcn_3es5gJH|ef$jBC9aZ#G=AsRy`TSGXD70|N4M}k*@&|PZ`aj>+)+Hr z-loQwkC=oMXY%^lue;i?N!j|>#}y&lcgTG4Vh*gJV-w#f85VTM&*8-ei$Ole2*w6a zd$sR8HF8}DIx)lD?@c-GBE~vgc@^+4I9U$mKmwMP@t2-G^x5yCRI{U1*Mx#if>)k^4J*&m4JHvEj*PqVYm{IaHjgM=aFw*3Gy2Y~8u7 zt~^nqyj}B+xWxt*_4soV1Em>O8*D>INZazquL)tgh1Re4nshF8R*zJ=hyMYh^7x zqh{Uk&Bq6ID>nIH?tgra9qRioIv`j!U=?(+^fRG+YTZ{Bq7O)!uHB;&G3EuLsv6aa(Im+U+v8w8yX8QI3BokxN;}wi-F3FS*zRC+*bYH z(`s2>d_zk$h>VBt>6g4ZDYh-&Qz`PpA<;WVc?WKg3cc)tVp}&suIpSL5=JKuM_7n; z6w?$4G@i?@;)o~tOF5%z!f!kJtqs4;?=ES6k1apbcxzs2`s%(L5Rxo$hr8xB)R`L*`q4>qB~l16)~xXf2yr zi0P~JwR_W__a&Q@zspP$>pvi(>$Zw%yL8lDE@m~OS{t17h{aBB%;1*im(ri#*tyPz0)RYf4uQ`!* z-n(k3@jQnx@zHgqr>tKdX7}HW)Ns0Swtu(e*(WUWn-cT;LNB-QD|&KdhE!=>CRO65 z=nuTG5Fw@-i7SqbGGk|h`O+17*PYF6=RUQG!~N?u-XD044HvyQwfYASn@ah%_r6%; zb$1U`Zz1m~UF+iYnp?S9-A{Qass@wl_&A4^=H_S3odddz$Mi>5iJa0uUE~|DaOGH< zU2l7=;59;olX%AGwT@>Mrp6OFENgAlbu89uq{b-(v!1wg`VP%cN-{pp=F@C?|J%C- zV+l>c=?Fr|$BQPP8&73gii%fp;kB@`fjC_e{bp{Oo4f91 z&d6}7wXfYhvc`MQ>o1@AlQkK9QH&O6Y?U$5-)5?W}9=)-1edS$x^%!tPo|;ToDs#G@Csc6)K+ zu0g^==HETiug)awvCy)b=ImJ8+qJ*oOz!UE5%}%2#yi|?dXVMQ468lmT8o@^@=!i} zEGl4kyW~`oo2DYf5uzgS=%7zot@7;At64uZu3Z*ONTjfte^c7>gX_ventU($FPaX= znlqIx9}ExQ+MW@2l*4ef^<)Z* zu8@IX-*xNcWWjCM6+|TJtSV3`_pu!^9jnzx^c^p}qu-aPhLVc3@IT0v=zt&B&tln- zz#KD%vXv6Qc*jOF=OQuZvgWIfNPz&Bz9Uz|f10GQ1*IFb8Tx4s8Ab^vr&qYoWY=li*iY8;E+eE&f0K@D=Sp~I_<;j&?Y z=Z~sODJCA}zApJZUN9)IsMz2O@0;wJ;sIg=CCOV@=gl$bb#mg(3BCS2^t7zOHE}Lx z@szjLA);fZbPUY1#uaigmjd+eALRc%ZyeiFNC(A+0#aGegi!S={~Ekcpn@ zr$07i5%Ua`_RCy7smJJW+~}>I1p|+R$f*sQcGbln^hg(jDYWk{tRHG~*|Nn##W?7*`zt@5aF?PU`h&E7GVg{C!^|4i;| z3ut*QJw6#NmTAHzcg#Da?EAaXqPi0?A8%9`2}p)u>Pijy4@JuD!;O~uwC5O>Y-4)a z*BasXZ8%-~{pGRIsCByzRjcl36R%#oVeNZKQI1N(eih~yd_Ii&kDn5bZ1Vg_n`I!my>AwmU_)1hDx7VYU|}tdio<@YITEW zQKPB*qhyb4m)){0#a8Y19>4n^%x{-}dQu@(VE9$Nf%c$+MI)ndjq>|Dx9)po|LRN!X=`TkCy&!J@!9NZ>&|}l z?!g!Tu=4FW+r{@|#~WJ~_qM&7sXN)YLZmw$&6* zwz*qNC!wszhc&qCj=Eo>8DVnl;`q!C0P{wl{`MEXZ}RTAq^xUB8GE-j+~VRMyTjc9 z=B1W=w_CZAWLNKv-y7h=U2!g=e)tkiyTzWvQKo{0H0@6sYI20Qc=Zp~__lp!y>j$| zaIhM|`hAsSG5-2fxfY$$fU(nM6T<$Gu+LY$;og$ISw;(ETDtW#e;=8HsrjPM|89V8 UVa&(`Z>9zR9Kg2%FZ}EO06j*}rvLx| literal 0 HcmV?d00001 diff --git a/src/bootsupport/modules/punk-0.1.1.tm b/src/bootsupport/modules/punk-0.1.1.tm new file mode 100644 index 00000000..e3ba36b4 --- /dev/null +++ b/src/bootsupport/modules/punk-0.1.1.tm @@ -0,0 +1,9302 @@ +#Punk - where radical modification is a craft and anti-patterns are another exploratory tool for the Pattern Punk. +#Built on Tcl of course - because it's the most powerful piece of under-appreciated and alternate-thinking engineering you can plug into. + + +namespace eval punk { + proc lazyload {pkg} { + #experimental - for binary packages that have significant load time. + package require zzzload + if {[package provide $pkg] eq ""} { + zzzload::pkg_require $pkg + } + } + #lazyload twapi ? + + catch {package require vfs} ;#attempt load now so we can use faster 'package provide' to test existence later + + variable can_exec_windowsapp + set can_exec_windowsapp unknown ;#don't spend a potential X00ms testing until needed + variable windowsappdir + set windowsappdir "" + variable cmdexedir + set cmdexedir "" + + proc sync_package_paths_script {} { + #the tcl::tm namespace doesn't exist until one of the tcl::tm commands + #is run. (they are loaded via ::auto_index triggering load of tm.tcl) + #we call tcl::tm::list to trigger the initial set of tm paths before + #we can override it, otherwise our changes will be lost + #REVIEW - won't work on safebase interp where paths are mapped to {$p(:x:)} etc + list apply {{ap tmlist} { + set ::auto_path $ap + tcl::tm::list + set ::tcl::tm::paths $tmlist + }} $::auto_path [tcl::tm::list] + } + + + + proc ::punk::auto_execok_original name [info body ::auto_execok] + variable better_autoexec + + + #use this var via better_autoexec only + set better_autoexec 1 + proc ::punk::auto_execok_windows name { + ::punk::auto_execok_better $name + } + + set has_commandstack [expr {![catch {package require commandstack}]}] + if {$has_commandstack} { + if {[catch { + package require punk::packagepreference + } errM]} { + catch {puts stderr "Failed to load punk::packagepreference"} + } + catch punk::packagepreference::install + } else { + # + } + + if {![interp issafe] && $::tcl_platform(platform) eq "windows"} { + + #return the raw command string from the registry for the association of the given extension, without processing the placeholders such as %1 %SystemRoot% etc. + #This is because we want to process these ourselves to be able to return a proper list of command and arguments. + #Note that the resulting string can't be directly treated as a tcl list because it has double quoted segments with characters that are literals (not escaped) + #Accessing it directly as a list will cause tcl to interpret the backslashes as escapes and lose the literal meaning values such as the path. + proc extension_open_association {ext} { + #look up assoc and ftype to find associated file type and application. + #Note that the windows 'ftype' and 'assoc' commands only examine the system's data - not the user-specific data which may override the system data. + #to get the user-specific associations we need to read the registry keys. + + #extensions in the registry seem to be stored lower case wnd with a leading dot. + set lext [string tolower $ext] + package require registry + set user_assoc_path [join [list HKEY_CURRENT_USER Software Microsoft Windows CurrentVersion Explorer FileExts $lext UserChoice] "\\"] + + #The UserChoice subkey under this key is where the user-specific association is stored when the user has made a choice. It contains a Progid value which points to the associated file type. + #It can return something like "Python.File" or "Applications\python.exe" or even tcl_auto_file (for .tcl files associated with tclsh by a tcl installer) + + #The UserChoice key may not exist if the user hasn't made an explicit choice, in which case we fall back to the system association which is stored under HKEY_CLASSES_ROOT\$ext (which also contains user-specific overrides but is more cumbersome to query for them) + if {![catch {registry get $user_assoc_path Progid} user_choice]} { + if {$user_choice ne ""} { + #examples such as Applications\python.exe and tcl_auto_file are found under HKEY_CURRENT_USER\Software\Classes + #they then have a sub-path shell\open\command which contains the command to open files of that type, which is what we need to extract the associated application. + #it is faster to query for the key directly within a catch than to retrieve keys as lists and iterate through them to find the one we want. + if {![catch {registry get [join [list HKEY_CURRENT_USER Software Classes $user_choice shell open command] "\\"] ""} raw_assoc]} { + #The command string can contain placeholders like "%1" for the file name, so we need to extract just the executable path. + #e.g .py -> "c:\Program Files\Python\python.exe" "%1" + #e.g .rb -> "C:\tools\ruby31\bin\ruby.exe" "%1" %* + # e.g .vbs -> "%SystemRoot%\System32\WScript.exe" "%1" %* + #we need to process this without Tcl interpreting the backslashes as escapes. + #we will use double quotes to determine which entries belong together as a list item for the resulting list of command and arguments. + #set assoc [string map [list \\ \\\\] $raw_assoc] + set assoc $raw_assoc + } else { + #e.g Python.File + if {![catch {registry get [join [list HKEY_LOCAL_MACHINE SOFTWARE Classes $user_choice shell open command] "\\"] ""} raw_assoc]} { + #set assoc [string map [list \\ \\\\] $raw_assoc] + set assoc $raw_assoc + } else { + set assoc "" + } + } + + } else { + #review - is it possible for Progid to be empty string? If so we should probably fall back to system association instead of returning no association. + #alternatively it could mean the user has explicitly chosen to have no association for this file type - in which case returning an empty association may be the correct behaviour. + set assoc "" + } + } else { + #fall back to system association and ftype + if {![catch {registry get [join [list HKEY_LOCAL_MACHINE SOFTWARE Classes $lext] "\\"] ""} ftype]} { + #ftype is the file type associated with the extension, e.g "Python.File" + #we then need to look up the command associated with this file type under the same path but with the file type instead of the extension and with the additional sub-path shell\open\command + if {![catch {registry get [join [list HKEY_LOCAL_MACHINE SOFTWARE Classes $ftype shell open command] "\\"] ""} raw_assoc]} { + #set assoc [string map [list \\ \\\\] $raw_assoc] + set assoc $raw_assoc + } else { + set assoc "" + } + } else { + set assoc "" + } + } + return $assoc + } + + + } + + if {![interp issafe] && $has_commandstack && $::tcl_platform(platform) eq "windows"} { + + #still a caching version of auto_execok - but with proper(fixed) search order + + #set b [info body ::auto_execok] + #proc ::auto_execok_original name $b + + proc better_autoexec {{onoff ""}} { + variable better_autoexec + if {$onoff eq ""} { + return $better_autoexec + } + if {![string is boolean -strict $onoff]} { + error "better_autoexec argument 'onoff' must be a boolean, received: $onoff" + } + if {$onoff && ($onoff != $better_autoexec)} { + puts "Turning on better_autoexec - search PATH first then extension" + set better_autoexec 1 + proc ::punk::auto_execok_windows name { + ::punk::auto_execok_better $name + } + punk::auto_exec::rehash + } elseif {!$onoff && ($onoff != $better_autoexec)} { + puts "Turning off better_autoexec - search extension then PATH" + set better_autoexec 0 + proc ::punk::auto_execok_windows name { + ::punk::auto_execok_original $name + } + punk::auto_exec::rehash + } else { + puts "no change" + } + } + #better_autoexec $better_autoexec ;#init to default + + + proc auto_execok_better name { + #review - we have a gneral problem of auto_exec caching negative results for relative paths. + #A failed resolution of a relative path should not generate an entry in ::auto_execs. + #This happens in plain tclsh - so we need to determine where in Tcl this happens and fix it there. + #Simply returning an empty string here will still result in a negative cache entry. + #we want to cache negative results for absolute paths or plain filenames with no file-separator. + #e.g ./doesntexist.exe should not be cached as not found, but should be re-resolved every time. (cwd dependent) + #e.g doesntexist.exe should be cached as not found, because it will always be not found until it appears in the PATH. + #i.e it is required to prefix with ./ to exec a file in the current directory. (similar to unix shells) + + + global auto_execs env tcl_platform + #for now at least, auto_execok_better is windows-specific. + package require punk::auto_exec + + if {[info exists auto_execs($name)]} { + return $auto_execs($name) + } + #puts stdout "[a+ red]...[a]" + set auto_execs($name) "" + + set shellBuiltins [list {*}{ + assoc cls copy date del dir echo erase exit ftype + md mkdir mklink move rd ren rename rmdir start time type ver vol + }] + if {[info exists env(PATHEXT)]} { + # Add an initial ; to have the {} extension check first. + set execExtensions [split ";$env(PATHEXT)" ";"] + } else { + set execExtensions [list {} .com .exe .bat .cmd] + } + + if {[string tolower $name] in $shellBuiltins} { + # When this is command.com for some reason on Win2K, Tcl won't + # exec it unless the case is right, which this corrects. COMSPEC + # may not point to a real file, so do the check. + set cmd $env(COMSPEC) + if {[file exists $cmd]} { + set cmd [file attributes $cmd -shortname] + } + return [set auto_execs($name) [list $cmd /c $name]] + } + + if {[llength [file split $name]] != 1} { + #----------------------------------------------------- + #has a path component - could be relative or absolute. + #----------------------------------------------------- + if {[file pathtype $name] eq "relative"} { + #don't cache negative result for any relative paths - as they may become valid if the file appears in the relative location, or if the user changes directory and the same relative path points to a different file. + #our only way to do this is by cooperating with the unknown handler. + set auto_execs($name) "for_unknown_handler by punk::auto_exec relative_path - file existence should be re-checked at call time" + return $auto_execs($name) + } + + if {[string tolower [file extension $name]] eq ".lnk"} { + #special case .lnk + #todo - consider working directory or other properties of link before launching? + package require punk::winlnk + if {![catch {punk::winlnk::target $name} linktarget]} { + if {$linktarget ne ""} { + set target $linktarget + } else { + return "" + } + } else { + set target $name + } + } else { + set target $name + } + #always store $name as the key when setting auto_execs. + foreach ext $execExtensions { + set file ${target}${ext} + #first execExtension is empty string - ensure we test actual file as given before we try appending extensions. + if {$ext eq ""} { + set test_ext [file extension $file] + } else { + set test_ext $ext + } + if {[file exists $file] && ![file isdirectory $file]} { + #look up assoc and ftype to find associated file type and application. + #Note that the windows 'ftype' and 'assoc' commands only examine the system's data - not the user-specific data which may override the system data. + #set assoc [extension_open_association $ext] + set associnfo [punk::auto_exec::shell_open_command $test_ext] + set valuetype [dict get $associnfo type] + set assoc [dict get $associnfo value] + set windows_file_type [dict get $associnfo filetype] + if {$assoc eq ""} { + return [set auto_execs($name) [list $file]] + } else { + if {[file pathtype $target] eq "relative" && $windows_file_type eq "InternetShortcut"} { + #special case InternetShortcut - cannot accept relative path - so we can't cache it in auto_execs if we used a relative path to launch + #if we return an empty string - the auto_exec will fail to launch this every time. + #The best we can do is return a token for the 'unknown' process to detect and re-resolve the path every time. + #This requires cooperation from 'unknown' which may not be configured to handle this token if the default 'punk' version isn't installed. + + #we can't resolve using absolute path here - because we don't want to lock in a specific file for a relative path. + #e.g ::auto_execs(./link.url) = some.exe c:/desktop/link.url + #this would be wrong if the user changed directory and tried to run ./link.url again on a different file with the same name + # - as the cached path would no longer be correct. + return [set auto_execs($name) "for_unknown_handler by punk::auto_exec absolute_path required"] + } + puts stderr "auto_execok_better: (review required) assoc $assoc for file $file ext $test_ext" + set run [punk::auto_exec::shell_command_as_tcl_list -type $valuetype $assoc $file] ;# -workingdir [pwd] vs path of script? + return [set auto_execs($name) $run] + #return [set auto_execs($name) [list $file]] + } + } + } + #cache negative result for absolute paths - as they will always point to the same location, so if they don't exist now, they won't exist later. + set auto_execs($name) "" + return "" + } + + #change1 + #set path "[file dirname [info nameofexecutable]];.;" + set path "[file dirname [info nameofexecutable]];" + + + # ------------------------ + #Note that unlike an ordinary Tcl array - the linked ::env behaves differently. + #e.g parray ::env Path will not find ::env(PATH) and yet 'info exists env(Path)' returns true. + #similarly 'set ::env(Path) ?newval?' or any case variation can set/get the value of ::env(PATH) + #Windows environment variables are case-insensitive. + + #No evidence has been seen that any version of windows; current or historic since NT; can allow differently cased versions + # of an environment variable to exist concurrently in the same environment. + #for this reason we should be able to just use PATH. + # + if {[info exists env(PATH)]} { + append path ";$env(PATH)" + } + # ------------------------ + + if {[info exists env(SystemRoot)]} { + set windir $env(SystemRoot) + } elseif {[info exists env(WINDIR)]} { + set windir $env(WINDIR) + } + if {[info exists windir]} { + append path "$windir/system32;$windir/system;$windir;" + } + + #change2 + if {[file extension $name] ne "" && [string tolower [file extension $name]] in [string tolower $execExtensions]} { + set lookfor [list $name] + } else { + set lookfor [lmap ext $execExtensions {string cat ${name} ${ext}}] + } + #puts "-->$lookfor" + + + foreach dir [split $path {;}] { + set dir [string trim $dir {\\}] ;#trailing slash will result in a tail such as "/python.exe" + #set dir [file normalize $dir] + # Skip already checked directories + if {[info exists checked($dir)] || ($dir eq "")} { + continue + } + set checked($dir) {} + + #surprisingly fast + #set matches [glob -nocomplain -dir $dir -types f -tails {*}$lookfor] + ##puts "--dir $dir matches:$matches" + #if {[llength $matches]} { + # set file [file join $dir [lindex $matches 0]] + # #puts "--match0:[lindex $matches 0] file:$file" + # return [set auto_execs($name) [list $file]] + #} + + #what if it's a link? + #foreach match [glob -nocomplain -dir $dir -types f -tail {*}$lookfor] { + # set file [file join $dir $match] + # if {[file exists $file]} { + # return [set auto_execs($name) [list $file]] + # } + #} + + #safest? could be a link? + foreach match [glob -nocomplain -dir $dir -tail -- {*}$lookfor] { + set file [file join $dir $match] + if {[file exists $file] && ![file isdirectory $file]} { + #set assoc [extension_open_association [file extension $file]] + #todo - cache this lookup for each extension we encounter? maybe not, as the user might like changes reflected between runs. review. + if {"windows" ne $::tcl_platform(platform)} { + return [set auto_execs($name) [list $file]] + } + + set associnfo [punk::auto_exec::shell_open_command [file extension $file]] + set assoc [dict get $associnfo value] + set type [dict get $associnfo type] + if {$assoc eq ""} { + return [set auto_execs($name) [list $file]] + } else { + puts stderr "auto_execok_better: assoc $assoc for file $file with type $type" + #return [set auto_execs($name) [list $file]] + #review - our stored auto_execs doesn't have any way to capture the full assoc info such as how subsequent arguments should be processed. + #This may need handling in our Tcl shell 'unknown' function when calls are actually made to these commands + #- we may need to re-process the assoc info at that point to determine how to combine all arguments with the calling specification in the assoc string. + #The workingdir for the command may also need to be determined at that point - should it be the dir of the script being called, or the current dir of the shell? + + #The main point of Tcl's auto_execs is to avoid scanning the PATH entries every time a command is called, + #but we may want to keep some of the assoc info available for processing at call time. + set run [punk::auto_exec::shell_command_as_tcl_list -type $type $assoc $file] ;# -workingdir [pwd] vs path of script? + return [set auto_execs($name) $run] + } + } + } + } + + #foreach ext $execExtensions { + #unset -nocomplain checked + #foreach dir [split $path {;}] { + # # Skip already checked directories + # if {[info exists checked($dir)] || ($dir eq "")} { + # continue + # } + # set checked($dir) {} + # set file [file join $dir ${name}${ext}] + # if {[file exists $file] && ![file isdirectory $file]} { + # return [set auto_execs($name) [list $file]] + # } + #} + #} + return "" + } + + + + #review - what if punk package reloaded - but ::auto_execs has updated path for winget.exe? + #what if we create another interp and use the same ::auto_execs? The appdir won't be detected. + #TODO - see if there is a proper windows way to determine where the 'reparse point' apps are installed + + + + #winget is installed on all modern windows (but not on windows sandbox!) and is an example of the problem this addresses + #we target apps with same location + + #the main purpose of this override is to support windows app executables (installed as 'reparse points') + #for Tcl versions prior to the 2025-01 fix by APN https://core.tcl-lang.org/tcl/tktview/4f0b5767ac + #versions prior to this will use cmd.exe to resolve the links + set stackrecord [commandstack::rename_command -renamer ::punk auto_execok name { + #set windowsappdir "%appdir%" + upvar ::punk::can_exec_windowsapp can_exec_windowsapp + upvar ::punk::windowsappdir windowsappdir + upvar ::punk::cmdexedir cmdexedir + + if {$windowsappdir eq ""} { + #we are targeting the winget location under the presumption this is where microsoft store apps are stored as 'reparse points' + #Tcl (2025) can't exec when given a path to these 0KB files + #This path is probably something like C:/Users/username/AppData/Local/Microsoft/WindowsApps + if {!([info exists ::env(LOCALAPPDATA)] && + [file exists [set testapp [file join $::env(LOCALAPPDATA) "Microsoft" "WindowsApps" "winget.exe"]]])} { + #should be unlikely to get here - unless LOCALAPPDATA missing (or winget.exe missing e.g windows sandbox) + set windowsappdir [file dirname [lindex [::punk::auto_execok_windows winget.exe] 0]] + catch {puts stderr "(resolved winget by search)"} + } else { + set windowsappdir [file dirname $testapp] + } + } + + #set default_auto [$COMMANDSTACKNEXT $name] + set default_auto [::punk::auto_execok_windows $name] + #if {$name ni {cmd cmd.exe}} { + # unset -nocomplain ::auto_execs + #} + + if {$default_auto eq ""} { + return + } + set namedir [file dirname [lindex $default_auto 0]] + + if {$namedir eq $windowsappdir} { + if {$can_exec_windowsapp eq "unknown"} { + if {[catch {exec [file join $windowsappdir winget.exe] --version}]} { + set can_exec_windowsapp 0 + } else { + set can_exec_windowsapp 1 + } + } + if {$can_exec_windowsapp} { + return [file join $windowsappdir $name] + } + if {$cmdexedir eq ""} { + #cmd.exe very unlikely to move + set cmdexedir [file dirname [lindex [::punk::auto_execok_windows cmd.exe] 0]] + #auto_reset never seems to exist as a command - because auto_reset deletes all commands in the ::auto_index + #anyway.. it has other side effects (affects auto_load) + } + return "[file join $cmdexedir cmd.exe] /c $name" + } + return $default_auto + }] + + + } + +} + + + +#repltelemetry cooperation with other packages such as shellrun +#Maintenance warning: shellrun expects repltelemetry_emmitters to exist if punk namespace exists +namespace eval punk { + variable repltelemetry_emmitters + #don't stomp.. even if something created this namespace in advance and is 'cooperating' a bit early + if {![info exists repltelemetry_emitters]} { + set repltelemetry_emmitters [list] + } +} + +namespace eval punk::pipecmds { + #where to install proc/compilation artifacts for pieplines + namespace export * +} +namespace eval punk::pipecmds::split_patterns {} +namespace eval punk::pipecmds::split_rhs {} +namespace eval punk::pipecmds::var_classify {} +namespace eval punk::pipecmds::destructure {} +namespace eval punk::pipecmds::insertion {} + + +#globals... some minimal global var pollution +#punk's official silly test dictionary +set punk_testd [dict create \ + a0 a0val \ + b0 [dict create \ + a1 b0a1val \ + b1 b0b1val \ + c1 b0c1val \ + d1 b0d1val \ + ] \ + c0 [dict create] \ + d0 [dict create \ + a1 [dict create \ + a2 d0a1a2val \ + b2 d0a1b2val \ + c2 d0a1c2val \ + ] \ + b1 [dict create \ + a2 [dict create \ + a3 d0b1a2a3val \ + b3 d0b1a2b3val \ + ] \ + b2 [dict create \ + a3 d0b1b2a3val \ + bananas "in pyjamas" \ + c3 [dict create \ + po "in { }" \ + b4 ""\ + c4 "can go boom" \ + ] \ + d3 [dict create \ + a4 "-paper -cuts" \ + ] \ + e3 [dict create] \ + ] \ + ] \ + ] \ + e0 "multi\nline"\ + ] +#test dict 2 - uniform structure and some keys with common prefixes for glob matching +set punk_testd2 [dict create {*}{ + } a0 [dict create {*}{ + b1 {a b c} + b2 {a b c d} + x1 {x y z 1 2} + y2 {X Y Z 1 2} + z1 {k1 v1 k2 v2 k3 v3} + }] {*}{ + } a1 [dict create {*}{ + b1 {a b c} + b2 {a b c d} + x1 {x y z 1 2} + y2 {X Y Z 1 2} + z1 {k1 v1 k2 v2 k3 v3} + }] {*}{ + } b1 [dict create {*}{ + b1 {a b c} + b2 {a b c d} + x1 {x y z 1 2} + y2 {X Y Z 1 2} + z1 {k1 v1 k2 v2 k3 v3} + }] {*}{ + } +] + +#impolitely cooperative with punk repl - todo - tone it down. +#namespace eval ::punk::repl::codethread { +# variable running 0 +#} +package require punk::lib ;# subdependency punk::args +package require punk::ansi +if {![llength [info commands ::ansistring]]} { + namespace import punk::ansi::ansistring +} +#require aliascore after punk::lib & punk::ansi are loaded +#package require punk::aliascore ;#mostly punk::lib aliases +#punk::aliascore::init -force 1 + +package require punk::repl::codethread +package require punk::config +#package require textblock +catch {package require punk::console} ;#requires Thread - will not work in safe interps. +package require punk::ns +package require punk::winpath ;# for windows paths - but has functions that can be called on unix systems +package require punk::repo +package require punk::du +package require punk::mix::base +package require base64 + +package require punk::pipe + +namespace eval punk { + # -- --- --- + #namespace import ::control::assert ;#according to tcllib doc - assert can be enabled/disabled per namespace + # using control::control assert enabled within a namespace for which ::control::assert wasn't imported can produce surprising results. + #e.g setting to zero may keep asserts enabled - (e.g if the assert command is still available due to namespace path etc) - but.. querying the enabled status may show zero even in the parent namespace where asserts also still work. + #package require control + #control::control assert enabled 1 + + #We will use punk::assertion instead + + package require punk::assertion + if {[catch {namespace import ::punk::assertion::assert} errM]} { + catch { + puts stderr "punk error importing punk::assertion::assert\n$errM" + puts stderr "punk::a* commands:[info commands ::punk::a*]" + } + } + punk::assertion::active on + # -- --- --- + + interp alias {} purelist {} lreplace x 0 0 ;#required by pipe system + if {[catch { + package require pattern + } errpkg]} { + catch {puts stderr "Failed to load package pattern error: $errpkg"} + } + package require shellfilter + package require punkapp + + package require struct::list + package require fileutil + #package require punk::lib + + #NOTE - always call debug.xxx with braced message instead of double-quoted (unless specifically intending to do double-subtition) + #(or $ within values will be substituted, causing an extra error message if the var doesn't exist - which it quite possibly doesn't) + package require debug + + debug define punk.unknown + debug define punk.pipe + debug define punk.pipe.var + debug define punk.pipe.args + debug define punk.pipe.rep ;#string/list representation with tcl::unsupported::representation + debug define punk.pipe.compile ;#info about when we compile pipeline components into procs etc + + + #----------------------------------- + # todo - load initial debug state from config + debug off punk.unknown + debug level punk.unknown 1 + debug off punk.pipe + debug level punk.pipe 4 + debug off punk.pipe.var + debug level punk.pipe.var 4 + debug off punk.pipe.args + debug level punk.pipe.args 3 + debug off punk.pipe.rep 2 + debug off punk.pipe.compile + debug level punk.pipe.compile 2 + + + debug header "dbg> " + + + variable last_run_display [list] + + + #variable re_headvar1 {([a-zA-Z:@.(),]+?)(?![^(]*\))(,.*)*$} + + + + #----------------------------------------------------------------------------------- + #strlen is important for testing issues with string representationa and shimmering. + #This specific implementation with append (as at 2023-09) is designed to ensure the original str representation isn't changed + #It may need to be reviewed with different Tcl versions in case the append empty string is 'optimised/tuned' in some way that affects the behaviour + proc strlen {str} { + append str2 $str {} + string length $str2 + } + #----------------------------------------------------------------------------------- + + #get a copy of the item without affecting internal rep + proc valcopy {obj} { + append obj2 $obj {} + } + + + proc set_valcopy {varname obj} { + #maintenance: also punk::lib::set_valcopy + #e.g used by repl's codeinterp. Maintains internal rep, easier to call e.g interp eval code [list punk::set_valcopy varnmame $val] + append obj2 $obj {} + uplevel 1 [list set $varname $obj2] + } + + interp alias "" strlen "" ::punk::strlen + interp alias "" str_len "" ::punk::strlen + interp alias "" valcopy "" ::punk::valcopy + #proc ::strlen {str} { + # string length [append str2 $str {}] + #} + #proc ::valcopy {obj} { + # append obj2 $obj {} + #} + + #----------------------------------------------------------------------------------- + #order of arguments designed for pipelining + #review - 'piper_' prefix is a naming convention for functions that are ordered for tail-argument pipelining + #piper_ function names should read intuitively when used in a pipeline with tail argument supplied by the pipeline - but may seem reversed when using standalone. + proc piper_append {new base} { + append base $new + } + interp alias "" piper_append "" ::punk::piper_append + proc piper_prepend {new base} { + append new $base + } + interp alias "" piper_prepend "" ::punk::piper_prepend + + proc ::punk::K {x y} { return $x} + + #---------------------- + #todo - fix overtype + #create test + #overtype::renderline -insert_mode 0 -transparent 1 [a+ green]-----[a] " [a+ underline]x[a]" + #---------------------- + + + proc stacktrace {} { + set stack "Stack trace:\n" + for {set i 1} {$i < [info level]} {incr i} { + set lvl [info level -$i] + set pname [lindex $lvl 0] + append stack [string repeat " " $i]$pname + + if {![catch {info args $pname} pargs]} { + foreach value [lrange $lvl 1 end] arg $pargs { + + if {$value eq ""} { + if {$arg != 0} { + info default $pname $arg value + } + } + append stack " $arg='$value'" + } + } else { + append stack " !unknown vars for $pname" + } + + append stack \n + } + return $stack + } + + namespace eval argdoc { + punk::args::define { + @id -id ::punk::get_runchunk + @cmd -name "punk::get_runchunk" -help\ + "experimental" + @opts + -1 -optional 1 -type none + -2 -optional 1 -type none + @values -min 0 -max 0 + } + } + #get last command result that was run through the repl + proc ::punk::get_runchunk {args} { + #set argd [punk::args::parse $args withdef { + # @id -id ::punk::get_runchunk + # @cmd -name "punk::get_runchunk" -help\ + # "experimental" + # @opts + # -1 -optional 1 -type none + # -2 -optional 1 -type none + # @values -min 0 -max 0 + #}] + #todo - make this command run without truncating previous runchunks + set runchunks [tsv::array names repl runchunks-*] + + set sortlist [list] + foreach cname $runchunks { + set num [lindex [split $cname -] 1] + lappend sortlist [list $num $cname] + } + set sorted [lsort -index 0 -integer $sortlist] + set chunkname [lindex $sorted end-1 1] + set runlist [tsv::get repl $chunkname] + #puts stderr "--$runlist" + if {![llength $runlist]} { + return "" + } else { + return [lindex [lsearch -inline -index 0 $runlist result] 1] + } + } + interp alias {} _ {} ::punk::get_runchunk + + + proc ::punk::var {varname {= _=.=_} args} { + upvar $varname the_var + switch -exact -- ${=} { + = { + if {[llength $args] > 1} { + set the_var $args + } else { + set the_var [lindex $args 0] + } + } + .= { + if {[llength $args] > 1} { + set the_var [uplevel 1 $args] + } else { + set the_var [uplevel 1 [lindex $args 0]] + } + } + _=.=_ { + set the_var + } + default { + set the_var [list ${=} {*}$args] + } + } + } + proc src {args} { + #based on wiki.. https://wiki.tcl-lang.org/page/source+with+args + #added support for ?-encoding name? and other options of Tcl source command under assumption they come pairs before the filename + # review? seems unlikely source command will ever accept solo options. It would make complete disambiguation impossible when passing additional args as we are doing here. + set cmdargs [list] + set scriptargs [list] + set inopts 0 + set i 0 + foreach a $args { + if {$i eq [llength $args]-1} { + #reached end without finding end of opts + #must be file - even if it does match -* ? + break + } + if {!$inopts} { + if {[string match -* $a]} { + set inopts 1 + } else { + #leave loop at first nonoption - i should be index of file + break + } + } else { + #leave for next iteration to check + set inopts 0 + } + incr i + } + set cmdargs [lrange $args 0 $i] + set scriptargs [lrange $args $i+1 end] + set argv $::argv + set argc $::argc + set ::argv $scriptargs + set ::argc [llength $scriptargs] + set code [catch {uplevel [list source {*}$cmdargs]} return] + set ::argv $argv + set ::argc $argc + return -code $code $return + } + + + + + proc varinfo {vname {flag ""}} { + upvar $vname v + if {[array exists $vname]} { + error "can't read \"$vname\": variable is array" + } + if {[catch {set v} err]} { + error "can't read \"$vname\": no such variable" + } + set inf [shellfilter::list_element_info [list $v]] + set inf [dict get $inf 0] + if {$flag eq "-v"} { + return $inf + } + + set output [dict create] + dict set output wouldbrace [dict get $inf wouldbrace] + dict set output wouldescape [dict get $inf wouldescape] + dict set output head_tail_names [dict get $inf head_tail_names] + dict set output len [dict get $inf len] + return $output + } + + #review - extending core commands could be a bit intrusive...although it can make sense in a pipeline. + #e.g contrived pipeline example to only allow setting existing keys + ## .= @head.= list {a aaa b bbb c ccc} |d,dkeys@keys> |> &true.= {is_list_all_in_list $nkeys $dkeys} |> {dict modify d {*}$new} |> &true.= {is_list_all_ni_list $nkeys $dkeys} |> {dict modify d {*}$new} -1} { + #lassign [punk::lib::string_splitbefore $token $first_term] v k + set v [string range $token 0 $first_term-1] + set k [string range $token $first_term end] ;#key section includes the terminal char + lappend varlist [list $v $k] + } else { + lappend varlist [list $token ""] + } + set token "" + set token_index -1 ;#reduce by 1 because , not included in next token + set first_term -1 + } else { + if {$first_term == -1} { + if {$c in $var_terminals} { + set first_term $token_index + } + } + append token $c + if {$c eq "("} { + set in_brackets 1 + } + } + } + incr token_index + } + if {[string length $token]} { + if {$first_term > -1} { + set v [string range $token 0 $first_term-1] + set k [string range $token $first_term end] ;#key section includes the terminal char + lappend varlist [list $v $k] + } else { + lappend varlist [list $token ""] + } + } + return $varlist + } + + proc fp_restructure {selector data} { + if {$selector eq ""} { + fun=.= {val $input} and always break + set lhs "" + set rhs "" + #todo - check performance impact of catches around list and dict operations - consider single catch around destructure and less specific match error info? + foreach index $subindices { + set subpath [join [lrange $subindices 0 $i_keyindex] /] + set lhs $subpath + set assigned "" + set get_not 0 + set already_assigned 0 + set do_bounds_check 0 ;#modified by leading single @ for list operations - doesn't apply to certain items like 'head','tail' which have specifically defined bounds-checks implicit in their normal meaning. + #thse have anyhead and anytail for explicit allowance to be used on lists with insufficient items to produce values. + #todo - see if 'string is list' improved in tcl9 vs catch {llength $list} + switch -exact -- $index { + # { + set active_key_type "list" + if {![catch {llength $leveldata} assigned]} { + set already_assigned 1 + } else { + set action ?mismatch-not-a-list + break + } + } + ## { + set active_key_type "dict" + if {![catch {dict size $leveldata} assigned]} { + set already_assigned 1 + } else { + set action ?mismatch-not-a-dict + break + } + } + #? { + #review - compare to %# ????? + #seems to be unimplemented ? + set assigned [string length $leveldata] + set already_assigned 1 + } + @ { + upvar v_list_idx v_list_idx ;#positional tracker for /@ - list position + set active_key_type "list" + #e.g @1/1/@/1 the lone @ is a positional spec for this specific subkey + #no normalization done - ie @2/@ will not be considered same subkey as @end/@ or @end-0/@ even if llength = 3 + #while x@,y@.= is reasonably handy - especially for args e.g $len} { + set action ?mismatch-list-index-out-of-range + break + } + set assigned [lindex $leveldata $index] + set already_assigned 1 + } + @@ - @?@ - @??@ { + set active_key_type "dict" + + #NOTE: it may at first seem pointless to use @@/key, since we have to know the key - but this can be used to match 'key' only at the first position in .= list key {x y} key2 etc + #x@@ = a {x y} + #x@@/@0 = a + #x@@/@1 = x y + #x@@/a = a {x y} + # but.. as the @@ is stateful - it generally isn't very useful for multiple operations on the same pair within the pattern group. + # (note that ?@ forms a different subpath - so can be used to test match prior to @@ without affecting the index) + # It is analogous to v1@,v2@ for lists. + # @pairs is more useful for repeated operations + + # + #set subpath [join [lrange $subindices 0 $i_keyindex] /] + if {[catch {dict size $leveldata} dsize]} { + set action ?mismatch-not-a-dict + break + } + set next_this_level [incr v_dict_idx($subpath)] + set keyindex [expr {$next_this_level -1}] + if {($keyindex + 1) <= $dsize} { + set k [lindex [dict keys $leveldata] $keyindex] + if {$index eq "@?@"} { + set assigned [dict get $leveldata $k] + } else { + set assigned [list $k [dict get $leveldata $k]] + } + } else { + if {$index eq "@@"} { + set action ?mismatch-dict-index-out-of-range + break + } else { + set assigned [list] + } + } + set already_assigned 1 + } + default { + switch -glob -- $index { + @@* { + set active_key_type "dict" + set key [string range $index 2 end] + #dict exists test is safe - no need for catch + if {[dict exists $leveldata $key]} { + set assigned [dict get $leveldata $key] + } else { + set action ?mismatch-dict-key-not-found + break + } + set already_assigned 1 + } + {@\?@*} { + set active_key_type "dict" + set key [string range $index 3 end] + #dict exists test is safe - no need for catch + if {[dict exists $leveldata $key]} { + set assigned [dict get $leveldata $key] + } else { + set assigned [list] + } + set already_assigned 1 + } + {@\?\?@*} { + set active_key_type "dict" + set key [string range $index 4 end] + #dict exists test is safe - no need for catch + if {[dict exists $leveldata $key]} { + set assigned [list $key [dict get $leveldata $key]] + } else { + set assigned [list] + } + set already_assigned 1 + } + @* { + set active_key_type "list" + set do_bounds_check 1 + set index [string trimleft $index @] + } + default { + # + } + } + + if {!$already_assigned} { + if {[string match "not-*" $index] && $active_key_type in [list "" "list"]} { + #e.g not-0-end-1 not-end-4-end-2 + set get_not 1 + #cherry-pick some easy cases, and either assign, or re-map to corresponding index + switch -- $index { + not-tail { + set active_key_type "list" + set assigned [lindex $leveldata 0]; set already_assigned 1 + } + not-head { + set active_key_type "list" + #set selector "tail"; set get_not 0 + set assigned [lrange $leveldata 1 end]; set already_assigned 1 + } + not-end { + set active_key_type "list" + set assigned [lrange $leveldata 0 end-1]; set already_assigned 1 + } + default { + #trim off the not- and let the remaining index handle based on get_not being 1 + set index [string range $index 4 end] + } + } + } + } + } + } + + if {!$already_assigned} { + + #keyword 'pipesyntax' at beginning of error message + set listmsg "pipesyntax Unable to interpret subindex $index\n" + append listmsg "selector: '$selector'\n" + append listmsg "@ must be followed by a selector (possibly compound separated by forward slashes) suitable for lindex or lrange commands, or a not-x expression\n" + append listmsg "Additional accepted keywords include: head tail\n" + append listmsg "Use var@@key to treat value as a dict and retrieve element at key" + + + #we can't just set 'assigned' for a position spec for in/ni (not-in) because we don't have the value here to test against + #need to set a corresponding action + if {$active_key_type in [list "" "list"]} { + set active_key_type "list" + #for pattern matching purposes - head/tail not valid on empty lists (similar to elixir) + if {$index eq "0"} { + if {[catch {llength $leveldata} len]} { + set action ?mismatch-not-a-list + break + } + set assigned [lindex $leveldata 0] + } elseif {$index eq "head"} { + #NOTE: /@head and /head both do bounds check. This is intentional + if {[catch {llength $leveldata} len]} { + set action ?mismatch-not-a-list + break + } + if {$len == 0} { + set action ?mismatch-list-index-out-of-range-empty + break + } + #alias for 0 - for h@head,t@tail= similar to erlang/elixir hd() tl() or [head | tail] = list syntax + set assigned [lindex $leveldata 0] + } elseif {$index eq "end"} { + # @end /end + if {[catch {llength $leveldata} len]} { + set action ?mismatch-not-a-list + break + } + if {$do_bounds_check && $len < 1} { + set action ?mismatch-list-index-out-of-range + } + set assigned [lindex $leveldata end] + } elseif {$index eq "tail"} { + #NOTE: /@tail and /tail both do bounds check. This is intentional. + if {[catch {llength $leveldata} len]} { + set action ?mismatch-not-a-list + break + } + #tail is a little different in that we allow tail on a single element list - returning an empty result - but it can't be called on an empty list + #arguably tail could be considered as an index-out-of-range for less than 2 elements - but this would be less useful, and surprising to those coming from other pattern-matching systems. + #In this way tail is different to @1-end + if {$len == 0} { + set action ?mismatch-list-index-out-of-range + break + } + set assigned [lrange $leveldata 1 end] ;#return zero or more elements - but only if there is something (a head) at position zero. + } elseif {$index eq "anyhead"} { + # @anyhead + #allow returning of head or nothing if empty list + if {[catch {llength $leveldata} len]} { + set action ?mismatch-not-a-list + break + } + set assigned [lindex $leveldata 0] + } elseif {$index eq "anytail"} { + # @anytail + #allow returning of tail or nothing if empty list + #anytail will return empty both for empty list, or single element list - but potentially useful in combination with anyhead. + if {[catch {llength $leveldata} len]} { + set action ?mismatch-not-a-list + break + } + set assigned [lrange $leveldata 1 end] + } elseif {$index eq "init"} { + # @init + #all but last element - same as haskell 'init' + if {[catch {llength $leveldata} len]} { + set action ?mismatch-not-a-list + break + } + set assigned [lrange $leveldata 0 end-1] + } elseif {$index eq "list"} { + # @list + #allow returning of entire list even if empty + if {[catch {llength $leveldata} len]} { + set action ?mismatch-not-a-list + break + } + set assigned $leveldata + } elseif {$index eq "raw"} { + #no list checking.. + set assigned $leveldata + } elseif {$index eq "keys"} { + #need active_key_type of 'list' for 'keys' and 'values' keywords which act on either dict or a list with even number of elements + if {[catch {dict size $leveldata} dsize]} { + set action ?mismatch-not-a-dict + break + } + set assigned [dict keys $leveldata] + } elseif {$index eq "values"} { + #need active_key_type of 'list' for 'keys' and 'values' keywords which act on either dict or a list with even number of elements + if {[catch {dict size $leveldata} dsize]} { + set action ?mismatch-not-a-dict + break + } + set assigned [dict values $leveldata] + } elseif {$index eq "pairs"} { + if {[catch {dict size $leveldata} dsize]} { + set action ?mismatch-not-a-dict + break + } + #set assigned [dict values $leveldata] + set pairs [list] + tcl::dict::for {k v} $leveldata {lappend pairs [list $k $v]} + set assigned [lindex [list $pairs [unset pairs]] 0] + } elseif {[string is integer -strict $index]} { + if {[catch {llength $leveldata} len]} { + set action ?mismatch-not-a-list + break + } + # only check if @ was directly in original index section + if {$do_bounds_check && ($index+1 > $len || $index < 0)} { + set action ?mismatch-list-index-out-of-range + break + } + if {$get_not} { + #already handled not-0 + set assigned [lreplace $leveldata $index $index] + } else { + set assigned [lindex $leveldata $index] + } + } elseif {[string first "end" $index] >=0} { + if {[regexp {^end([-+]{1,2}[0-9]+)$} $index _match endspec]} { + if {[catch {llength $leveldata} len]} { + set action ?mismatch-not-a-list + break + } + #leave the - from the end- as part of the offset + set offset [expr $endspec] ;#don't brace! (consider: set x --34;puts expr $j;puts expr {$j} ) + if {$do_bounds_check && ($offset > 0 || abs($offset) >= $len)} { + set action ?mismatch-list-index-out-of-range + break + } + if {$get_not} { + set assigned [lreplace $leveldata $index $index] + } else { + set assigned [lindex $leveldata $index] + } + } elseif {[regexp {^([0-9]+|end|end[-+]{1,2}[0-9]+)-([0-9]+|end|end[-+]{1,2}([0-9]+))$} $index _ start end]} { + if {[catch {llength $leveldata} len]} { + set action ?mismatch-not-a-list + break + } + if {$do_bounds_check && [string is integer -strict $start]} { + if {$start+1 > $len || $start < 0} { + set action ?mismatch-list-index-out-of-range + break + } + } elseif {$start eq "end"} { + #ok + } elseif {$do_bounds_check} { + set startoffset [string range $start 3 end] ;#include the - from end- + set startoffset [expr $startoffset] ;#don't brace! + if {$startoffset > 0 || abs($startoffset) >= $len} { + set action ?mismatch-list-index-out-of-range + break + } + } + if {$do_bounds_check && [string is integer -strict $end]} { + if {$end+1 > $len || $end < 0} { + set action ?mismatch-list-index-out-of-range + break + } + } elseif {$end eq "end"} { + #ok + } elseif {$do_bounds_check} { + set endoffset [string range $end 3 end] ;#include the - from end- + set endoffset [expr $endoffset] ;#don't brace! + if {$endoffset > 0 || abs($endoffset) >= $len} { + set action ?mismatch-list-index-out-of-range + break + } + } + if {$get_not} { + set assigned [lreplace $leveldata $start $end] + } else { + set assigned [lrange $leveldata $start $end] + } + } else { + error $listmsg "destructure $selector" [list pipesyntax destructure selector $selector] + } + } elseif {[string first - $index] > 0} { + puts "====> index:$index leveldata:$leveldata" + if {[catch {llength $leveldata} len]} { + set action ?mismatch-not-a-list + break + } + #handle pure int-int ranges separately + set testindex [string map [list - "" + ""] $index] + if {[string is digit -strict $testindex]} { + #don't worry about leading - negative value for indices not valid anyway + set parts [split $index -] + if {[llength $parts] != 2} { + error $listmsg "destructure $selector" [list pipesyntax destructure selector $selector] + } + lassign $parts start end + if {$start+1 > $len || $end+1 > $len} { + set action ?mismatch-not-a-list + break + } + if {$get_not} { + set assigned [lreplace $leveldata $start $end] + } else { + set assigned [lrange $leveldata $start $end] + } + } else { + error $listmsg "destructure $selector" [list pipesyntax destructure selector $selector] + } + + } else { + #keyword 'pipesyntax' at beginning of error message + error $listmsg "destructure $selector" [list pipesyntax destructure selector $selector] + } + } else { + #treat as dict key + set active_key_type "dict" + if {[dict exists $leveldata $index]} { + set assigned [dict get $leveldata $index] + } else { + set action ?mismatch-dict-key-not-found + break + } + + } + } + set leveldata $assigned + set rhs $leveldata + #don't break on empty data - operations such as # and ## can return 0 + #if {![llength $leveldata]} { + # break + #} + incr i_keyindex + } + #puts stdout "----> destructure rep leveldata: [rep $leveldata]" + #puts stdout ">> destructure returning: [dict create -assigned $leveldata -action $action -lhs $lhs -rhs $rhs]" + + #maintain key order - caller unpacks using lassign + return [dict create -assigned $leveldata -action $action -lhs $lhs -rhs $rhs] + + } + #todo - fp_destructure - return a function-pipeline that can then be transformed to a funcl and finally a more efficient tcl script + proc destructure_func {selector data} { + #puts stderr ".d." + set selector [string trim $selector /] + #upvar v_list_idx v_list_idx ;#positional tracker for /@ - list position + #upvar v_dict_idx v_dict_idx ;#positional tracker for /@@ - dict position + + #map some problematic things out of the way in a manner that maintains some transparency + #e.g glob chars ? * in a command name can make testing using {[info commands $cmd] ne ""} produce spurious results - requiring a stricter (and slower) test such as {$cmd in [info commands $cmd]} + #The selector forms part of the proc name + #review - compare with pipecmd_namemapping + set selector_safe [string map [list {*}{ + ? + * + \\ + {"} + {$} + "\x1b\[" + "\x1b\]" + {[} + {]} + :: + {;} + " " + \t + \n + \r + }] $selector] + + set cmdname ::punk::pipecmds::destructure::_$selector_safe + if {[info commands $cmdname] ne ""} { + return [$cmdname $data] ;# note upvar 2 for stateful v_list_idx to be resolved in _multi_bind_result context + } + + set leveldata $data + set body [destructure_func_build_procbody $cmdname $selector $data] + + puts stdout ---- + puts stderr "proc $cmdname {leveldata} {" + puts stderr $body + puts stderr "}" + puts stdout --- + proc $cmdname {leveldata} $body + #eval $script ;#create the proc + debug.punk.pipe.compile {proc $cmdname} 4 + #return [dict create -assigned $leveldata -action $action -lhs $lhs -rhs $rhs] + #use return - script has upvar 2 for v_list_idx to be resolved in _multi_bind_result context + return [$cmdname $data] + } + + #Builds a *basic* function to do the destructuring. + #This is simply a set of steps to destructure each level of the data based on the hierarchical selector. + #It just uses intermediate variables and adds some comments to the code to show the indices used at each point. + #This may be useful in the long run as a debug/fallback mechanism - but ideally we should be building a more efficient script. + proc destructure_func_build_procbody {cmdname selector data} { + set script "" + #place selector in comment in script only - if there is an error in selector we pick it up when building the script. + #The script itself should only be returning errors in its action key of the result dictionary + append script \n [string map [list $selector] {# set selector {}}] + set subindices [split $selector /] + append script \n [string map [list [list $subindices]] {# set subindices }] + set action ?match ;#default assumption. Alternatively set to ?mismatch or ?mismatch- and always break + append script \n {set action ?match} + #append script \n {set assigned ""} ;#review + set active_key_type "" + append script \n {# set active_key_type ""} + set lhs "" + #append script \n [tstr {set lhs ${{$lhs}}}] + append script \n {set lhs ""} + set rhs "" + append script \n {set rhs ""} + + set INDEX_OPERATIONS {} ;#caps to make clear in templates that this is substituted from script building scope + + #maintain key order - caller unpacks using lassign + set returnline {dict create -assigned $leveldata -action $action -lhs $lhs -rhs $rhs} + set return_template {return [tcl::dict::create -assigned $leveldata -action $action -lhs $lhs -rhs xxx -index_operations {${$INDEX_OPERATIONS}}]} + #set tpl_return_mismatch {return [dict create -assigned $leveldata -action ${$MISMATCH} -lhs $lhs -rhs $rhs -index_operations {${$INDEX_OPERATIONS}}]} + set tpl_return_mismatch {return [dict create -assigned $leveldata -action ${$MISMATCH} -lhs $lhs -rhs xxx -index_operations {${$INDEX_OPERATIONS}}]} + set tpl_return_mismatch_not_a_list {return [dict create -assigned $leveldata -action ?mismatch-not-a-list -lhs $lhs -rhs xxx -index_operations {${$INDEX_OPERATIONS}}]} + set tpl_return_mismatch_list_index_out_of_range {return [dict create -assigned $leveldata -action ?mismatch-list-index-out-of-range -lhs $lhs -rhs xxx -index_operations {${$INDEX_OPERATIONS}}]} + set tpl_return_mismatch_list_index_out_of_range_empty {return [dict create -assigned $leveldata -action ?mismatch-list-index-out-of-range-empty -lhs $lhs -rhs xxx -index_operations {${$INDEX_OPERATIONS}}]} + set tpl_return_mismatch_not_a_dict {return [dict create -assigned $leveldata -action ?mismatch-not-a-dict -lhs $lhs -rhs xxx -index_operations {${$INDEX_OPERATIONS}}]} + #dict 'index' when using stateful @@ etc to iterate over dict instead of by key + set tpl_return_mismatch_dict_index_out_of_range {return [dict create -assigned $leveldata -action ?mismatch-dict-index-out-of-range -lhs $lhs -rhs xxx -index_operations {${$INDEX_OPERATIONS}}]} + set tpl_return_mismatch_dict_key_not_found {return [dict create -assigned $leveldata -action ?mismatch-dict-key-not-found -lhs $lhs -rhs xxx -index_operations {${$INDEX_OPERATIONS}}]} + + + if {![string length $selector]} { + #just return $leveldata + set script { + dict create -assigned $leveldata -action ?match -lhs "" -rhs $leveldata + } + return $script + } + + if {[string is digit -strict [join $subindices ""]]} { + #review tip 551 (underscores in numerical literals) (tcl9+) + #puts stderr ">>>>>>>>>>>>>>>> data: $leveldata selector: $selector subindices: $subindices" + #pure numeric keylist - put straight to lindex + # + #NOTE: this direct access e.g v/0/1/2 doesn't check out of bounds which is at odds with list access containing @ + #We will leave this as a syntax for different (more performant) behaviour + #- it's potentially a little confusing - but it would be a shame not to have the possibility to take advantage of the lindex deep indexing capability in pattern matching. + #TODO - review and/or document + # + #Todo - add a handler for v/n/n/n/n/# to allow unchecked counting at depth too. + #(or more generally - loop until we hit another type of subindex) + + #set assigned [lindex $leveldata {*}$subindices] + if {[llength $subindices] == 1} { + append script \n "# index_operation listindex" \n + lappend INDEX_OPERATIONS listindex + } else { + append script \n "# index_operation listindex-nested" \n + lappend INDEX_OPERATIONS listindex-nested + } + append script \n [tstr -return string -allowcommands { + if {[catch {lindex $leveldata ${$subindices}} leveldata]} { + ${[tstr -ret string $tpl_return_mismatch_not_a_list]} + } + }] + # -- --- --- + #append script \n $returnline \n + append script [tstr -return string $return_template] + return $script + # -- --- --- + } + if {[string match @@* $selector]} { + #part following a double @ is dict key possibly with forward-slash separators for subpath access e.g @@key/subkey/etc + set rawkeylist [split $selector /] ;#first key retains @@ - may be just '@@' + set keypath [string range $selector 2 end] + set keylist [split $keypath /] + lappend INDEX_OPERATIONS dict_path + if {([lindex $rawkeylist 0] ne "@@") && ([lsearch $keylist @*] == -1) && ([lsearch $keylist #*] == -1) && ([lsearch $keylist %*] == -1)} { + #pure keylist for dict - process in one go + #dict exists will return 0 if not a valid dict. + # is equivalent to {*}keylist when substituted + append script \n [tstr -return string -allowcommands { + if {[dict exists $leveldata ${$keylist}]} { + set leveldata [dict get $leveldata ${$keylist}] + } else { + #set action ?mismatch-dict-key-not-found + ${[tstr -ret string $tpl_return_mismatch_dict_key_not_found]} + } + }] + append script [tstr -return string $return_template] + return $script + # -- --- --- + } + #else + #compound keylist e.g x@@data/@0/1 or x@@/a (combined dict/list access) + #process level by level + } + + + + set i_keyindex 0 + append script \n {set i_keyindex 0} + #todo - check performance impact of catches around list and dict operations - consider single catch around destructure and less specific match error info? + foreach index $subindices { + #set index_operation "unspecified" + set level_script_complete 0 ;#instead of break - as we can't use data to determine break when building script + set SUBPATH [join [lrange $subindices 0 $i_keyindex] /] + append script \n "# ------- START index:$index subpath:$SUBPATH ------" + set lhs $index + append script \n "set lhs {$index}" + + set assigned "" + append script \n {set assigned ""} + + #got_not shouldn't need to be in script + set get_not 0 + if {[tcl::string::index $index 0] eq "!"} { + append script \n {#get_not is true e.g !0-end-1 !end-4-end-2 !0 !@0 !@@key} + set index [tcl::string::range $index 1 end] + set get_not 1 + } + + # do_bounds_check shouldn't need to be in script + set do_bounds_check 0 ;#modified by leading single @ for list operations - doesn't apply to certain items like 'head','tail' which have specifically defined bounds-checks implicit in their normal meaning. + #thse have anyhead and anytail for explicit allowance to be used on lists with insufficient items to produce values. + #append script \n {set do_boundscheck 0} + switch -exact -- $index { + # - @# { + #list length + set active_key_type "list" + if {$get_not} { + lappend INDEX_OPERATIONS not-list + append script \n {# set active_key_type "list" index_operation: not-list} + append script \n { + if {[catch {llength $leveldata}]} { + #not a list - not-length is true + set assigned 1 + } else { + #is a list - not-length is false + set assigned 0 + } + } + } else { + lappend INDEX_OPERATIONS list-length + append script \n {# set active_key_type "list" index_operation: list-length} + append script \n [tstr -return string -allowcommands { + if {[catch {llength $leveldata} assigned]} { + ${[tstr -ret string $tpl_return_mismatch_not_a_list]} + } + }] + } + set level_script_complete 1 + } + ## { + #dict size + set active_key_type "dict" + if {$get_not} { + lappend INDEX_OPERATIONS not-dict + append script \n {# set active_key_type "dict" index_operation: not-dict} + append script \n { + if {[catch {dict size $leveldata}]} { + set assigned 1 ;#not a dict - not-size is true + } else { + set assigned 0 ;#is a dict - not-size is false + } + } + } else { + lappend INDEX_OPERATIONS dict-size + append script \n {# set active_key_type "dict" index_operation: dict-size} + append script \n [tstr -return string -allowcommands { + if {[catch {dict size $leveldata} assigned]} { + #set action ?mismatch-not-a-dict + ${[tstr -ret string $tpl_return_mismatch_not_a_dict]} + } + }] + } + set level_script_complete 1 + } + %# { + set active_key_type "string" + if {$get_not} { + error "!%# not string length is not supported" + } + #string length - REVIEW - + lappend INDEX_OPERATIONS string-length + append script \n {# set active_key_type "" index_operation: string-length} + append script \n {set assigned [string length $leveldata]} + set level_script_complete 1 + } + %%# { + #experimental + set active_key_type "string" + if {$get_not} { + error "!%%# not string length is not supported" + } + #string length - REVIEW - + lappend INDEX_OPERATIONS ansistring-length + append script \n {# set active_key_type "" index_operation: ansistring-length} + append script \n {set assigned [ansistring length $leveldata]} + set level_script_complete 1 + } + %str - %string { + set active_key_type "string" + if {$get_not} { + error "!%str - not string-get is not supported" + } + lappend INDEX_OPERATIONS string-get + append script \n {# set active_key_type "" index_operation: string-get} + append script \n {set assigned $leveldata} + set level_script_complete 1 + + #todo - %lpad- %lpadstr- %join- etc as in punk::lib::showdict + #review - merge code shared with showdict for these operations + } + %sp { + #experimental + set active_key_type "string" + if {$get_not} { + error "!%sp - not string-space is not supported" + } + lappend INDEX_OPERATIONS string-space + append script \n {# set active_key_type "" index_operation: string-space} + append script \n {set assigned " "} + set level_script_complete 1 + } + %empty { + #experimental + set active_key_type "string" + if {$get_not} { + error "!%empty - not string-empty is not supported" + } + lappend INDEX_OPERATIONS string-empty + append script \n {# set active_key_type "" index_operation: string-empty} + append script \n {set assigned ""} + set level_script_complete 1 + } + @words { + set active_key_type "string" + if {$get_not} { + error "!%words - not list-words-from-string is not supported" + } + lappend INDEX_OPERATIONS list-words-from-string + append script \n {# set active_key_type "" index_operation: list-words-from-string} + append script \n {set assigned [regexp -inline -all {\S+} $leveldata]} + set level_script_complete 1 + } + @chars { + #experimental - leading character based on result not input(?) + #input type is string - but output is list + set active_key_type "list" + if {$get_not} { + error "!%chars - not list-chars-from-string is not supported" + } + lappend INDEX_OPERATIONS list-from_chars + append script \n {# set active_key_type "" index_operation: list-chars-from-string} + append script \n {set assigned [split $leveldata ""]} + set level_script_complete 1 + } + @join { + #experimental - flatten one level of list + #join without arg - output is list + set active_key_type "string" + if {$get_not} { + error "!@join - not list-join-list is not supported" + } + lappend INDEX_OPERATIONS list-join-list + append script \n {# set active_key_type "" index_operation: list-join-list} + append script \n {set assigned [join $leveldata]} + set level_script_complete 1 + } + %join { + #experimental + #input type is list - but output is string + set active_key_type "string" + if {$get_not} { + error "!%join - not string-join-list is not supported" + } + lappend INDEX_OPERATIONS string-join-list + append script \n {# set active_key_type "" index_operation: string-join-list} + append script \n {set assigned [join $leveldata ""]} + set level_script_complete 1 + } + %ansiview { + #review - implemented differently in showdict. + #(showdict uses ansistring VIEW -lf 1 ) + set active_key_type "string" + if {$get_not} { + error "!%# not string-ansiview is not supported" + } + lappend INDEX_OPERATIONS string-ansiview + append script \n {# set active_key_type "" index_operation: string-ansiview} + append script \n {set assigned [ansistring VIEW $leveldata]} + set level_script_complete 1 + } + %ansiviewstyle { + set active_key_type "string" + if {$get_not} { + error "!%# not string-ansiviewstyle is not supported" + } + lappend INDEX_OPERATIONS string-ansiviewstyle + append script \n {# set active_key_type "" index_operation: string-ansiviewstyle} + append script \n {set assigned [ansistring VIEWSTYLE $leveldata]} + set level_script_complete 1 + } + @ { + #as this is a stateful list next index operation - we use not (!@) to mean there is no element at the next index (instead of returning the complement ie all elements except next) + #This is in contrast to other not operations on indices e.g /!2 which returns all elements except that at index 2 + + + #append script \n {puts stderr [uplevel 1 [list info vars]]} + + #NOTE: + #v_list_idx in context of _multi_bind_result + #we call destructure_func from _mult_bind_result which in turn calls the proc (or the script on first run) + append script \n {upvar 2 v_list_idx v_list_idx} + + set active_key_type "list" + append script \n {# set active_key_type "list" index_operation: list-get-next} + #e.g @1/1/@/1 the lone @ is a positional spec for this specific subkey + #no normalization done - ie @2/@ will not be considered same subkey as @end/@ or @end-0/@ even if llength = 3 + #while x@,y@.= is reasonably handy - especially for args e.g $len} { + set assigned 1 + } else { + set assigned 0 + } + }] + + } else { + lappend INDEX_OPERATIONS get-next + append script \n [tstr -return string -allowcommands { + set index [expr {[incr v_list_idx(@)]-1}] + + if {[catch {llength $leveldata} len]} { + #set action ?mismatch-not-a-list + ${[tstr -ret string $tpl_return_mismatch_not_a_list]} + } elseif {$index+1 > $len} { + #set action ?mismatch-list-index-out-of-range + ${[tstr -ret string $tpl_return_mismatch_list_index_out_of_range]} + } else { + set assigned [lindex $leveldata $index] + } + }] + } + set level_script_complete 1 + } + @* { + set active_key_type "list" + if {$get_not} { + lappend INDEX_OPERATIONS list-is-empty + append script \n [tstr -return string -allowcommands { + if {[catch {llength $leveldata} len]} { + ${[tstr -ret string $tpl_return_mismatch_not_a_list]} + } elseif {$len == 0} { + set assigned 1 ;#list is empty + } else { + set assigned 0 + } + }] + } else { + lappend INDEX_OPERATIONS list-get-all + append script \n [tstr -return string -allowcommands { + if {[catch {llength $leveldata} len]} { + ${[tstr -ret string $tpl_return_mismatch_not_a_list]} + } else { + set assigned [lrange $leveldata 0 end] + } + }] + } + set level_script_complete 1 + } + @@ { + #stateful: tracking of index using v_dict_idx + set active_key_type "dict" + lappend INDEX_OPERATIONS get-next-value + append script \n {# set active_key_type "dict" index_operation: get-next-value} + append script \n {upvar v_dict_idx v_dict_idx} ;#review! + + #NOTE: it may at first seem pointless to use @@/key, since we have to know the key - but this can be used to match 'key' only at the first position in .= list key {x y} key2 etc + #x@@ = a {x y} + #x@@/@0 = a + #x@@/@1 = x y + #x@@/a = a {x y} + # but.. as the @@ is stateful - it generally isn't very useful for multiple operations on the same pair within the pattern group. + # (note that @@ @?@ @??@ form different subpaths - so the ? & ?? versions can be used to test match prior to @@ without affecting the index) + #review - might be more useful if they shared an index ? + # It is analogous to v1@,v2@ for lists. + # @pairs is more useful for repeated operations + + + set indent " " + set assignment_script [string map [list \r\n "\r\n$indent" \n "\n$indent" ] { + if {($keyindex + 1) <= $dsize} { + set k [lindex [dict keys $leveldata] $keyindex] + set assigned [list $k [dict get $leveldata $k]] + } else { + ${[tstr -ret string $tpl_return_mismatch_dict_index_out_of_range]} + } + }] + + set assignment_script [tstr -ret string -allowcommands $assignment_script] + + append script [tstr -return string -allowcommands { + if {[catch {dict size $leveldata} dsize]} { + ${[tstr -ret string $tpl_return_mismatch_not_a_dict]} + } else { + set next_this_level [incr v_dict_idx(${$SUBPATH})] + set keyindex [expr {$next_this_level -1}] + ${$assignment_script} + } + }] + set level_script_complete 1 + } + @?@ { + #stateful: tracking of index using v_dict_idx + set active_key_type "dict" + lappend INDEX_OPERATIONS get?-next-value + append script \n {# set active_key_type "dict" index_operation: get?-next-value} + append script \n {upvar v_dict_idx v_dict_idx} ;#review! + set indent " " + set assignment_script [string map [list \r\n "\r\n$indent" \n "\n$indent" ] { + if {($keyindex + 1) <= $dsize} { + set k [lindex [dict keys $leveldata] $keyindex] + set assigned [dict get $leveldata $k] + } else { + set assigned [list] + } + }] + append script [tstr -return string -allowcommands { + if {[catch {dict size $leveldata} dsize]} { + ${[tstr -ret string $tpl_return_mismatch_not_a_dict]} + } else { + set next_this_level [incr v_dict_idx(${$SUBPATH})] + set keyindex [expr {$next_this_level -1}] + ${$assignment_script} + } + }] + set level_script_complete 1 + } + @??@ { + set active_key_type "dict" + lappend INDEX_OPERATIONS get?-next-pair + append script \n {# set active_key_type "dict" index_operation: get?-next-pair} + append script \n {upvar v_dict_idx v_dict_idx} ;#review! + set indent " " + set assignment_script [string map [list \r\n "\r\n$indent" \n "\n$indent" ] { + if {($keyindex + 1) <= $dsize} { + set k [lindex [dict keys $leveldata] $keyindex] + set assigned [list $k [dict get $leveldata $k]] + } else { + set assigned [list] + } + }] + append script [tstr -return string -allowcommands { + if {[catch {dict size $leveldata} dsize]} { + ${[tstr -ret string $tpl_return_mismatch_not_a_dict]} + } else { + set next_this_level [incr v_dict_idx(${$SUBPATH})] + set keyindex [expr {$next_this_level -1}] + ${$assignment_script} + } + }] + set level_script_complete 1 + } + @vv@ - @VV@ - @kk@ - @KK@ { + error "unsupported index $index" + } + default { + + #assert rules for values within @@ + #glob search is done only if there is at least one * within @@ + #if there is at least one ? within @@ - then a non match will not raise an error (quiet) + + #single or no char between @@: + #lookup/search is based on key - return is values + + #double char within @@: + #anything with a dot returns k v pairs e.g @k.@ @v.@ @..@ + #anything that is a duplicate returns k v pairs e.g @kk@ @vv@ @**@ + #anything with a letter and a star returns the type of the letter, and the search is based on the position of the star where posn 1 is for key, posn 2 is for value + #e.g @k*@ returns keys - search on values + #e.g @*k@ returns keys - search on keys + #e.g @v*@ returns values - search on values + #e.g @*v@ returns values - search on keys + + switch -glob -- $index { + @@* { + #exact key match - return value + #noisy get value - complain if key non-existent + #doesn't complain if not a dict - because we use 'tcl::dict::exists' which will return false without error even if the value isn't dict-shaped + set active_key_type "dict" + set key [string range $index 2 end] + if {$get_not} { + lappend INDEX_OPERATIONS exactkey-get-value-not + #review - dict remove allows silent call if key doesn't exist - but we are enforcing existence here + #this seems reasonable given we have an explicit @?@ syntax (nocomplain equivalent) and there could be a legitimate case for wanting a non-match if trying to return the complement of a non-existent key + append script \n [tstr -return string -allowcommands { + # set active_key_type "dict" index_operation: exactkey-get-value-not + if {[dict exists $leveldata ${$key}]} { + set assigned [dict values [dict remove $leveldata ${$key}]] + } else { + #set action ?mismatch-dict-key-not-found + ${[tstr -ret string $tpl_return_mismatch_dict_key_not_found]} + } + }] + + } else { + lappend INDEX_OPERATIONS exactkey-get-value + append script \n [tstr -return string -allowcommands { + # set active_key_type "dict index_operation: exactkey-get-value" + if {[dict exists $leveldata ${$key}]} { + set assigned [dict get $leveldata ${$key}] + } else { + #set action ?mismatch-dict-key-not-found + ${[tstr -ret string $tpl_return_mismatch_dict_key_not_found]} + } + }] + } + set level_script_complete 1 + } + {@\?@*} { + #exact key match - quiet get value + #silent empty result if non-existent key - silence when non-existent key also if using not-@?@badkey which will just return whole dict + #note - dict remove will raise error on non-dict-shaped value whilst dict exists will not + set active_key_type "dict" + set key [string range $index 3 end] + if {$get_not} { + lappend INDEX_OPERATIONS exactkey?-get-value-not + append script \n [tstr -return string -allowcommands { + # set active_key_type "dict" index_operation: exactkey?-get-value-not + if {[catch {dict size $leveldata}]} { + ${[tstr -ret string $tpl_return_mismatch_not_a_dict]} + } + set assigned [dict values [dict remove $leveldata ${$key}]] + }] + + } else { + lappend INDEX_OPERATIONS exactkey?-get-value + #dict exists test is safe - no need for catch + append script \n [string map [list $key] { + # set active_key_type "dict" index_operation: exactkey?-get-value + if {[dict exists $leveldata ]} { + set assigned [dict get $leveldata ] + } else { + set assigned [dict create] + } + }] + } + set level_script_complete 1 + } + {@\?\?@*} { + #quiet get pairs + #this is silent too.. so how do we do a checked return of dict key+val? + set active_key_type "dict" + set key [string range $index 4 end] + if {$get_not} { + lappend INDEX_OPERATIONS exactkey?-get-pair-not + append script \n [tstr -return string -allowcommands { + # set active_key_type "dict" index_operation: exactkey?-get-pair-not + if {[catch {dict size $leveldata}]} { + ${[tstr -ret string $tpl_return_mismatch_not_a_dict]} + } + set assigned [dict remove $leveldata ${$key}] + }] + } else { + lappend INDEX_OPERATIONS exactkey?-get-pair + append script \n [string map [list $key] { + # set active_key_type "dict" index_operation: exactkey?-get-pair + if {[dict exists $leveldata ]} { + set assigned [dict create [dict get $leveldata ]] + } else { + set assigned [dict create] + } + }] + } + set level_script_complete 1 + } + @..@* - @kk@* - @KK@* { + #noisy get pairs by key + set active_key_type "dict" + set key [string range $index 4 end] + if {$get_not} { + lappend INDEX_OPERATIONS exactkey-get-pairs-not + #review - dict remove allows silent call if key doesn't exist - but we are enforcing existence here + #this seems reasonable given we have an explicit @?@ syntax (nocomplain equivalent) and there could be a legitimate case for wanting a non-match if trying to return the complement of a non-existent key + append script \n [tstr -return string -allowcommands { + # set active_key_type "dict" index_operation: exactkey-get-pairs-not + if {[dict exists $leveldata ${$key}]} { + set assigned [tcl::dict::remove $leveldata ${$key}] + } else { + ${[tstr -ret string $tpl_return_mismatch_dict_key_not_found]} + } + }] + + } else { + lappend INDEX_OPERATIONS exactkey-get-pairs + append script \n [tstr -return string -allowcommands { + # set active_key_type "dict index_operation: exactkey-get-pairs" + if {[dict exists $leveldata ${$key}]} { + tcl::dict::set assigned ${$key} [tcl::dict::get $leveldata ${$key}] + } else { + ${[tstr -ret string $tpl_return_mismatch_dict_key_not_found]} + } + }] + } + set level_script_complete 1 + + } + @vv@* - @VV@* { + #noisy(?) get pairs by exact value + #return mismatch on non-match even when not- specified + set active_key_type "dict" + set keyglob [string range $index 4 end] + set active_key_type "dict" + set key [string range $index 4 end] + if {$get_not} { + #review - for consistency we are reporting a mismatch when the antikey being looked up doesn't exist + #The utility of this is debatable + lappend INDEX_OPERATIONS exactvalue-get-pairs-not + append script \n [tstr -return string -allowcommands { + # set active_key_type "dict" index_operation: exactvalue-get-pairs-not + if {[catch {dict size $leveldata}]} { + ${[tstr -ret string $tpl_return_mismatch_not_a_dict]} + } + set nonmatches [dict create] + tcl::dict::for {k v} $leveldata { + if {![string equal ${$key} $v]} { + dict set nonmatches $k $v + } + } + + if {[dict size $nonmatches] < [dict size $leveldata]} { + #our key matched something + set assigned $nonmatches + } else { + #our key didn't match anything - don't return the nonmatches + #set action ?mismatch-dict-key-not-found + ${[tstr -ret string $tpl_return_mismatch_dict_key_not_found]} + } + }] + + } else { + lappend INDEX_OPERATIONS exactvalue-get-pairs + append script \n [tstr -return string -allowcommands { + # set active_key_type "dict index_operation: exactvalue-get-pairs-not" + if {[catch {dict size $leveldata}]} { + ${[tstr -ret string $tpl_return_mismatch_not_a_dict]} + } + set matches [list] + tcl::dict::for {k v} $leveldata { + if {[string equal ${$key} $v]} { + lappend matches $k $v + } + } + if {[llength $matches]} { + set assigned $matches + } else { + #set action ?mismatch-dict-key-not-found + ${[tstr -ret string $tpl_return_mismatch_dict_key_not_found]} + } + }] + } + set level_script_complete 1 + + } + {@\*@*} - {@\*v@*} - {@\*V@*} { + #dict key glob - return values only + set active_key_type "dict" + if {[string match {@\*@*} $index]} { + set keyglob [string range $index 3 end] + } else { + #vV + set keyglob [string range $index 4 end] + } + #if $keyglob eq "" - needs to query for dict key that is empty string. + if {$get_not} { + lappend INDEX_OPERATIONS globkey-get-values-not + append script \n [tstr -return string -allowcommands { + if {[catch {dict size $leveldata}]} { + ${[tstr -ret string $tpl_return_mismatch_not_a_dict]} + } + # set active_key_type "dict" index_operation: globkey-get-values-not + set matched [dict keys $leveldata {${$keyglob}}] + set assigned [dict values [dict remove $leveldata {*}$matched]] + }] + + } else { + lappend INDEX_OPERATIONS globkey-get-values + append script \n [tstr -return string -allowcommands { + # set active_key_type "dict" index_operation: globkey-get-values + if {[catch {dict size $leveldata}]} { + ${[tstr -ret string $tpl_return_mismatch_not_a_dict]} + } + set matched [dict keys $leveldata {${$keyglob}}] + set assigned [list] + foreach m $matched { + lappend assigned [dict get $leveldata $m] + } + }] + } + set level_script_complete 1 + + } + {@\*.@*} { + #dict key glob - return pairs + set active_key_type "dict" + set keyglob [string range $index 4 end] + append script [tstr -return string -allowcommands { + if {[catch {dict size $leveldata}]} { + ${[tstr -ret string $tpl_return_mismatch_not_a_dict]} + } + }] + if {$get_not} { + lappend INDEX_OPERATIONS globkey-get-pairs-not + append script \n [string map [list $keyglob] { + # set active_key_type "dict" index_operation: globkey-get-pairs-not + set matched [dict keys $leveldata {}] + set assigned [dict remove $leveldata {*}$matched] + }] + + } else { + lappend INDEX_OPERATIONS globkey-get-pairs + append script \n [string map [list $keyglob] { + # set active_key_type "dict" index_operations: globkey-get-pairs + set matched [dict keys $leveldata {}] + set assigned [dict create] + foreach m $matched { + dict set assigned $m [dict get $leveldata $m] + } + }] + } + set level_script_complete 1 + } + {@\*k@*} - {@\*K@*} { + #dict key glob - return keys + set active_key_type "dict" + set keyglob [string range $index 4 end] + append script [tstr -return string -allowcommands { + if {[catch {dict size $leveldata}]} { + ${[tstr -ret string $tpl_return_mismatch_not_a_dict]} + } + }] + if {$get_not} { + lappend INDEX_OPERATIONS globkey-get-keys-not + append script \n [string map [list $keyglob] { + # set active_key_type "dict" index_operation: globkey-get-keys-not + set matched [dict keys $leveldata {}] + set assigned [dict keys [dict remove $leveldata {*}$matched]] + }] + + } else { + lappend INDEX_OPERATIONS globkey-get-keys + append script \n [string map [list $keyglob] { + # set active_key_type "dict" index_operation: globkey-get-keys + set assigned [dict keys $leveldata {}] + }] + } + set level_script_complete 1 + } + {@k\*@*} - {@K\*@*} { + #dict value glob - return keys + set active_key_type "dict" + set valglob [string range $index 4 end] + append script [tstr -return string -allowcommands { + if {[catch {dict size $leveldata}]} { + ${[tstr -ret string $tpl_return_mismatch_not_a_dict]} + } + }] + if {$get_not} { + lappend INDEX_OPERATIONS globvalue-get-keys-not + append script \n [string map [list $valglob] { + # set active_key_type "dict" index_operation: globvalue-get-keys-not + set assigned [list] + tcl::dict::for {k v} $leveldata { + if {![string match {} $v]} { + lappend assigned $k + } + } + }] + } else { + lappend INDEX_OPERATIONS globvalue-get-keys + append script \n [string map [list $valglob] { + # set active_key_type "dict" index_operation: globvalue-get-keys + set assigned [list] + tcl::dict::for {k v} $leveldata { + if {[string match {} $v]} { + lappend assigned $k + } + } + }] + } + set level_script_complete 1 + } + {@.\*@*} { + #dict value glob - return pairs + set active_key_type "dict" + set valglob [string range $index 4 end] + append script [tstr -return string -allowcommands { + if {[catch {dict size $leveldata}]} { + ${[tstr -ret string $tpl_return_mismatch_not_a_dict]} + } + }] + if {$get_not} { + lappend INDEX_OPERATIONS globvalue-get-pairs-not + append script \n [string map [list $valglob] { + # set active_key_type "dict" index_operation: globvalue-get-pairs-not + set assigned [dict create] + tcl::dict::for {k v} $leveldata { + if {![string match {} $v]} { + dict set assigned $k $v + } + } + }] + } else { + lappend INDEX_OPERATIONS globvalue-get-pairs + append script \n [string map [list $valglob] { + # set active_key_type "dict" index_operation: globvalue-get-pairs + set assigned [dict create] + tcl::dict::for {k v} $leveldata { + if {[string match {} $v]} { + dict set assigned $k $v + } + } + }] + } + set level_script_complete 1 + } + {@V\*@*} - {@v\*@*} { + #dict value glob - return values + set active_key_type dict + set valglob [string range $index 4 end] + append script [tstr -return string -allowcommands { + if {[catch {dict size $leveldata}]} { + ${[tstr -ret string $tpl_return_mismatch_not_a_dict]} + } + }] + if {$get_not} { + lappend INDEX_OPERATIONS globvalue-get-values-not + append script \n [string map [list $valglob] { + # set active_key_type "dict" ;# index_operation: globvalue-get-values-not + set assigned [list] + tcl::dict::for {k v} $leveldata { + if {![string match {} $v]} { + lappend assigned $v + } + } + }] + + } else { + lappend INDEX_OPERATIONS globvalue-get-values + append script \n [string map [list $valglob] { + # set active_key_type "dict" ;#index_operation: globvalue-get-value + set assigned [dict values $leveldata ] + }] + } + set level_script_complete 1 + + } + {@\*\*@*} { + #dict val/key glob return pairs) + set active_key_type "dict" + set keyvalglob [string range $index 4 end] + append script [tstr -return string -allowcommands { + if {[catch {dict size $leveldata}]} { + ${[tstr -ret string $tpl_return_mismatch_not_a_dict]} + } + }] + if {$get_not} { + lappend INDEX_OPERATIONS globkeyvalue-get-pairs-not + error "globkeyvalue-get-pairs-not todo" + } 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 assigned [dict create] + tcl::dict::for {k v} $leveldata { + if {[string match {} $k] || [string match {} $v]} { + dict set assigned $k $v + } + } + }] + } + set level_script_complete 1 + puts stderr "globkeyvalue-get-pairs review" + } + @* { + set active_key_type "list" + set do_bounds_check 1 + + set index [string trimleft $index @] + append script \n [string map [list $index] { + # set active_key_type "list" index_operation: ? + set index + }] + } + %split-* { + #split on one or more chars - review + #set hidekey 1 + #lassign [split $key -] _ splitchars + #set thisval [split $dval $splitchars] + set active_key_type "string" + set splitchars [string range $index 7 end] + append script \n [string map [list $splitchars] { + # set active_key_type "string" index_operation: split-string + #e.g supports %split-"\\n"= "l1\n\nl3" -> {l1 "" l3} + set splitchars "" + set assigned [split $leveldata $splitchars] + }] + puts "---split script: $script" + set level_script_complete 1 + + #todo %splitat- %splitn- ?? + } + %lpad-* { + #moved from punk::lib::showdict patterns. + #set hidekey 1 + #lassign [split $key -] _ extra + #set width [expr {[textblock::width $dval] + $extra}] + #set thisval [textblock::pad $dval -which left -width $width] + set active_key_type "string" + set extra [string range $index 6 end] + append script \n [string map [list $extra] { + # set active_key_type "string" index_operation: lpad-string + set extra "" + set width [expr {[textblock::width $leveldata] + $extra}] + set assigned [textblock::pad $leveldata -which left -width $width] + }] + set level_script_complete 1 + } + %* { + #see above re %lpad- etc and synchronizing with showdict + set active_key_type "string" + set do_bounds_check 0 + set index [string range $index 1 end] + append script \n [string map [list $index] { + # set active_key_type "string" index_operation: ? + set index + }] + } + default { + puts "destructure_func_build_body unmatched index $index" + } + } + } + } + + if {!$level_script_complete} { + + + #keyword 'pipesyntax' at beginning of error message + set listmsg "pipesyntax Unable to interpret subindex $index\n" + append listmsg "selector: '$selector'\n" + append listmsg "@ must be followed by a selector (possibly compound separated by forward slashes) suitable for lindex or lrange commands, or a not-x expression\n" + append listmsg "Additional accepted keywords include: head tail\n" + append listmsg "Use var@@key to treat value as a dict and retrieve element at key" + + #append script \n [string map [list $listmsg] {set listmsg ""}] + + + + #we can't just set 'assigned' for a position spec for in/ni (not-in) because we don't have the value here to test against + #need to set a corresponding action + if {$active_key_type in [list "" "list"]} { + set active_key_type "list" + append script \n {# set active_key_type "list"} + #for pattern matching purposes - head/tail not valid on empty lists (similar to elixir) + switch -exact -- $index { + 0 { + if {$get_not} { + append script \n "# index_operation listindex-int-not" \n + lappend INDEX_OPERATIONS listindex-zero-not + set assignment_script {set assigned [lrange $leveldata 1 end]} + } else { + lappend INDEX_OPERATIONS listindex-zero + set assignment_script {set assigned [lindex $leveldata 0]} + if {$do_bounds_check} { + append script \n "# index_operation listindex-int (bounds checked)" \n + append script \n [tstr -return string -allowcommands { + if {[catch {llength $leveldata} len]} { + ${[tstr -ret string $tpl_return_mismatch_not_a_list]} + } elseif {[llength $leveldata] == 0} { + ${[tstr -ret string $tpl_return_mismatch_list_index_out_of_range_empty]} + } else { + ${$assignment_script} + } + }] + } else { + append script \n "# index_operation listindex-int" \n + append script \n [tstr -return string -allowcommands { + if {[catch {llength $leveldata} len]} { + ${[tstr -ret string $tpl_return_mismatch_not_a_list]} + } else { + ${$assignment_script} + } + }] + } + } + } + head { + #NOTE: /@head and /head both do bounds check. This is intentional + if {$get_not} { + append script \n "# index_operation listindex-head-not" \n + lappend INDEX_OPERATIONS listindex-head-not + set assignment_script {set assigned [lrange $leveldata 1 end]} + } else { + append script \n "# index_operation listindex-head" \n + lappend INDEX_OPERATIONS listindex-head + set assignment_script {set assigned [lindex $leveldata 0]} + } + append script \n [tstr -return string -allowcommands { + if {[catch {llength $leveldata} len]} { + #set action ?mismatch-not-a-list + ${[tstr -ret string $tpl_return_mismatch_not_a_list]} + } elseif {$len == 0} { + #set action ?mismatch-list-index-out-of-range-empty + ${[tstr -ret string $tpl_return_mismatch_list_index_out_of_range_empty]} + } else { + #alias for 0 - for h@head,t@tail= similar to erlang/elixir hd() tl() or [head | tail] = list syntax + ${$assignment_script} + } + }] + } + end { + if {$get_not} { + append script \n "# index_operation listindex-end-not" \n + lappend INDEX_OPERATIONS listindex-end-not + #on single element list Tcl's lrange will do what we want here and return nothing + set assignment_script {set assigned [lrange $leveldata 0 end-1]} + } else { + append script \n "# index_operation listindex-end" \n + lappend INDEX_OPERATIONS listindex-end + set assignment_script {set assigned [lindex $leveldata end]} + } + if {$do_bounds_check} { + append script \n [tstr -return string -allowcommands { + if {[catch {llength $leveldata} len]} { + #set action ?mismatch-not-a-list + ${[tstr -ret string $tpl_return_mismatch_not_a_list]} + } elseif {$len == 0} { + #set action ?mismatch-list-index-out-of-range + ${[tstr -ret string $tpl_return_mismatch_list_index_out_of_range_empty]} + } else { + ${$assignment_script} + } + }] + } else { + append script \n [tstr -return string -allowcommands { + if {[catch {llength $leveldata} len]} { + #set action ?mismatch-not-a-list + ${[tstr -ret string $tpl_return_mismatch_not_a_list]} + } else { + ${$assignment_script} + } + }] + } + } + tail { + #NOTE: /@tail and /tail both do bounds check. This is intentional. + # + #tail is a little different in that we allow tail on a single element list - returning an empty result - but it can't be called on an empty list + #arguably tail could be considered as an index-out-of-range for less than 2 elements - but this would be less useful, and surprising to those coming from other pattern-matching systems. + #In this way tail is different to @1-end + if {$get_not} { + append script \n "# index_operation listindex-tail-not" \n + lappend INDEX_OPERATIONS listindex-tail-not + set assignment_script {set assigned [lindex $leveldata 0]} + } else { + append script \n "# index_operation listindex-tail" \n + lappend INDEX_OPERATIONS listindex-tail + set assignment_script {set assigned [lrange $leveldata 1 end] ;#return zero or more elements - but only if there is something (a head) at position zero} + } + append script \n [tstr -return string -allowcommands { + if {[catch {llength $leveldata} len]} { + #set action ?mismatch-not-a-list + ${[tstr -ret string $tpl_return_mismatch_not_a_list]} + } elseif {$len == 0} { + #set action ?mismatch-list-index-out-of-range + ${[tstr -ret string $tpl_return_mismatch_list_index_out_of_range_empty]} + } else { + ${$assignment_script} + } + }] + } + anyhead { + #allow returning of head or nothing if empty list + if {$get_not} { + append script \n "# index_operation listindex-anyhead-not" \n + lappend INDEX_OPERATIONS listindex-anyhead-not + set assignment_script {set assigned [lrange $leveldata 1 end]} + } else { + append script \n "# index_operation listindex-anyhead" \n + lappend INDEX_OPERATIONS listindex-anyhead + set assignment_script {set assigned [lindex $leveldata 0]} + } + append script \n [tstr -return string -allowcommands { + if {[catch {llength $leveldata} len]} { + #set action ?mismatch-not-a-list + ${[tstr -ret string $tpl_return_mismatch_not_a_list]} + } else { + ${$assignment_script} + } + }] + } + anytail { + #allow returning of tail or nothing if empty list + #anytail will return empty both for empty list, or single element list - but potentially useful in combination with anyhead. + if {$get_not} { + append script \n "# index_operation listindex-anytail-not" \n + lappend INDEX_OPERATIONS listindex-anytail-not + set assignment_script {set assigned [lindex $leveldata 0]} + } else { + append script \n "# index_operation listindex-anytail" \n + lappend INDEX_OPERATIONS listindex-anytail + set assignment_script {set assigned [lrange $leveldata 1 end]} + } + append script \n [tstr -return string -allowcommands { + if {[catch {llength $leveldata} len]} { + #set action ?mismatch-not-a-list + ${[tstr -ret string $tpl_return_mismatch_not_a_list]} + } else { + ${$assignment_script} + } + }] + } + init { + #all but last element - same as haskell 'init' + #counterintuitively, get-notinit can therefore return first element if it is a single element list + #does bounds_check for get-not@init make sense here? maybe - review + if {$get_not} { + append script \n "# index_operation listindex-init-not" \n + lappend INDEX_OPERATIONS listindex-init-not + set assignment_script {set assigned [lindex $leveldata end]} + } else { + append script \n "# index_operation listindex-init" \n + lappend INDEX_OPERATIONS listindex-init + set assignment_script {set assigned [lrange $leveldata 0 end-1]} + } + append script \n [tstr -return string -allowcommands { + if {[catch {llength $leveldata} len]} { + #set action ?mismatch-not-a-list + ${[tstr -ret string $tpl_return_mismatch_not_a_list]} + } else { + ${$assignment_script} + } + }] + } + list { + #get_not? + #allow returning of entire list even if empty + if {$get_not} { + lappend INDEX_OPERATIONS list-getall-not + set assignment_script {set assigned {}} + } else { + lappend INDEX_OPERATIONS list-getall + set assignment_script {set assigned $leveldata} + } + append script \n [tstr -return string -allowcommands { + if {[catch {llength $leveldata} len]} { + #set action ?mismatch-not-a-list + ${[tstr -ret string $tpl_return_mismatch_not_a_list]} + } else { + ${$assignment_script} + } + }] + } + raw { + #get_not - return nothing?? + #no list checking.. + if {$get_not} { + lappend INDEX_OPERATIONS getraw-not + append script \n {set assigned {}} + } else { + lappend INDEX_OPERATIONS getraw + append script \n {set assigned $leveldata} + } + } + keys { + #@get_not?? + #need active_key_type of 'list' for 'keys' and 'values' keywords which act on either dict or a list with even number of elements + if {$get_not} { + lappend INDEX_OPERATIONS list-getkeys-not + set assignment_script {set assigned [dict values $leveldata]} ;#not-keys is equivalent to values + } else { + lappend INDEX_OPERATIONS list-getkeys + set assignment_script {set assigned [dict keys $leveldata]} + } + append script \n [tstr -return string -allowcommands { + if {[catch {dict size $leveldata} dsize]} { + #set action ?mismatch-not-a-dict + ${[tstr -ret string $tpl_return_mismatch_not_a_dict]} + } else { + ${$assignment_script} + } + }] + } + values { + #get_not ?? + #need active_key_type of 'list' for 'keys' and 'values' keywords which act on either dict or a list with even number of elements + if {$get_not} { + lappend INDEX_OPERATIONS list-getvalues-not + set assignment_script {set assigned [dict keys $leveldata]} ;#not-values is equivalent to keys + } else { + lappend INDEX_OPERATIONS list-getvalues + set assignment_script {set assigned [dict values $leveldata]} + } + append script \n [tstr -return string -allowcommands { + if {[catch {dict size $leveldata} dsize]} { + #set action ?mismatch-not-a-dict + ${[tstr -ret string $tpl_return_mismatch_not_a_dict]} + } else { + ${$assignment_script} + } + }] + } + pairs { + #get_not ?? + if {$get_not} { + #review - return empty list instead like not-list and not-raw? + error $listmsg "destructure $selector" [list pipesyntax destructure selector $selector not-pairs_not_supported] + } else { + lappend INDEX_OPERATIONS list-getpairs + } + append script \n [tstr -return string -allowcommands { + if {[catch {dict size $leveldata} dsize]} { + #set action ?mismatch-not-a-dict + ${[tstr -ret string $tpl_return_mismatch_not_a_dict]} + } else { + set pairs [list] + tcl::dict::for {k v} $leveldata {lappend pairs [list $k $v]} + set assigned [lindex [list $pairs [unset pairs]] 0] + } + }] + } + default { + if {[regexp {[?*]} $index]} { + if {$get_not} { + lappend INDEX_OPERATIONS listsearch-not + set assign_script [string map [list $index] { + set assigned [lsearch -all -inline -not $leveldata ] + }] + } else { + lappend INDEX_OPERATIONS listsearch + set assign_script [string map [list $index] { + set assigned [lsearch -all -inline $leveldata ] + }] + } + append script \n [tstr -return string -allowcommands { + if {[catch {llength $leveldata} len]} { + ${[tstr -ret string $tpl_return_mismatch_not_a_list]} + } else { + ${$assign_script} + } + }] + } elseif {[string is integer -strict $index]} { + if {$get_not} { + lappend INDEX_OPERATIONS listindex-not + set assign_script [string map [list $index] { + #not- was specified (already handled not-0) + set assigned [lreplace $leveldata ] + }] + } else { + lappend INDEX_OPERATIONS listindex + set assign_script [string map [list $index] {set assigned [lindex $leveldata ]}] + } + + if {$do_bounds_check} { + if {$index < 0} { + error $listmsg "destructure $selector" [list pipesyntax destructure selector $selector index_lessthanzero_out_of_bounds_for_all_data_while_bounds_check_on] + } + set max [expr {$index + 1}] + append script \n [tstr -return string -allowcommands { + if {[catch {llength $leveldata} len]} { + #set action ?mismatch-not-a-list + ${[tstr -ret string $tpl_return_mismatch_not_a_list]} + } else { + # bounds_check due to @ directly specified in original index section + if {${$max} > $len} { + #set action ?mismatch-list-index-out-of-range + ${[tstr -ret string $tpl_return_mismatch_list_index_out_of_range]} + } else { + ${$assign_script} + } + } + }] + } else { + append script \n [tstr -return string -allowcommands { + if {[catch {llength $leveldata} len]} { + #set action ?mismatch-not-a-list + ${[tstr -ret string $tpl_return_mismatch_not_a_list]} + } else { + ${$assign_script} + } + }] + } + } elseif {[punk::lib::is_indexset $index]} { + #review - a basic math statement such as 5-1 is also a valid member of an indexset + #see punk::lib::is_indexset and punk::lib::indexset_resolve + #single element of an indexset - e.g @..3 or @1..5 or @..end or @.. or @end..0 or @end-5..8 etc + set is_range [expr {[string first ".." $index] >= 0}] + if {$get_not} { + if {$is_range} { + lappend INDEX_OPERATIONS list-range-not + } else { + lappend INDEX_OPERATIONS listindex-not + } + set assign_script { + set assigned [lremove $assigned {*}[punk::lib::indexset_resolve [llength $leveldata] ]] + } + } else { + if {$is_range} { + lappend INDEX_OPERATIONS list-range + #todo - if we know it's a contiguous range, we could use lrange here instead of lindex + #we would also need to detect if it's a reverse range such as @5..1 and handle that correctly + #- lrange doesn't support reverse ranges, but we could resolve the indexset to a list of indices + #and then use lindex with that list of indices to get the correct result. + #we don't always know at this point if the range is in reverse or not because we don't know the size of the list until + #runtime - so we will handle both cases in the same way for now. + #e.g for index 5..end-6 - this could be forward or reverse depending on the length of the list. + set assign_script { + set assigned [lmap i [punk::lib::indexset_resolve [llength $leveldata] ] {lindex $leveldata $i}] + } + } else { + lappend INDEX_OPERATIONS listindex + set assign_script { + set assigned [lindex $leveldata [punk::lib::indexset_resolve [llength $leveldata] ]] + } + } + } + + if {$do_bounds_check} { + #bounds check each element of the resolved indexset - if any are out of bounds, return mismatch-list-index-out-of-range + if {$is_range} { + append script \n [tstr -return string -allowcommands { + if {[catch {llength $leveldata} len]} { + #set action ?mismatch-not-a-list + ${[tstr -ret string $tpl_return_mismatch_not_a_list]} + } else { + lassign [split ..] idx1 _ idx2 + set v2 [punk::lib::lindex_resolve_basic $len $idx2] + if {isinf($v2)} { + ${[tstr -ret string $tpl_return_mismatch_list_index_out_of_range]} + } + set v1 [punk::lib::lindex_resolve_basic $len $idx1] + if {isinf($v1)} { + ${[tstr -ret string $tpl_return_mismatch_list_index_out_of_range]} + } + ${$assign_script} + } + }] + } else { + append script \n [tstr -return string -allowcommands { + if {[catch {llength $leveldata} len]} { + #set action ?mismatch-not-a-list + ${[tstr -ret string $tpl_return_mismatch_not_a_list]} + } else { + set v1 [punk::lib::lindex_resolve_basic $len ] + if {isinf($v1)} { + ${[tstr -ret string $tpl_return_mismatch_list_index_out_of_range]} + } + ${$assign_script} + } + }] + } + } else { + append script \n [tstr -return string -allowcommands { + if {[catch {llength $leveldata} len]} { + #set action ?mismatch-not-a-list + ${[tstr -ret string $tpl_return_mismatch_not_a_list]} + } else { + ${$assign_script} + } + }] + } + set script [string map [list $index] $script] + } elseif {[string first "end" $index] >=0} { + #review - obsoleted by indexset syntax. prune branch? + puts stderr "index with end detected - review if this branch still reachable - prune? $index" + if {[regexp {^end([-+]{1,2}[0-9]+)$} $index _match endspec]} { + + if {$get_not} { + lappend INDEX_OPERATIONS listindex-endoffset-not + set assign_script [string map [list $index] { + #not- was specified (already handled not-0) + set assigned [lreplace $leveldata ] + }] + } else { + lappend INDEX_OPERATIONS listindex-endoffset + set assign_script [string map [list $index ] {set assigned [lindex $leveldata ]}] + } + + if {$do_bounds_check} { + #tstr won't add braces - so the ${$endspec} value inserted in the expr will remain unbraced as required in this case. + append script \n [tstr -return string -allowcommands { + if {[catch {llength $leveldata} len]} { + set action ?mismatch-not-a-list + } else { + #bounds-check is true + #leave the - from the end- as part of the offset + set offset [expr ${$endspec}] ;#don't brace! + if {($offset > 0 || abs($offset) >= $len)} { + #set action ?mismatch-list-index-out-of-range + ${[tstr -ret string $tpl_return_mismatch_list_index_out_of_range]} + } else { + ${$assign_script} + } + } + }] + } else { + append script \n [tstr -ret string -allowcommands { + if {[catch {llength $leveldata} len]} { + #set action ?mismatch-not-a-list + ${[tstr -ret string $tpl_return_mismatch_not_a_list]} + } else { + ${$assign_script} + } + }] + } + + } elseif {[regexp {^([0-9]+|end|end[-+]{1,2}[0-9]+)-([0-9]+|end|end[-+]{1,2}([0-9]+))$} $index _ start end]} { + #review - obsoleted by indexset syntax. prune branch? + puts stderr "index with range and end detected - review if this branch still reachable - prune? $index" + if {$get_not} { + lappend INDEX_OPERATIONS list-range-not + set assign_script [string map [list $start $end ] { + #not- was specified (already handled not-0) + set assigned [lreplace $leveldata ] + }] + } else { + lappend INDEX_OPERATIONS list-range + set assign_script [string map [list $start $end] {set assigned [lrange $leveldata ]}] + } + + append script \n [tstr -ret string -allowcommands { + if {[catch {llength $leveldata} len]} { + #set action ?mismatch-not-a-list + ${[tstr -ret string $tpl_return_mismatch_not_a_list]} + } + }] + + if {$do_bounds_check} { + if {[string is integer -strict $start]} { + if {$start < 0} { + error $listmsg "destructure $selector" [list pipesyntax destructure selector $selector start_lessthanzero_out_of_bounds_for_all_data_while_bounds_check_on] + } + append script \n [tstr -return string -allowcommands { + set start ${$start} + if {$start+1 > $len} { + #set action ?mismatch-list-index-out-of-range + ${[tstr -ret string $tpl_return_mismatch_list_index_out_of_range]} + } + }] + } elseif {$start eq "end"} { + #noop + } else { + set startoffset [string range $start 3 end] ;#include the - from end- + set startoffset [expr $startoffset] ;#don't brace! + if {$startoffset > 0} { + #e.g end+1 + error $listmsg "destructure $selector" [list pipesyntax destructure selector $selector end+x_out_of_bounds_for_all_data_while_bounds_check_on] + + } + append script \n [tstr -return string -allowcommands { + set startoffset ${$startoffset} + if {abs($startoffset) >= $len} { + #set action ?mismatch-list-index-out-of-range + ${[tstr -ret string $tpl_return_mismatch_list_index_out_of_range]} + } + }] + } + if {[string is integer -strict $end]} { + if {$end < 0} { + error $listmsg "destructure $selector" [list pipesyntax destructure selector $selector end_lessthanzero_out_of_bounds_for_all_data_while_bounds_check_on] + } + append script \n [tstr -return string -allowcommands { + set end ${$end} + if {$end+1 > $len} { + #set action ?mismatch-list-index-out-of-range + ${[tstr -ret string $tpl_return_mismatch_list_index_out_of_range]} + } + }] + } elseif {$end eq "end"} { + #noop + } else { + set endoffset [string range $end 3 end] ;#include the - from end- + + set endoffset [expr $endoffset] ;#don't brace! + if {$endoffset > 0} { + error $listmsg "destructure $selector" [list pipesyntax destructure selector $selector end+x_out_of_bounds_for_all_data_while_bounds_check_on] + } + append script \n [tstr -return string -allowcommands { + set endoffset ${$endoffset} + if {abs($endoffset) >= $len} { + #set action ?mismatch-list-index-out-of-range + ${[tstr -ret string $tpl_return_mismatch_list_index_out_of_range]} + } + }] + } + } + + append script \n [string map [list $assign_script] { + if {![string match ?mismatch-* $action]} { + + } + }] + + } else { + #fail now - no need for script + error $listmsg "destructure $selector" [list pipesyntax destructure selector $selector] + } + } elseif {[string first - $index] > 0} { + puts stderr "index with - detected - review if this branch still reachable - prune? $index" + #review - we changed to detect indexset above. + #syntax @m-n should be deprecated in favour of @m..n + #todo - check if this branch still reachable - prune? + #e.g @1-3 gets here + #JMN + if {$get_not} { + lappend INDEX_OPERATIONS list-range-not + } else { + lappend INDEX_OPERATIONS list-range + } + + append script \n [tstr -return string -allowcommands { + if {[catch {llength $leveldata} len]} { + #set action ?mismatch-not-a-list + ${[tstr -ret string $tpl_return_mismatch_not_a_list]} + } + }] + + #handle pure int-int ranges separately + set testindex [string map [list - "" + ""] $index] + if {[string is digit -strict $testindex]} { + #don't worry about leading - negative value for indices not valid anyway + set parts [split $index -] + if {[llength $parts] != 2} { + error $listmsg "destructure $selector" [list pipesyntax destructure selector $selector] + } + lassign $parts start end + + #review - Tcl lrange just returns nothing silently. + #if we don't intend to implement reverse indexing - we should probably not emit an error + if {$start > $end} { + puts stderr "pipesyntax for selector $selector error - reverse index unimplemented" + error $listmsg "destructure $selector" [list pipesyntax destructure selector $selector] + } + if {$do_bounds_check} { + #append script [string map [list $start $end] { + # set start + # set end + # if {$start+1 > $len || $end+1 > $len} { + # set action ?mismatch-list-index-out-of-range + # } + #}] + #set eplusone [expr {$end+1}] + append script [tstr -return string -allowcommands { + if {$len < ${[expr {$end+1}]}} { + set action ?mismatch-list-index-out-of-range + ${[tstr -ret string $tpl_return_mismatch_list_index_out_of_range]} + } + }] + } + + + if {$get_not} { + set assign_script [string map [list $start $end] { + #not- was specified (already handled not-0) + set assigned [lreplace $leveldata ] + }] + } else { + set assign_script [string map [list $start $end] {set assigned [lrange $leveldata ]}] + } + + + } else { + error $listmsg "destructure $selector" [list pipesyntax destructure selector $selector] + } + + append script \n [string map [list $assign_script] { + if {![string match ?mismatch-* $action]} { + + } + }] + + } else { + #keyword 'pipesyntax' at beginning of error message + #pipesyntax error - no need to even build script - can fail now + error $listmsg "destructure $selector" [list pipesyntax destructure selector $selector] + } + } + } + } elseif {$active_key_type eq "string"} { + #changed to indexset notation m..n allowing eg 2..end-1 etc. + #if {[string match *-* $index]} {} + + if {[punk::lib::is_indexset $index]} { + #review - we are assuming a single element indexset here - ie no comma separated sets. + + #todo - support $get_not + #todo - consider bounds_check for string indices. + # - Tcl doesn't do bounds checking for string index, but we need to consider in the context of pattern-matching + # whether we want to support syntaxes for with and without bounds checking on string indices. + + set is_range [expr {[string first ".." $index] >= 0}] + if {$is_range} { + lappend INDEX_OPERATIONS string-range + #review - not efficient for contiguous monotonically increasing ranges + #because we are retrievinng each character individually and concatenating + #- but it is more flexible because it also supports reverse ranges and could support non-contiguous ranges such as @0,2,4..6 + set assign_script { + set assigned [join [lmap i [punk::lib::indexset_resolve [string length $leveldata] ] {string index $leveldata $i}] ""] + } + } else { + lappend INDEX_OPERATIONS string-index + set assign_script { + set assigned [string index $leveldata [punk::lib::indexset_resolve [string length $leveldata] ]] + } + } + + #set assign_script { + # set assigned [lmap i [punk::lib::indexset_resolve [llength $leveldata] ] {lindex $leveldata $i}] + #} + + #todo - consider where/if we can support 'ansistring INDEX' for ANSI strings. + #if so - it shouldn't overload the % operator we currently use for string access. + append script \n [tstr -return string -allowcommands { + if {$leveldata eq ""} { + set assigned "" + } else { + ${$assign_script} + } + }] + set script [string map [list $index] $script] + + + #set re_idxdashidx {^([-+]{0,1}\d+|end[-+]{1}\d+|end)-([-+]{0,1}\d+|end[-+]{1}\d+|end)$} + ##todo - support more complex indices: 0-end-1 etc + + #lassign [split $index -] a b + #append script \n [tstr -return string -allowcommands { + # # set active_key_type "string" + # set assigned [string range $leveldata ${$a} ${$b}] + #}] + + } else { + if {$index eq "*"} { + #equivalent to indexset ".." + lappend INDEX_OPERATIONS string-all + append script \n [tstr -return string -allowcommands { + # set active_key_type "string" + set assigned $leveldata + }] + } elseif {[regexp {[?*]} $index]} { + lappend INDEX_OPERATIONS string-globmatch + append script \n [tstr -return string -allowcommands { + # set active_key_type "string" + if {[string match $index $leveldata]} { + set assigned $leveldata + } else { + set assigned "" + } + }] + } else { + lappend INDEX_OPERATIONS string-index + append script \n [tstr -return string -allowcommands { + # set active_key_type "string" + set assigned [string index $leveldata ${$index}] + }] + } + } + + } else { + #treat as dict key + if {$get_not} { + #dict remove can accept non-existent keys.. review do we require not-@?@key to get silence? + append script \n [tstr -return string { + set assigned [dict remove $leveldata ${$index}] + }] + } else { + append script \n [tstr -return string -allowcommands { + # set active_key_type "dict" + if {[dict exists $leveldata {${$index}}]} { + set assigned [dict get $leveldata {${$index}}] + } else { + set action ?mismatch-dict-key-not-found + ${[tstr -ret string $tpl_return_mismatch_dict_key_not_found]} + } + }] + } + + } + + + } ;# end if $level_script_complete + + + append script \n { + set leveldata $assigned + } + incr i_keyindex + append script \n "# ------- END index $index ------" + } ;# end foreach + + + + #puts stdout "----> destructure rep leveldata: [rep $leveldata]" + #puts stdout ">> destructure returning: [dict create -assigned $leveldata -action $action -lhs $lhs -rhs $rhs]" + + #maintain key order - caller unpacks using lassign + #append script \n {dict create -assigned $leveldata -action $action -lhs $lhs -rhs $rhs} + append script \n [tstr -return string $return_template] \n + return $script + } + + + + + #called from match_assign/know_dot_assign for lhs of assignment - uplevel 2 to caller's level + #called from match_assign/know_dot_assign for rhs pipelined vars - uplevel 1 to write vars only in 'apply' scope + #return a dict with keys result, setvars, unsetvars + #TODO - implement cross-binding (as opposed to overwrite/reassignment) when a var appears multiple times in a pattern/multivar + #e.g x@0,x@1 will only match if value at positions 0 & 1 is the same (a form of auto-pinning?) + #e.g x,x@0 will only match a single element list + #todo blocking or - p1|p2 if p1 matches - return p1 and continue pipeline - immediately return p2 if p1 didn't match. (ie p2 not forwarded in pipeline) + # non-blocking or - p1||p2 if p1 matches - return p1 and continue pipeline - else match p2 and continue pipeline + proc _multi_bind_result {multivar data args} { + #puts stdout "---- _multi_bind_result multivar:'$multivar' data:'$data' options:'$args'" + #'ismatch' must always be first element of dict - as we dispatch on ismatch 0 or ismatch 1 + if {![string length $multivar]} { + #treat the absence of a pattern as a match to anything + #JMN2 - changed to list based destructuring + return [dict create ismatch 1 result $data setvars {} script {}] + #return [dict create ismatch 1 result [list $data] setvars {} script {}] + } + set returndict [dict create ismatch 0 result "" setvars {}] + set script "" + + set defaults [list -unset 0 -levelup 2 -mismatchinfo 1 -script 0] + set opts [dict merge $defaults $args] + set unset [dict get $opts -unset] + set lvlup [dict get $opts -levelup] + set get_mismatchinfo [dict get $opts -mismatchinfo] + + + + #first classify into var_returntype of either "pipeline" or "segment" + #segment returntype is indicated by leading % + + set varinfo [punk::pipe::lib::_var_classify $multivar] + set var_names [dict get $varinfo var_names] + set var_class [dict get $varinfo var_class] + set varspecs_trimmed [dict get $varinfo varspecs_trimmed] + + set var_actions [list] + set expected_values [list] + #e.g {a = abc} {b set ""} + foreach classinfo $var_class vname $var_names { + lassign [lindex $classinfo 0] v + lappend var_actions [list $v "" ""] ;#varactions keeps original lhs - not trimmed version + lappend expected_values [list var $vname spec $v info - lhs - rhs -] ;#code looks for 'info -' to see if changed from default + } + + #puts stdout "var_actions: $var_actions" + #puts stdout "expected_values: $expected_values" + + + #puts stdout "\n var_class: $var_class\n" + # e.g {{x {}} 0} {{y @0} 0} {{'ok @0} 1} {{^v @@key} 2} + + #set varspecs_trimmed [lmap varinfo $var_class {expr {([lindex $varinfo 1] > 0) ? [list [string range [lindex $varinfo 0 0] 1 end] [lindex $varinfo 0 1]] : [lindex $varinfo 0]}}] + #puts stdout "\n varspecs_trimmed: $varspecs_trimmed\n" + + + #var names (possibly empty portion to the left of ) + #debug.punk.pipe.var "varnames: $var_names" 4 + + set v_list_idx(@) 0 ;#for spec with single @ only + set v_dict_idx(@@) 0 ;#for spec with @@ only + + #jn + + #member lists of returndict which will be appended to in the initial value-retrieving loop + set returndict_setvars [dict get $returndict setvars] + + set assigned_values [list] + + + #varname action value - where value is value to be set if action is set + #actions: + # "" unconfigured - assert none remain unconfigured at end + # noop no-change + # matchvar-set name is a var to be matched + # matchatom-set names is an atom to be matched + # matchglob-set + # set + # question mark versions are temporary - awaiting a check of action vs var_class + # e.g ?set may be changed to matchvar or matchatom or set + + + debug.punk.pipe.var {initial map expected_values: $expected_values} 5 + + set returnval "" + set i 0 + #assertion i incremented at each continue and at each end of loop - at end i == list length + 1 + #always use 'assigned' var in each loop + # (for consistency and to assist with returnval) + # ^var means a pinned variable - compare value of $var to rhs - don't assign + # + # In this loop we don't set variables - but assign an action entry in var_actions - all with leading question mark. + # as well as adding the data values to the var_actions list + # + # TODO! we may (commonly) encounter same vkey in the pattern - no need to reparse and re-fetch from data! + set vkeys_seen [list] + foreach v_and_key $varspecs_trimmed { + set vspec [join $v_and_key ""] + lassign $v_and_key v vkey + + set assigned "" + #The binding spec begins at first @ or # or / + + #set firstq [string first "'" $vspec] + #set v [lindex $var_names $i] + #if v contains any * and/or ? - then it is a glob match - not a varname + + lassign [destructure_func $vkey $data] _assigned assigned _action matchaction _lhs lhs _rhs rhs + if {$matchaction eq "?match"} { + set matchaction "?set" + } + lset var_actions $i 1 $matchaction + lset var_actions $i 2 $assigned + + #update the setvars/unsetvars elements + if {[string length $v]} { + dict set returndict_setvars $v $assigned + } + + #JMN2 + #special case expansion for empty varspec (e.g , or ,,) + #if {$vspec eq ""} { + # lappend assigned_values {*}$assigned + #} else { + lappend assigned_values $assigned + #} + incr i + } + + #todo - fix! this isn't the actual tclvars that were set! + dict set returndict setvars $returndict_setvars + + #assigned_values is the ordered list of source elements in the data (rhs) as extracted by each position-spec + #For booleans the final val may later be normalised to 0 or 1 + + + #assertion all var_actions were set with leading question mark + #perform assignments only if matched ok + + + #0 - novar + #1 - atom ' + #2 - pin ^ + #3 - boolean & + #4 - integer + #5 - double + #6 - var + #7 - glob (no classifier and contains * or ?) + if 0 { + debug.punk.pipe.var {VAR_CLASS: $var_class} 5 + debug.punk.pipe.var {VARACTIONS: $var_actions} 5 + debug.punk.pipe.var {VARSPECS_TRIMMED: $varspecs_trimmed} 5 + + debug.punk.pipe.var {atoms: [lsearch -all -inline -index 1 $var_class 1]} 5 + debug.punk.pipe.var {pins: [lsearch -all -inline -index 1 $var_class 2]} 5 + debug.punk.pipe.var {bools: [lsearch -all -inline -index 1 $var_class 3]} 5 + debug.punk.pipe.var {ints: [lsearch -all -inline -index 1 $var_class 4]} 5 + debug.punk.pipe.var {doubles: [lsearch -all -inline -index 1 $var_class 5]} 5 + debug.punk.pipe.var {vars: [lsearch -all -inline -index 1 $var_class 6]} 5 + debug.punk.pipe.var {globs: [lsearch -all -inline -index 1 $var_class 7]} 5 + } + + set match_state [lrepeat [llength $var_names] ?] + unset -nocomplain v + unset -nocomplain nm + set mismatched [list] + set i 0 + #todo - stop at first mismatch - for pattern matching (especially pipecase - we don't want to waste time reading vars if we already have a mismatch earlier in the pattern) + foreach va $var_actions { + #val comes from -assigned + lassign $va lhsspec act val ;#lhsspec is the full value source for LHS ie the full atom/number/varspec e.g for pattern ^var@@key/@0 it is "^var" + set varname [lindex $var_names $i] + + if {[string match "?mismatch*" $act]} { + #already determined a mismatch - e.g list or dict key not present + lset match_state $i 0 + lset expected_values $i [list var $varname spec $lhsspec info mismatch lhs ? rhs $val] + break + } + + + set class_key [lindex $var_class $i 1] + lassign {0 0 0 0 0 0 0 0 0 0} isatom ispin isbool isint isdouble isvar isglob isnumeric isgreaterthan islessthan + foreach ck $class_key { + switch -- $ck { + 1 {set isatom 1} + 2 {set ispin 1} + 3 {set isbool 1} + 4 {set isint 1} + 5 {set isdouble 1} + 6 {set isvar 1} + 7 {set isglob 1} + 8 {set isnumeric 1} + 9 {set isgreaterthan 1} + 10 {set islessthan 1} + } + } + + + #set isatom [expr {$class_key == 1}] + #set ispin [expr {2 in $class_key}] + #set isbool [expr {3 in $class_key}] + #set isint [expr {4 in $class_key}] + #set isdouble [expr {5 in $class_key}] + #set isvar [expr {$class_key == 6}] + #set isglob [expr {7 in $class_key}] + #set isnumeric [expr {8 in $class_key}] ;#force numeric comparison (only if # classifier present) + ##marking numbers with pin ^ has undetermined meaning. Perhaps force expr matching only? + #set isgreaterthan [expr {9 in $class_key}] + #set islessthan [expr {10 in $class_key}] + + + + if {$isatom} { + #puts stdout "==>isatom $lhsspec" + set lhs [string range $lhsspec 1 end] + if {[string index $lhs end] eq "'"} { + set lhs [string range $lhs 0 end-1] + } + lset var_actions $i 1 matchatom-set + if {$lhs eq $val} { + lset match_state $i 1 + lset expected_values $i [list var $varname spec $lhsspec info match lhs $lhs rhs $val] + incr i + continue + } else { + lset match_state $i 0 + lset expected_values $i [list var $varname spec $lhsspec info strings-not-equal lhs $lhs rhs $val] + break + } + } + + + + + # - should set expected_values in each branch where match_state is not set to 1 + # - setting expected_values when match_state is set to 0 is ok except for performance + + + #todo - pinned booleans? we would need to disambiguate from a direct value match.. ie double tag as something like: ^&var or + #ispin may reclassify as isint,isdouble based on contained value (as they don't have their own classifier char and are unambiguous and require special handling) + if {$ispin} { + #puts stdout "==>ispin $lhsspec" + if {$act in [list "?set" "?matchvar-set"]} { + lset var_actions $i 1 matchvar-set + #attempt to read + upvar $lvlup $varname the_var + #if {![catch {uplevel $lvlup [list ::set $varname]} existingval]} {} + if {![catch {set the_var} existingval]} { + + if {$isbool} { + #isbool due to 2nd classifier i.e ^& + lset expected_values $i [list var $varname spec $lhsspec info test-lhs-bool lhs $existingval rhs $val] + #normalise to LHS! + lset assigned_values $i $existingval + } elseif {$isglob} { + #isglob due to 2nd classifier ^* + lset expected_values $i [list var $varname spec $lhsspec info test-lhs-glob lhs $existingval rhs $val] + } elseif {$isnumeric} { + #flagged as numeric by user using ^# classifiers + set testexistingval [join [scan $existingval %lld%s] ""] ;# handles octals (leading zeros), ok for use with bignums, internal decimal points and sci notation (but not leading .) + if {[string is integer -strict $testexistingval]} { + set isint 1 + lset assigned_values $i $existingval + lset expected_values $i [list var $varname spec $lhsspec info test-lhs-int lhs $existingval rhs $val] + } elseif {[string is double $existingval] || [string is double -strict $testexistingval]} { + #test existingval in case something like .5 (which scan will have missed - producing empty testexistingval) + set isdouble 1 + #doubles comparisons use float_almost_equal - so lhs can differ from rhs - for pins we always want to return the normalised lhs ie exactly what is in the var + lset assigned_values $i $existingval + + lset expected_values $i [list var $varname spec $lhsspec info test-lhs-double lhs $existingval rhs $val] + } else { + #user's variable doesn't seem to have a numeric value + lset match_state $i 0 + lset expected_values $i [list var $varname spec $lhsspec info mismatch-lhs-not-numeric lhs $existingval rhs $val] + break + } + + } else { + #standard pin - single classifier ^var + lset match_state $i [expr {$existingval eq $val}] + if {![lindex $match_state $i]} { + lset match_state $i 0 + lset expected_values $i [list var $varname spec $lhsspec info "string-compare-not-equal" lhs $existingval rhs $val] + break + } else { + lset expected_values $i [list var $varname spec $lhsspec info "string-compare-equal" lhs $existingval rhs $val] + } + } + + } else { + #puts stdout "pinned var $varname result:$result vs val:$val" + #failure is *probably* because var is unset - but could be a read-only var due to read-trace or it could be nonexistant namespace + lset match_state $i 0 + lset expected_values $i [list var $varname spec $lhsspec info failread-$varname lhs ? rhs $val] + break + } + } + } + + + + if {$isint} { + #note - we can have classified (above) a value such as 08 on lhs as integer - even though expr and string is integer don't do so. + #expected_values $i [list var $varname spec $lhsspec info match-lhs-int lhs $existingval rhs $val] + + if {$ispin} { + set existing_expected [lindex $expected_values $i] + set lhs [dict get $existing_expected lhs] + } else { + set lhs $lhsspec ;#literal integer in the pattern + } + if {$isgreaterthan || $islessthan} { + set lhs [string range $lhsspec 0 end-1] + set testlhs $lhs + } + if {[string index $lhs 0] eq "."} { + set testlhs $lhs + } else { + set testlhs [join [scan $lhs %lld%s] ""] + } + if {[string index $val 0] eq "."} { + set testval $val + } else { + set testval [join [scan $val %lld%s] ""] ;# handles octals (leading zeros) and bignums (not leading .) + } + if {[string is integer -strict $testval]} { + if {$isgreaterthan} { + #puts "lhsspec: $lhsspec testlhs: $testlhs testval: $testval" + if {$testlhs <= $testval} { + lset match_state $i 1 + } else { + lset match_state $i 0 + lset expected_values $i [list var $varname spec $lhsspec info "expr-not-greater-than-int-int" lhs $lhs rhs $val] + break + } + } elseif {$islessthan} { + if {$testlhs >= $testval} { + lset match_state $i 1 + } else { + lset match_state $i 0 + lset expected_values $i [list var $varname spec $lhsspec info "expr-not-less-than-int-int" lhs $lhs rhs $val] + break + } + } else { + if {$testlhs == $testval} { + lset match_state $i 1 + } else { + lset match_state $i 0 + lset expected_values $i [list var $varname spec $lhsspec info "expr-mismatch-int-int" lhs $lhs rhs $val] + break + } + } + } elseif {[string is double -strict $testval]} { + #dragons. (and shimmering) + if {[string first "e" $val] != -1} { + #scientific notation - let expr compare + if {$isgreaterhthan} { + if {$testlhs <= $testval} { + lset match_state $i 1 + } else { + lset match_state $i 0 + lset expected_values $i [list var $varname spec $lhsspec info "expr-not-greater-than-int-sci" lhs $lhs rhs $val] + break + } + } elseif {$islessthan} { + if {$testlhs >= $testval} { + lset match_state $i 1 + } else { + lset match_state $i 0 + lset expected_values $i [list var $varname spec $lhsspec info "expr-not-less-than-int-sci" lhs $lhs rhs $val] + break + } + } else { + if {$testlhs == $testval} { + lset match_state $i 1 + } else { + lset match_state $i 0 + lset expected_values $i [list var $varname spec $lhsspec info "expr-mismatch-int-sci" lhs $lhs rhs $val] + break + } + } + } elseif {[string is digit -strict [string trim $val -]] } { + #probably a wideint or bignum with no decimal point + #It seems odd that bignums which just look like large integers should ever compare equal if you do a +1 to one side . + #if we use float_almost_equal they may compare equal. on the other hand expr also does apparently inconsistent thins with comparing integer-like bignums vs similar sized nums with .x at the end. + #2 values further apart can compare equal while int-like ones closer together can compare different. + #The rule seems to be for bignums that if it *looks* like a whole int the comparison is exact - but otherwise the float behaviours kick in. + #This is basically what we're doing here but with an arguably better (for some purposes!) float comparison. + #string comparison can presumably always be used as an alternative. + # + #let expr compare + if {$isgreaterthan} { + if {$testlhs <= $testval} { + lset match_state $i 1 + } else { + lset match_state $i 0 + lset expected_values $i [list var $varname spec $lhsspec info "expr-not-greater-than-int-puredigits" lhs $lhs rhs $val] + break + } + } elseif {$islessthan} { + if {$testlhs >= $testval} { + lset match_state $i 1 + } else { + lset match_state $i 0 + lset expected_values $i [list var $varname spec $lhsspec info "expr-not-less-than-int-puredigits" lhs $lhs rhs $val] + break + } + } else { + if {$testlhs == $testval} { + lset match_state $i 1 + } else { + lset match_state $i 0 + lset expected_values $i [list var $varname spec $lhsspec info "expr-mismatch-int-puredigits" lhs $lhs rhs $val] + break + } + } + } else { + if {[punk::pipe::float_almost_equal $testlhs $testval]} { + lset match_state $i 1 + } else { + if {$isgreaterthan} { + if {$testlhs <= $testval} { + lset match_state $i 1 + } else { + lset match_state $i 0 + lset expected_values $i [list var $varname spec $lhsspec info "expr-not-greater-than-int-float" lhs $lhs rhs $val] + break + } + } elseif {$islessthan} { + if {$testlhs >= $testval} { + lset match_state $i 1 + } else { + lset match_state $i 0 + lset expected_values $i [list var $varname spec $lhsspec info "expr-not-less-than-int-float" lhs $lhs rhs $val] + break + } + } else { + lset match_state $i 0 + lset expected_values $i [list var $varname spec $lhsspec info "float_almost_equal-mismatch-int-float" lhs $lhs rhs $val] + break + } + } + } + } else { + #e.g rhs not a number.. + if {$testlhs == $testval} { + lset match_state $i 1 + } else { + lset match_state $i 0 + lset expected_values $i [list var $varname spec $lhsspec info "expr-mismatch-unknown-rhstestval-$testval" lhs $lhs rhs $val] + break + } + } + } elseif {$isdouble} { + #dragons (and shimmering) + # + # + if {$ispin} { + set existing_expected [lindex $expected_values $i] + set lhs [dict get $existing_expected lhs] + } else { + set lhs $lhsspec ;#literal integer in the pattern + } + if {$isgreaterthan || $islessthan} { + error "+/- not yet supported for lhs float" + set lhs [string range $lhsspec 0 end-1] + set testlhs $lhs + } + if {[string index $val 0] eq "."} { + set testval $val ;#not something with some number of leading zeros + } else { + set testval [join [scan $val %lld%s] ""] ;# handles octals (leading zeros), ok for use with bignums, internal decimal points and sci notation (but not leading .) + } + #expr handles leading 08.1 0009.1 etc without triggering octal + #so we don't need to scan lhs + if {[string first "e" $lhs] >= 0 || [string first "e" $testval] >= 0} { + if {$lhs == $testval} { + lset match_state $i 1 + lset expected_values $i [list var $varname spec $lhsspec info match-expr-sci lhs $lhs rhs $val] + } else { + lset match_state $i 0 + lset expected_values $i [list var $varname spec $lhsspec info mismatch-expr-sci lhs $lhs rhs $val] + break + } + } elseif {[string is digit -strict [string trim $lhs -]] && [string is digit -strict [string trim $val -]]} { + #both look like big whole numbers.. let expr compare using it's bignum capability + if {$lhs == $testval} { + lset match_state $i 1 + lset expected_values $i [list var $varname spec $lhsspec info match-expr-pure-digits lhs $lhs rhs $val] + } else { + lset match_state $i 0 + lset expected_values $i [list var $varname spec $lhsspec info mismatch-expr-pure-digits lhs $lhs rhs $val] + break + } + } else { + #float_almost_equal will disagree with expr based on scale.. just enough to allow for example [expr 0.2 + 0.1] to equal 0.3 - whereas expr will declare a mismatch + if {[punk::pipe::float_almost_equal $lhs $testval]} { + lset match_state $i 1 + lset expected_values $i [list var $varname spec $lhsspec info match-float-almost-equal lhs $lhs rhs $val] + } else { + lset match_state $i 0 + lset expected_values $i [list var $varname spec $lhsspec info mismatch-float-almost-equal lhs $lhs rhs $val] + break + } + } + } elseif {$isbool} { + #Note - cross binding of booleans deliberately doesn't compare actual underlying values - only that truthiness or falsiness matches. + #e.g &x/0,&x/1,&x/2= {1 2 yes} + # all resolve to true so the cross-binding is ok. + # Also - the setting of the variable x is normalized to 1 or 0 only. (true & false would perhaps be nicer - but 1 & 0 are theoretically more efficient for later comparisons as they can have a pure int rep?.) + # todo - consider the booleanString rep. Can/should we return true & false instead and maintain efficiency w.r.t shimmering? + # + #punk::pipe::boolean_equal $a $b + set extra_match_info "" ;# possible crossbind indication + set is_literal_boolean 0 + if {$ispin} { + #for a pinned boolean - the most useful return is the value in the pinned var rather than the rhs. This is not entirely consistent .. e.g pinned numbers will return rhs !review! + #As an additional pattern can always retrieve the raw value - pinned vars returning themselves (normalisation use-case ) seems the most consistent overall, and the most useful + set existing_expected [lindex $expected_values $i] + set lhs [dict get $existing_expected lhs] + } else { + set lhs [string range $lhsspec 1 end] ;# - strip off & classifier prefix + + if {![string length $lhs]} { + #empty varname - ok + if {[string is boolean -strict $val] || [string is double -strict $val]} { + lset match_state $i 1 + lset var_actions $i 1 "return-normalised-value" + lset assigned_values $i [expr {bool($val)}] + lset expected_values $i [list var $varname spec $lhsspec info "return-boolean-rhs-normalised" lhs - rhs $val] + } else { + lset match_state $i 0 + lset expected_values $i [list var $varname spec $lhsspec info "mismatch-boolean-rhs" lhs - rhs $val] + break + } + } elseif {$lhs in [list 0 1]} { + #0 & 1 are the only literal numbers that satisfy Tcl's 'string is boolean' test. + set is_literal_boolean 1 + } elseif {[string index $lhs 0] eq "'" && [string index $lhs end] eq "'"} { + #literal boolean (&'yes',&'false',&'1',&'0' etc) in the pattern + #we won't waste any cycles doing an extra validity test here - it will fail in the comparison below if not a string understood by Tcl to represent a boolean. + set is_literal_boolean 1 + set lhs [string range $lhs 1 end-1] ;#strip off squotes + } else { + #todo - a standard variable name checking function for consistency.. for now we'll rule out numbers here to help avoid mistakes. + set tclvar $lhs + if {[string is double $tclvar]} { + error "pipesyntax invalid variable name '$tclvar' for boolean in pattern. (subset of legal tcl vars allowed in pattern context)" "_multi_bind_result $multivar $data $args" [list pipesyntax patternvariable invalid_boolean $tclvar] + #proc _multi_bind_result {multivar data args} + } + #treat as variable - need to check cross-binding within this pattern group + set first_bound [lsearch -index 0 $var_actions $lhsspec] + if {$first_bound == $i} { + #test only rhs (val) for boolean-ness - but boolean-ness as boolean_almost_equal understands it. (e.g floats allowed) + if {[string is boolean -strict $val] || [string is double -strict $val]} { + lset match_state $i 1 + lset var_actions $i 1 [string range $act 1 end] ;# should now be the value "set". We only need this on the first_bound + #review - consider what happens if boolean is leftmost pattern - underlying value vs normalised value to continue in pipeline + #Passing underlying value is inconsistent with what goes in the tclvar - so we need to update the returnval + #puts stderr "==========[lindex $assigned_values $i]" + lset var_actions $i 2 [expr {bool($val)}] ;#normalise to 1 or 0 + lset assigned_values $i [lindex $var_actions $i 2] + #puts stderr "==========[lindex $assigned_values $i]" + lset expected_values $i [list var $varname spec $lhsspec info "match-boolean-rhs-any-lhs" lhs - rhs $val] ;#retain underlying val in expected_values for diagnostics. + } else { + lset match_state $i 0 + lset expected_values $i [list var $varname spec $lhsspec info "mismatch-boolean-rhs-any-lhs" lhs - rhs $val] + break + } + } else { + set expectedinfo [lindex $expected_values $first_bound] + set expected_earlier [dict get $expectedinfo rhs] + set extra_match_info "-crossbind-first" + set lhs $expected_earlier + } + } + } + + + #may have already matched above..(for variable) + if {[lindex $match_state $i] != 1} { + if {![catch {punk::pipe::boolean_almost_equal $lhs $val} ismatch]} { + if {$ismatch} { + lset match_state $i 1 + lset expected_values $i [list var $varname spec $lhsspec info match-boolean-almost-equal$extra_match_info lhs $lhs rhs $val] + } else { + lset match_state $i 0 + lset expected_values $i [list var $varname spec $lhsspec info mismatch-boolean-almost-equal$extra_match_info lhs $lhs rhs $val] + break + } + } else { + #we should only error from boolean_equal if passed something Tcl doesn't recognise as a boolean + lset match_state $i 0 + lset expected_values $i [list var $varname spec $lhsspec info badvalue-boolean$extra_match_info lhs $lhs rhs $val] + break + } + } + + } elseif {$isglob} { + if {$ispin} { + set existing_expected [lindex $expected_values $i] + set lhs [dict get $existing_expected lhs] + } else { + set lhs $lhsspec ;#literal glob in the pattern - no classifier prefix + } + if {[string match $lhs $val]} { + lset match_state $i 1 + lset expected_values $i [list var $varname spec $lhsspec info "match-glob" lhs $lhs rhs $val] + } else { + lset match_state $i 0 + lset expected_values $i [list var $varname spec $lhsspec info "mismatch-glob" lhs $lhs rhs $val] + break + } + + } elseif {$ispin} { + #handled above.. leave case in place so we don't run else for pins + + } else { + #puts stdout "==> $lhsspec" + #NOTE - pinned var of same name is independent! + #ie ^x shouldn't look at earlier x bindings in same pattern + #unpinned non-atoms + #cross-binding. Within this multivar pattern group only (use pin ^ for binding to result from a previous pattern) + # + switch -- $varname { + "" { + #don't attempt cross-bind on empty-varname + lset match_state $i 1 + #don't change var_action $i 1 to set + lset expected_values $i [list var $varname spec $lhsspec info "match-no-lhs-var" lhs - rhs $val] + } + "_" { + #don't cross-bind on the special 'don't-care' varname + lset match_state $i 1 + lset var_actions $i 1 [string range $act 1 end] ;# ?set -> set + lset expected_values $i [list var $varname spec $lhsspec info "match-any-lhs-dontcare-var" lhs - rhs $val] + } + default { + set first_bound [lsearch -index 0 $var_actions $varname] + #assertion first_bound >=0, we will always find something - usually self + if {$first_bound == $i} { + lset match_state $i 1 + lset var_actions $i 1 [string range $act 1 end] ;# ?set -> set + lset expected_values $i [list var $varname spec $lhsspec info "match-any-lhs" lhs - rhs $val] + } else { + assert {$first_bound < $i} assertion_fail: _multi_bind_result condition: [list $first_bound < $i] + set expectedinfo [lindex $expected_values $first_bound] + set expected_earlier [dict get $expectedinfo rhs] + if {$expected_earlier ne $val} { + lset match_state $i 0 + lset expected_values $i [list var $varname spec $lhsspec info "mismatch-crossbind-first" lhs $expected_earlier rhs $val] + break + } else { + lset match_state $i 1 + #don't convert ?set to set - or var setter will write for each crossbound instance. Possibly no big deal for performance - but could trigger unnecessary write traces for example + #lset var_actions $i 1 [string range $act 1 end] + lset expected_values $i [list var $varname spec $lhsspec info "match-crossbind-first" lhs $expected_earlier rhs $val] + } + } + } + } + } + + incr i + } + + #JMN2 - review + #set returnval [lindex $assigned_values 0] + if {[llength $assigned_values] == 1} { + set returnval [join $assigned_values] + } else { + set returnval $assigned_values + } + #puts stdout "----> > rep returnval: [rep $returnval]" + + + + + + #-------------------------------------------------------------------------- + #Variable assignments (set) should only occur down here, and only if we have a match + #-------------------------------------------------------------------------- + set match_count_needed [llength $var_actions] + #set match_count [expr [join $match_state +]] ;#expr must be unbraced here + set matches [lsearch -all -inline $match_state 1] ;#default value for each match_state entry is "?" + set match_count [llength $matches] + + + debug.punk.pipe.var {MATCH_STATE: $match_state count_needed: $match_count_needed vs match_count: $match_count} 4 + debug.punk.pipe.var {VARACTIONS2: $var_actions} 5 + debug.punk.pipe.var {EXPECTED : $expected_values} 4 + + #set match_count [>f . foldl 0 [>f . sum .] $match_state] ;#ok method.. but slow compared to expr with join + if {$match_count == $match_count_needed} { + #do assignments + for {set i 0} {$i < [llength $var_actions]} {incr i} { + if {([lindex $var_class $i 1] == 6 || [lindex $var_class $i] == 3 ) && ([string length [set varname [lindex $var_names $i]]])} { + #isvar + if {[lindex $var_actions $i 1] eq "set"} { + upvar $lvlup $varname the_var + set the_var [lindex $var_actions $i 2] + } + } + } + dict set returndict ismatch 1 + #set i 0 + #foreach va $var_actions { + # #set isvar [expr {[lindex $var_class $i 1] == 6}] + # if {([lindex $var_class $i 1] == 6 || [lindex $var_class $i] == 3 ) && ([string length [set varname [lindex $var_names $i]]])} { + # #isvar + # lassign $va lhsspec act val + # upvar $lvlup $varname the_var + # if {$act eq "set"} { + # set the_var $val + # } + # #if {[lindex $var_actions $i 1] eq "set"} { + # # set the_var $val + # #} + # } + # incr i + #} + } else { + #todo - some way to restrict mismatch info to simple "mismatch" and avoid overhead of verbose message + #e.g for within pipeswitch block where mismatches are expected and the reasons are less important than moving on quickly + set vidx 0 + #set mismatches [lmap m $match_state v $var_names {expr {$m == 0} ? {[list mismatch $v]} : {[list match $v]}}] + set mismatches [lmap m $match_state v $var_names {expr {$m == 0 ? [list mismatch $v] : [list match $v]}}] + set var_display_names [list] + foreach v $var_names { + if {$v eq ""} { + lappend var_display_names {{}} + } else { + lappend var_display_names $v + } + } + #REVIEW 2025 + #set mismatches_display [lmap m $match_state v $var_display_names {expr {$m == 0} ? {$v} : {[expr {$m eq "?"} ? {"?[string repeat { } [expr [string length $v] -1]]"} : {[string repeat " " [string length $v]]} ]}}] + set mismatches_display [lmap m $match_state v $var_display_names {expr {$m == 0 ? $v : [expr {$m eq "?" ? "?[string repeat { } [expr {[string length $v] -1}]]" : [string repeat " " [string length $v]] }]}}] + set msg "\n" + append msg "Unmatched\n" + append msg "Cannot match right hand side to pattern $multivar\n" + append msg "vars/atoms/etc: $var_names\n" + append msg "mismatches: [join $mismatches_display { } ]\n" + set i 0 + #0 - novar + #1 - atom ' + #2 - pin ^ + #3 - boolean & + #4 - integer + #5 - double + #6 - var + #7 - glob (no classifier and contains * or ?) + foreach mismatchinfo $mismatches { + lassign $mismatchinfo status varname + if {$status eq "mismatch"} { + # varname can be empty string + set varclass [lindex $var_class $i 1] + set val [lindex $var_actions $i 2] + set e [dict get [lindex $expected_values $i] lhs] + set type "" + if {2 in $varclass} { + append type "pinned " + } + + if {$varclass == 1} { + set type "atom" + } elseif {$varclass == 2} { + set type "pinned var" + } elseif {3 in $varclass} { + append type "boolean" + } elseif {4 in $varclass} { + append type "int" + } elseif {5 in $varclass} { + append type "double" + } elseif {$varclass == 6} { + set type "var" + } elseif {7 in $varclass} { + append type "glob" + } elseif {8 in $varclass} { + append type "numeric" + } + if {$type eq ""} { + set type "" + } + + set lhs_tag "- [dict get [lindex $expected_values $i] info]" + set mmaction [lindex $var_actions $i 1] ;#e.g ?mismatch-dict-index-out-of-range + set tag "?mismatch-" + if {[string match $tag* $mmaction]} { + set mismatch_reason [string range $mmaction [string length $tag] end] + } else { + set mismatch_reason $mmaction + } + append msg " $type: '$varname' $mismatch_reason $lhs_tag LHS: '$e' vs RHS: '$val'\n" + } + incr i + } + #error $msg + dict unset returndict result + #structured error return - used by pipeswitch/pipecase - matching on "binding mismatch*" + dict set returndict mismatch [dict create binding mismatch varnames $var_names matchinfo $mismatches display $msg data $data] + return $returndict + } + + if {![llength $var_names]} { + #var_name entries can be blank - but it will still be a list + #JMN2 + #dict set returndict result [list $data] + dict set returndict result $data + } else { + assert {$i == [llength $var_names]} assertion_fail _multi_bind_result condition {$i == [llength $var_names]} + dict set returndict result $returnval + } + return $returndict + } + + ######################################################## + # dragons. + # using an error as out-of-band way to signal mismatch is the easiest. + # It comes at some cost (2us 2023?) to trigger catches. (which is small relative to uncompiled pipeline costs in initial version - but per pattern mismatch will add up) + # The alternative of attempting to tailcall return the mismatch as data - is *hard* if not impossible to get right. + # We need to be able to match on things like {error {mismatch etc}} - without it then itself being interpreted as a mismatch! + # A proper solution may involve a callback? tailcall some_mismatch_func? + # There may be a monad-like boxing we could do.. to keep it in data e.g {internalresult match } {internalresult mismatch } and be careful to not let boxed data escape ?? + # make sure there is good test coverage before experimenting with this + proc _handle_bind_result {d} { + #set match_caller [info level 2] + #debug.punk.pipe {_handle_bind_result match_caller: $match_caller} 9 + if {![dict exists $d result]} { + #uplevel 1 [list error [dict get $d mismatch]] + #error [dict get $d mismatch] + return -code error -errorcode [list binding mismatch varnames [dict get $d mismatch varnames]] [dict get $d mismatch] + } else { + return [dict get $d result] + } + } + # initially promising - but the approach runs into impossible disambiguation of mismatch as data vs an actual mismatch + proc _handle_bind_result_experimental1 {d} { + #set match_caller [info level 2] + #debug.punk.pipe {_handle_bind_result match_caller: $match_caller} 9 + if {![dict exists $d result]} { + tailcall return [dict get $d mismatch] + } else { + return [dict get $d result] + } + } + ######################################################## + + #timings very similar. listset3 closest in performance to pipeset. review - test on different tcl versions. + #Unfortunately all these variations seem around 10x slower than 'set list {a b c}' or 'set list [list a b c]' + #there seems to be no builtin for list setting with args syntax. lappend is close but we would need to catch unset the var first. + #proc listset1 {listvarname args} { + # tailcall set $listvarname $args + #} + #interp alias {} listset2 {} apply {{vname args} {tailcall set $vname $args}} + #interp alias {} listset3 {} apply {{vname args} {upvar $vname v; set v $args}} + proc pipeset {pipevarname args} { + upvar $pipevarname the_pipe + set the_pipe $args + } + + #pipealias should capture the namespace context of the pipeline so that commands are resolved in the namespace in which the pipealias is created + proc pipealias {targetcmd args} { + set cmdcopy [punk::valcopy $args] + set nscaller [uplevel 1 [list ::tcl::namespace::current]] + tailcall interp alias {} $targetcmd {} apply [list args [append cmdcopy " {*}\$args"] $nscaller] + } + proc pipealias_extract {targetcmd} { + set applybody [lindex [interp alias "" $targetcmd] 1 1] + #strip off trailing " {*}$args" + return [lrange [string range $applybody 0 end-9] 0 end] + } + #although the pipealias2 'concat' alias is cleaner in that the original pipeline can be extracted using list commands - it runs much slower + proc pipealias2 {targetcmd args} { + set cmdcopy [punk::valcopy $args] + set nscaller [uplevel 1 [list ::tcl::namespace::current]] + tailcall interp alias {} $targetcmd {} apply [list args [concat "\[concat" [list $cmdcopy] "\$args]"] $nscaller] + } + + + #same as used in unknown func for initial launch + #variable re_assign {^([^\r\n=\{]*)=(.*)} + #variable re_assign {^[\{]{0,1}([^ \t\r\n=]*)=(.*)} + variable re_assign {^([^ \t\r\n=\{]*)=(.*)} + variable re_dot_assign {^([^ \t\r\n=\{]*)\.=(.*)} + #match_assign is tailcalled from unknown - uplevel 1 gets to caller level + proc match_assign {scopepattern equalsrhs args} { + #review - :: is legal in atoms! + if {[string match "*::*" $scopepattern]} { + error "match_assign scopepattern '$scopepattern' contains namespace separator '::' - invalid." + } + #puts stderr ">> match_assign '$scopepattern=$equalsrhs' $args" + set fulltail $args + set cmdns ::punk::pipecmds + set namemapping [punk::pipe::lib::pipecmd_namemapping $equalsrhs] + + #we deliberately don't call pipecmd_namemapping on the scopepattern even though it may contain globs. REVIEW + #(we need for example x*= to be available as is via namespace path mechanism (from punk::pipecmds namespace)) + + set pipecmd ${cmdns}::$scopepattern=$namemapping + + #pipecmd could have glob chars - test $pipecmd in the list - not just that info commands returns results. + if {$pipecmd in [info commands $pipecmd]} { + #puts "==nscaller: '[uplevel 1 [list namespace current]]'" + #uplevel 1 [list ::namespace import $pipecmd] + set existing_path [uplevel 1 [list ::tcl::namespace::path]] + if {$cmdns ni $existing_path} { + uplevel 1 [list ::tcl::namespace::path [concat $existing_path $cmdns]] + } + tailcall $pipecmd {*}$args + } + + + #NOTE: + #we need to ensure for case: + #= x=y + #that the second arg is treated as a raw value - never a pipeline command + + #equalsrhs is set if there is a segment-insertion-pattern *directly* after the = + #debug.punk.pipe {match_assign '$multivar' '$equalsrhs' '$fulltail'} 4 + #can match pattern on lhs with a value where pattern is a minilang that can refer to atoms (simple non-whitespace strings), numbers, or varnames (possibly pinned) as well as a trailing spec for position within the data. + + # allow x=insertionpattern to begin a pipeline e.g x= |> string tolower ? or x=1 a b c <| X to produce a X b c + # + #to assign an entire pipeline to a var - use pipeset varname instead. + + # in our script's handling of args: + #avoid use of regexp match on each element - or we will unnecessarily force string reps on lists + #same with lsearch with a string pattern - + #wouldn't matter for small lists - but we need to be able to handle large ones efficiently without unneccessary string reps + set script [string map [list [list $scopepattern] $equalsrhs] { + #script built by punk::match_assign + if {[llength $args]} { + #scan for existence of any pipe operator (|*> or <*|) only - we don't need position + #all pipe operators must be a single element + #we don't first check llength args == 1 because for example: + # x= <| + # x= |> + #both leave x empty. To assign a pipelike value to x we would have to do: x= <| |> (equiv: set x |>) + set scopep + foreach a $args { + if {![catch {llength $a} sublen]} { + #don't enforce sublen == 1. Legal to have whitespace including newlines {| x >} + if {[string match |*> $a] || [string match <*| $a]} { + tailcall punk::pipeline = $scopep "" {*}$args + } + } + } + if {[llength $args] == 1} { + set segmenttail [lindex $args 0] + } else { + error "pipedata = must take a single argument. Got [llength $args] args: '$args'" "match_assign $args" [list pipedata segment too_many_elements segment_type =] + } + } else { + #set segmenttail [purelist] + set segmenttail [lreplace x 0 0] + } + }] + + + + + if {[string length $equalsrhs]} { + # as we aren't in a pipleine - there is no data to insert - we proably still need to run _split_equalsrhs to verify the syntax. + # review - consider way to turn it off as optimisation for non-pipelined assignment - but generally standard Tcl set could be used for that purpose. + # We are probably only here if testing in the repl - in which case the error messages are important. + set var_index_position_list [punk::pipe::lib::_split_equalsrhs $equalsrhs] + #we may have an insertion-spec that inserts a literal atom e.g to wrap in "ok" + # x='ok'>0/0 data + # => {ok data} + # we won't examine for vars as there is no pipeline - ignore + # also ignore trailing * (indicator for variable data to be expanded or not - ie {*}) + # we will differentiate between / and @ in the same way that general pattern matching works. + # /x will simply call linsert without reference to length of list + # @x will check for out of bounds + # + # !TODO - sort by position lowest to highest? or just require user to order the pattern correctly? + + + + foreach v_pos $var_index_position_list { + lassign $v_pos v indexspec positionspec + #e.g =v1/1>0 A pattern predator system) + # + #todo - review + # + # + #for now - the script only needs to handle the case of a single segment pipeline (no |> <|) + + + #temp - needs_insertion + #we can safely output no script for variable insertions for now - because if there was data available, + #we would have to be in a pipeline - in which case the script above would have delegated all our operations anyway. + #tag: positionspechandler + if {([string index $v 0] eq "'" && [string index $v end] eq "'") || [string is integer -strict $v]} { + #(for now)don't allow indexspec on a literal value baked into the pipeline - it doesn't really make sense + #- unless the pipeline construction has been parameterised somehow e.g "=${something}/0" + #review + if {[string length $indexspec]} { + error "pipesyntax literal value $v - index specification not allowed (match_assign)1" "match_assign $scopepattern $equalsrhs $args" [list pipesyntax index_on_literal] + } + if {[string index $v 0] eq "'" && [string index $v end] eq "'"} { + set datasource [string range $v 1 end-1] + } elseif {[string is integer -strict $v]} { + set datasource $v + } + append script [string map [list $datasource] { + set insertion_data "" ;#atom could have whitespace + }] + + set needs_insertion 1 + } elseif {$v eq ""} { + #default variable is 'data' + set needs_insertion 0 + } else { + append script [string map [list $v] { + #uplevel? + #set insertion_data [set ] + }] + set needs_insertion 0 + } + if {$needs_insertion} { + set script2 [punk::list_insertion_script $positionspec segmenttail ] + set script2 [string map [list "\$insertion_data" ] $script2] + append script $script2 + } + + + } + + + } + + if {![string length $scopepattern]} { + append script { + return $segmenttail + } + } else { + append script [string map [list $scopepattern] { + #we still need to bind whether list is empty or not to allow any patternmatch to succeed/fail + set d [punk::_multi_bind_result {} $segmenttail] + #return [punk::_handle_bind_result $d] + #maintenance: inlined + if {![dict exists $d result]} { + #uplevel 1 [list error [dict get $d mismatch]] + #error [dict get $d mismatch] + return -code error -level 1 -errorcode [list binding mismatch] [dict get $d mismatch] + } else { + return [dict get $d result] + } + }] + } + + debug.punk.pipe.compile {match_assign creating proc $pipecmd} 2 + uplevel 1 [list ::proc $pipecmd args $script] + set existing_path [uplevel 1 [list ::tcl::namespace::path]] + if {$cmdns ni $existing_path} { + uplevel 1 [list ::tcl::namespace::path [concat $existing_path $cmdns]] + } + tailcall $pipecmd {*}$args + } + + #return a script for inserting data into listvar + #review - needs updating for list-return semantics of patterns? + proc list_insertion_script {keyspec listvar {data }} { + set positionspec [string trimright $keyspec "*"] + set do_expand [expr {[string index $keyspec end] eq "*"}] + if {$do_expand} { + set exp {{*}} + } else { + set exp "" + } + #NOTE: linsert and lreplace can take multiple values at tail ie expanded data + + set ptype [string index $positionspec 0] + if {$ptype in [list @ /]} { + set index [string range $positionspec 1 end] + } else { + #the / is optional (default) at first position - and we have already discarded the ">" + set ptype "/" + set index $positionspec + } + #puts stderr ">> >> $index" + set script "" + set isint [string is integer -strict $index] + if {$index eq "."} { + #do nothing - this char signifies no insertion + } elseif {$isint || [regexp {^(end|end[-+]{1,2}[0-9]+)$} $index]} { + if {$ptype eq "@"} { + #compare position to *possibly updated* list - note use of $index > $datalen rather than $index+1 > $datalen - (we allow 'insertion' at end of list by numeric index) + if {$isint} { + append script [string map [list $listvar $index] { + if {( > [llength $])} { + #not a pipesyntax error + error "pipedata insertionpattern index out of bounds. index: vs len: [llength $] use /x instead of @x to avoid check (list_insertion_script)" "list_insertion_script $keyspec" [list pipedata insertionpattern index_out_f_bounds] + } + }] + } + #todo check end-x bounds? + } + #todo - change to ledit + #consider also $[set {}] instead of using unset + #see https://wiki.tcl-lang.org/page/K regarding Unsharing Objects + if {$isint} { + append script [string map [list $listvar $index $exp $data] { + set [linsert [lindex [list $ [unset ]] 0] ] + }] + } else { + append script [string map [list $listvar $index $exp $data] { + #use inline K to make sure the list is unshared (optimize for larger lists) + set [linsert [lindex [list $ [unset ]] 0] ] + }] + + } + } elseif {[string first / $index] < 0 && [string first - $index] > 0} { + if {[regexp {^([0-9]+|end|end[-+]{1,2}[0-9]+)-([0-9]+|end|end[-+]{1,2}([0-9]+))$} $index _ start end]} { + #also - range checks for @ which must go into script !!! + append script [string map [list $listvar $start $end $exp $data] { + set [lreplace [lindex [list $ [unset ]] 0] ] + }] + } else { + error "pipesyntax error in segment insertionpattern - positionspec:'$keyspec' unable to interpret position spec (list_insertion_script)2" "list_insertion_script $keyspec" [list pipedata insertionpattern_invalid] + } + } elseif {[string first / $index] >= 0} { + #nested insertion e.g /0/1/2 /0/1-1 + set parts [split $index /] + set last [lindex $parts end] + if {[string first - $last] >=0} { + lassign [split $last -] a b + if {![regexp {^([0-9]+|end|end[-+]{1,2}[0-9]+)-([0-9]+|end|end[-+]{1,2}([0-9]+))$} $last _ a b]} { + error "pipesyntax error in segment insertionpattern - positionspec:'$keyspec' unable to interpret position spec (list_insertion_script)3" "list_insertion_script $keyspec" [list pipesyntax insertionpattern_invalid] + } + if {$a eq $b} { + if {!$do_expand} { + #we can do an lset + set lsetkeys [list {*}[lrange $parts 0 end-1] $a] + append script [string map [list $listvar $lsetkeys $data] { + lset + }] + } else { + #we need to lreplace the containing item + append script [string map [list $listvar [lrange $parts 0 end-1] $a $data] { + set target [lindex $ ] + lset target {*} + lset $target + }] + } + } else { + #we need to lreplace a range at the target level + append script [string map [list $listvar [lrange $parts 0 end-1] $a $b $exp $data] { + set target [lindex $ ] + set target [lreplace $target ] + lset $target + }] + } + } else { + #last element has no -, so we are inserting at the final position - not replacing + append script [string map [list $listvar [lrange $parts 0 end-1] $last $exp $data] { + set target [lindex $ ] + #set target [linsert $target ] + ledit target -1 + lset $target + }] + } + + + } else { + error "pipesyntax error in segment - positionspec:'$keyspec' unable to interpret position spec (list_insertion_script)4" "list_insertion_script $keyspec" [list pipesyntax insertionpattern_invalid] + } + return $script + } + + + + + proc _is_math_func_prefix {e1} { + #also catch starting brackets.. e.g "(min(4,$x) " + if {[regexp {^[^[:alnum:]]*([[:alnum:]]*).*} $e1 _ word]} { + #possible math func + if {$word in [info functions]} { + return true + } + } + return false + } + + #todo - option to disable these traces which provide clarifying errors (performance hit?) + proc pipeline_args_read_trace_error {args} { + error "The pipelined data doesn't appear to be a valid Tcl list\nModify input, or use \$data or another variable name instead of \$args." "pipeline_args_read_trace_error $args" [list pipedata args_unavailable_data_not_a_list] + } + + + #NOTE: the whole idea of scanning for %x% is a lot of work(performance penalty) + #consider single placeholder e.g "_" as only positional indicator - for $data only - and require braced script with $var for more complex requirements + #possibly also *_ for expanded _ ? + #This would simplify code a lot - but also quite possible to collide with user data. + #Perhaps not a big deal as unbraced segments between |> are mainly(?) a convenience for readability/repl etc. + # (but importantly (at pipeline start anyway) unbraced segments are a mechanism to inject data from calling scope or from pipeline args <|) + # + #detect and retrieve %xxx% elements from item without affecting list/string rep + #commas, @, ', ^ and whitespace not part of a valid tag (allows some substitution within varspecs) + #%% is not a valid tag + #(as opposed to using regexp matching which causes string reps) + proc get_tags {item} { + set chars [split $item {}] + set terminal_chars [list , @ ' ^ " " \t \n \r] + #note % is both terminal and initiating - so for the algorithm we don't include it in the list of terminal_chars + set nonterminal [lmap v $chars {expr {$v ni $terminal_chars}}] + set percents [lmap v $chars {expr {$v eq "%"}}] + #useful for test/debug + #puts "CHARS : $chars" + #puts "NONTERMINAL: $nonterminal" + #puts "PERCENTS : $percents" + set sequences [list] + set in_sequence 0 + set start -1 + set end -1 + set i 0 + #todo - some more functional way of zipping/comparing these lists? + set s_length 0 ;#sequence length including % symbols - minimum for tag therefore 2 + foreach n $nonterminal p $percents { + if {!$in_sequence} { + if {$n & $p} { + set s_length 1 + set in_sequence 1 + set start $i + set end $i + } else { + set s_length 0 + } + } else { + if {$n ^ $p} { + incr s_length + incr end + } else { + if {$n & $p} { + if {$s_length == 1} { + # % followed dirctly by % - false start + #start again from second % + set s_length 1 + set in_sequence 1 + set start $i + set end $i + } else { + incr end + lappend sequences [list $start $end] + set in_sequence 0 + set s_length 0 + set start -1; set end -1 + } + } else { + #terminated - not a tag + set in_sequence 0 + set s_length 0 + set start -1; set end -1 + } + } + } + incr i + } + + set tags [list] + foreach s $sequences { + lassign $s start end + set parts [lrange $chars $start $end] + lappend tags [join $parts ""] + } + return $tags + } + + #show underlying rep of list and first level + proc rep_listname {lname} { + upvar $lname l + set output "$lname list rep: [rep $l]\n" + foreach item $l { + append output "-rep $item\n" + append output " [rep $item]\n" + } + return $output + } + + + # -- + #consider possible tilde templating version ~= vs .= + #support ~ and ~* placeholders only. + #e.g x~= list aa b c |> lmap v ~ {string length $v} |> tcl::mathfunc::max ~* + #The ~ being mapped to $data in the pipeline. + #This is more readable and simpler for beginners - although it doesn't handle more advanced insertion requirements. + #possibility to mix as we can already with .= and = + #e.g + #x.= list aa b c |> ~= lmap v ~ {string length $v} |> .=>* tcl::mathfunc::max + # -- + proc pipeline {segment_op initial_returnvarspec equalsrhs args} { + set fulltail $args + #unset args ;#leave args in place for error diagnostics + debug.punk.pipe {call pipeline: op:'$segment_op' '$initial_returnvarspec' '$equalsrhs' '$fulltail'} 4 + #debug.punk.pipe.rep {[rep_listname fulltail]} 6 + + + #review + set equalsrhs [string map [list {;} {\;}] $equalsrhs] + + + #--------------------------------------------------------------------- + # test if we have an initial x.=y.= or x.= y.= + + #nextail is tail for possible recursion based on first argument in the segment + #set nexttail [lassign $fulltail next1] ;#tail head + + set next1 [lindex $args 0] + switch -- $next1 { + pipematch { + set nexttail [lrange $args 1 end] + set results [uplevel 1 [list pipematch {*}$nexttail]] + debug.punk.pipe {>>> pipematch results: $results} 1 + + set d [_multi_bind_result $initial_returnvarspec $results] + return [_handle_bind_result $d] + } + pipecase { + set msg "pipesyntax\n" + append msg "pipecase does not return a value directly in the normal way\n" + append msg "It will return a casemismatch dict on mismatch\n" + append msg "But on a successful match - it will use an 'error' mechanism to return {ok result {something}} in the caller's scope -\n" + append msg "This will appear as an error in the repl, or disrupt pipeline result propagation if not in an appropriate wrapper\n" + append msg "Call pipecase from within a pipeline script block or wrapper such as pipeswitch or apply." + error $msg + } + } + + #temp - this is related to a script for the entire pipeline (functional composition) - not the script for the segment-based x=y or x.=y proc. + set ::_pipescript "" + + + + #NOTE: + #important that for assignment: + #= x=y .. + #The second element is always treated as a raw value - not a pipeline instruction. + #whereas... for execution: + #.= x=y the second element is a pipeline-significant symbol based on the '=' even if it was passed in as an argument. + #Usually an execution segment (.= cmd etc..) will have args inserted at the tail anyway - + #- but if the pipeline is designed to put an argument in the zero position - then presumably it is intended as a pipeline-significant element anyway + #This gives a *slight* incompatibility with external commands containing '=' - in that they may not work properly in pipelines + # + if {$segment_op ne "="} { + #handle for example: + #var1.= var2= "etc" |> string toupper + # + #var1 will contain ETC (from entire pipeline), var2 will contain etc (from associated segment) + # + + + if {([set nexteposn [string last = $next1]] >= 0)} { + set next1 [string map [list {;} {\;}] $next1] ;#review + #do we really need to test for script_shaped if last char is = ? + if {![punk::pipe::lib::arg_is_script_shaped $next1]} { + set nexttail [lrange $args 1 end] + #*SUB* pipeline recursion. + #puts "======> recurse based on next1:$next1 " + if {[string index $next1 $nexteposn-1] eq {.}} { + #var1.= var2.= ... + #non pipelined call to self - return result + set results [uplevel 1 [list $next1 {*}$nexttail]] + #debug.punk.pipe.rep {==> rep recursive results: [rep $results]} 5 + #debug.punk.pipe {>>> results: $results} 1 + return [_handle_bind_result [_multi_bind_result $initial_returnvarspec $results]] + } + #puts "======> recurse assign based on next1:$next1 " + #if {[regexp {^([^ \t\r\n=\{]*)=(.*)} $next1 _ nextreturnvarspec nextrhs]} { + #} + #non pipelined call to plain = assignment - return result + set results [uplevel 1 [list $next1 {*}$nexttail]] + #debug.punk.pipe {>>> results: $results} 1 + set d [_multi_bind_result $initial_returnvarspec $results] + return [_handle_bind_result $d] + } + } + } + + set procname $initial_returnvarspec.=$equalsrhs + + #--------------------------------------------------------------------- + + #todo add 'op' argument and handle both .= and = + # + #|> data piper symbol + #<| args piper symbol (arguments supplied at end of pipeline e.g from commandline or from calling and/or currying the command) + # + + set more_pipe_segments 1 ;#first loop + + #this contains the main %data% and %datalist% values going forward in the pipeline + #as well as any extra pipeline vars defined in each |> + #It also contains any 'args' with names supplied in <| + set dict_tagval [dict create] ;#cumulative %x% tag dict which operates on the whole length of the pipeline + + #determine if there are input args at the end of the pipeline indicated by reverse <| symbol possibly with argspecs e.g transform x y z =0} { + set tailremaining [lrange $fulltail 0 $firstargpipe_posn-1] + set argslist [lrange $fulltail $firstargpipe_posn+1 end] ;#Note that this could be a whole other pipeline with |> and/or <| elements. + set argpipe [lindex $fulltail $firstargpipe_posn] + set argpipespec [string range $argpipe 1 end-1] ;# strip off < & | from " b1 b2 b3 |outpipespec> c1 c2 c3 + # for a1 a2 a3 - the pipe to the right is actually an outpipespec and for c1 c2 c3 the pipe to the left is an inpipespec + + + #our initial command list always has *something* before we see any pipespec |> + #Therefore we initially have a blank inpipespec (although in effect, it comes from the argpipespec <|) + set inpipespec $argpipespec + set outpipespec "" + + #avoiding regexp on each arg to maintain list reps + #set tailmap [lmap v $tailremaining {lreplace [split $v {}] 1 end-1}] + ## set tailmap [lmap v $tailremaining {if {[regexp {^\|(.*)>$} $v _ outpipespec] && !$pipeseen} {set pipeseen 1;set outpipespec} {if {$pipeseen} {set v} 0}}] + #e.g for: a b c |> e f g |> h + #set firstpipe_posn [lsearch $tailmap {| >}] + + set firstpipe_posn [lsearch $tailremaining "|*>"] + + if {$firstpipe_posn >=0} { + set outpipespec [string range [lindex $tailremaining $firstpipe_posn] 1 end-1] + set segment_members [lrange $tailremaining 0 $firstpipe_posn-1] + #set tailremaining [lrange $tailremaining $firstpipe_posn+1 end] + set tailremaining [lreplace $tailremaining 0 $firstpipe_posn] ;#generally too short for any K combinator benefit? what about lists with scripts? is it dependent on list length or also element content size? + } else { + set segment_members $tailremaining + set tailremaining [list] + } + + + + set script_like_first_word 0 + set rhs $equalsrhs + + set segment_first_is_script 0 ;#default assumption until tested + + set segment_first_word [lindex $segment_members 0] + if {$segment_op ne "="} { + if {[punk::pipe::lib::arg_is_script_shaped $segment_first_word]} { + set segment_first_is_script 1 + } + } else { + if {[llength $segment_members] > 1} { + error "pipedata = can only accept a single argument (got: '$segment_members')" "pipeline $segment_op $initial_returnvarspec $equalsrhs $fulltail" [list pipedata too_many_elements] + #proc pipeline {segment_op initial_returnvarspec equalsrhs args} + } + set segment_members $segment_first_word + } + + + + #tailremaining includes x=y during the loop. + set returnvarspec $initial_returnvarspec + if {![llength $argslist]} { + unset -nocomplain previous_result ;# we want it unset for first iteration - differentiate from empty string + } else { + set previous_result $argslist + } + + set segment_result_list [list] + set i 0 ;#segment id + set j 1 ;#next segment id + set pipespec(args) $argpipespec ;# from trailing <| + set pipespec(0,in) $inpipespec + set pipespec(0,out) $outpipespec + + set max_iterations 100 ;# configurable? -1 for no limit ? This is primarily here to aid debugging of runaway loops in initial development .. should probably set to no-limit in final version. + while {$more_pipe_segments == 1} { + #--------------------------------- + debug.punk.pipe {[a yellow bold]i$i SEGMENT MEMBERS([llength $segment_members]): $segment_members[a]} 4 + debug.punk.pipe {[a yellow bold]i$i TAIL REMAINING([llength $tailremaining]): $tailremaining[a]} 4 + debug.punk.pipe {[a] inpipespec(prev [a yellow bold]|$pipespec($i,in)[a]>) outpipespec(next [a+ yellow bold]|$pipespec($i,out)>[a])} 4 + debug.punk.pipe {[a cyan bold] segment_first_is_script:$segment_first_is_script} 4 + if {$segment_first_is_script} { + debug.punk.pipe {[a cyan bold] script segment: [lindex $segment_members 0][a]} 4 + } + + + + #examine inpipespec early to give faster chance for mismatch. ie before scanning segment for argument position + set segment_result "" + if {[info exists previous_result]} { + set prevr $previous_result + } else { + set prevr "" + } + set pipedvars [dict create] + if {[string length $pipespec($i,in)]} { + #check the varspecs within the input piper + # - data and/or args may have been manipulated + set d [apply {{mv res} { + punk::_multi_bind_result $mv $res -levelup 1 + }} $pipespec($i,in) $prevr] + #temp debug + #if {[dict exists $d result]} { + #set jjj [dict get $d result] + #puts "!!!!! [rep $jjj]" + #} + set inpipespec_result [_handle_bind_result $d] + set pipedvars [dict get $d setvars] + set prevr $inpipespec_result ;# leftmost spec in |> needs to affect pipeline flow of 'data' + #puts stdout "inpipespec:|$pipespec($i,in)> prevr:$prevr setvars: $pipedvars" + } + debug.punk.pipe {[a] previous_iteration_result: $prevr[a]} 6 + debug.punk.pipe.rep {rep previous_iteration_result [rep $prevr]} + + + if {$i == $max_iterations} { + puts stderr "ABORTING. Reached max_iterations $max_iterations (todo: make configurable)" + set more_pipe_segments 0 + } + + set insertion_patterns [punk::pipe::lib::_split_equalsrhs $rhs] ;#raises error if rhs of positionspec not like /* or @* + set segment_has_insertions [expr {[llength $insertion_patterns] > 0}] + #if {$segment_has_insertions} { + # puts stdout ">>> $segment_members insertion_patterns $insertion_patterns" + #} + + debug.punk.pipe.var {segment_has_insertions: $insertion_patterns} 5 + debug.punk.pipe.rep {[rep_listname segment_members]} 4 + + + + + #whether the segment has insertion_patterns or not - apply any modification from the piper argspecs (script will use modified args/data) + #pipedvars comes from either previous segment |>, or <| args + if {[dict exists $pipedvars "data"]} { + #dict set dict_tagval %data% [list [dict get $pipedvars "data"]] + dict set dict_tagval data [dict get $pipedvars "data"] + } else { + if {[info exists previous_result]} { + dict set dict_tagval data $prevr + } + } + foreach {vname val} $pipedvars { + #add additionally specified vars and allow overriding of %args% and %data% by not setting them here + if {$vname eq "data"} { + #already potentially overridden + continue + } + dict set dict_tagval $vname $val + } + + #todo! + #segment_script - not in use yet. + #will require non-iterative pipeline processor to use ... recursive.. or coroutine based + set script "" + + if {!$segment_has_insertions} { + #debug.punk.pipe.var {[a cyan]SEGMENT has no tags[a]} 7 + #add previous_result as data in end position by default, only if *no* insertions specified (data is just list-wrapped previous_result) + #set segment_members_filled [concat $segment_members [dict get $dict_tagval %data%]] ;# data flows through by default as single element - not args - because some strings are not valid lists + #insertion-specs with a trailing * can be used to insert data in args format + set segment_members_filled $segment_members + if {[dict exists $dict_tagval data]} { + lappend segment_members_filled [dict get $dict_tagval data] + } + + } else { + debug.punk.pipe.var {processing insertion_pattern dict_tagval: $dict_tagval} 4 + set segment_members_filled [list] + set segmenttail $segment_members ;# todo - change to segment_members here to match punk::match_assign + + set rhsmapped [punk::pipe::lib::pipecmd_namemapping $rhs] + set cmdname "::punk::pipecmds::insertion::_$rhsmapped" + #glob chars have been mapped - so we can test by comparing info commands result to empty string + if {[info commands $cmdname] eq ""} { + + set insertion_script "proc $cmdname {dict_tagval segmenttail} {\n" + foreach v_pos $insertion_patterns { + #puts stdout "v_pos '$v_pos'" + lassign $v_pos v indexspec positionspec ;#v may be atom, or varname (in pipeline scope) + #puts stdout "v:'$v' indexspec:'$indexspec' positionspec:'$positionspec'" + #julz + + append insertion_script \n [string map [list $v_pos] { + lassign [list ] v indexspec positionspec + }] + + if {([string index $v 0] eq "'") && ([string index $v end] eq "'")} { + set v [string range $v 1 end-1] ;#assume trailing ' is present! + if {[string length $indexspec]} { + error "pipesyntax - index not supported on atom" "pipeline $segment_op $initial_returnvarspec $equalsrhs $args" [list pipesyntax index_on_literal] + } + append insertion_script \n "set insertion_data [list $v]" ;#sub in shortened $v now -i.e use atom value itself (string within single quotes) + } elseif {[string is double -strict $v]} { + #don't treat numbers as variables + if {[string length $indexspec]} { + error "pipesyntax - index not supported on number" "pipeline $segment_op $initial_returnvarspec $equalsrhs $args" [list pipesyntax index_on_literal] + } + append insertion_script \n {set insertion_data $v} + } else { + #todo - we should potentially group by the variable name and pass as a single call to _multi_bind_result - because stateful @ and @@ won't work in independent calls + append insertion_script \n [string map [list $cmdname] { + #puts ">>> v: $v dict_tagval:'$dict_tagval'" + if {$v eq ""} { + set v "data" + } + if {[dict exists $dict_tagval $v]} { + set insertion_data [dict get $dict_tagval $v] + #todo - use destructure_func + set d [punk::_multi_bind_result $indexspec $insertion_data] + set insertion_data [punk::_handle_bind_result $d] + } else { + #review - skip error if varname is 'data' ? + #e.g we shouldn't really fail for: + #.=>* list a b c <| + #??? Technically + #we need to be careful not to insert empty-list as an argument by default + error "pipevariable - varname $v not present in pipeline context. pipecontext_vars: [dict keys $dict_tagval] (2)" " pipecontext_vars: [dict keys $dict_tagval]" [list pipevariable variable_not_in_pipeline_scope] + } + + }] + } + + + + + #append script [string map [list $getv]{ + # + #}] + #maintenance - index logic should be similar identical? to to match_assign - which only needs to process atoms because it (for now?) delegates all pipeline ops here, so no vars available (single segment assign) + #tag: positionspechandler + + + #puts stdout "=== list_insertion_script '$positionspec' segmenttail " + set script2 [punk::list_insertion_script $positionspec segmenttail ] + set script2 [string map [list "\$insertion_data" ] $script2] + append insertion_script \n $script2 + + } + append insertion_script \n {set segmenttail} + append insertion_script \n "}" + #puts stderr "$insertion_script" + debug.punk.pipe.compile {creating proc ::punk::pipecmds::insertion::_$rhsmapped } 4 + eval $insertion_script + } + + set segment_members_filled [::punk::pipecmds::insertion::_$rhsmapped $dict_tagval [lindex [list $segmenttail [unset segmenttail]] 0] ] + + #set segment_members_filled $segmenttail + #note - length of segment_members_filled may now differ from length of original segment_members! (if do_expand i.e trailing * in any insertion_patterns) + + } + set rhs [string map $dict_tagval $rhs] ;#obsolete? + + debug.punk.pipe.rep {segment_members_filled rep: [rep $segment_members_filled]} 4 + + + # script index could have changed!!! todo fix! + + #we require re_dot_assign before re_assign (or fix regexes so order doesn't matter!) + if {(!$segment_first_is_script ) && $segment_op eq ".="} { + #no scriptiness detected + + #debug.punk.pipe.rep {[a yellow bold][rep_listname segment_members_filled][a]} 4 + + set cmdlist_result [uplevel 1 $segment_members_filled] + #debug.punk.pipe {[a green bold]forward_result: $forward_result[a]} 4 + #debug.punk.pipe.rep {[a yellow bold]forward_result REP: [rep $forward_result][a]} 4 + + #set d [_multi_bind_result $returnvarspec [punk::K $cmdlist_result [unset cmdlist_result]]] + set d [_multi_bind_result $returnvarspec [lindex [list $cmdlist_result [unset cmdlist_result ]] 0]] + + set segment_result [_handle_bind_result $d] + #puts stderr ">>forward_result: $forward_result segment_result $segment_result" + + + } elseif {$segment_op eq "="} { + #slightly different semantics for assigment! + #We index into the DATA - not the position within the segment! + #(an = segment must take a single argument, as opposed to a .= segment) + #(This was a deliberate design choice for consistency with set, and to reduce errors.) + #(we could have allowed multiple args to = e.g to form a list, but it was tried, and the edge-cases were unintuitive and prone to user error) + #(The choice to restrict to single argument, but allow insertion and appending via insertion-specs is more explicit and reliable even though the insertion-specs operate differently to those of .=) + # + #we have to ensure that for an empty segment - we don't append to the empty list, thus listifying the data + #v= {a b c} |> = + # must return: {a b c} not a b c + # + if {!$segment_has_insertions} { + set segment_members_filled $segment_members + if {[dict exists $dict_tagval data]} { + if {![llength $segment_members_filled]} { + set segment_members_filled [dict get $dict_tagval data] + } else { + lappend segment_members_filled [dict get $dict_tagval data] + } + } + } + + set d [_multi_bind_result $returnvarspec [lindex [list $segment_members_filled [unset segment_members_filled ]] 0]] + set segment_result [_handle_bind_result $d] + + + } elseif {$segment_first_is_script || $segment_op eq "script"} { + #script + debug.punk.pipe {[a+ cyan bold].. evaluating as script[a]} 2 + + set script [lindex $segment_members 0] + + #build argument lists for 'apply' + set segmentargnames [list] + set segmentargvals [list] + foreach {k val} $dict_tagval { + if {$k eq "args"} { + #skip args - it is manually added at the end of the apply list if it's a valid tcl list + continue + } + lappend segmentargnames $k + lappend segmentargvals $val + } + + set argsdatalist $prevr ;#default is raw result as a list. May be overridden by an argspec within |> e.g |args@@key> or stripped if not a tcl list + #puts "------> rep prevr argsdatalist: [rep $argsdatalist]" + set add_argsdata 0 + if {[dict exists $dict_tagval "args"]} { + set argsdatalist [dict get $dict_tagval "args"] + #see if the raw result can be treated as a list + if {[catch {lindex $argsdatalist 0}]} { + #we cannot supply 'args' + set pre_script "" + #todo - only add trace if verbose warnings enabled? + append pre_script "trace add variable args read punk::pipeline_args_read_trace_error\n" + set script $pre_script + append script $segment_first_word + set add_argsdata 0 + } else { + set add_argsdata 1 + } + } + + debug.punk.pipe.rep {>> [rep_listname segmentargvals]} 4 + set ns [uplevel 1 {::tcl::namespace::current}] + if {!$add_argsdata} { + debug.punk.pipe {APPLY1: (args not set; not a list) segment vars:$segmentargnames} 4 + #puts stderr " script: $script" + #puts stderr " vals: $segmentargvals" + set evaluation [uplevel 1 [list ::apply [::list $segmentargnames $script $ns] {*}$segmentargvals]] + } else { + debug.punk.pipe {APPLY2: (args is set)segment vars:$segmentargnames} 4 + #puts stderr " script: $script" + #puts stderr " vals: $segmentargvals $argsdatalist" + #pipeline script context should be one below calling context - so upvar v v will work + #ns with leading colon will fail with apply + set evaluation [uplevel 1 [list ::apply [::list [::concat $segmentargnames args] $script $ns] {*}$segmentargvals {*}$argsdatalist]] + } + + debug.punk.pipe.rep {script result, evaluation: [rep_listname evaluation]} 4 + #puts "---> rep script evaluation result: [rep $evaluation]" + #set d [_multi_bind_result $returnvarspec [punk::K $evaluation [unset evaluation]]] + + #trailing segment_members are *pipedata* scripts - as opposed to ordinary pipeline scripts! + set tail_scripts [lrange $segment_members 1 end] + if {[llength $tail_scripts]} { + set r [pipedata $evaluation {*}$tail_scripts] + } else { + set r $evaluation + } + set d [_multi_bind_result $returnvarspec [lindex [list $r [unset r]] 0]] + set segment_result [_handle_bind_result $d] + } else { + #tags ? + #debug.punk.pipe {>>raw commandline: [concat $rhs $segment_members_filled]} 5 + if {false} { + #experimental. + package require funcl + #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] + } 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 " + #append snew "set pipe_[expr $i -1]" + #append pscript $snew + set pscript [funcl::o_of_n 1 $segment_members $pscript] + + } + } + + 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 ]] + + #multi_bind_result needs to return a funcl for rhs of: + #lindex [list [set syncvar [main pipeline.. ]] [rhs binding funcl...] 1 ] + #which uses syncvar + # + #The lhs of 'list' runs first so now syncvar can be the root level of the rhs function list and bind the necessary vars. + #NOTE: unintuitively, we are returning the value of rhs to the main pipleline! (leftmost binding) this is because the leftmost binding determines what goes back to the pipeline result + + set segment_result [_handle_bind_result $d] + } + #the subresult doesn't need to go backwards - as the final assignment can emit the result into a variable + #It makes more sense and is ultimately more useful (and more easy to reason about) for the result of each assignment to be related only to the pre-pipe section + #It may however make a good debug point + #puts stderr "segment $i segment_result:$segment_result" + + debug.punk.pipe.rep {[rep_listname segment_result]} 3 + + + + + + #examine tailremaining. + # either x x x |?> y y y ... + # or just y y y + #we want the x side for next loop + + #set up the conditions for the next loop + #|> x=y args + # inpipespec - contents of previous piper |xxx> + # outpipespec - empty or content of subsequent piper |xxx> + # previous_result + # assignment (x=y) + + + set pipespec($j,in) $pipespec($i,out) + set outpipespec "" + set tailmap "" + set next_pipe_posn -1 + if {[llength $tailremaining]} { + + #set tailmap [lmap v $tailremaining {lreplace [split $v {}] 1 end-1}] + ##e.g for: a b c |> e f g |> h + #set next_pipe_posn [lsearch $tailmap {| >}] + set next_pipe_posn [lsearch $tailremaining "|*>"] + + set outpipespec [string range [lindex $tailremaining $next_pipe_posn] 1 end-1] + } + set pipespec($j,out) $outpipespec + + + set script_like_first_word 0 + if {[llength $tailremaining] || $next_pipe_posn >= 0} { + + if {$next_pipe_posn >=0} { + set next_all_members [lrange $tailremaining 0 $next_pipe_posn-1] ;#exclude only piper |xxx> for + set tailremaining [lrange $tailremaining $next_pipe_posn+1 end] + + } else { + set next_all_members $tailremaining + set tailremaining [list] + } + + + #assignment is the arg immediately following |> operator e.g x.=blah or x=etc (or a normal commandlist or script!) + set segment_first_word "" + set returnvarspec "" ;# the lhs of x=y + set segment_op "" + set rhs "" + set segment_first_is_script 0 + if {[llength $next_all_members]} { + if {[punk::pipe::lib::arg_is_script_shaped [lindex $next_all_members 0]]} { + set segment_first_word [lindex $next_all_members 0] + set segment_first_is_script 1 + set segment_op "" + set segment_members $next_all_members + } else { + set possible_assignment [lindex $next_all_members 0] + #set re_dot_assign {^([^ \t\r\n=\{]*)\.=(.*)} + if {[regexp {^([^ \t\r\n=\{]*)\.=(.*)} $possible_assignment _ returnvarspec rhs]} { + set segment_op ".=" + set segment_first_word [lindex $next_all_members 1] + set script_like_first_word [punk::pipe::lib::arg_is_script_shaped $segment_first_word] + if {$script_like_first_word} { + set segment_first_is_script 1 ;#relative to segment_members which no longer includes the .= + } + set segment_members [lrange $next_all_members 1 end] + } elseif {[regexp {^([^ \t\r\n=]*)=(.*)} $possible_assignment _ returnvarspec rhs]} { + set segment_op "=" + #never scripts + #must be at most a single element after the = ! + if {[llength $next_all_members] > 2} { + #raise this as pipesyntax as opposed to pipedata? + error "pipesyntax - at most one element can follow = (got [lrange $next_all_members 1 end])" "pipeline $segment_op $returnvarspec $rhs [lrange $next_all_members 1 end]" [list pipesyntax too_many_elements] + } + set segment_first_word [lindex $next_all_members 1] + if {[catch {llength $segment_first_word}]} { + set segment_is_list 0 ;#only used for segment_op = + } else { + set segment_is_list 1 ;#only used for segment_op = + } + + set segment_members $segment_first_word + } else { + #no assignment operator and not script shaped + set segment_op "" + set returnvarspec "" + set segment_first_word [lindex $next_all_members 0] + set segment_first_word [lindex $next_all_members 1] + set segment_members $next_all_members + #puts stderr ">>3 no-operator segment_first_word: '$segment_first_word'" + } + } + + + } else { + #?? two pipes in a row ? + debug.punk.pipe {[a+ yellow bold]WARNING: no segment members found[a]} 0 + set segment_members return + set segment_first_word return + } + + #set forward_result $segment_result + #JMN2 + set previous_result $segment_result + #set previous_result [join $segment_result] + } else { + debug.punk.pipe {[a+ cyan bold]End of pipe segments ($i)[a]} 4 + #output pipe spec at tail of pipeline + + set pipedvars [dict create] + if {[string length $pipespec($i,out)]} { + set d [apply {{mv res} { + punk::_multi_bind_result $mv $res -levelup 1 + }} $pipespec($i,out) $segment_result] + set segment_result [_handle_bind_result $d] + set pipedvars [dict get $d setvars] + } + + set more_pipe_segments 0 + } + + #the segment_result is based on the leftmost var on the lhs of the .= + #whereas forward_result is always the entire output of the segment + #JMN2 + #lappend segment_result_list [join $segment_result] + lappend segment_result_list $segment_result + incr i + incr j + } ;# end while + + return [lindex $segment_result_list end] + #JMN2 + #return $segment_result_list + #return $forward_result + } + + + #just an experiment + #what advantage/difference versus [llength [lrange $data $start $end]] ??? + proc data_range_length {data start end} { + set datalen [llength $data] + + #normalize to s and e + if {$start eq "end"} { + set s [expr {$datalen - 1}] + } elseif {[string match end-* $start]} { + set stail [string range $start 4 end] + set posn [expr {$datalen - $stail -1}] + if {$posn < 0} { + return 0 + } + set s $posn + } else { + #int + if {($start < 0) || ($start > ($datalen -1))} { + return 0 + } + set s $start + } + if {$end eq "end"} { + set e [expr {$datalen - 1}] + } elseif {[string match end-* $end]} { + set etail [string range $end 4 end] + set posn [expr {$datalen - $etail -1}] + if {$posn < 0} { + return 0 + } + set e $posn + } else { + #int + if {($end < 0)} { + return 0 + } + set e $end + } + if {$s > ($datalen -1)} { + return 0 + } + if {$e > ($datalen -1)} { + set e [expr {$datalen -1}] + } + + + + if {$e < $s} { + return 0 + } + + return [expr {$e - $s + 1}] + } + + # unknown -- + # This procedure is called when a Tcl command is invoked that doesn't + # exist in the interpreter. It takes the following steps to make the + # command available: + # + # 1. See if the autoload facility can locate the command in a + # Tcl script file. If so, load it and execute it. + # 2. If the command was invoked interactively at top-level: + # (a) see if the command exists as an executable UNIX program. + # If so, "exec" the command. + # (b) see if the command requests csh-like history substitution + # in one of the common forms !!, !, or ^old^new. If + # so, emulate csh's history substitution. + # (c) see if the command is a unique abbreviation for another + # command. If so, invoke the command. + # + # Arguments: + # args - A list whose elements are the words of the original + # command, including the command name. + + #review - we shouldn't really be doing this + #We need to work out if we can live with the real default unknown and just inject some special cases at the beginning before falling-back to the normal one + + proc ::unknown args { + #puts stderr "unk>$args" + variable ::tcl::UnknownPending + global auto_noexec auto_noload env tcl_interactive errorInfo errorCode + + if {[info exists errorInfo]} { + set savedErrorInfo $errorInfo + } + if {[info exists errorCode]} { + set savedErrorCode $errorCode + } + + set name [lindex $args 0] + if {![info exists auto_noload]} { + # + # Make sure we're not trying to load the same proc twice. + # + if {[info exists UnknownPending($name)]} { + return -code error "self-referential recursion\ + in \"unknown\" for command \"$name\"" + } + set UnknownPending($name) pending + set ret [catch { + auto_load $name [uplevel 1 {::tcl::namespace::current}] + } msg opts] + unset UnknownPending($name) + if {$ret != 0} { + dict append opts -errorinfo "\n (autoloading \"$name\")" + return -options $opts $msg + } + if {![array size UnknownPending]} { + unset UnknownPending + } + if {$msg} { + if {[info exists savedErrorCode]} { + set ::errorCode $savedErrorCode + } else { + unset -nocomplain ::errorCode + } + if {[info exists savedErrorInfo]} { + set errorInfo $savedErrorInfo + } else { + unset -nocomplain errorInfo + } + set code [catch {uplevel 1 $args} msg opts] + if {$code == 1} { + # + # Compute stack trace contribution from the [uplevel]. + # Note the dependence on how Tcl_AddErrorInfo, etc. + # construct the stack trace. + # + set errInfo [dict get $opts -errorinfo] + set errCode [dict get $opts -errorcode] + set cinfo $args + if {[string length [encoding convertto utf-8 $cinfo]] > 150} { + set cinfo [string range $cinfo 0 150] + while {[string length [encoding convertto utf-8 $cinfo]] > 150} { + set cinfo [string range $cinfo 0 end-1] + } + append cinfo ... + } + set tail "\n (\"uplevel\" body line 1)\n invoked\ + from within\n\"uplevel 1 \$args\"" + set expect "$msg\n while executing\n\"$cinfo\"$tail" + if {$errInfo eq $expect} { + # + # The stack has only the eval from the expanded command + # Do not generate any stack trace here. + # + dict unset opts -errorinfo + dict incr opts -level + return -options $opts $msg + } + # + # Stack trace is nested, trim off just the contribution + # from the extra "eval" of $args due to the "catch" above. + # + set last [string last $tail $errInfo] + if {$last + [string length $tail] != [string length $errInfo]} { + # Very likely cannot happen + return -options $opts $msg + } + set errInfo [string range $errInfo 0 $last-1] + set tail "\"$cinfo\"" + set last [string last $tail $errInfo] + if {$last < 0 || $last + [string length $tail] != [string length $errInfo]} { + return -code error -errorcode $errCode \ + -errorinfo $errInfo $msg + } + set errInfo [string range $errInfo 0 $last-1] + set tail "\n invoked from within\n" + set last [string last $tail $errInfo] + if {$last + [string length $tail] == [string length $errInfo]} { + return -code error -errorcode $errCode \ + -errorinfo [string range $errInfo 0 $last-1] $msg + } + set tail "\n while executing\n" + set last [string last $tail $errInfo] + if {$last + [string length $tail] == [string length $errInfo]} { + return -code error -errorcode $errCode \ + -errorinfo [string range $errInfo 0 $last-1] $msg + } + return -options $opts $msg + } else { + dict incr opts -level + return -options $opts $msg + } + } + } + #set isrepl [expr {[file tail [file rootname [info script]]] eq "repl"}] + set isrepl [punk::repl::codethread::is_running] ;#may not be reading though + if {$isrepl} { + #set ::tcl_interactive 1 + } + if {$isrepl || (([info level] == 1) && (([info script] eq "" ) ) + && ([info exists tcl_interactive] && $tcl_interactive))} { + + if {![info exists auto_noexec]} { + set new [auto_execok $name] + if {$new ne ""} { + set redir "" + if {[namespace which -command console] eq ""} { + set redir ">&@stdout <@stdin" + } + + + #windows experiment todo - use twapi and named pipes + #twapi::namedpipe_server {\\.\pipe\something} + #Then override tcl 'exec' and replace all stdout/stderr/stdin with our fake ones + #These can be stacked with shellfilter and operate as OS handles - which we can't do with fifo2 etc + # + + #if {[string first " " $new] > 0} { + # set c1 $name + #} else { + # set c1 $new + #} + + # -- --- --- --- --- + set idlist_stdout [list] + set idlist_stderr [list] + #set shellrun::runout "" + #when using exec with >&@stdout (to ensure process is connected to console) - the output unfortunately doesn't go via the shellfilter stacks + #lappend idlist_stderr [shellfilter::stack::add stderr ansiwrap -settings {-colour {red bold}}] + #lappend idlist_stdout [shellfilter::stack::add stdout tee_to_var -action float -settings {-varname ::shellrun::runout}] + + if {[punk::config::configure running auto_exec_mechanism] eq "experimental"} { + #TODO - something cross-platform that allows us to maintain a separate console(s) with an additional set of IO channels to drive it + #not a trivial task + + #This runs external executables in a context in which they are not attached to a terminal + #VIM for example won't run, and various programs can't detect terminal dimensions etc and/or will default to ansi-free output + #ctrl-c propagation also needs to be considered + + set teehandle punksh + uplevel 1 [list ::catch {*}{ + } [list ::shellfilter::run [concat [list $new] [lrange $args 1 end]] -teehandle $teehandle -inbuffering line -outbuffering none ] {*}{ + } ::tcl::UnknownResult ::tcl::UnknownOptions + ] + + if {[string trim $::tcl::UnknownResult] ne "exitcode 0"} { + dict set ::tcl::UnknownOptions -code error + set ::tcl::UnknownResult "Non-zero exit code from command '$args' $::tcl::UnknownResult" + } else { + #no point returning "exitcode 0" if that's the only non-error return. + #It is misleading. Better to return empty string. + set ::tcl::UnknownResult "" + } + } else { + set repl_runid [punk::get_repl_runid] + #set ::punk::last_run_display [list] + set resolved $new + if {[string match "for_unknown_handler *" $new]} { + set ext [file extension $name] + if {[string tolower $ext] eq ".lnk"} { + #for .lnk files we can often resolve the target path without needing to execute the shell open command + #- which is desirable because it allows us to avoid the absolute path requirement for unknown-handler auto_execok commands, + #which is desirable because it allows us to support relative paths and paths with environment variables in them + #(e.g for .lnk files that point to executables with environment variables in the path) + set targetinfo [punk::winlnk::resolve $name] + if {[dict exists $targetinfo link_roottarget]} { + set resolved [dict get $targetinfo link_roottarget] + #arguments? + } else { + puts "(unknown-handler): failed to resolve .lnk target for $name. Falling back to shell open command resolution, which may fail if absolute path is required." + } + } else { + #re-resolve. + set associnfo [punk::auto_exec::shell_open_command $ext] + set registry_valuetype [dict get $associnfo type] ;#sz vs expand_sz + set command_spec [dict get $associnfo value] + set windows_file_type [dict get $associnfo filetype] + if {[string match "*absolute_path required" $new]} { + puts "(unknown-handler): auto_execok for $name requires absolute path. Re-resolving $name with absolute path." + set fullpath [file normalize $name] + #at least for .url files - long paths (paths with multiple spaces?) can fail to run. Using the short path seems to fix this. + #This seems hacky but anyway.. + set attributes [file attributes $fullpath] + if {[dict exists $attributes -shortname]} { + set fullpath [dict get $attributes -shortname] + } + set resolved [punk::auto_exec::shell_command_as_tcl_list -type $registry_valuetype $command_spec $fullpath] + } else { + #todo + set newnorm [file normalize $name] + puts stderr "(unknown-handler): re-resolving $name with auto_execok $newnorm" + set resolved [auto_execok $newnorm] + } + } + } + + if {$resolved eq ""} { + #resolved may be emptyif auto_execok returns an empty string. + dict set ::tcl::UnknownOptions -code error + set ::tcl::UnknownResult "unresolved path '$name'" + return -options $::tcl::UnknownOptions $::tcl::UnknownResult + } + set redir ">&@stdout <@stdin" + uplevel 1 [list ::catch [concat exec $redir $resolved [lrange $args 1 end]] ::tcl::UnknownResult ::tcl::UnknownOptions] + #we can't detect stdout/stderr output from the exec + #for now emit an extra \n on stderr + #todo - there is probably no way around this but to somehow exec in the context of a completely separate console + #This is probably a tricky problem - especially to do cross-platform + # + # - use [dict get $::tcl::UnknownOptions -code] (0|1) exit + if {[dict get $::tcl::UnknownOptions -code] == 0} { + set c green + set m "ok" + } else { + set c yellow + set m "errorCode $::errorCode" + } + set chunklist [list] + lappend chunklist [list "info" "[a $c]$m[a] " ] + if {$repl_runid != 0} { + tsv::lappend repl runchunks-$repl_runid {*}$chunklist + } + + } + + foreach id $idlist_stdout { + shellfilter::stack::remove stdout $id + } + foreach id $idlist_stderr { + shellfilter::stack::remove stderr $id + } + # -- --- --- --- --- + + + #uplevel 1 [list ::catch \ + # [concat exec $redir $new [lrange $args 1 end]] \ + # ::tcl::UnknownResult ::tcl::UnknownOptions] + + #puts "===exec with redir:$redir $::tcl::UnknownResult ==" + dict incr ::tcl::UnknownOptions -level + return -options $::tcl::UnknownOptions $::tcl::UnknownResult + } + } + + if {$name eq "!!"} { + set newcmd [history event] + } elseif {[regexp {^!(.+)$} $name -> event]} { + set newcmd [history event $event] + } elseif {[regexp {^\^([^^]*)\^([^^]*)\^?$} $name -> old new]} { + set newcmd [history event -1] + catch {regsub -all -- $old $newcmd $new newcmd} + } + if {[info exists newcmd]} { + tclLog $newcmd + history change $newcmd 0 + uplevel 1 [list ::catch $newcmd \ + ::tcl::UnknownResult ::tcl::UnknownOptions] + dict incr ::tcl::UnknownOptions -level + return -options $::tcl::UnknownOptions $::tcl::UnknownResult + } + + set ret [catch {set candidates [info commands $name*]} msg] + if {$name eq "::"} { + set name "" + } + if {$ret != 0} { + dict append opts -errorinfo \ + "\n (expanding command prefix \"$name\" in unknown)" + return -options $opts $msg + } + # Filter out bogus matches when $name contained + # a glob-special char [Bug 946952] + if {$name eq ""} { + # Handle empty $name separately due to strangeness + # in [string first] (See RFE 1243354) + set cmds $candidates + } else { + set cmds [list] + foreach x $candidates { + if {[string first $name $x] == 0} { + lappend cmds $x + } + } + } + + #punk - disable prefix match search + set default_cmd_search 0 + if {$default_cmd_search} { + if {[llength $cmds] == 1} { + uplevel 1 [list ::catch [lreplace $args 0 0 [lindex $cmds 0]] ::tcl::UnknownResult ::tcl::UnknownOptions] + dict incr ::tcl::UnknownOptions -level + return -options $::tcl::UnknownOptions $::tcl::UnknownResult + } + if {[llength $cmds]} { + return -code error "ambiguous command name \"$name\": [lsort $cmds]" + } + } else { + #punk hacked version - report matches but don't run + if {[llength $cmds]} { + return -code error "unknown command name \"$name\": possible match(es) [lsort $cmds]" + } + + } + + + } + return -code error -errorcode [list TCL LOOKUP COMMAND $name] "invalid command name $name" + } + + proc know {cond body} { + set existing [info body ::unknown] + #assuming we can't test on cond being present in existing unknown script - because it may be fairly simple and prone to false positives (?) + ##This means we can't have 2 different conds with same body if we test for body in unknown. + ##if {$body ni $existing} { + set scr [base64::encode -maxlen 0 $cond] ;#will only be decoded if the debug is triggered + #tcllib has some double-substitution going on.. base64 seems easiest and will not impact the speed of normal execution when debug off. + + #tclint-disable-next-line + proc ::unknown {args} [string map [list @c@ $cond @b@ $body @scr@ $scr] { + #--------------------------------------- + if {![catch {expr {@c@}} res] && $res} { + debug.punk.unknown {HANDLED BY: punk unknown_handler ([llength $args]) args:'$args' "cond_script:'[punk::decodescript @scr@]'" } 4 + return [eval {@b@}] + } else { + debug.punk.unknown {skipped: punk unknown_handler ([llength $args]) args:'$args' "cond_script:'[punk::decodescript @scr@]'" } 4 + } + #--------------------------------------- + }]$existing + #} + } + + proc know? {{len 2000}} { + puts [string range [info body ::unknown] 0 $len] + } + proc decodescript {b64} { + if {[ catch { + base64::decode $b64 + } scr]} { + return "" + } else { + return "($scr)" + } + } + + # --------------------------- + # commands that should be aliased in safe interps that need to use punk repl + # + proc get_repl_runid {} { + if {[interp issafe]} { + if {[info commands ::tsv::exists] eq ""} { + puts stderr "punk::get_repl_runid cannot operate directly in safe interp - install the appropriate punk aliases" + error "punk::get_repl_runid punk repl aliases not installed" + } + #if safe interp got here - there must presumably be a direct set of aliases on tsv::* commands + } + if {[tsv::exists repl runid]} { + return [tsv::get repl runid] + } else { + return 0 + } + } + #ensure we don't get into loop in unknown when in safe interp - which won't have tsv + proc set_repl_last_unknown {args} { + if {[interp issafe]} { + if {[info commands ::tsv::set] eq ""} { + puts stderr "punk::set_repl_last_unknown cannot operate directly in safe interp - install an alias to tsv::set repl last_unknown" + return + } + #tsv::* somehow working - possibly custom aliases for tsv functionality ? review + } + if {[info commands ::tsv::set] eq ""} { + puts stderr "set_repl_last_unknown - tsv unavailable!" + return + } + tsv::set repl last_unknown {*}$args + } + # --------------------------- + + #---------------- + #for var="val {a b c}" + #proc ::punk::val {{v {}}} {tailcall lindex $v} + #proc ::punk::val {{v {}}} {return $v} ;#2023 - approx 2x faster than the tailcall lindex version + + proc ::punk::val [list [list v [purelist]]] {return $v} + #---------------- + + proc configure_unknown {} { + #----------------------------- + #these are critical e.g core behaviour or important for repl displaying output correctly + + + #can't use know - because we don't want to return before original unknown body is called. + proc ::unknown {args} [string cat { + #set ::punk::last_run_display [list] + #set ::repl::last_unknown [lindex $args 0] ;#jn + #tsv::set repl last_unknown [lindex $args 0] ;#REVIEW + punk::set_repl_last_unknown [lindex $args 0] + }][info body ::unknown] + + + #handle process return dict of form {exitcode num etc blah} + #ie when the return result as a whole is treated as a command + #exitcode must be the first key + know {[lindex $args 0 0] eq "exitcode"} { + uplevel 1 [list exitcode {*}[lrange [lindex $args 0] 1 end]] + } + + + #----------------------------- + # + # potentially can be disabled by config(?) - but then scripts not able to use all repl features.. + + + #------------------------ + #todo 2026 - remove - use new : expr syntax instead + #todo - repl output info that it was evaluated as an expression + #know {[expr $args] || 1} {expr $args} + #know {[expr $args] || 1} {tailcall expr $args} + #--------------------------- + + #it is significantly faster to call a proc such as punk::lib::range like this than to inline it in the unknown proc + #punk::lib::range is defined as a wrapper to lseq if it is available (8.7+) + know {[regexp {^([+-]*[0-9_]+)\.\.([+-]*[0-9_]+)$} [lindex $args 0 0] -> from to]} {punk::lib::range $from $to} + + + #NOTE: + #we don't allow setting namespace qualified vars in the lhs assignment pattern. + #The principle is that we shouldn't be setting vars outside of the immediate calling scope. + #(It would also be difficult and error-prone and generally make the pipelines less re-usable and reliable) + #Therefore ::nswhatever::blah= x is the pipeline: blah= x - where the corresponding command, if any is first resolved in ::nswhatever + #We will require that the namespace already exists - which is consistent with if the command were to be run without unknown + proc ::punk::_unknown_assign_dispatch {matchedon pattern equalsrhs args} { + set tail [lassign $args hd] + #puts "-> _unknown_assign_dispatch '$partzerozero' pattern:'$pattern' equalsrhs:'$equalsrhs' args:'$args' argshd:'$hd' argstail:'$tail'" + if {$hd ne $matchedon} { + if {[llength $tail]} { + error "unknown_assign_dispatch: pipeline with args unexpanded. Try {*}\$pipeline $tail" + } + #regexp $punk::re_assign $hd _ pattern equalsrhs + #we assume the whole pipeline has been provided as the head + #regexp {^([^\t\r\n=]*)\=([^ \t\r\n]*)(.*)} $hd _ pattern equalsrhs tail + regexp {^([^\t\r\n=]*)\=([^\r\n]*)} $hd _ pattern fullrhs + lassign [punk::pipe::lib::_rhs_tail_split $fullrhs] equalsrhs tail + } + #NOTE: - it doesn't make sense to call 'namespace' qualifiers or 'namespace tail' on a compound hd such as v,::etc= blah + # we only look at leftmost namespace-like thing and need to take account of the pattern syntax + # e.g for ::etc,'::x'= + # the ns is :: and the tail is etc,'::x'= + # (Tcl's namespace qualifiers/tail won't help here) + if {[string match ::* $hd]} { + set patterns [punk::pipe::lib::_split_patterns_memoized $hd] + #get a pair-list something like: {::x /0} {etc {}} + set ns [namespace qualifiers [lindex $patterns 0 0]] + set nslen [string length $ns] + set patterntail [string range $ns $nslen end] + } else { + set ns "" + set patterntail $pattern + } + if {[string length $ns] && ![namespace exists $ns]} { + error "unknown_assign_dispatch: namespace '$ns' not found. (Note that pipeline lhs variables cannot be namespaced)" + } else { + set nscaller [uplevel 1 [list ::tcl::namespace::current]] + #jmn + set rhsmapped [punk::pipe::lib::pipecmd_namemapping $equalsrhs] + set commands [uplevel 1 [list ::tcl::info::commands $pattern=$rhsmapped]] ;#uplevel - or else we are checking from perspective of this namespace ::punk + #we must check for exact match of the command in the list - because command could have glob chars. + if {"$pattern=$rhsmapped" in $commands} { + puts stderr "unknown_assign_dispatch>> '$pattern=$equalsrhs' $commands nscaller: '$nscaller'" + #we call the namespaced function - we don't evaluate it *in* the namespace. + #REVIEW + #warn for now...? + #tailcall $pattern=$equalsrhs {*}$args + tailcall $pattern=$rhsmapped {*}$tail + } + } + #puts "--->nscurrent [uplevel 1 [list ::namespace current]]" + #ignore the namespace.. + #We could interpret the fact that the nonexistant pipe was called with a namespace to indicate that's where the pipecommand should be created.. + #But.. we would need to ensure 1st (compiling) invocation runs the same way as subsequent invocations. + #namespace evaling match_assign here probably wouldn't accomplish that and may create surprises with regards to where lhs vars(if any) are created + tailcall ::punk::match_assign $patterntail $equalsrhs {*}$tail + #return [uplevel 1 [list ::punk::match_assign $varspecs $rhs $tail]] + } + #variable re_assign {^([^\r\n=\{]*)=(.*)} + #characters directly following = need to be assigned to the var even if they are escaped whitespace (e.g \t \r \n) + #unescaped whitespace causes the remaining elements to be part of the tail -ie are appended to the var as a list + #e.g x=a\nb c + #x will be assigned the list {a\nb c} ie the spaces between b & c are not maintained + # + #know {[regexp {^([^\t\r\n=]*)\=([^ \t\r\n]*)} [lindex $args 0] matchedon pattern equalsrhs]} {tailcall ::punk::_unknown_assign_dispatch $matchedon $pattern $equalsrhs {*}$args} + #know {[regexp {^{([^\t\r\n=]*)\=([^ \t\r\n]*)}} [lindex $args 0] matchedon pattern equalsrhs]} {tailcall ::punk::_unknown_assign_dispatch $matchedon $pattern $equalsrhs {*}$args} + + + + proc ::punk::_unknown_compare {val1 val2 args} { + if {![string length [string trim $val2]]} { + if {[llength $args] > 1} { + #error "Extra args after comparison operator ==. usage e.g : \$var1==\$var2 or \$var1==\$var2 + 2" + set val2 [string cat {*}[lrange $args 1 end]] + return [expr {$val1 eq $val2}] + } + return $val1 + } elseif {[llength $args] == 1} { + #simple comparison + if {[string is digit -strict $val1$val2]} { + return [expr {$val1 == $val2}] + } else { + return [string equal $val1 $val2] + } + } elseif {![catch {expr $val2 {*}[lrange $args 1 end]} evaluated]} { + if {[string is digit -strict $val1$evaluated]} { + return [expr {$val1 == $evaluated}] + } else { + return [expr {$val1 eq $evaluated}] + } + } else { + set evaluated [uplevel 1 [list {*}$val2 {*}[lrange $args 1 end]]] + if {[string is digit -strict $val1$evaluated]} { + return [expr {$val1 == $evaluated}] + } else { + return [expr {$val1 eq $evaluated}] + } + } + } + #ensure == is after = in know sequence + #.* on left is pretty broad - todo: make it a little more specific to avoid unexpected interactions + know {[regexp {(.*)==(.*)} [lindex $args 0] _ val1 val2]} {tailcall ::punk::_unknown_compare $val1 $val2 {*}$args} + #.= must come after = here to ensure it comes before = in the 'unknown' proc + #set punk::re_dot_assign {([^=]*)\.=(.*)} + #know {[regexp $punk::re_dot_assign [lindex $args 0 0] _ varspecs rhs]} { + # set tail [expr {([lindex $args 0] eq [lindex $args 0 0]) ? [lrange $args 1 end] : [concat [lrange [lindex $args 0] 1 end] [lrange $args 1 end] ] }] + # tailcall ::punk::match_exec $varspecs $rhs {*}$tail + # #return [uplevel 1 [list ::punk::match_exec $varspecs $rhs {*}$tail]] + # } + # + + + + proc ::punk::_unknown_dot_assign_dispatch {partzerozero pattern equalsrhs args} { + #puts stderr ". unknown dispatch $partzerozero" + set argstail [lassign $args hd] + + #this equates to auto-flattening the head.. which seems like a bad idea, the structure was there for a reason. + #we should require explicit {*} expansion if the intention is for the args to be joined in at that level. + #expr {($hd eq $partzerozero) ? [set tail $argstail] : [set tail [concat [lrange $hd 1 end] $argstail ]] } + + if {$hd ne $partzerozero} { + if {[llength $argstail]} { + error "unknown_dot_assign_dispatch: pipeline with args unexpanded. Try {*}\$pipeline $argstail" + } + #regexp $punk::re_assign $hd _ pattern equalsrhs + #we assume the whole pipeline has been provided as the head + #regexp {^([^ \t\r\n=\{]*)\.=([^ \t\r\n]*)(.*)} $hd _ pattern equalsrhs argstail + #regexp {^([^ \t\r\n=\{]*)\.=([^ \t\r\n]*)(.*)} $hd _ pattern equalsrhs argstail + + regexp {^([^ \t\r\n=\{]*)\.=([^\r\n]*)} $hd _ pattern fullrhs + lassign [punk::pipe::lib::_rhs_tail_split $fullrhs] equalsrhs argstail + } + #tailcall ::punk::match_assign $pattern $equalsrhs {*}$argstail + + + return [uplevel 1 [list ::punk::pipeline .= $pattern $equalsrhs {*}$argstail]] + + } + + # + know {[regexp {^([^\t\r\n=]*)\=([^\r\n]*)} [lindex $args 0] matchedon pattern equalsrhs]} {tailcall ::punk::_unknown_assign_dispatch $matchedon $pattern $equalsrhs {*}$args} + know {[regexp {^{([^\t\r\n=]*)\=([^\r\n]*)}} [lindex $args 0] matchedon pattern equalsrhs]} {tailcall ::punk::_unknown_assign_dispatch $matchedon $pattern $equalsrhs {*}$args} + + #variable re_dot_assign {^([^ \t\r\n=\{]*)\.=(.*)} + #know {[regexp {^([^ \t\r\n=\{]*)\.=(.*)} [lindex $args 0 0] partzerozero varspecs rhs]} {tailcall punk::_unknown_dot_assign_dispatch $partzerozero $varspecs $rhs {*}$args} + #know {[regexp {^([^ \t\r\n=\{]*)\.=(.*)} [lindex $args 0] partzerozero varspecs rhs]} {tailcall punk::_unknown_dot_assign_dispatch $partzerozero $varspecs $rhs {*}$args} + #know {[regexp {^([^\t\r\n=\{]*)\.=(.*)} [lindex $args 0] partzerozero varspecs rhs]} {tailcall punk::_unknown_dot_assign_dispatch $partzerozero $varspecs $rhs {*}$args} + #know {[regexp {^([^\t\r\n=]*)\.=(.*)} [lindex $args 0] partzerozero varspecs rhs]} {tailcall punk::_unknown_dot_assign_dispatch $partzerozero $varspecs $rhs {*}$args} + know {[regexp {^([^=]*)\.=(.*)} [lindex $args 0] partzerozero varspecs rhs]} {tailcall punk::_unknown_dot_assign_dispatch $partzerozero $varspecs $rhs {*}$args} + + #add escaping backslashes to a value + #matching odd keys in dicts using pipeline syntax can be tricky - as + #e.g + #set ktest {a"b} + #@@[escv $ktest].= list a"b val + #without escv: + #@@"a\\"b".= list a"b val + #with more backslashes in keys the escv use becomes more apparent: + #set ktest {\\x} + #@@[escv $ktest].= list $ktest val + #without escv we would need: + #@@\\\\\\\\x.= list $ktest val + proc escv {v} { + #https://stackoverflow.com/questions/11135090/is-there-any-tcl-function-to-add-escape-character-automatically + #thanks to DKF + regsub -all {\W} $v {\\&} + } + interp alias {} escv {} punk::escv + #review + #set v "\u2767" + # + #escv $v + #\ + #the + + + #know {[regexp $punk::re_dot_assign [lindex $args 0 0] partzerozero varspecs rhs]} { + # set argstail [lassign $args hd] + # #set tail [expr {($hd eq $partzerozero) ? $argstail : [concat [lrange $hd 1 end] $argstail ] }] ;#!WRONG. expr will convert some numbers to scientific notation - this is premature/undesirable! + # #avoid using the return from expr and it works: + # expr {($hd eq $partzerozero) ? [set tail $argstail] : [set tail [concat [lrange $hd 1 end] $argstail ]] } + # + # tailcall ::punk::match_exec $varspecs $rhs {*}$tail + # #return [uplevel 1 [list ::punk::match_exec $varspecs $rhs {*}$tail]] + #} + + } + configure_unknown + #if client redefines 'unknown' after package require punk, they must call punk::configure_unknown afterwards. + # + + #main Pipe initiator function - needed especially if 'unknown' not configured to interpret x.= x= etc + #Should theoretically be slightly faster.. but pipelines are relatively slow until we can get pipeline compiling and optimisation. + proc % {args} { + set arglist [lassign $args assign] ;#tail, head + if {$assign eq ".="} { + tailcall {*}[list ::punk::pipeline .= "" "" {*}$arglist] + } elseif {$assign eq "="} { + tailcall {*}[list ::punk::pipeline = "" "" {*}$arglist] + } + + #review + set assign [string map {; \\;} $assign] + + set is_script [punk::pipe::lib::arg_is_script_shaped $assign] + + if {!$is_script && [string index $assign end] eq "="} { + #set re_dotequals {^([^ \t\r\n=\{]*)\.=$} + #set dumbeditor {\}} + #set re_equals {^([^ \t\r\n=\{]*)=$} + #set dumbeditor {\}} + if {[regexp {^([^ \t\r\n=\{]*)\.=$} $assign _ returnvarspecs]} { + set cmdlist [list ::punk::pipeline .= $returnvarspecs "" {*}$arglist] + } elseif {[regexp {^([^ \t\r\n=\{]*)=$} $assign _ returnvarspecs]} { + set cmdlist [list ::punk::pipeline = $returnvarspecs "" {*}$arglist] + } else { + error "pipesyntax punk::% unable to interpret pipeline '$args'" "% $args" [list pipesyntax unable_to_interpret] + } + } else { + if {$is_script} { + set cmdlist [list ::punk::pipeline "script" "" "" {*}$args] + } else { + set cmdlist [list ::punk::pipeline ".=" "" "" $assign {*}$arglist] + } + } + tailcall {*}$cmdlist + + + #result-based mismatch detection can probably never work nicely.. + #we need out-of-band method to detect mismatch. Otherwise we can't match on mismatch results! + # + set result [uplevel 1 $cmdlist] + #pipeline result not guaranteed to be a proper list so we can't use list methods to directly look for 'binding mismatch' + #.. but if we use certain string methods - we shimmer the case where the main result is a list + #string match doesn't seem to change the rep.. though it does generate a string rep. + #puts >>1>[rep $result] + if {[catch {lrange $result 0 1} first2wordsorless]} { + #if we can't get as a list then it definitely isn't the semi-structured 'binding mismatch' + return $result + } else { + if {$first2wordsorless eq {binding mismatch}} { + error $result + } else { + #puts >>2>[rep $result] + return $result + } + } + } + + proc ispipematch {args} { + expr {[lindex [uplevel 1 [list ::punk::pipematch {*}$args]] 0] eq "ok"} + } + + #pipe initiator which will never raise an error *except for pipesyntax* , but always returns {ok {result something}} or {error {mismatch something}} or, for tcl errors {error {reason something}} + proc pipematch {args} { + #debug.punk.pipe {pipematch level [info level] levelinfo [info level 0]} 2 + variable re_dot_assign + variable re_assign + + set arglist [lassign $args assign] + if {$assign eq ".="} { + set cmdlist [list ::punk::pipeline .= "" "" {*}$arglist] + } elseif {$assign eq "="} { + set cmdlist [list ::punk::pipeline = "" "" {*}$arglist] + } elseif {![punk::pipe::lib::arg_is_script_shaped $assign] && [string index $assign end] eq "="} { + #set re_dotequals {^([^ \t\r\n=\{]*)\.=$} + # set dumbeditor {\}} + #set re_equals {^([^ \t\r\n=\{]*)=$} + # set dumbeditor {\}} + if {[regexp {^([^ \t\r\n=]*)\.=.*} $assign _ returnvarspecs]} { + set cmdlist [list ::punk::pipeline .= $returnvarspecs "" {*}$arglist] + } elseif {[regexp {^([^ \t\r\n=]*)=.*} $assign _ returnvarspecs]} { + set cmdlist [list $assign {*}$arglist] + #set cmdlist [list ::punk::pipeline = $returnvarspecs "" {*}$arglist] + } else { + error "pipesyntax punk::pipematch unable to interpret pipeline '$args'" "pipematch $args" [pipesyntax unable_to_interpret] + } + } else { + set cmdlist $args + #script? + #set cmdlist [list ::punk::pipeline .= "" "" {*}$args] + } + + if {[catch {uplevel 1 $cmdlist} result erroptions]} { + #puts stderr "pipematch erroptions:$erroptions" + #debug.punk.pipe {pipematch error $result} 4 + set ecode [dict get $erroptions -errorcode] + switch -- [lindex $ecode 0] { + binding { + if {[lindex $ecode 1] eq "mismatch"} { + #error {reason xxx} should only be returned for underlying tcl errors. error {someotherkey xxx} for structured errors such as a binding mismatch + #return [dict create error [dict create mismatch $result]] + #puts stderr "pipematch converting error to {error {mismatch }}" + return [list error [list mismatch $result]] + } + } + pipesyntax { + #error $result + return -options $erroptions $result + } + casematch { + return $result + } + } + #return [dict create error [dict create reason $result]] + return [list error [list reason $result]] + } else { + return [list ok [list result $result]] + #debug.punk.pipe {pipematch result $result } 4 + #return [dict create ok [dict create result $result]] + } + } + + proc pipenomatchvar {varname args} { + if {[string first = $varname] >=0} { + #first word "pipesyntax" is looked for by pipecase + error "pipesyntax pipenomatch expects a simple varname as first argument" "pipenomatchvar $varname $args" [list pipesyntax expected_simple_varname] + } + #debug.punk.pipe {pipematch level [info level] levelinfo [info level 0]} 2 + + set assign [lindex $args 0] + set arglist [lrange $args 1 end] + if {[string first = $assign] >= 0} { + variable re_dot_assign + variable re_assign + #what if we get passed a script block containing = ?? e.g {error x=a} + if {$assign eq ".="} { + set cmdlist [list ::punk::pipeline .= "" "" {*}$arglist] + } elseif {$assign eq "="} { + set cmdlist [list ::punk::pipeline = "" "" {*}$arglist] + } elseif {[regexp $re_dot_assign $assign _ returnvarspecs rhs]} { + set cmdlist [list ::punk::pipeline .= $returnvarspecs $rhs {*}$arglist] + } elseif {[regexp $re_assign $assign _ returnvarspecs rhs]} { + set cmdlist [list ::punk::pipeline = $returnvarspecs $rhs {*}$arglist] + } else { + debug.punk.pipe {[a+ yellow bold] Unexpected arg following pipenomatchvar variable [a]} 0 + set cmdlist $args + #return [dict create error [dict create reason [dict create pipematch bad_first_word value $assign pipeline [list pipematch $assign {*}$args]]]] + } + } else { + set cmdlist $args + } + + upvar 1 $varname nomatchvar + if {[catch {uplevel 1 $cmdlist} result erroptions]} { + set ecode [dict get $erroptions -errorcode] + debug.punk.pipe {[a+ yellow bold]pipematchnomatch error $result[a]} 3 + if {[lindex $ecode 0] eq "pipesyntax"} { + set errordict [dict create error [dict create pipesyntax $result]] + set nomatchvar $errordict + return -options $erroptions $result + } + if {[lrange $ecode 0 1] eq "binding mismatch"} { + #error {reason xxx} should only be returned for underlying tcl errors. error {someotherkey xxx} for structured errors such as a binding mismatch + set errordict [dict create error [dict create mismatch $result]] + set nomatchvar $errordict + return -options $erroptions $result + } + set errordict [dict create error [dict create reason $result]] + set nomatchvar $errordict + #re-raise the error for pipeswitch to deal with + return -options $erroptions $result + } else { + debug.punk.pipe {pipematchnomatch result $result } 4 + set nomatchvar "" + #uplevel 1 [list set $varname ""] + #return raw result only - to pass through to pipeswitch + return $result + #return [dict create ok [dict create result $result]] + } + } + + #should only raise an error for pipe syntax errors - all other errors should be wrapped + proc pipecase {args} { + #debug.punk.pipe {pipecase level [info level] levelinfo [info level 0]} 9 + set arglist [lassign $args assign] + if {$assign eq ".="} { + set cmdlist [list ::punk::pipeline .= "" "" {*}$arglist] + } elseif {$assign eq "="} { + #set cmdlist [list ::punk::pipeline = "" "" {*}$arglist] + set cmdlist [list ::= {*}$arglist] + } elseif {![punk::pipe::lib::arg_is_script_shaped $assign] && [string first "=" $assign] >= 0} { + #set re_dotequals {^([^ \t\r\n=\{]*)\.=$} + #set dumbeditor {\}} + #set re_equals {^([^ \t\r\n=\{]*)=$} + #set dumbeditor {\}} + + if {[regexp {^([^ \t\r\n=]*)\.=.*} $assign _ returnvarspecs]} { + set cmdlist [list ::punk::pipeline .= $returnvarspecs "" {*}$arglist] + } elseif {[regexp {^([^ \t\r\n=]*)=.*} $assign _ returnvarspecs]} { + set cmdlist [list $assign {*}$arglist] + #set cmdlist [list ::punk::pipeline = $returnvarspecs "" {*}$arglist] + } else { + error "pipesyntax pipecase unable to interpret pipeline '$args'" + } + #todo - account for insertion-specs e.g x=* x.=/0* + } else { + #script? + set cmdlist [list ::punk::pipeline .= "" "" {*}$args] + } + + + if {[catch {uplevel 1 [list ::if 1 $cmdlist]} result erroptions]} { + #puts stderr "====>>> result: $result erroptions" + set ecode [dict get $erroptions -errorcode] + switch -- [lindex $ecode 0] { + pipesyntax { + #error $result + return -options $erroptions $result + } + casenomatch { + return -options $erroptions $result + } + binding { + if {[lindex $ecode 1] eq "mismatch"} { + #error {reason xxx} should only be returned for underlying tcl errors. error {someotherkey xxx} for structured errors such as a binding mismatch + #return [dict create error [dict create mismatch $result]] + # + #NOTE: casemismatch is part of the api for pipecase. It is a casemismatch rather than an error - because for a pipecase - a casemismatch is an expected event (many casemismatches - one match) + return [dict create casemismatch $result] + } + } + } + + #we can't always treat $result as a list - may be an error string which can't be represented as a list, and there may be no useful errorCode + #todo - use errorCode instead + if {[catch {lindex $result 0} word1]} { + #tailcall error $result + return -options $erroptions $result + } else { + switch -- $word1 { + switcherror - funerror { + error $result "pipecase [lsearch -all -inline $args "*="]" + } + resultswitcherror - resultfunerror { + #recast the error as a result without @@ok wrapping + #use the tailcall return to stop processing other cases in the switch! + tailcall return [dict create error $result] + } + ignore { + #suppress error, but use normal return + return [dict create error [dict create suppressed $result]] + } + default { + #normal tcl error + #return [dict create error [dict create reason $result]] + tailcall error $result "pipecase $args" [list caseerror] + } + } + } + } else { + tailcall return -errorcode [list casematch] [dict create ok [dict create result $result]] + } + + } + + #note that pipeswitch deliberately runs in callers scope to have direct access to variables - it is akin to a control structure. + #It also - somewhat unusually accepts args - which we provide as 'switchargs' + #This is unorthodox/risky in that it will clobber any existing var of that name in callers scope. + #Solve using documentation.. consider raising error if 'switchargs' already exists, which would require user to unset switchargs in some circumstances. + proc pipeswitch {pipescript args} { + #set nextargs $args + #unset args + #upvar args upargs + #set upargs $nextargs + upvar switchargs switchargs + set switchargs $args + uplevel 1 [::list ::if 1 $pipescript] + } + #static-closure version - because we shouldn't be writing back to calling context vars directly + #Tcl doesn't (2023) have mutable closures - but for functional pipeline composition - we probably don't want that anyway! + #pipeswitchc is preferable to pipeswitch in that we can access context without risk of affecting it, but is less performant. (particularly in global scope.. but that probably isn't an important usecase) + proc pipeswitchc {pipescript args} { + set binding {} + if {[info level] == 1} { + #up 1 is global + set get_vars [list info vars] + } else { + set get_vars [list info locals] + } + set vars [uplevel 1 {*}$get_vars] + set posn [lsearch $vars switchargs] + #set vars [lreplace $vars $posn $posn] + set vars [lreplace $vars[set vars {}] $posn $posn] + foreach v $vars { + upvar 1 $v var + if {(![array exists var]) && [info exists var]} { + lappend binding [list $v $var] ;#values captured as defaults for apply args. + } + } + lappend binding [list switchargs $args] + apply [list $binding $pipescript [uplevel 1 {::tcl::namespace::current}]] + } + + proc pipedata {data args} { + #puts stderr "'$args'" + set r $data + for {set i 0} {$i < [llength $args]} {incr i} { + set e [lindex $args $i] + #review: string is list is as slow as catch {llength $e} - and also affects ::errorInfo unlike other string is commands. bug/enhancement report? + if {![string is list $e]} { + #not a list - assume script and run anyway + set r [apply [list {data} $e] $r] + } else { + if {[llength $e] == 1} { + switch -- $e { + > { + #output to calling context. only pipedata return value and '> varname' should affect caller. + incr i + uplevel 1 [list set [lindex $args $i] $r] + } + % - pipematch - ispipematch { + incr i + set e2 [lindex $args $i] + #set body [list $e {*}$e2] + #append body { $data} + + set body [list $e {*}$e2] + append body { {*}$data} + + + set applylist [list {data} $body] + #puts stderr $applylist + set r [apply $applylist $r] + } + pipeswitch - pipeswitchc { + #pipeswitch takes a script not a list. + incr i + set e2 [lindex $args $i] + set body [list $e $e2] + #pipeswitch takes 'args' - so expand $data when in pipedata context + append body { {*}$data} + #use applylist instead of uplevel when in pipedata context! + #can use either switchdata/data but not vars in calling context of 'pipedata' command. + #this is consistent with pipeswitch running in a % / .= pipeline which can only access vars in immediate calling context. + set applylist [list {data} $body] + #puts stderr $applylist + set r [apply $applylist $r] + } + default { + #puts "other single arg: [list $e $r]" + append e { $data} + set r [apply [list {data} $e] $r] + } + } + } elseif {[llength $e] == 0} { + #do nothing - pass data through + #leave r as is. + } else { + set r [apply [list {data} $e] $r] + } + } + } + return $r + } + + + proc scriptlibpath {{shortname {}} args} { + set scriptlib [punk::config::configure running scriptlib] + if {[string match "lib::*" $shortname]} { + set relpath [string map [list "lib::" "" "::" "/"] $shortname] + set relpath [string trimleft $relpath "/"] + set fullpath $scriptlib/$relpath + } else { + set shortname [string trimleft $shortname "/"] + set fullpath $scriptlib/$shortname + } + return $fullpath + } + + + #useful for aliases e.g treemore -> xmore tree + proc xmore {args} { + if {[llength $args]} { + #more is older and not as featureful as less + #more importantly - at least some implementations (msys on windows) can skip output lines - unknown as to why + #uplevel #0 [list {*}$args | more] + uplevel #0 [list {*}$args | less -X] ;#-X to avoid use of alternate-screen + } else { + error "usage: punk::xmore args where args are run as {*}\$args | more" + } + } + + + #environment path as list + # + #return *appendable* pipeline - i.e no args via <| + proc path_list_pipe {{glob *}} { + if {$::tcl_platform(platform) eq "windows"} { + set sep ";" + } else { + # : ok for linux/bsd ... mac? + set sep ":" + } + set cond [string map [list $glob] {expr {[string length $item] && [string match $item]}}] + #env members such as ''path' not case sensitive on windows - but are on some other platforms (at least FreeBSD) + return [list .= set ::env(PATH) |> .=>2 string trimright $sep |> .=>1 split $sep |> list_filter_cond $cond ] + } + proc path_list {{glob *}} { + set pipe [punk::path_list_pipe $glob] + {*}$pipe + } + proc path_basic {{glob *}} { + set pipe [punk::path_list_pipe $glob] + {*}$pipe |> list_as_lines + } + namespace eval argdoc { + punk::args::define { + @id -id ::punk::path + @cmd -name "punk::path"\ + -summary\ + "Display PATH executable shadowing and conflicts with TCL commands"\ + -help\ + {Introspection of the PATH environment variable. + This tool will examine executables within each PATH entry and show which binaries + are overshadowed by earlier PATH entries. + It can also be used to examine the contents of each PATH entry, and to filter results using glob patterns. + + ${[punk::args::helpers::example { + + #show all executables in all PATH entries + punk::path + #show all executables in all PATH entries that contain 'Windows' in the path + punk::path -pathglob *Windows* + #show all executables in all PATH entries that contain 'scoop' in the path, + #and filter the executables to show only those that are named dir, ls or start with 'ca' + punk::path -pathglob *scoop* dir ls ca* + #show all executables that conflict with TCL commands starting with 'a' in the current namespace. + punk::path {*}[nscommandlist a*] + #show all executables that conflict with TCL commands resolvable from the current namespace. + punk::path {*}[info commands] + + }]} + + see also the punk::auto_exec package. + } + @opts + -pathglob -type string -default {*} -multiple true -help "Case insensitive glob pattern to filter path entries. Default '*' to include all PATH directories." + @values -min 0 -max -1 + binglob -type list -default {*} -multiple true -optional 1 -help "glob pattern to filter results. Default '*' to include all entries." + } + } + + variable d_path_info + variable d_bin_info + variable d_index_executables + #there is still a potential conflict regarding auto_execok on windows - which has some cmd.exe builtins as auto-executable + #- but these are not actually executable files on the filesystem - so they won't be found by our path search + #- but they will be found when not masked by a tcl command. + proc path {args} { + variable d_path_info + variable d_bin_info + variable d_index_executables + set is_windows [expr {$::tcl_platform(platform) eq "windows"}] + set argd [punk::args::parse $args withid ::punk::path] + lassign [dict values $argd] leaders opts values received + set pathglobs [dict get $opts -pathglob] + set binglobs [dict get $values binglob] + if {$is_windows} { + set sep ";" + } else { + # : ok for linux/bsd ... mac? + set sep ":" + } + set all_paths [split [string trimright $::env(PATH) $sep] $sep] + if {[llength $pathglobs]} { + if {[lsearch -exact $pathglobs "*"] >= 0} { + #if we have a wildcard glob then the others are irrelevant - we want to match all paths + set matched_paths $all_paths + } else { + set matched_paths [list] + foreach p $all_paths { + foreach pg $pathglobs { + if {[string match -nocase $pg $p]} { + lappend matched_paths $p + break + } + } + } + } + } + + #This should be designed to be useful on all platforms. + #Case sensitivity represents a difficulty because even on a particular platform + #- different filesystems or folders may have different case sensitivity configurations. + + #as a first step - we can detect windows and mac platforms and treat paths as case-insensitive, vs case-sensitive on other unix-like platforms. + #as a second step - we will consider running a test on each path to determine if the folder at the leaf level is case-sensitive or not. + #- and then use that information to determine how to treat the executables in that path. + #This may be a bit of a performance hit - so we may want to cache the results of this test for each path - and provide a way to clear the cache if needed. + #Alternatively we could just provide an option to treat all paths as case-sensitive or case-insensitive. + + #Windows executable search location order: + #1. The current directory. + #2. The directories that are listed in the PATH environment variable. + # within each directory windows uses the PATHEXT environment variable to determine + #which files are considered executable and in which order they are considered. + #So for example if PATHEXT is set to .COM;.EXE;.BAT;.CMD then if there are files + #with the same name but different extensions in the same directory, then the one + #with the extension that appears first in PATHEXT will be executed when that name is called. + + #On windows platform, PATH entries can be case-insensitively duplicated - we want to treat these as the same path for the purposes of overshadowing - but we want to show the actual paths in the output. + #Duplicate PATH entries are also a fairly likely possibility on all platforms. + #This is likely a misconfiguration, but we want to be able to show it in the output - as it can affect which executables are overshadowed by which PATH entries. + + #By default we don't want to display all executables in all PATH entries - as this can be very verbose + #- but we want to be able to show which executables are overshadowed by which PATH entries, + #and to be able to filter the PATH entries and the executables using glob patterns. + #To achieve this we will build two dicts - one keyed by normalized path, and one keyed by normalized executable name. + #The path dict will contain the original paths that correspond to each normalized path, and the indices of those paths + #in the original PATH list. The executable dict will contain the paths and path indices where each executable is found, + #and the actual executable names (with case and extensions as they appear on the filesystem). We will also build a + #dict keyed by path index which contains the list of executables in that path - to make it easy to show which + #executables are overshadowed by which paths. + if {$is_windows} { + #Sometimes PATHEXT includes an entry of just a dot - which means files with no extension are considered executable. + #We need to account for this in our glob pattern. + set pathexts [list] + #review - we assume this is only relevant on windows for now. + if {[info exists ::env(PATHEXT)]} { + set env_pathexts [split $::env(PATHEXT) ";"] + #set pathexts [lmap e $env_pathexts {string tolower $e}] + foreach pe $env_pathexts { + if {$pe eq "."} { + continue + } + lappend pathexts [string tolower $pe] + } + } else { + set env_pathexts [list] + #default PATHEXT if not set - according to Microsoft docs + set pathexts [list .com .exe .bat .cmd] + } + foreach bg $binglobs { + set has_pathext 0 + foreach pe $pathexts { + if {[string match -nocase "*$pe" $bg]} { + set has_pathext 1 + break + } + } + if {!$has_pathext} { + foreach pe $pathexts { + set globext "$bg$pe" + if {$globext ni $binglobs} { + lappend binglobs "$bg$pe" + } + } + } + } + set lc_binglobs [lmap e $binglobs {string tolower $e}] + if {"." in $pathexts} { + foreach bg $binglobs { + set has_pathext 0 + foreach pe $pathexts { + if {[string match -nocase "*$pe" $bg]} { + set base [string range $bg 0 [expr {[string length $bg] - [string length $pe] - 1}]] + set has_pathext 1 + break + } + } + if {$has_pathext} { + if {[string tolower $base] ni $lc_binglobs} { + lappend binglobs "$base" + } + } + } + } + } + + set d_path_info [dict create] ;#key is normalized path (e.g case-insensitive on windows). + set d_bin_info [dict create] ;#key is normalized executable name (e.g case-insensitive on windows, or callable with extensions stripped off). + set d_index_executables [dict create] ;#key is path index, value is list of executables in that path + set path_idx 0 + foreach p $all_paths { + if {$is_windows} { + set pnorm [string tolower $p] + } else { + set pnorm $p + } + if {[string length $pnorm] > 1} { + set lastchar [string index $pnorm end] + if {$lastchar eq "/" || $lastchar eq "\\"} { + set pnorm [string range $pnorm 0 end-1] + } + } + if {![dict exists $d_path_info $pnorm]} { + dict set d_path_info $pnorm [dict create original_paths [list $p] indices [list $path_idx]] + set executables [list] + if {[file isdirectory $p]} { + #get all files that are executable in this path. + #If we don't normalize the path here - then trailing backslashes on windows can cause a problem with the -tail glob returning a leading slash on the executable names. + #also as we don't necessarily normalize the resulting final path with executable - we want the case to be correct. + set pnormglob [file normalize $p] + if {$is_windows} { + + #TCL's glob on windows is case-insensitive, but in some cases return the result with the case as globbed for regardless of the actual case on the filesystem. + #(This seems to occur when the pattern does *not* contain a wildcard and is probably a bug) + #We would rather report results with the actual case as they appear on the filesystem - so we try to normalize the results. + #The normalization doesn't work as expected - but can be worked around by using 'string range $e 0 end' instead of just $e - which seems to force Tcl to give us the actual case from the filesystem rather than the case as globbed for. + #(another workaround is to use a degenerate case glob e.g when looking for 'SDX.exe' to glob for '[S]DX.exe' + # but tcl's glob does not respect the case of even the character-class pattern - so this is not a reliable workaround). + #see punk::fglob for a work-in-progress glob implementation which gives us more control over case sensitivity and the case of results on windows. + + #----------------------- + #JJJ + #set globresults [lsort -unique [glob -nocomplain -directory $pnormglob -types {f x} {*}$binglobs]] + #set executables [list] + #foreach e $globresults { + # puts stderr "glob result: $e" + # puts stderr "normalized executable name: [file tail [file normalize [string range $e 0 end]]]]" + # lappend executables [file tail [file normalize $e]] + #} + #----------------------- + + #track all executables in the path - even those that don't match the binglobs + #use fglob to get the actual case of the executables on windows - as glob seems to return the case as globbed for rather than the actual case on the filesystem in some cases. + #this doesn't run a full 'file normalize' on the results which affects whether a more efficient internal representation is stored + + #fglob with single glob argument should already return a unique list. + set folder_exes [fglob -nocomplain -directory $pnormglob -types {f x} *] + set executables [list] + foreach e $folder_exes { + lappend executables [file tail $e] + } + + } else { + #set executables [lsort -unique [glob -nocomplain -directory $p -types {f x} -tail {*}$binglobs]] + set executables [lsort -unique [glob -nocomplain -directory $p -types {f x} -tail *]] + } + } + dict set d_index_executables $path_idx $executables + foreach exe $executables { + #todo - other case-insensitive platforms/filesystems. + if {$is_windows} { + set exe_key [string tolower $exe] + } else { + #on case + set exe_key $exe + } + if {![dict exists $d_bin_info $exe_key]} { + dict set d_bin_info $exe_key [dict create path_indices [list $path_idx] paths [list $p] executable_names [list $exe]] + } else { + #dict lappend d_bin_info $exe_key path_indices $path_idx paths $p executable_names $exe + set bindata [dict get $d_bin_info $exe_key] + dict lappend bindata path_indices $path_idx + dict lappend bindata paths $p + dict lappend bindata executable_names $exe + dict set d_bin_info $exe_key $bindata + } + } + } else { + #duplicate path entry - add to list of original paths for this normalized path + + # Tcl's dict lappend takes the arguments dictionaryVariable key value ?value ...? + # we need to extract the inner dictionary containig lists to append to, and then set it back after appending to the lists within it. + set pathdata [dict get $d_path_info $pnorm] + dict lappend pathdata original_paths $p + dict lappend pathdata indices $path_idx + dict set d_path_info $pnorm $pathdata + + #consider this alternative approach which reduces number of references to the extracted inner dictionary. + #Will it help avoid copy on write performance issues with dicts? + #see voo package. + # --------------- + #set pathdata [dict get $d_path_info $pnorm] + #dict set d_path_info $pnorm {} + #try { + # dict lappend pathdata original_paths $p + # dict lappend pathdata indices $path_idx + #} finally { + # dict set d_path_info $pnorm $pathdata + #} + # --------------- + + #we don't need to add executables for this path - as they will be the same as the original path that we have already processed. + #However we do need to add the path index to the path_indices for each executable that is found in this path - as this will affect which paths are shown as overshadowing which executables. + set executables [dict get $d_index_executables [lindex [dict get $d_path_info $pnorm indices] 0]] ;#get executables for this path + foreach exe $executables { + if {$is_windows} { + set exe_key [string tolower $exe] + } else { + set exe_key $exe + } + #dict lappend d_bin_info $exe_key path_indices $path_idx paths $p executable_names $exe + set bindata [dict get $d_bin_info $exe_key] + dict lappend bindata path_indices $path_idx + dict lappend bindata paths $p + dict lappend bindata executable_names $exe + dict set d_bin_info $exe_key $bindata + } + } + + incr path_idx + } + + #temporary debug output to check dicts are being built correctly + #set debug "" + #append debug "Path info dict:" \n + #append debug [showdict $d_path_info] \n + #append debug "Binary info dict:" \n + #append debug [showdict $d_bin_info {*}$binglobs] \n + ##append debug "Index executables dict:" \n + ##append debug [showdict $d_index_executables] \n + ##return $debug + #puts stdout $debug + + + #dict for {p pinfo} $d_path_info { + # set original_paths [dict get $pinfo original_paths] + # set indices [dict get $pinfo indices] + # puts stdout "Path: $p" + # puts stdout " Original paths: $original_paths" + # puts stdout " Indices in PATH: $indices" + # if {[dict exists $d_index_executables [lindex $indices 0]]} { + # set executables [dict get $d_index_executables [lindex $indices 0]] + # puts stdout " Executables: [llength $executables]" + # } else { + # puts stdout " Executables: (not a directory or no executables found)" + # } + #} + + set nscaller [uplevel 1 {::tcl::namespace::current}] + set context_commands [namespace eval $nscaller {info commands}] + + #process paths in order they appear in the original PATH. + set pidx 0 + #use a punk::textblock::table for formatting. + set rows [list] + set headers [list "idx" "Path" "exe\nCount" "Shadow\nCount" "Executables" "TCL context\nConflicts"] + set ERR [punk::ansi::a+ red bold] + set RST [punk::ansi::a] + set STR [punk::ansi::a+ strike] + set SDW [punk::ansi::a+ red strike] + set WRN [punk::ansi::a+ yellow bold] + set subcols 2 + foreach p $all_paths { + #if {$p ni $matched_paths} { + # incr pidx + # continue + #} + set thisrow [list $pidx] + if {$is_windows} { + set pnorm [string tolower $p] + } else { + set pnorm $p + } + if {[string length $pnorm] > 1} { + set lastchar [string index $pnorm end] + if {$lastchar eq "/" || $lastchar eq "\\"} { + set pnorm [string range $pnorm 0 end-1] + } + } + set pinfo [dict get $d_path_info $pnorm] + set original_paths [dict get $pinfo original_paths] + set indices [dict get $pinfo indices] + if {[lindex $indices 0] == $pidx} { + #this is the first occurrence of this path in the original PATH. + set overshadowed [list] + set conflicts [list] + lappend thisrow $p + if {[dict exists $d_index_executables $pidx]} { + set executables [dict get $d_index_executables $pidx] + lappend thisrow [llength $executables] + set display_executables [list] + foreach exe $executables { + set matched_binglob 0 + if {$is_windows} { + foreach bg $binglobs { + #review - -nocase only on case-insensitive platforms/filesystems? + #todo - mac has case-insensitive filesystem by default. + if {[string match -nocase $bg $exe]} { + set matched_binglob 1 + continue + } + } + } else { + foreach bg $binglobs { + if {[string match $bg $exe]} { + set matched_binglob 1 + continue + } + } + } + if {$is_windows} { + set exe_key [string tolower $exe] + } else { + set exe_key $exe + } + if {[dict exists $d_bin_info $exe_key]} { + set bindata [dict get $d_bin_info $exe_key] + set path_indices [dict get $bindata path_indices] + set is_overshadowed 0 + foreach pi $path_indices { + if {$pi < $pidx} { + lappend overshadowed $exe + set is_overshadowed 1 + break + } + } + if {$matched_binglob} { + if {$is_windows} { + #check for matches in context_commands - which are case-insensitive on windows + #the context_commands are however case sensitive. + #we want to mark conflicts in one of two ways in the conflicts column. + #- if there is a case-insensitive match but not a case-sensitive match + #- then we have a conflict but not an exact match - so we will mark this with orange style. + #If there is an exact match in context_commands - then we will mark this with the red style + #to indicate that this executable is overshadowed by a command in the current context. + + #we may have multiple tcl commands that conflict with the same executable. + #e.g DIG and dig. + if {[llength [set ncmatches [lsearch -all -inline -nocase $context_commands [file rootname $exe]]]]} { + if {[set exactmatch [lsearch -exact $context_commands [file rootname $exe]]] ne ""} { + foreach nc $ncmatches { + set nc [namespace eval $nscaller [list namespace origin $nc]] + if {$nc eq $exactmatch} { + lappend conflicts $ERR$nc$RST + } else { + lappend conflicts "$WRN$nc$RST" + } + } + } else { + foreach nc $ncmatches { + set nc [namespace eval $nscaller [namespace origin $nc]] + lappend conflicts "$WRN$nc$RST" + } + } + } else { + if {[llength [set ncmatches [lsearch -all -inline -nocase $context_commands $exe]]]} { + if {[set exactmatch [lsearch -exact $context_commands $exe]] ne ""} { + foreach nc $ncmatches { + set nc [namespace eval $nscaller [namespace origin $nc]] + if {$nc eq $exactmatch} { + lappend conflicts $ERR$nc$RST + } else { + lappend conflicts "$WRN$nc$RST" + } + } + } else { + foreach nc $ncmatches { + set nc [namespace eval $nscaller [namespace origin $nc]] + lappend conflicts "$WRN$nc$RST" + } + } + } + } + + } else { + #check for any exact matches in context_commands + if {$exe in $context_commands} { + lappend conflicts $ERR$exe$RST + } + } + if {$is_overshadowed} { + lappend display_executables "$SDW$exe$RST" + } else { + lappend display_executables $exe + } + } + } else { + #executable not found in bin_info dict - this shouldn't happen - but if it does we will just treat it as not overshadowed and include it in the display. + lappend display_executables $WRN$exe$RST + } + } + if {[llength $overshadowed]} { + lappend thisrow "$ERR[llength $overshadowed]$RST" + } else { + lappend thisrow "0" + } + if {[llength $display_executables]} { + lappend thisrow [textblock::list_as_table -columns $subcols -show_edge 0 $display_executables] + } else { + lappend thisrow "" + } + if {[llength $conflicts]} { + #lappend thisrow [textblock::list_as_table -columns $subcols -show_edge 0 $conflicts] + lappend thisrow [join $conflicts \n] + } else { + lappend thisrow "" + } + } else { + lappend thisrow "" + lappend thisrow "" + lappend thisrow "" + lappend thisrow "(not a directory or no executables found)" + lappend thisrow "" + } + } else { + #this is a duplicate path entry - we want to show it as a duplicate of the original path entry. + set original_path_idx [lindex $indices 0] + set original_path [lindex [dict get $d_path_info $pnorm original_paths] 0] + #duplicate paths might be cased differently. + lappend thisrow "$ERR$p (repeated pathentry)\n original at index $original_path_idx as\n$original_path$RST" + set overshadowed [list] + set conflicts [list] + set display_executables [list] + if {[dict exists $d_index_executables $original_path_idx]} { + set executables [dict get $d_index_executables $original_path_idx] + lappend thisrow [llength $executables] + foreach exe $executables { + if {$is_windows} { + set exe_key [string tolower $exe] + } else { + set exe_key $exe + } + if {[dict exists $d_bin_info $exe_key]} { + set bindata [dict get $d_bin_info $exe_key] + set path_indices [dict get $bindata path_indices] + set is_overshadowed 0 + foreach pi $path_indices { + if {$pi < $pidx} { + lappend overshadowed $exe + set is_overshadowed 1 + break + } + } + + + + #dupe will always have all exes as overshadowed by the original. + #don't need to waste time and screen space to display duplicate info - the user should tidy up the PATH. + #if {$is_overshadowed} { + # lappend display_executables "$SDW$exe$RST" + #} else { + # lappend display_executables $exe + #} + } + } + } else { + #this shouldn't happen - but if it does we will just treat it as not overshadowed and include it in the display. + lappend thisrow "(not a directory or no executables found)" + } + if {[llength $overshadowed]} { + lappend thisrow "$ERR[llength $overshadowed]$RST" + } else { + lappend thisrow "0" + } + if {[llength $display_executables]} { + lappend thisrow [textblock::list_as_table -columns $subcols -show_edge 0 $display_executables] + } else { + lappend thisrow "" + } + lappend thisrow "" ;#don't show conflict info for duplicate paths - as the user should tidy up the PATH to remove duplicates, and the conflict info will be the same as the original path entry. + } + if {[llength $matched_paths] < [llength $all_paths]} { + #if there is any filtering of paths - then we want to show all these paths whether or not there are any matches for binglobs + if {$p in $matched_paths} { + lappend rows $thisrow + } + } else { + #no specific filtering of paths - so only show rows where there are matches for binglobs + if {[lsearch -exact $binglobs "*"] >= 0} { + lappend rows $thisrow + } else { + #end-1 is the executables column. + #if there are no matches for binglobs then we'll hide the row. + if {[string length [lindex $thisrow end-1]] > 0} { + lappend rows $thisrow + } + } + } + incr pidx + } + set t [textblock::table -return tableobject -rows $rows -headers $headers] + return [$t print] + + } + + #------------------------------------------------------------------- + #sh 'test' equivalent - to be used with exitcode of process + # + + #single evaluation to get exitcode + proc sh_test {args} { + set a1 [lindex $args 0] + if {$a1 in [list -b -c -d -e -f -h -L -s -S -x -w]} { + set a2 [lindex $args 1] + if {![catch { + set attrinfo [file attributes $a2] + } errM]} { + if {[dict exists $attrinfo -vfs] && [dict get $attrinfo -vfs] == 1} { + puts stderr "WARNING: external 'test' being called on vfs path. External command will probably not have access to the vfs. Use 'TEST' for Tcl view of vfs mounted filesystems." + } + } + } + tailcall run test {*}$args + } + + #whether v is an integer from perspective of unix test command. + #can be be bigger than a tcl int or wide ie bignum - but must be whole number + #test doesn't handle 1.0 - so we shouldn't auto-convert + proc is_sh_test_integer {v} { + if {[string first . $v] >=0 || [string first e $v] >= 0} { + return false + } + #if it is double but not sci notation and has no dots - then we can treat as a large integer for 'test' + if {[string is double -strict $v]} { + return true + } else { + return false + } + } + #can use double-evaluation to get true/false + #faster tcl equivalents where possible to accuratley provide, and fallthrough to sh for compatibility of unimplemented + #The problem with fallthrough is that sh/bash etc have a different view of existant files + #e.g unix files such as /dev/null vs windows devices such as CON,PRN + #e.g COM1 is mapped as /dev/ttyS1 in wsl (?) + #Note also - tcl can have vfs mounted file which will appear as a directory to Tcl - but a file to external commands! + #We will stick with the Tcl view of the file system. + #User can use their own direct calls to external utils if + #Note we can't support $? directly in Tcl - script would have to test ${?} or use [set ?] + proc sh_TEST {args} { + upvar ? lasterr + set lasterr 0 + set a1 [lindex $args 0] + set a2 [lindex $args 1] + set a3 [lindex $args 2] + set fileops [list -b -c -d -e -f -h -L -s -S -x -w] + if {[llength $args] == 1} { + #equivalent of -n STRING + set boolresult [expr {[string length $a1] != 0}] + } elseif {[llength $args] == 2} { + if {$a1 in $fileops} { + if {$::tcl_platform(platform) eq "windows"} { + #e.g trailing dot or trailing space + if {[punk::winpath::illegalname_test $a2]} { + #protect with \\?\ to stop windows api from parsing + #will do nothing if already prefixed with \\?\ + + set a2 [punk::winpath::illegalname_fix $a2] + } + } + } + switch -- $a1 { + -b { + #dubious utility on FreeBSD, windows? + #FreeBSD has dropped support for block devices - stating 'No serious applications rely on block devices' + #Linux apparently uses them though + if{[file exists $a2]} { + set boolresult [expr {[file type $a2] eq "blockSpecial"}] + } else { + set boolresult false + } + } + -c { + #e.g on windows CON,NUL + if {[file exists $a2]} { + set boolresult [expr {[file type $a2] eq "characterSpecial"}] + } else { + set boolresult false + } + } + -d { + set boolresult [file isdirectory $a2] + } + -e { + set boolresult [file exists $a2] + } + -f { + #e.g on windows CON,NUL + if {[file exists $a2]} { + set boolresult [expr {[file type $a2] eq "file"}] + } else { + set boolresult false + } + } + -h - + -L { + set boolresult [expr {[file type $a2] eq "link"}] + } + -s { + set boolresult [expr {[file exists $a2] && ([file size $a2] > 0 )}] + } + -S { + if {[file exists $a2]} { + set boolresult [expr {[file type $a2] eq "socket"}] + } else { + set boolresult false + } + } + -x { + set boolresult [expr {[file exists $a2] && [file executable $a2]}] + } + -w { + set boolresult [expr {[file exists $a2] && [file writable $a2]}] + } + -z { + set boolresult [expr {[string length $a2] == 0}] + } + -n { + set boolresult [expr {[string length $a2] != 0}] + } + default { + puts stderr "sh_TEST: delegating 'test $args' to external 'test' command" + #set boolresult [apply {arglist {uplevel #0 [runx test {*}$arglist]} ::} $args] + set callinfo [runx test {*}$args] + set errinfo [dict get $callinfo stderr] + set exitcode [dict get $callinfo exitcode] + if {[string length $errinfo]} { + puts stderr "sh_TEST error in external call to 'test $args': $errinfo" + set lasterr $exitcode + } + if {$exitcode == 0} { + set boolresult true + } else { + set boolresult false + } + } + } + } elseif {[llength $args] == 3} { + switch -- $a2 { + "=" { + #test does string comparisons + set boolresult [string equal $a1 $a3] + } + "!=" { + #string comparison + set boolresult [expr {$a1 ne $a3}] + } + "-eq" { + #test expects a possibly-large integer-like thing + #shell scripts will + if {![is_sh_test_integer $a1]} { + puts stderr "sh_TEST: invalid integer '$a1'" + set lasterr 2 + return false + } + if {![is_sh_test_integer $a3]} { + puts stderr "sh_TEST: invalid integer '$a3'" + set lasterr 2 + return false + } + set boolresult [expr {$a1 == $a3}] + } + "-ge" { + if {![is_sh_test_integer $a1]} { + puts stderr "sh_TEST: invalid integer '$a1'" + set lasterr 2 + return false + } + if {![is_sh_test_integer $a3]} { + puts stderr "sh_TEST: invalid integer '$a3'" + set lasterr 2 + return false + } + set boolresult [expr {$a1 >= $a3}] + } + "-gt" { + if {![is_sh_test_integer $a1]} { + puts stderr "sh_TEST: invalid integer '$a1'" + set lasterr 2 + return false + } + if {![is_sh_test_integer $a3]} { + puts stderr "sh_TEST: invalid integer '$a3'" + set lasterr 2 + return false + } + set boolresult [expr {$a1 > $a3}] + } + "-le" { + if {![is_sh_test_integer $a1]} { + puts stderr "sh_TEST: invalid integer '$a1'" + set lasterr 2 + return false + } + if {![is_sh_test_integer $a3]} { + puts stderr "sh_TEST: invalid integer '$a3'" + set lasterr 2 + return false + } + set boolresult [expr {$a1 <= $a3}] + } + "-lt" { + if {![is_sh_test_integer $a1]} { + puts stderr "sh_TEST: invalid integer '$a1'" + set lasterr 2 + return false + } + if {![is_sh_test_integer $a3]} { + puts stderr "sh_TEST: invalid integer '$a3'" + set lasterr 2 + return false + } + set boolresult [expr {$a1 < $a3}] + } + "-ne" { + if {![is_sh_test_integer $a1]} { + puts stderr "sh_TEST: invalid integer '$a1'" + set lasterr 2 + return false + } + if {![is_sh_test_integer $a3]} { + puts stderr "sh_TEST: invalid integer '$a3'" + set lasterr 2 + return false + } + set boolresult [expr {$a1 != $a3}] + } + default { + puts stderr "sh_TEST: delegating 'test $args' to external 'test' command" + #set boolresult [apply {arglist {uplevel #0 [runx test {*}$arglist]} ::} $args] + set callinfo [runx test {*}$args] + set errinfo [dict get $callinfo stderr] + set exitcode [dict get $callinfo exitcode] + if {[string length $errinfo]} { + puts stderr "sh_TEST error in external call to 'test $args': $errinfo" + set lasterr $exitcode + } + if {$exitcode == 0} { + set boolresult true + } else { + set boolresult false + } + + } + } + } else { + puts stderr "sh_TEST: delegating 'test $args' to external 'test' command" + #set boolresult [apply {arglist {uplevel #0 [runx test {*}$arglist]} ::} $args] + set callinfo [runx test {*}$args] + set errinfo [dict get $callinfo stderr] + set exitcode [dict get $callinfo exitcode] + if {[string length $errinfo]} { + puts stderr "sh_TEST error in external call to 'test $args': $errinfo" + set lasterr $exitcode + } + if {$exitcode == 0} { + set boolresult true + } else { + set boolresult false + } + } + + #normalize 1,0 etc to true,false + #we want to make it obvious we are not just reporting exitcode 0 for example - which represents true in tcl. + if {$boolresult} { + return true + } else { + if {$lasterr == 0} { + set lasterr 1 + } + return false + } + + + } + proc sh_echo {args} { + tailcall run echo {*}$args + } + proc sh_ECHO {args} { + #execute the result of the run command - which is something like: 'exitcode n' - to get true/false + tailcall apply {arglist {uplevel #0 [run echo {*}$arglist]} ::} $args + } + + + #sh style true/false for process exitcode. 0 is true - everything else false + proc exitcode {args} { + set c [lindex $args 0] + if {[string is integer -strict $c]} { + #return [expr {$c == 0}] + #return true/false to make it clearer we are outputting tcl-boolean inverse mapping from the shell style 0=true + if {$c == 0} { + return true + } else { + return false + } + } else { + return false + } + } + #------------------------------------------------------------------- + + namespace export help aliases alias exitcode % pipedata pipecase pipeline pipematch pipeswitch pipeswitchc pipecase linelist linesort inspect list_as_lines val treemore + + #namespace ensemble create + + + + + + + #maint - punk::args has similar + #this is largely obsolete - uses dict for argspecs (defaults) instead of textblock as in punk::args + #textblock has more flexibility in some ways - but not as easy to manipulate especially with regards to substitutions + #todo - consider a simple wrapper for punk::args to allow calling with dict of just name and default? + #JMN + #generally we expect values to contain leading dashes only if -- specified. Otherwise no reliable way determine difference between bad flags and values + #If no eopts (--) specified we stop looking for opts at the first nondash encountered in a position we'd expect a dash - so without eopt, values could contain dashes - but not in first position after flags. + #only supports -flag val pairs, not solo options + #If an option is supplied multiple times - only the last value is used. + #TODO - remove + proc get_leading_opts_and_values {defaults rawargs args} { + if {[llength $defaults] %2 != 0} { + error "get_leading_opts_and_values expected first argument 'defaults' to be a dictionary" + } + dict for {k v} $defaults { + if {![string match -* $k]} { + error "get_leading_opts_and_values problem with supplied defaults. Expect each key to begin with a dash. Got key '$k'" + } + } + #puts "--> [info frame -2] <--" + set cmdinfo [dict get [info frame -2] cmd] + #we can't treat cmdinfo as a list - it may be something like {command {*}$args} in which case lindex $cmdinfo 0 won't work + #hopefully first word is a plain proc name if this function was called in the normal manner - directly from a proc + #we will break at first space and assume the lhs of that will give enough info to be reasonable - (alternatively we could use entire cmdinfo - but it might be big and ugly) + set caller [regexp -inline {\S+} $cmdinfo] + + #if called from commandline or some other contexts such as outside of a proc in a namespace - caller may just be "namespace" + if {$caller eq "namespace"} { + set caller "get_leading_opts_and_values called from namespace" + } + + # ------------------------------ + if {$caller ne "get_leading_opts_and_values"} { + #check our own args + lassign [get_leading_opts_and_values {-anyopts 0 -minvalues 0 -maxvalues -1} $args] _o ownopts _v ownvalues + if {[llength $ownvalues] > 0} { + error "get_leading_opts_and_values expected: a dictionary of defaults, a list of args and at most two option pairs -minvalues and -maxvalues - got extra arguments: '$ownvalues'" + } + set opt_minvalues [dict get $ownopts -minvalues] + set opt_maxvalues [dict get $ownopts -maxvalues] + set opt_anyopts [dict get $ownopts -anyopts] + } else { + #don't check our own args if we called ourself + set opt_minvalues 0 + set opt_maxvalues 0 + set opt_anyopts 0 + } + # ------------------------------ + + if {[set eopts [lsearch $rawargs "--"]] >= 0} { + set values [lrange $rawargs $eopts+1 end] + set arglist [lrange $rawargs 0 $eopts-1] + } else { + if {[lsearch $rawargs -*] >= 0} { + #to support option values with leading dash e.g -offset -1 , we can't just take the last flagindex + set i 0 + foreach {k v} $rawargs { + if {![string match -* $k]} { + break + } + if {$i+1 >= [llength $rawargs]} { + #no value for last flag + error "bad options for $caller. No value supplied for last option $k" + } + incr i 2 + } + set arglist [lrange $rawargs 0 $i-1] + set values [lrange $rawargs $i end] + } else { + set values $rawargs ;#no -flags detected + set arglist [list] + } + } + if {$opt_maxvalues == -1} { + #only check min + if {[llength $values] < $opt_minvalues} { + error "bad number of trailing values for $caller. Got [llength $values] values. Expected at least $opt_minvalues" + } + } else { + if {[llength $values] < $opt_minvalues || [llength $values] > $opt_maxvalues} { + if {$opt_minvalues == $opt_maxvalues} { + error "bad number of trailing values for $caller. Got [llength $values] values. Expected exactly $opt_minvalues" + } else { + error "bad number of trailing values for $caller. Got [llength $values] values. Expected between $opt_minvalues and $opt_maxvalues inclusive" + } + } + } + + if {!$opt_anyopts} { + set checked_args [dict create] + for {set i 0} {$i < [llength $arglist]} {incr i} { + #allow this to error out with message indicating expected flags + dict set checked_args [tcl::prefix match -message "options for $caller. Unexpected option" [dict keys $defaults] [lindex $arglist $i]] [lindex $arglist $i+1] + incr i ;#skip val + } + } else { + set checked_args $arglist + } + set opts [dict merge $defaults $checked_args] + + #maintain order of opts $opts values $values as caller may use lassign. + return [dict create opts $opts values $values] + } + + + + + + + + + + #-------------------------------------------------- + #some haskell-like operations + #group equivalent + #http://zvon.org/other/haskell/Outputlist/group_f.html + #as we can't really distinguish a single element list from a string we will use 2 functions + proc group_list1 {lst} { + set out [list] + set prev [lindex $lst 0] + set g [list] + foreach i $lst { + if {$i eq $prev} { + lappend g $i + } else { + lappend out $g + set g [list $i] + } + set prev $i + } + lappend out $g + return $out + } + proc group_list {lst} { + set out [list] + set next [lindex $lst 1] + set tail [lassign $lst x] + set g [list $x] + set y [lindex $tail 0] + set last_condresult [expr {$x}] + set n 1 ;#start at one instead of zero for lookahead + foreach x $tail { + set y [lindex $tail $n] + set condresult [expr {$x}] + if {$condresult eq $last_condresult} { + lappend g $x + } else { + lappend out $g + set g [list $x] + set last_condresult $condresult + } + incr n + } + lappend out $g + return $out + } + + #NOT attempting to match haskell other than in overall concept. + # + #magic var-names are a bit of a code-smell. But submitting only an expr argument is more Tcl-like than requiring an 'apply' specification. + #Haskell seems to take an entire lambda so varnames can be user-specified - but the 'magic' there is in it's choice of submitting 2 elements at a time + #We could do similar .. but we'll focus on comprehensibility for the basic cases - especially as begginning and end of list issues could be confusing. + # + #vars: index prev, prev0, prev1, item, next, next0, next1,nextr, cond + #(nextr is a bit obscure - but basically means next-repeat ie if no next - use same value. just once though.) + #group by cond result or first 3 wordlike parts of error + #e.g group_list_by {[lindex $item 0]} {{a 1} {a 2} {b 1}} + proc group_list_by {cond lst} { + set out [list] + set prev [list] + set next [lindex $lst 1] + set tail [lassign $lst item] + set g [list $item] + set next [lindex $tail 0] + if {$prev eq ""} { + set prev0 0 + set prev1 1 + set prevr $item + } else { + set prev0 $prev + set prev1 $prev + set prevr $prev + } + if {$next eq ""} { + set next0 0 + set next1 1 + set nextr $item + } else { + set next0 $next + set next1 $next + set nextr $next + } + set last_condresult [apply {{index cond prev prev0 prev1 prevr item next next0 next1 nextr} { + if {[catch {expr $cond} r]} { + puts stderr "index: 0 ERROR $r" + set wordlike_parts [regexp -inline -all {\S+} $r] + set r [list ERROR {*}[lrange $wordlike_parts 0 2]] + } + set r + } + } 0 $cond $prev $prev0 $prev1 $prevr $item $next $next0 $next1 $nextr] + set n 1 ;#start at one instead of zero for lookahead + #note - n also happens to matchi zero-based index of original list + set prev $item + foreach item $tail { + set next [lindex $tail $n] + if {$prev eq ""} { + set prev0 0 + set prev1 1 + set prevr $item + } else { + set prev0 $prev + set prev1 $prev + set prevr $prev + } + if {$next eq ""} { + set next0 0 + set next1 1 + set nextr $item + } else { + set next0 $next + set next1 $next + set nextr $next + } + set condresult [apply {{index cond prev prev0 prev1 prevr item next next0 next1 nextr} { + if {[catch {expr $cond} r]} { + puts stderr "index: $index ERROR $r" + set wordlike_parts [regexp -inline -all {\S+} $r] + set r [list ERROR {*}[lrange $wordlike_parts 0 2]] + } + set r + } + } $n $cond $prev $prev0 $prev1 $prevr $item $next $next0 $next1 $nextr] + if {$condresult eq $last_condresult} { + lappend g $item + } else { + lappend out $g + set g [list $item] + set last_condresult $condresult + } + incr n + set prev $item + } + lappend out $g + return $out + } + + #group_numlist ? preserve representation of numbers rather than use string comparison? + + + # - group_string + #.= punk::group_string "aabcccdefff" + # aa b ccc d e fff + proc group_string {str} { + lmap v [group_list [split $str ""]] {string cat {*}$v} + } + + #lists may be of unequal lengths + proc transpose_lists {list_rows} { + set res {} + #set widest [pipedata $list_rows {lmap v $data {llength $v}} {tcl::mathfunc::max {*}$data}] + set widest [tcl::mathfunc::max {*}[lmap v $list_rows {llength $v}]] + for {set j 0} {$j < $widest} {incr j} { + set newrow {} + foreach oldrow $list_rows { + if {$j >= [llength $oldrow]} { + #continue + lappend newrow "" + } else { + lappend newrow [lindex $oldrow $j] + } + } + lappend res $newrow + } + return $res + } + proc transpose_equal_lists {list_rows} { + set columns [list] + set rowidx -1 + foreach l $list_rows { + set colidx -1 + incr rowidx + foreach val $l { + incr colidx + lset columns $colidx $rowidx $val + } + } + return $columns + } + proc transpose_strings {list_of_strings} { + set charlists [lmap v $list_of_strings {split $v ""}] + set tchars [transpose_lists $charlists] + lmap v $tchars {string cat {*}$v} + } + + package require struct::matrix + #transpose a serialized matrix using the matrix command + #Note that we can have missing row values below and to right + #e.g + #a + #a b + #a + proc transpose_matrix {matrix_rows} { + set mcmd [struct::matrix] + #serialization format: numcols numrows rowlist + set widest [tcl::mathfunc::max {*}[lmap v $matrix_rows {llength $v}]] + $mcmd deserialize [list [llength $matrix_rows] $widest $matrix_rows] + $mcmd transpose + set result [lindex [$mcmd serialize] 2] ;#strip off dimensions + $mcmd destroy + return $result + } + + set objname [namespace current]::matrixchain + if {$objname ni [info commands $objname]} { + oo::class create matrixchain { + variable mcmd + constructor {matrixcommand} { + puts "wrapping $matrixcommand with [self]" + set mcmd $matrixcommand + } + destructor { + puts "matrixchain destructor called for [self] (wrapping $mcmd)" + $mcmd destroy + } + method unknown {args} { + if {[llength $args]} { + switch -- [lindex $args 0] { + add - delete - insert - transpose - sort - set - swap { + $mcmd {*}$args + return [self] ;#result is the wrapper object for further chaining in pipelines + } + default { + tailcall $mcmd {*}$args + } + } + } else { + #will error.. but we should pass that on + tailcall $mcmd + } + } + } + } + + #review + #how do we stop matrix pipelines from leaving commands around? i.e how do we call destroy on the matrixchain wrapper if not explicitly? + #Perhaps will be solved by: Tip 550: Garbage collection for TclOO + #Theoretically this should allow tidy up of objects created within the pipeline automatically + #If the object name is placed in the pipeline variable dict then it should survive across segment apply scripts and only go out of scope at the end. + proc matrix_command_from_rows {matrix_rows} { + set mcmd [struct::matrix] + set widest [tcl::mathfunc::max {*}[lmap v $matrix_rows {llength $v}]] + $mcmd deserialize [list [llength $matrix_rows] $widest $matrix_rows] + #return $mcmd + set wrapper [punk::matrixchain new $mcmd] + } + + #-------------------------------------------------- + + proc list_filter_cond {itemcond listval} { + set filtered_list [list] + set binding {} + if {[info level] == 1} { + #up 1 is global + set get_vars [list ::info vars] + } else { + set get_vars [list ::info locals] + } + set vars [uplevel 1 {*}$get_vars] + set posn [lsearch $vars item] + #set vars [lreplace $vars $posn $posn] + set vars [lreplace $vars[set vars {}] $posn $posn] + foreach v $vars { + upvar 1 $v var + if {(![array exists var]) && [info exists var]} { + lappend binding [list $v $var] ;#values captured as defaults for apply args. + } + } + #lappend binding [list item $args] + + #puts stderr "binding: [join $binding \n]" + #apply [list $binding $pipescript [uplevel 1 ::namespace current]] + foreach item $listval { + set bindlist [list {*}$binding [list item $item]] + if {[apply [list $bindlist $itemcond [uplevel 1 ::tcl::namespace::current]] ]} { + lappend filtered_list $item + } + } + return $filtered_list + } + + + proc ls {args} { + if {![llength $args]} { + set args [list [pwd]] + } + if {[llength $args] ==1} { + return [glob -nocomplain -tails -dir [lindex $args 0] *] + } else { + set result [dict create] + foreach a $args { + set k [file normalize $a] + set contents [glob -nocomplain -tails -dir $a *] + dict set result $k $contents + } + return $result + } + } + + + + #linelistraw is essentially split $text \n so is only really of use for pipelines, where the argument order is more convenient + #like linelist - but keeps leading and trailing empty lines + #single \n produces {} {} + #the result can be joined to reform the arg if a single arg supplied + # + proc linelistraw {args} { + set linelist [list] + foreach {a} $args { + set nlsplit [split $a \n] + lappend linelist {*}$nlsplit + } + #return [split $text \n] + return $linelist + } + proc linelist1 {args} { + set linelist [list] + foreach {a} $args { + set nlsplit [split $a \n] + set start 0 + set end "end" + + if {[lindex $nlsplit 0] eq ""} { + set start 1 + } + if {[lindex $nlsplit end] eq ""} { + set end "end-1" + } + set alist [lrange $nlsplit $start $end] + lappend linelist {*}$alist + } + return $linelist + } + + namespace eval argdoc { + set DYN_ANTIGLOB_PATHS {${[punk::args::resolved_def -types opts ::punk::path::treefilenames -exclude-paths]}} + punk::args::define { + @dynamic + @id -id ::punk::LOC + @cmd -name punk::LOC\ + -summary\ + "Lines Of Code counter"\ + -help\ + "LOC - lines of code. + An implementation of a notoriously controversial metric. + Returns a dict or dictionary-display containing various + counts such as: + 'loc' - total lines of code. + 'purepunctuationlines' - lines consisting soley of punctuation. + 'filecount' - number of files examined." + @opts + -return -default showdict -choices {dict showdict} + -dir -default "\uFFFF" + -no-dupfiles -default 1 -type boolean + -no-punctlines -default 1 -type boolean + ${$DYN_ANTIGLOB_PATHS} + -exclude-files -default "" -type list -help\ + "Exclude if file tail matches any of these patterns" + -show_largest -default 0 -type integer -help\ + "Report the top largest linecount files. + The value represents the number of files + to report on." + } " + #we could map away whitespace and use string is punct - but not as flexible? review + -punctchars -default { [list \{ \} \" \\ - _ + = . > , < ' : \; ` ~ ! @ # \$ % ^ & * \[ \] ( ) | / ?] } + " { + @values + fileglob -type string -default * -optional 1 -multiple 1 -help\ + "glob patterns to match against the filename portion (last segment) of each + file path. e.g *.tcl *.tm" + } + } + #An implementation of a notoriously controversial metric. + proc LOC {args} { + set argd [punk::args::parse $args withid ::punk::LOC] + lassign [dict values $argd] leaders opts values received + set searchspecs [dict get $values fileglob] + + # -- --- --- --- --- --- + set opt_return [dict get $opts -return] + set opt_dir [dict get $opts -dir] + if {$opt_dir eq "\uFFFF"} { + set opt_dir [pwd] ;#pwd can take over a ms on windows in a not terribly deep path even with SSDs - so as a general rule we don't use it in the original defaults list + } + # -- --- --- --- --- --- + set opt_no_dupfiles [dict get $opts -no-dupfiles] + set opt_no_punctlines [dict get $opts -no-punctlines] ;#exclude lines that consist purely of whitespace and the chars in -punctchars + set opt_punctchars [dict get $opts -punctchars] + set opt_largest [dict get $opts -show_largest] + set opt_exclude_paths [dict get $opts -exclude-paths] + set opt_exclude_files [dict get $opts -exclude-files] + # -- --- --- --- --- --- + + + set filepaths [punk::path::treefilenames -dir $opt_dir -exclude-paths $opt_exclude_paths -exclude-files $opt_exclude_files {*}$searchspecs] + set loc 0 + set dupfileloc 0 + set seentails [dict create] + set seencksums [dict create] ;#key is cksum value is list of paths + set largestloc [dict create] + set dupfilecount 0 + set extensions [list] + set purepunctlines 0 + set dupinfo [dict create] + set has_hashfunc [expr {![catch {package require sha1}]}] + set notes "" + if {$has_hashfunc} { + set dupfilemech sha1 + if {$opt_no_punctlines} { + append notes "checksums are on content stripped of whitespace lines,trailing whitespace, and pure punct lines. Does not indicate file contents equal.\n" + } else { + append notes "checksums are on content stripped of whitespace lines and trailing whitespace. Does not indicate file contents equal.\n" + } + } else { + set dupfilemech filetail + append notes "dupfilemech filetail because sha1 not loadable\n" + } + foreach fpath $filepaths { + set isdupfile 0 + set floc 0 + set fpurepunctlines 0 + set ext [file extension $fpath] + if {$ext ni $extensions} { + lappend extensions $ext + } + if {[catch {fcat $fpath} contents]} { + puts stderr "Error processing $fpath\n $contents" + continue + } + set lines [linelist -line {trimright} -block {trimall} $contents] + if {!$opt_no_punctlines} { + set floc [llength $lines] + set comparedlines $lines + } else { + set mapawaypunctuation [list] + foreach p $opt_punctchars empty {} { + lappend mapawaypunctuation $p $empty + } + set comparedlines [list] + foreach ln $lines { + if {[string length [string trim [string map $mapawaypunctuation $ln]]] > 0} { + incr floc + lappend comparedlines $ln + } else { + incr fpurepunctlines + } + } + } + if {$opt_largest > 0} { + dict set largestloc $fpath $floc + } + if {$has_hashfunc} { + set cksum [sha1::sha1 [encoding convertto utf-8 [join $comparedlines \n]]] + if {[dict exists $seencksums $cksum]} { + set isdupfile 1 + incr dupfilecount + incr dupfileloc $floc + dict lappend seencksums $cksum $fpath + } else { + dict set seencksums $cksum [list $fpath] + } + } else { + if {[dict exists $seentails [file tail $fpath]]} { + set isdupfile 1 + incr dupfilecount + incr dupfileloc $floc + } + } + if {!$isdupfile || ($isdupfile && !$opt_no_dupfiles)} { + incr loc $floc + incr purepunctlines $fpurepunctlines + } + + dict lappend seentails [file tail $fpath] $fpath + #lappend seentails [file tail $fpath] + } + if {$has_hashfunc} { + dict for {cksum paths} $seencksums { + if {[llength $paths] > 1} { + dict set dupinfo checksums $cksum $paths + } + } + } + dict for {tail paths} $seentails { + if {[llength $paths] > 1} { + dict set dupinfo sametail $tail $paths + } + } + + set result [dict create {*}[ + ] loc $loc {*}[ + ] filecount [llength $filepaths] {*}[ + ] dupfiles $dupfilecount {*}[ + ] dupfilemech $dupfilemech {*}[ + ] dupfileloc $dupfileloc {*}[ + ] dupinfo $dupinfo {*}[ + ] extensions $extensions {*}[ + # purepunctuationlines key only retained if punctuation lines are excluded from count by opt_no_punctlines + ] purepunctuationlines $purepunctlines {*}[ + ] notes $notes {*}[ + ]] + if {!$opt_no_punctlines} { + dict unset result purepunctuationlines + } + + if {$opt_largest > 0} { + set largest_n [dict create] + set sorted [lsort -stride 2 -index 1 -decreasing -integer $largestloc] + set kidx 0 + for {set i 0} {$i < $opt_largest} {incr i} { + if {$kidx+1 > [llength $sorted]} {break} + dict set largest_n [lindex $sorted $kidx] [lindex $sorted $kidx+1] + incr kidx 2 + } + dict set result largest $largest_n + } + if {$opt_return eq "showdict"} { + return [punk::lib::showdict $result @@dupinfo/*/* !@@dupinfo] + } + return $result + } + + ##dict of lists? + #a + # 1 + # 2 + #b + # 3 + # 4 + # "" + # etc + # d + # D + # "ok then" + + + ##dict of dicts + #a + # x + # 1 + # y + # 2 + #b + # x + # 11 + + ##dict of mixed + #list + # a + # b + # c + #dict + # a + # aa + # b + # bb + #val + # x + #list + # a + # b + + # each line has 1 key or value OR part of 1 key or value. ie <=1 key/val per line! + ##multiline + #key + # "multi + # line value" + # + + #-------------------------------- + #a + # 1 + # 2 + + #vs + + #a + # 1 + # 2 + + #dict of list-len 2 is equiv to dict of dict with one keyval pair + #-------------------------------- + + + + #!!!todo fix - linedict is unfinished and non-functioning + #linedict based on indents + proc linedict {args} { + puts stderr "linedict is experimental and incomplete" + set data [lindex $args 0] + set opts [lrange $args 1 end] ;#todo + set nlsplit [split $data \n] + set rootindent -1 + set stepindent -1 + + + #first do a partial loop through lines and work out the rootindent and stepindent. + #we could do this in the main loop - but we do it here to remove a small bit of logic from the main loop. + #review - if we ever move to streaming a linedict - we'll need to re-arrange to validating indents as we go anyway. + set linenum 0 + set firstkey_line "N/A" + set firstkey_linenum -1 + set firststep_line "N/A" + set firststep_linenum -1 + set indents_seen [dict create] + foreach ln $nlsplit { + incr linenum + if {![string length [string trim $ln]]} { + continue + } + + #todo - use info complete to accept keys/values with newlines + regexp {(\s*)(.*)} $ln _ space linedata + if {[catch {lindex $linedata 0}]} { + error "bad line value '$linedata' - each line must be a valid Tcl list of length 1. Use quotes or curly braces as necessary" + } + if {[llength $linedata] > 1} { + error "bad line value '$linedata' - each line must be a valid Tcl list of length 1. Use quotes or curly braces as necessary" + } + #puts stderr "--linenum:[format %-3s $linenum] line:[format "%-20s" $ln] [format %-4s [string length $space]] $linedata" + set this_indent [string length $space] + if {[dict exists $indents_seen $this_indent]} { + continue + } + if {$rootindent < 0} { + set firstkey_line $ln + set firstkey_linenum $linenum + set rootindent $this_indent + dict set indents_seen $this_indent 1 + } elseif {$stepindent < 0} { + if {$this_indent > $rootindent} { + set firststep_line $ln + set firststep_linenum $linenum + set stepindent [expr {$this_indent - $rootindent}] + dict set indents_seen $this_indent 1 + } elseif {$this_indent < $rootindent} { + error "bad root indentation ($this_indent) at line: $linenum. Smallest indent was set on linenumber: $firstkey_linenum by first key line: $firstkey_line" + } + #if equal - it's just another root key + } else { + #validate all others + if {$this_indent < $rootindent} { + error "bad root indentation ($this_indent) at line: $linenum. Smallest indent was set on linenumber: $firstkey_linenum by first key line: $firstkey_line" + } + if {($this_indent - $rootindent) % $stepindent != 0} { + error "bad indentation ($this_indent) at linenum: $linenum line:'$ln'. this_indent - rootindent ($this_indent - $rootindent == [expr {$this_indent - $rootindent}]) is not a multiple of the first key indent $stepindent seen on linenumber: $firststep_linenum value:'$firststep_line'" + } else { + dict set indents_seen $this_indent 1 + } + } + } + + + #set wordlike_parts [regexp -inline -all {\S+} $lastitem] + set d [dict create] + set keys [list] + set linenum 0 ;#line-numbers 1 based + foreach ln $nlsplit { + incr linenum + if {![string length [string trim $ln]]} { + incr linenum + continue + } + regexp {(\s*)(.*)} $ln _ space linedata + puts stderr ">>linenum:[format %-3s $linenum] line:[format "%-20s " $ln] [format %-4s [string length $space]] $linedata" + set linedata [lindex $linedata 0] + set this_indent [string length $space] + + + if {$this_indent == $rootindent} { + #is rootkey + dict set d $linedata {} + set keys [list $linedata] + } else { + set ispan [expr {$this_indent - $rootindent}] + set numsteps [expr {$ispan / $stepindent}] + #assert - since validated in initial loop - numsteps is always >= 1 + set keydepth [llength $keys] + if {$numsteps > $keydepth + 1} { + #too deep - not tested for in initial loop. ? todo - convert to leading spaces in key/val? + error "bad indentation ($this_indent) at linenum: $linenum line:'$ln'. (too deep) - review" + } + if {$numsteps > ($keydepth - 1)} { + #assert - from above test - must be 1 or 2 deeper + set parentkey [lindex $keys end] + set oldval [dict get $d {*}$parentkey] + if {$numsteps - ($keydepth -1) == 1} { + #1 deeper + if {$oldval ne {}} { + lappend keys [list {*}$parentkey $linedata] + dict unset d {*}$parentkey + #dict set d {*}$parentkey $oldval $linedata + dict set d {*}$parentkey $oldval {} ;#convert to key? + dict set d {*}$parentkey $linedata {} + } else { + dict set d {*}$parentkey $linedata + } + } else { + #2 deeper - only ok if there is an existing val + if {$oldval eq {}} { + error "bad indentation ($this_indent) at linenum: $linenum line:'$ln'. (too deep) - review" + } + puts ">>> 2deep d:'$d' oldval:$oldval linedata:$linedata parentkey:$parentkey" + dict unset d {*}$parentkey + dict set d {*}$parentkey $oldval $linedata + lappend keys [list {*}$parentkey $oldval] + } + } elseif {$numsteps < ($keydepth - 1)} { + set diff [expr {$keydepth - 1 - $numsteps}] + set keys [lrange $keys 0 end-$diff] + #now treat as same level + set parentkey [lindex $keys end-1] + lset keys end end $linedata + dict set d {*}$parentkey $linedata {} + } else { + #same level + set parentkey [lindex $keys end-1] + lset keys end end $linedata + dict set d {*}$parentkey $linedata {} + } + } + #puts ">>keys:$keys" + } + return $d + } + proc dictline {d {indent 2}} { + puts stderr "unimplemented" + set lines [list] + + return $lines + } + + + proc ooinspect {obj} { + set obj [uplevel 1 [list ::tcl::namespace::which -command $obj]] + set isa [lmap type {object class metaclass} { + if {![info object isa $type $obj]} continue + set type + }] + foreach tp $isa { + switch -- $tp { + class { + lappend info {class superclasses} {class mixins} {class filters} + lappend info {class methods} {class methods} + lappend info {class variables} {class variables} + } + object { + lappend info {object class} {object mixins} {object filters} + lappend info {object methods} {object methods} + lappend info {object variables} {object variables} + lappend info {object namespace} {object vars} ;#{object commands} + } + } + } + + set result [dict create isa $isa] + foreach args $info { + dict set result $args [info {*}$args $obj] + foreach opt {-private -all} { + catch { + dict set result [list {*}$args $opt] [info {*}$args $obj $opt] + } + } + } + dict filter $result value {?*} + } + + punk::args::define { + @id -id ::punk::inspect + @cmd -name punk::inspect -help\ + "Function to display values - used pimarily in a punk pipeline. + The raw value arguments (not options) are always returned to pass + forward in the pipeline. + (pipeline data inserted at end of each |...> segment is passed as single item unless + inserted with an expanding insertion specifier such as .=>* ) + e.g1: + .= list a b c |v1,/1-end,/0>\\ + .=>* inspect -label i1 -- |>\\ + .=v1> inspect -label i2 -- |>\\ + string toupper + (3) i1: {a b c} {b c} a + (1) i2: a b c + + - A B C + " + -label -type string -default "" -help\ + "An optional label to help distinguish output when multiple + inspect statements are in a pipeline. This appears after the + bracketed count indicating number of values supplied. + e.g (2) MYLABEL: val1 val2 + The label can include ANSI codes. + e.g + inspect -label [a+ red]mylabel -- val1 val2 val3 + " + -limit -type int -default 20 -help\ + "When multiple values are passed to inspect - limit the number + of elements displayed in -channel output. + + When truncation has occured an elipsis indication (...) will be appended. + e.g + ${[punk::args::helpers::example { + + .= lseq 20 to 50 by 3 |> .=>* inspect -limit 4 -- |> .=>* tcl::mathop::+ + (11) 20 23 26 29... + + - 385 + + }]} + + If the current pipeline data is not a list, the limit is applied to the + number of lines in the pipeline value. + + For no limit - use -limit -1 + " + -channel -type string -default stderr -help\ + "An existing open channel to write to. If value is any of nul, null, /dev/nul + the channel output is disabled. This effectively disables inspect as the args + are simply passed through in the return to continue the pipeline. + " + -showcount -type boolean -default 1 -help\ + "Display a leading indicator in brackets showing the number of arg values present." + -ansi -type integer -default 1 -nocase 1 -choices {0 1 2 VIEW 3 VIEWCODES 4 VIEWSTYLES} -choicelabels { + 0 " Strip ANSI codes from display + of values. The disply output will + still be colourised if -ansibase has + not been set to empty string or + [a+ normal]. The stderr or stdout + channels may also have an ansi colour. + (see 'colour off' or punk::config)" + 1 " Leave value as is" + 2 " Display the ANSI codes and + other control characters inline + with replacement indicators. + e.g esc, newline, space, tab" + VIEW " Alias for 2" + 3 " Display as per 2 but with + colourised ANSI replacement codes." + VIEWCODES " Alias for 3" + 4 " Display ANSI and control + chars in default colour, but + apply the contained ansi to + the text portions so they display + as they would for -ansi 1" + VIEWSTYLE "Alias for 4" + } + -ansibase -type ansistring -default {${[a+ brightgreen]}} -help\ + "Base ansi code(s) that will apply to output written to the chosen -channel. + If there are ansi resets in the displayed values - output will revert to this base. + Does not affect return value." + -- -type none -help\ + "End of options marker. + It is advisable to use this, as data in a pipeline may often begin with -" + + @values -min 0 -max -1 + arg -type string -optional 1 -multiple 1 -help\ + "value to display" + } + #pipeline inspect + #e.g + #= {a z c} |> inspect -label input_dict |> lsort |> {inspect $data} + proc inspect {args} { + set defaults [list -label "" -limit 20 -channel stderr -showcount 1 -ansi 1 -ansibase [a+ brightgreen]] + set flags [list] + set endoptsposn [lsearch $args --] ;#first -- if data expected to contain --, then should always be called with --. e.g inspect -- + if {$endoptsposn >= 0} { + set flags [lrange $args 0 $endoptsposn-1] + set pipeargs [lrange $args $endoptsposn+1 end] + } else { + #no explicit end of opts marker + #last trailing elements of args after taking *known* -tag v pairs is the value to inspect + for {set i 0} {$i < [llength $args]} {incr i} { + set k [lindex $args $i] + if {$k in [dict keys $defaults]} { + lappend flags {*}[lrange $args $i $i+1] + incr i + } else { + #first unrecognised option represents end of flags + break + } + } + set pipeargs [lrange $args $i end] + } + foreach {k v} $flags { + if {$k ni [dict keys $defaults]} { + #error "inspect: unknown option $k. Known options: [dict keys $defaults]. If data contains flaglike elements, consider calling with end-of-opts marker. e.g inspect --" + punk::args::parse $args -errorstyle minimal withid ::punk::inspect + } + } + set opts [dict merge $defaults $flags] + # -- --- --- --- --- + set label [dict get $opts -label] + set channel [dict get $opts -channel] + set showcount [dict get $opts -showcount] + if {[string length $label]} { + set label "${label}: " + } + set limit [dict get $opts -limit] + set opt_ansiraw [dict get $opts -ansi] + set opt_ansi [tcl::prefix::match -error "" [list 0 1 2 3 4 view viewcodes viewstyle] [string tolower $opt_ansiraw]] + switch -- [string tolower $opt_ansi] { + 0 - 1 - 2 - 3 - 4 {} + view {set opt_ansi 2} + viewcodes {set opt_ansi 3} + viewstyle {set opt_ansi 4} + default { + error "inspect -ansi 0|1|2|view|3|viewcodes|4|viewstyle - received -ansi $opt_ansiraw" + } + } + # -- --- --- --- --- + + set more "" + if {[llength $pipeargs] == 1} { + #usual case is data as a single element + set val [lindex $pipeargs 0] + set count 1 + } else { + #but the pipeline segment could have an insertion-pattern ending in * + set val $pipeargs + set count [llength $pipeargs] + } + switch -- [string tolower $channel] { + nul - null - /dev/null { + return $val + } + } + set displayval $val ;#default - may be overridden based on -limit + + if {$count > 1} { + #val is a list + set llen [llength $val] + if {$limit > 0 && ($limit < $llen)} { + set displayval [lrange $val 0 $limit-1] + if {$llen > $limit} { + set more "..." + } + } + } else { + #not a valid tcl list - limit by lines + if {$limit > 0} { + set rawlines [split $val \n] + set llen [llength $rawlines] + set displaylines [lrange $rawlines 0 $limit-1] + set displayval [join $displaylines "\n"] + if {$llen > $limit} { + set more "\n..." + } + } + + } + if {$showcount} { + set displaycount "[a purple bold]($count)[a] " + #if {$showcount} { + # set countspace [expr {[string length $count] + 3}] ;#lhs margin size of count number plus brackets and one space + # set margin [string repeat " " $countspace] + # set displayval [string map [list \r "" \n "\n$margin"] $displayval] + #} + } else { + set displaycount "" + } + + set ansibase [dict get $opts -ansibase] + if {$ansibase ne ""} { + #-ansibase default is hardcoded into punk::args definition + #run a test using any ansi code to see if colour is still enabled + if {[a+ red] eq ""} { + set ansibase "" ;#colour seems to be disabled + } + } + + switch -- $opt_ansi { + 0 { + set displayval $ansibase[punk::ansi::ansistrip $displayval] + } + 1 { + #val may have ansi - including resets. Pass through ansibase_lines to + if {$ansibase ne ""} { + #set displayval [::textblock::ansibase_lines $displayval $ansibase] + set displayval [punk::ansi::ansiwrap_raw $ansibase "" "" $displayval] + } + } + 2 { + set displayval $ansibase[ansistring VIEW $displayval] + if {$ansibase ne ""} { + #set displayval [::textblock::ansibase_lines $displayval $ansibase] + set displayval [punk::ansi::ansiwrap_raw $ansibase "" "" $displayval] + } + } + 3 { + set displayval $ansibase[ansistring VIEWCODE $displayval] + if {$ansibase ne ""} { + #set displayval [::textblock::ansibase_lines $displayval $ansibase] + set displayval [punk::ansi::ansiwrap_raw $ansibase "" "" $displayval] + } + } + 4 { + set displayval $ansibase[ansistring VIEWSTYLE $displayval] + if {$ansibase ne ""} { + #set displayval [::textblock::ansibase_lines $displayval $ansibase] + set displayval [punk::ansi::ansiwrap_raw $ansibase "" "" $displayval] + } + } + } + + if {![string length $more]} { + #puts $channel "$displaycount$label$displayval[a]" + set chunk [textblock::join -- $displaycount$label " " $displayval[a]] + } else { + #puts $channel "$displaycount$label$displayval[a yellow bold]$more[a]" + set chunk [textblock::join -- $displaycount$label " " "$displayval[a yellow bold]$more[a]"] + } + puts $channel $chunk + return $val + } + + + + proc help {args} { + set chunks [uplevel 1 [list ::punk::help_chunks {*}$args]] + foreach chunk $chunks { + lassign $chunk chan text + puts -nonewline $chan $text + } + puts -nonewline stdout \n + } + #return list of {chan chunk} elements + + namespace eval argdoc { + punk::args::define { + @id -id ::punk::help_chunks + @cmd -name "punk::help_chunks"\ + -summary\ + ""\ + -help\ + "" + @opts + -- -type none + @values -min 0 -max -1 + arg -type any -optional 1 -multiple 1 + } + } + proc help_chunks {args} { + set argd [punk::args::parse $args withid ::punk::help_chunks] + lassign [dict values $argd] leaders opts values received + if {[dict exists $values arg]} { + set topicparts [dict get $values arg] + } else { + set topicparts [list ""] + } + #set topic [lindex $args end] + #set argopts [lrange $args 0 end-1] + + + set chunks [list] + set linesep [string repeat - 76] + + set warningblock "" + + set I [punk::ansi::a+ italic] + set NI [punk::ansi::a+ noitalic] + + set sizedict [punk::console::get_size] + set cols [dict get $sizedict columns] + set rows [dict get $sizedict rows] + + + + #todo - provide a mechanism to configure the default frametype everywhere and describe it in this help. + + set frametype ascii ;#conservative default. + #if the test char width fails - it's likely we're on a very old terminal that doesn't support unicode at all. + if {![catch {punk::console::test_char_width \u00e9} testcharwidth]} { + if {$cols <= 80} { + # Be conservative with frame types on narrow terminals for help. + # an 80x30 terminal is more likely to be an older style terminal and may not have unicode support. + # unicode on a non-unicode terminal is a bad experience - with the frame chars showing as garbage (e.g 3 chars per grapheme). + set frametype ascii + } else { + if {$testcharwidth == 1} { + set frametype light ;#unicode box-drawing chars. + } + } + } + + + # ------------------------------------------------------- + set logoblock "" + if {[catch { + package require patternpunk + #lappend chunks [list stderr [>punk . rhs]] + append logoblock [textblock::frame -type $frametype -title "Punk Shell [package provide punk]" -width 29 -checkargs 0 [>punk . banner -title "" -left Tcl -right [package provide Tcl]]] + }]} { + append logoblock [textblock::frame -type $frametype -title "Punk Shell [package provide punk]" -subtitle "TCL [package provide Tcl]" -width 29 -height 10 -checkargs 0 ""] + } + set title "[a+ brightgreen] Help System: " + set cmdinfo [list] + lappend cmdinfo [list help "?${I}topic${NI}?" "This help.\nTo see available subitems type:\nhelp topics\n\nFor an unrecognised ${I}topic${NI}\nhelp will look for basic\ninfo for it as a command.\n"] + set t [textblock::class::table new -minwidth 51 -show_seps 0] + $t configure -frametype $frametype + foreach row $cmdinfo { + $t add_row $row + } + set width_0 [$t column_datawidth 0] + $t configure_column 0 -minwidth [expr {$width_0 + 2}] + set width_1 [$t column_datawidth 1] + $t configure_column 1 -minwidth [expr {$width_1 + 1}] + $t configure -title $title + set text [$t print] + + set introblock [textblock::join -- $logoblock $text] + + lappend chunks [list stdout $introblock\n] + # ------------------------------------------------------- + + switch -- [lindex $topicparts 0] { + "" { + + # ------------------------------------------------------- + set title "[a+ brightgreen] Filesystem navigation: " + set cmdinfo [list] + lappend cmdinfo [list ./ "?${I}glob${NI}?" "view/change dir, list dirs."] + lappend cmdinfo [list .// "?${I}glob${NI}?" "view/change dir, list dirs and files"] + lappend cmdinfo [list ../ "?${I}path${NI}" "go up one dir, then to path if given"] + lappend cmdinfo [list newdir "${I}subdir${NI}..." "make new dir or dirs and show status"] + lappend cmdinfo [list fcat "${I}file ?file?...${NI}" "cat file(s)"] + set t [textblock::class::table new -minwidth 80 -show_seps 0] + $t configure -frametype $frametype + foreach row $cmdinfo { + $t add_row $row + } + set width_0 [$t column_datawidth 0] + $t configure_column 0 -minwidth [expr {$width_0 + 2}] + set width_1 [$t column_datawidth 1] + $t configure_column 1 -minwidth [expr {$width_1 + 1}] + $t configure -title $title + + set text "" + append text [$t print] + lappend chunks [list stdout $text\n] + # ------------------------------------------------------- + + + # ------------------------------------------------------- + set title "[a+ brightgreen] Namespace navigation: " + set cmdinfo [list] + lappend cmdinfo [list n/ "?${I}ns${NI}|${I}glob${NI}?" "view/change namespace\n (accepts ns path globs e.g **::*get* to match\n commands at any level )"] + lappend cmdinfo [list n// "?${I}ns${NI}|${I}glob${NI}?" "view/change namespace (with command listing)"] + lappend cmdinfo [list "nn/" "" "go up one namespace"] + lappend cmdinfo [list "newns" "${I}ns${NI}" "make child namespace and switch to it"] + set t [textblock::class::table new -minwidth 80 -show_seps 0] + $t configure -frametype $frametype + foreach row $cmdinfo { + $t add_row $row + } + set width_0 [$t column_datawidth 0] + $t configure_column 0 -minwidth [expr {$width_0 + 2}] + set width_1 [$t column_datawidth 1] + $t configure_column 1 -minwidth [expr {$width_1 + 1}] + $t configure -title $title + + set text "" + append text [$t print] + lappend chunks [list stdout $text\n] + # ------------------------------------------------------- + + # ------------------------------------------------------- + set title "[a+ brightgreen] Command help: " + set cmdinfo [list] + lappend cmdinfo [list i "${I}cmd${NI} ?${I}subcommand${NI}...?" "Show usage for a command or ensemble subcommand"] + lappend cmdinfo [list s "${I}cmd${NI} ?${I}subcommand${NI}...?" "Show synopsis for a command or ensemble subcommand"] + lappend cmdinfo [list eg "${I}cmd${NI} ?${I}subcommand${NI}...?" "Show example from manpage"] + lappend cmdinfo [list corp "${I}proc${NI}" "View proc body and arguments with basic highlighting"] + set t [textblock::class::table new -minwidth 80 -show_seps 0] + $t configure -frametype $frametype + foreach row $cmdinfo { + $t add_row $row + } + set width_0 [$t column_datawidth 0] + $t configure_column 0 -minwidth [expr {$width_0 + 2}] + set width_1 [$t column_datawidth 1] + $t configure_column 1 -minwidth [expr {$width_1 + 1}] + $t configure -title $title + + set text "" + append text [$t print] + lappend chunks [list stdout $text\n] + # ------------------------------------------------------- + + + set title "[a+ brightgreen] Miscellaneous: " + #todo - load from source code annotation? + set cmdinfo [list] + lappend cmdinfo [list dev "?${I}subcommand${NI}?" "(ensemble command to make new projects/modules and\n to generate docs)"] + lappend cmdinfo [list a? "?${I}subcommand${NI}...?" "view ANSI colours\n e.g a? web\n or individual code samples/diagnostics\n e.g a? red bold\n e.g a? underline web-orange Term-purple3"] + lappend cmdinfo [list a+ "?${I}colourcode${NI}...?" "Return ANSI codes\n e.g puts \"\[a+ purple\]purple\[a+ Green\]purple on green\[a\]\"\n [a+ purple]purple[a+ Green]purple on green[a] "] + lappend cmdinfo [list a "?${I}colourcode${NI}...?" "Return ANSI codes (with leading reset)\n e.g puts \"\[a+ purple\]purple\[a Green\]normal on green\[a\]\"\n [a+ purple]purple[a Green]normal on green[a] "] + + set t [textblock::class::table new -minwidth 80 -show_seps 0] + $t configure -frametype $frametype + foreach row $cmdinfo { + $t add_row $row + } + set width_0 [$t column_datawidth 0] + $t configure_column 0 -minwidth [expr {$width_0 + 2}] + set width_1 [$t column_datawidth 1] + $t configure_column 1 -minwidth [expr {$width_1 + 1}] + $t configure -title $title + + set text "" + append text [$t print] + lappend chunks [list stdout $text] + # ------------------------------------------------------- + + } + tcl { + set text "Tcl Patchlevel: [info patchlevel]" + catch { + append text \n "Tcl build-info: [::tcl::build-info]" + } + #generate warningblocks for each triggered Tcl bug in namespace ::punk::lib::check + set bugcheck_procs [info procs ::punk::lib::check::has_tclbug*] + foreach bp $bugcheck_procs { + set buginfo [$bp] + if {[dict get $buginfo bug]} { + set level unknown + if {[dict exists $buginfo level]} { + set level [dict get $buginfo level] + } + switch -- $level { + minor {set highlight [punk::ansi::a+ cyan]} + medium {set highlight [punk::ansi::a+ yellow]} + major {set highlight [punk::ansi::a+ red bold]} + default {set highlight ""} + } + append warningblock \n $highlight "warning level: $level $bp triggered." + if {[dict exists $buginfo description]} { + set indent " " + append warningblock \n "[punk::lib::indent [dict get $buginfo description] $indent]" + } + if {[dict exists $buginfo bugref] && [dict get $buginfo bugref] ne ""} { + set bugref [dict get $buginfo bugref] + append warningblock \n "${indent}see [punk::ansi::hyperlink https://core.tcl-lang.org/tcl/tktview/$bugref]" + } + append warningblock [a] + } + } + + if {[catch {lsearch -stride 2 {a b} b}]} { + #has_tclbug_lsearch_strideallinline will have reported bug false because it couldn't test it. + set indent " " + append warningblock \n "[a+ web-red]warning: lsearch does not seem to support -stride option" \n + append warningblock "${indent}(Consider upgrading to a late release of tcl 8.6 or tcl 9+ )" \n + append warningblock [a] + } + lappend chunks [list stdout $text] + } + env - environment { + set text "" + #todo - move to punk::config? + upvar ::punk::config::punk_env_vars_config punkenv_config + upvar ::punk::config::other_env_vars_config otherenv_config + + set known_punk [dict keys $punkenv_config] + set known_other [dict keys $otherenv_config] + append text \n + set usetable 1 + if {$usetable} { + set t [textblock::class::table new -show_hseps 0 -show_header 1 -ansiborder_header [a+ web-green]] + $t configure -frametype $frametype + if {"windows" eq $::tcl_platform(platform)} { + #If any env vars have been set to empty string - this is considered a deletion of the variable on windows. + #The Tcl ::env array is linked to the underlying process view of the environment + #- but info exists ::env(var) can misreport as true if it has been deleted by setting to empty string rather than using unset. + #an 'array get' will resynchronise. + #Even if an env variable didn't exist before - setting it to empty string can get it to this inconsistent state. + array get ::env + } + #do an array read on ::env + foreach {v vinfo} $punkenv_config { + if {[info exists ::env($v)]} { + set c2 [set ::env($v)] + } else { + set c2 "(NOT SET)" + } + set help "" + if {[dict exists $vinfo help]} { + set help [dict get $vinfo help] + } + $t add_row [list $v $c2 $help] + } + $t configure_column 0 -headers [list "Punk environment vars"] + $t configure_column 0 -minwidth [expr {[$t column_datawidth 0]+4}] -blockalign left -textalign left -header_colspans {any} + + set punktable [$t print] + $t destroy + + set t [textblock::class::table new -show_hseps 0 -show_header 1 -ansiborder_header [a+ web-green]] + $t configure -frametype $frametype + foreach {v vinfo} $otherenv_config { + if {[info exists ::env($v)]} { + set env_val [set ::env($v)] + if {[string match "*_TM_PATH" $v]} { + set entries [split $env_val $::tcl_platform(pathSeparator)] + set c2 [join $entries \n] + } else { + set c2 $::env($v) + } + } else { + set c2 "(NOT SET)" + } + $t add_row [list $v $c2] + } + $t configure_column 0 -headers [list "Other environment vars"] + $t configure_column 0 -minwidth [expr {[$t column_datawidth 0]+4}] -blockalign left -textalign left -header_colspans {any} + + set othertable [$t print] + $t destroy + #append text [textblock::join -- $punktable " " $othertable]\n + append text $punktable\n$othertable\n + } else { + + append text $linesep\n + append text "punk environment vars:\n" + append text $linesep\n + set col1 [string repeat " " 25] + set col2 [string repeat " " 50] + foreach v $known_punk { + set c1 [overtype::left $col1 $v] + if {[info exists ::env($v)]} { + set c2 [overtype::left $col2 [set ::env($v)]] + } else { + set c2 [overtype::right $col2 "(NOT SET)"] + } + append text "$c1 $c2\n" + } + append text $linesep\n + } + + lappend chunks [list stdout $text] + } + console - term - terminal { + set term_env_vars {TERM TERM_PROGRAM TERM_PROGRAM_VERSION COLORTERM} + set term_dict [dict create] + foreach e $term_env_vars { + if {[info exists ::env($e)]} { + dict set term_dict $e [set ::env($e)] + } else { + dict set term_dict $e "(NOT SET)" + } + } + set text "Terminal environment variables:\n" + append text [punk::lib::showdict $term_dict] \n + lappend chunks [list stdout $text] + set text "" + set indent [string repeat " " [string length "WARNING: "]] + + if {[catch {package require punk::console} result]} { + set text "Unable to load punk::console package - cannot test\n$result" + lappend chunks [list stdout $text] + } else { + + if {![catch {punk::console::class_info} console_class_info]} { + set text "Terminal class info (from device secondary attributes query to terminal):\n" + append text [punk::lib::showdict $console_class_info] \n + } else { + set text "Unable to query terminal class info - err:$console_class_info\n" + } + lappend chunks [list stdout $text] + + lappend cstring_tests [dict create {*}{ + type "PM " + msg "UN" + f7 punk::ansi::controlstring_PM + f7prefix "7bit ESC ^ secret " + f7suffix "safe" + f8 punk::ansi::controlstring_PM8 + f8prefix "8bit \\x9e secret " + f8suffix "safe" + }] + lappend cstring_tests [dict create {*}{ + type SOS + msg "NOT" + f7 punk::ansi::controlstring_SOS + f7prefix "7bit ESC X string " + f7suffix " hidden" + f8 punk::ansi::controlstring_SOS8 + f8prefix "8bit \\x98 string " + f8suffix " hidden" + }] + lappend cstring_tests [dict create {*}{ + type APC + msg "NOT" + f7 punk::ansi::controlstring_APC + f7prefix "7bit ESC _ APPLICATION PROGRAM COMMAND " + f7suffix " hidden" + f8 punk::ansi::controlstring_APC8 + f8prefix "8bit \\x9f APPLICATION PROGRAM COMMAND " + f8suffix " hidden" + }] + + foreach test $cstring_tests { + set m [[dict get $test f7] [dict get $test msg]] + set hidden_width_m [punk::console::test_char_width $m] + set m8 [[dict get $test f8] [dict get $test msg]] + set hidden_width_m8 [punk::console::test_char_width $m8] + if {$hidden_width_m != 0 || $hidden_width_m8 != 0} { + if {$hidden_width_m == 0} { + set d "[a+ green bold][dict get $test f7prefix][a red]${m}[a][a+ green bold][dict get $test f7suffix][a]" + } else { + set d "[a+ yellow bold][dict get $test f7prefix][a red]$m[a][a+ yellow bold][dict get $test f7suffix][a]" + } + if {$hidden_width_m8 == 0} { + set d8 "[a+ green ][dict get $test f8prefix][a red]$m8[a][a+ green][dict get $test f8suffix][a]" + } else { + set d8 "[a+ yellow bold][dict get $test f8prefix][a red]$m8[a][a+ yellow bold][dict get $test f8suffix][a]" + } + append warningblock \n "WARNING: terminal doesn't hide all [dict get $test type] control strings: $d $d8" + } + } + if {![catch {punk::console::check::has_bug_legacysymbolwidth} result]} { + if {$result} { + append warningblock \n "WARNING: terminal has legacysymbolwidth bug - screen position for symbol reports 2 wide but displays 1 wide." + append warningblock \n $indent "Layout using 'legacy symbols for computing' affected." + append warningblock \n $indent "(e.g textblock frametype block2 unsupported)" + append warningblock \n $indent "This can cause extreme layout deformation when ANSI is present" + append warningblock \n $indent "In some cases unwanted spacing effects occur at a distance from the characters causing it" + } + } else { + append warningblock \n "WARNING: terminal unable to check for legacysymbolwidth bug. err:$result" + } + + if {![catch {punk::console::check::has_bug_zwsp} result]} { + if {$result} { + append warningblock \n "WARNING: terminal has zero width space (\\u200b) bug - cursor position incremented when it shouldn't be." + append warningblock \n $indent "The zwsp may or may not be displayed. zwsp contributes to line length and wrapping point" + } + } else { + append warningblock \n "WARNING: terminal unable to check for zwsp bug. err:$result" + } + + + set grapheme_support [punk::console::grapheme_cluster_support] + #mode, 1 = set, 2 = unset. (0 = mode not recognised, 3 = permanently set, 4 = permanently unset) + if {![dict size $grapheme_support] || [dict get $grapheme_support mode] eq "unsupported" } { + append warningblock \n "WARNING: terminal either doesn't support grapheme clusters, or doesn't report so via decmode 2027 query." + if {[dict size $grapheme_support] && [dict get $grapheme_support available]} { + append warningblock \n $indent "(but punk::console::grapheme_cluster_support has determined it is probably available)" + } + } else { + if {![dict get $grapheme_support available]} { + switch -- [dict get $grapheme_support mode] { + "unset" { + append warningblock \n "WARNING: terminal reports via decmode 2027 that grapheme cluster support is off." + } + "permanently_unset" { + append warningblock \n "WARNING: terminal reports via decmode 2027 that grapheme cluster support is permanently off." + } + "BAD_RESPONSE" { + append warningblock \n "WARNING: terminal doesn't seem to recognize decmode 2027 query. No grapheme cluster support." + } + } + } + } + set posn [punk::console::get_cursor_pos] ;#warmup call - and test if works + if {$posn eq ""} { + append warningblock \n "WARNING: terminal doesn't respond to cursor position query - may cause display bugs in some cases." + } else { + set timeresult [timerate {set cpos [punk::console::get_cursor_pos]}] + lassign [split $cpos {;}] row col + if {![string is integer -strict $row] || ![string is integer -strict $col]} { + append warningblock \n "WARNING: terminal returns non-integer values for cursor position query - may cause display bugs in some cases. got row:'$row' col:'$col'" + } else { + set micros [lindex $timeresult 0] + if {$micros > 2000} { + append warningblock \n "WARNING: terminal cursor position query is very slow ($micros microseconds - expect < 2000us )" + append warningblock \n $indent "- may cause display lag/bugs in some cases." + } else { + if {$micros > 1000} { + set text "\n[a+ yellow]Terminal cursor position query test passed." + append text \n $indent "Response time: ${micros} microseconds (OK, good would be <= 1000us).[a]" + + } else { + set text "[a+ green]Terminal cursor position query test passed." + append text \n $indent "Response time: ${micros} microseconds (GOOD).[a]" + } + lappend chunks [list stdout $text] + } + } + } + + + if {![string length $warningblock]} { + set text "[a+ green]No terminal warnings[a]\n" + lappend chunks [list stdout $text] + } else { + set mode [punk::console::mode] + if {$mode eq "line"} { + append warningblock \n "Terminal appears to be in line mode. Consider switching to raw mode and re-testing (command: punk::console::mode raw)." + } + } + puts stdout [punk::ansi::move_back 200] ;#hack for some horizontal position bugs where the above tests can leave the cursor in the wrong place for the next output. + #200 is arbitrary large number to move back enough to get to start of line. + } + } + topics - help { + set text "" + set topics [dict create {*}{ + "topics|help" "List help topics" + "tcl" "Tcl version warnings" + "env|environment" "punkshell environment vars" + "console|terminal" "Some console behaviour tests and warnings" + "*" "Try to find help on the topic as a command or external executable" + }] + + set t [textblock::class::table new -show_seps 0] + $t configure -frametype $frametype + $t add_column -headers [list "Topic"] + $t add_column + foreach {k v} $topics { + $t add_row [list $k $v] + } + set widest0 [$t column_datawidth 0] + $t configure_column 0 -minwidth [expr {$widest0 + 4}] + append text \n [$t print] + + lappend chunks [list stdout $text] + } + default { + set text "" + set cinfo [uplevel 1 [list ::punk::ns::cmdwhich [lindex $topicparts 0]]] + set wtype [dict get $cinfo whichtype] + if {$wtype eq "notfound"} { + set externalinfo [auto_execok [lindex $topicparts 0]] + if {[string length $externalinfo]} { + set text "$topicparts" + append text \n "Base type: External command" + append text \n "$externalinfo [lrange $topicparts 1 end]" + } else { + set text "$topicparts\n" + append text "No matching internal or external command found" + } + } else { + set text "[dict get $cinfo which] [lrange $topicparts 1 end]" + append text \n "Base type: $wtype" + set synopsis [uplevel 1 [list ::punk::ns::synopsis {*}$topicparts]] + set synshow "" + foreach sline [split $synopsis \n] { + if {[regexp {\s*#.*} $sline]} { + append synshow [punk::ansi::a+ bold term-darkgreen Term-white]$sline[punk::ansi::a] \n + } else { + append synshow $sline \n + } + } + if {[string index $synshow end] eq "\n"} { + set synshow [string range $synshow 0 end-1] + } + append text \n $synshow + } + lappend chunks [list stdout $text] + } + } + + + lappend chunks [list stderr $warningblock] + return $chunks + } + proc mode {{raw_or_line query}} { + package require punk::console + tailcall ::punk::console::mode $raw_or_line + } + + #this hides windows cmd's mode command - probably no big deal - anyone who needs it will know how to exec it. + interp alias {} mode {} punk::mode + + + + #proc aliases {{glob *}} { + # tailcall punk::ns::aliases $glob + #} + + ##review + #proc alias {{aliasorglob ""} args} { + # tailcall punk::ns::alias $aliasorglob {*}$args + #} + + + #pipeline-toys - put in lib/scriptlib? + ##geometric mean + #alias gmean .=> llength |> expr 1.0 / |e> .=i>* tcl::mathop::* |> .=>1,e>3 expr ** {::tcl::tm::add {*}$data; set path} |> inspect -label added_to_module_path <0/#| + + + + + + #todo - review + #interp alias {} clear {} ::punk::reset + #interp alias {} c {} ::punk::reset + + interp alias {} reset {} ::punk::reset + proc reset {} { + if {[llength [info commands ::punk::repl::reset_terminal]]} { + #punk::repl::reset_terminal notifies prompt system of reset + punk::repl::reset_terminal + } else { + puts -nonewline stdout [punk::ansi::reset] + } + } + + namespace eval argdoc { + punk::args::define { + @id -id ::punk::ansi8 + @cmd -name punk::ansi8\ + -summary\ + "Tell terminal to enable 8-bit ANSI codes."\ + -help\ + "Enable 8-bit ANSI codes in the terminal. + May not be supported by all terminals. + Some terminals may already have 8-bit ANSI enabled, but some may require an explicit command to enable it. + 7-bit ANSI codes are generally preferred - and will still work on terminals with 8-bit ANSI support. + + (This is nothing to do with 8-bit colors - it is about the underlying bytes used for ANSI control sequences). + The ANSI sequence sent to the terminal to enable 8-bit codes is: ESC 7 + + To disable 8-bit ANSI support - a reset of the terminal may be required. + " + @opts + @values -min 0 -max 0 + } + } + proc ansi8 {} { + punk::console::S8C1R + } + namespace eval argdoc { + punk::args::define { + @id -id ::punk::clear + @cmd -name punk::clear\ + -summary\ + "Clear the terminal screen (and scrollback buffer by default)."\ + -help\ + "Clear the terminal screen. + By default this will also clear scrollback if supported by the terminal. + With -x option it will preserve scrollback but clear the screen. + " + @opts + -x -optional 1 -type none -mash 1 -help\ + "Preserve scrollback (if supported by terminal) but clear screen." + -s -optional 1 -type none -mash 1 -help\ + "Stay at the current cursor position instead of moving to top-left after clearing." + @values -min 0 -max 0 + } + } + proc clear {args} { + set argd [punk::args::parse $args withid ::punk::clear] + lassign [dict values $argd] leaders opts values received + set opt_x [dict exists $received -x] + set opt_s [dict exists $received -s] + # -x preserves scrollback but clears screen + if {$opt_s} { + #set pre_move_cmd [punk::ansi::move_up 1] + #review - terminal support for save/restore. + #we can just move up one line before clearing to preserve the line we're on, + #but this won't work if we're already at the last line. + #save/restore would be better if widely supported. + + #review - get_size already calls get_cursor pos - maybe we can optimize by not calling get_cursor_pos separately? + #review - consider turning off cursor updating while doing this to avoid flicker? + set cpos [punk::console::get_cursor_pos] + set row [lindex $cpos 0] + set size [punk::console::get_size] + set lastrow [dict get $size rows] + if {$row >= $lastrow} { + set pre_move_cmd [punk::ansi::cursor_save_dec] + } else { + set pre_move_cmd [punk::ansi::move_up 1][punk::ansi::cursor_save_dec] + } + set move_cmd [punk::ansi::cursor_restore_dec] + + #set pre_move_cmd [punk::ansi::move_up 1] + #set move_cmd "" + + } else { + set pre_move_cmd "" + set move_cmd [punk::ansi::move 1 1] + } + if {$opt_x} { + puts -nonewline stdout $pre_move_cmd[punk::ansi::clear]$move_cmd + } else { + puts -nonewline stdout $pre_move_cmd[punk::ansi::clear_all]$move_cmd + } + } + #c aliased to clear -xs + #cc aliases to clear -x + + + + #fileutil::cat except with checking for windows illegal path names (when on windows platform) + interp alias {} fcat {} punk::mix::util::fcat + + #---------------------------------------------- + interp alias {} linelistraw {} punk::linelistraw + + # 'path' collides with kettle path in kettle::doc function - todo - patch kettle? + interp alias {} PATH {} punk::path + + interp alias {} path_list {} punk::path_list + interp alias {} list_filter_cond {} punk::list_filter_cond + + + interp alias {} inspect {} punk::inspect + interp alias {} ooinspect {} punk::ooinspect + + interp alias {} linedict {} punk::linedict + interp alias {} dictline {} punk::dictline + + #todo - pipepure - evaluate pipeline in a slave interp without commands that have side-effects. (safe interp?) + interp alias {} % {} punk::% + interp alias {} pipeswitch {} punk::pipeswitch + interp alias {} pipeswitchc {} punk::pipeswitchc ;#closure version - more correct + interp alias {} pipecase {} punk::pipecase + interp alias {} pipematch {} punk::pipematch + interp alias {} ispipematch {} punk::ispipematch + interp alias {} pipenomatchvar {} punk::pipenomatchvar + interp alias {} pipedata {} punk::pipedata + interp alias {} pipeset {} punk::pipeset + interp alias {} pipealias {} punk::pipealias + interp alias {} listset {} punk::listset ;#identical to pipeset + + + #non-core aliases + interp alias {} is_list_all_in_list {} punk::lib::is_list_all_in_list + interp alias {} is_list_all_ni_list {} punk::libis_list_all_ni_list + + + + #interp alias {} = {} ::punk::pipeline = "" "" + #interp alias {} = {} ::punk::match_assign "" "" + interp alias {} .= {} ::punk::pipeline .= "" "" + #proc .= {args} { + # #uplevel 1 [list ::punk::pipeline .= "" "" {*}$args] + # tailcall ::punk::pipeline .= "" "" {*}$args + #} + + + interp alias {} rep {} ::tcl::unsupported::representation + interp alias {} dis {} ::tcl::unsupported::disassemble + + + + # ls aliases - note that tcl doesn't exand * but sh_xxx functions pass to sh -c allowing shell expansion + interp alias {} l {} sh_runout -n ls -A ;#plain text listing + #interp alias {} ls {} sh_runout -n ls -AF --color=always + interp alias {} ls {} shellrun::runconsole ls -AF --color=always ;#use unknown to use terminal and allow | more | less + #note that shell globbing with * won't work on unix systems when using unknown/exec + interp alias {} lw {} sh_runout -n ls -AFC --color=always ;#wide listing (use A becaus no extra info on . & ..) + interp alias {} ll {} sh_runout -n ls -laFo --color=always ;#use a instead of A to see perms/owner of . & .. + # -v for natural number sorting not supported on freeBSD. Todo - test at startup and modify aliases? + #interp alias {} lw {} ls -aFv --color=always + + interp alias {} dir {} shellrun::runconsole dir + + # punk::nav::fs + package require punk::nav::fs + package require punk::nav::ns + + + + variable pshell_path "" + # ---------------------------------------- + set pshell_path [auto_execok pwsh] ;#Still not installed by default on win10 11? + if {$pshell_path eq ""} { + #fallback to powershell 5 + #set pshell_path [auto_execok powershell] + set pshell_path powershell ;#temp + } else { + set pshell_path pwsh ;#temp + } + #todo - review run commands and handling of paths with spaces + # ---------------------------------------- + + + + if {$pshell_path eq ""} { + set has_powershell 0 + } else { + #todo - review powershell detection on non-windows platforms + set has_powershell 1 + } + + if {$::tcl_platform(platform) eq "windows"} { + interp alias {} dl {} dir /q + interp alias {} dw {} dir /W/D + } else { + #todo - natsorted equivalent + #interp alias {} dl {} + interp alias {} dl {} puts stderr "not implemented" + interp alias {} dw {} puts stderr "not implemented" + } + + #todo - distinguish non-preinstalled pwsh (powershell core) from powershell which is available by default + if {$has_powershell} { + #see also powershell runspaces etc: + # powershell runspaces e.g $rs=[RunspaceFactory]::CreateRunspace() + # $ps = [Powershell]::Create() + + interp alias {} pse {} exec >@stdout {*}$pshell_path -nolo -nop -c + interp alias {} psx {} runx -n {*}$pshell_path -nop -nolo -c + interp alias {} psr {} run -n {*}$pshell_path -nop -nolo -c + interp alias {} psout {} runout -n {*}$pshell_path -nop -nolo -c + interp alias {} pserr {} runerr -n {*}$pshell_path -nop -nolo -c + #interp alias {} psls {} shellrun::runconsole $pshell_path -nop -nolo -c ls + #interp alias {} psls {} shellrun::runconsole {*}$pshell_path -nop -nolo -c {ls | Select-Object Mode, @{Name='Owner';Expression={(Get-Acl $_.FullName).Owner}}, LastWriteTime, Length, Name | Format-Table} + proc psls args { + variable pshell_path + shellrun::runconsole {*}$pshell_path -nop -nolo -c {*}[string map [list %a% $args] {{ls %a% | Select-Object Mode, @{Name='Owner';Expression={(Get-Acl $_.FullName).Owner}}, LastWriteTime, Length, Name | Format-Table}}] + } + interp alias {} psls {} punk::psls + interp alias {} psps {} shellrun::runconsole {*}$pshell_path -nop -nolo -c ps + } else { + set ps_missing "powershell missing (powershell is MIT licensed open source and can be installed on windows and most unix-like platforms)" + interp alias {} pse {} puts stderr $ps_missing + interp alias {} psx {} puts stderr $ps_missing + interp alias {} psr {} puts stderr $ps_missing + interp alias {} psout {} puts stderr $ps_missing + interp alias {} pserr {} puts stderr $ps_missing + interp alias {} psls {} puts stderr $ps_missing + interp alias {} psps {} puts stderr $ps_missing + } + proc psencode {cmdline} { + + } + proc psdecode {encodedcmd} { + + } + + #proc repl {startstop} { + # switch -- $startstop { + # stop { + # if {[punk::repl::codethread::is_running]} { + # puts stdout "Attempting repl stop. Try ctrl-c or exit command to leave interpreter" + # set ::repl::done 1 + # } + # } + # start { + # if {[punk::repl::codethread::is_running]} { + # repl::start stdin + # } + # } + # default { + # error "repl unknown action '$startstop' - must be start or stop" + # } + # } + #} + +} + + +# -- --- --- --- +#Load decks. commandset packages are not loaded until the deck is called. +# -- --- --- --- +package require punk::mod +#punk::mod::cli set_alias pmod +punk::mod::cli set_alias app + +#todo - change to punk::dev +package require punk::mix +punk::mix::cli set_alias dev +punk::mix::cli set_alias deck ;#deprecate! + +#todo - add punk::deck for managing cli modules and commandsets + +package require punkcheck::cli +punkcheck::cli set_alias pcheck +punkcheck::cli set_alias punkcheck +# -- --- --- --- + +package provide punk [namespace eval punk { + #FUNCTL + variable version + set version 0.1.1 +}] + + + diff --git a/src/bootsupport/modules/punk/aliascore-0.1.0.tm b/src/bootsupport/modules/punk/aliascore-0.1.0.tm index 296fa148..bea6a48f 100644 --- a/src/bootsupport/modules/punk/aliascore-0.1.0.tm +++ b/src/bootsupport/modules/punk/aliascore-0.1.0.tm @@ -123,6 +123,7 @@ tcl::namespace::eval punk::aliascore { ansistrip ::punk::ansi::ansistrip stripansi ::punk::ansi::ansistrip ansiwrap ::punk::ansi::ansiwrap + ansisplit ::punk::ansi::ta::split_codes_single grepstr ::punk::ansi::grepstr untabify ::punk::ansi::untabify colour ::punk::console::colour diff --git a/src/bootsupport/modules/punk/ansi-0.1.1.tm b/src/bootsupport/modules/punk/ansi-0.1.1.tm index e8518d0f..53ffd420 100644 --- a/src/bootsupport/modules/punk/ansi-0.1.1.tm +++ b/src/bootsupport/modules/punk/ansi-0.1.1.tm @@ -127,7 +127,8 @@ tcl::namespace::eval punk::ansi::class { -width -type integer -default "" -height -type integer -default "" -crm_mode -type boolean -default 0 - -binarytext -type string -default "" -choices {"" bios ice} + -format -type string -choices {ansi binarytext-bios binarytext-ice xbin} -help\ + "Format of new data being applied as an overlay" @values -min 0 -max 0 }] method rendertest {args} { @@ -135,7 +136,7 @@ tcl::namespace::eval punk::ansi::class { set opt_width [dict get $argd opts -width] set opt_height [dict get $argd opts -height] set opt_crm_mode [dict get $argd opts -crm_mode] - set opt_binarytext [dict get $argd opts -binarytext] + set opt_format [dict get $argd opts -format] set existing_dimensions $o_render_dimensions if {![regexp {^([0-9]+)[xX]([0-9]+)$} $existing_dimensions _m w h]} { @@ -150,8 +151,7 @@ tcl::namespace::eval punk::ansi::class { set o_render_dimensions ${w}x${h} - - set rendered [overtype::renderspace -binarytext $opt_binarytext -cp437 1 -crm_mode $opt_crm_mode -expand_right 0 -wrap 1 -width $w -height $h -appendlines 1 "" [$o_ansistringobj get]] + set rendered [overtype::renderspace -format $opt_format -cp437 1 -crm_mode $opt_crm_mode -expand_right 0 -wrap 1 -width $w -height $h -appendlines 1 "" [$o_ansistringobj get]] return $rendered } @@ -630,7 +630,8 @@ tcl::namespace::eval punk::ansi { package require punk::ansi::sauce set sdict [punk::ansi::sauce::from_file $filename] set result "" - if {[dict size $sdict]} { + #if no sauce header - sdict will contain only posn -1 + if {[dict size $sdict] > 1} { if {$opt_return eq "dict"} { return $sdict } @@ -695,33 +696,75 @@ tcl::namespace::eval punk::ansi { } set opt_crm_mode [dict get $opts -crm_mode] - set binarytext "" set sdict [dict create] #if SAUCE data is present - it may give an indication of encoding as well as number of columns/lines if {![catch {package require punk::ansi::sauce}]} { if {[catch {punk::ansi::sauce::from_file $fname} sdict]} { - #no 128 Byte SAUCE record at end of file + #error parsing 128 Byte SAUCE record at end of file set sdict [dict create] } + #if no error - there may be no SAUCE record at all (sdict is just posn -1) } else { puts stderr "Warning punk::ansi::sauce package not loaded - unable to detect or use any SAUCE data to aid in display" } - if {![dict size $sdict]} { - if {[string tolower [file extension $fname]] eq ".bin"} { - #In the absence of SAUCE data - assume .bin is binary text - set binarytext bios ;#16 fg, 8 bg + blink + + set format ansi ;#default assumption + + + if {[dict size $sdict] < 2} { + #either no SAUCE (dict is just posn -1) or there was an error during sauce::from_file parsing (empty sdict) + switch -exact -- [string tolower [file extension $fname]] { + .bin { + #In the absence of SAUCE data - assume .bin is binary text + set format binarytext-bios ;#16 fg, 8 bg + blink + } + .xb { + set format xbin + } } } + + #review - we open and read from file twice - once for sauce, once to slurp in whole file. + # - consider optimising to read file in first and use slurped data for sauce + #(create punk::ansi::sauce::from_data ?) + set ansidata [fcat -translation binary $fname] + if {[dict size $sdict] && [dict get $sdict posn] != -1} { + #the SAUCE ctrl-z may not be the only ctrl-z in the file data + #use the position returned by sauce::from_file rather than splitting on ctrl-z + #posn will be -1 if no SAUCE, or the position of the ctrl-z immediatly before the entire SAUCE block (including comments) + set ansidata [string range $ansidata 0 [dict get $sdict posn]-1] + } + + if {[dict exists $sdict datatype_name]} { - if {[dict get $sdict datatype_name] eq "binarytext"} { - #todo - SAUCE ANSiFlags - ice vs default bios - if {[dict exists $sdict ansiflags_ice] && [dict get $sdict ansiflags_ice]} { - set binarytext ice - } else { - set binarytext bios + switch -- [dict get $sdict datatype_name] { + binarytext { + #SAUCE ANSiFlags - iCE vs default bios + if {[dict exists $sdict ansiflags_ice] && [dict get $sdict ansiflags_ice]} { + set format binarytext-ice + } else { + set format binarytext-bios + } + } + xbin { + set format xbin + } + default { } } } + + if {$format eq "xbin"} { + #set ansidata [fcat -translation binary $fname] ;#don't split on \x1a - this is also present in xbin header + set xbin_header [string range $ansidata 0 10] ;#11 bytes + set non_header [string range $ansidata 11 end] + #set ansidata $xbin_header[lindex [split $non_header \x1a] 0] ;#ignore sauce at tail + set xbin_header_info [punk::ansi::xbin::parse_header $xbin_header] + #keys width height fontsize flags + set dimensions [dict get $xbin_header_info width]x[dict get $xbin_header_info height] ;#cols x rows + } + + if {$encoding eq ""} { if {[dict exists $sdict codepage]} { set encoding [dict get $sdict codepage] @@ -733,11 +776,13 @@ tcl::namespace::eval punk::ansi { if {$dimensions eq ""} { # defaults - if {$binarytext ne ""} { + if {[string match binarytext* $format]} { set cols 160 } else { set cols 80 } + + #sauce-specified if {[dict exists $sdict columns]} { set c [dict get $sdict columns] if {$c > 0} { @@ -764,17 +809,24 @@ tcl::namespace::eval punk::ansi { } lassign [split $dimensions x] cols rows - #set ansidata [fcat -encoding $encoding $fname] - set ansidata [lindex [split [fcat -translation binary $fname] \x1a] 0] - #hack - #if {$binarytext eq ""} { + if {$format eq "xbin"} { + #review + ##don't decode binary xbin header + #set hdr [string range $ansidata 0 10] + #set data [encoding convertfrom $encoding [string range $ansidata 11 end]] + #set ansidata $hdr$data + + #don't convert at all - compressed is binary? + } elseif {[string match binarytext* $format]} { + #don't convert - this is binary data - the rendering obj will handle it as binary + } else { set ansidata [encoding convertfrom $encoding $ansidata] - #} + } set obj [punk::ansi::class::class_ansi new $ansidata] if {$encoding eq "cp437"} { - set result [$obj rendertest -binarytext $binarytext -width $cols -height $rows -crm_mode $opt_crm_mode] + set result [$obj rendertest -format $format -width $cols -height $rows -crm_mode $opt_crm_mode] } else { set result [$obj render $dimensions] } @@ -6193,24 +6245,12 @@ be as if this was off - ie lone CR. #counterintuitively "x\b" still shows the x ie length is still one. The backspace just moves the position. There must be a char following \b for it to affect the length. #(we are not interested in the destructive backspace case present in editors,terminals etc - that is a different context) - set n 0 - #set chars [split $line ""] ; #review - graphemes vs chars? Terminals differ in how they treat this. - set chars [punk::char::grapheme_split $line] - set cr_posns [lsearch -all $chars \r] - set bs_posns [lsearch -all $chars \b] - foreach p $cr_posns { - lset chars $p - } - foreach p $bs_posns { - lset chars $p - } #mintty seems more 'correct'. It will backspace over an entire grapheme (char+combiners) whereas windows terminal/wezterm etc remove a combiner #build an output set idx 0 set outchars [list] - set outsizes [list] # -- #tcl8.6/8.7 we can get a fast byte-compiled switch statement only with literals in the source code #this is difficult/risky to maintain - hence the lsearch and grapheme-replacement above @@ -6220,39 +6260,65 @@ be as if this was off - ie lone CR. #set cr ? # -- - - #consider also that AB\0\bC will usually render as AC not ABC - foreach c $chars { - switch -- $c { - { - if {$idx > 0} { - incr idx -1 - } - } - { - set idx 0 - } - default { - if {$c eq "\0"} { - #nulls don't print - and backspace will ignore them and remove the preceding char if there is one. - #we need to remove them here or else backspace processing will only remove the null and not the preceding char - which is not how terminals work. - #review - other zero-width chars? - continue - } - #set nxt [llength $outchars] - if {$idx < [llength $outchars]} { - #overstrike? - should usually have no impact on width - width taken as last grapheme in that column - #e.g nroff would organise text such that underline written first, then backspace, then the character - so that terminals without overstrike would display something useful if no overstriking is done - #Conceivably double_wide_char then backspace then underscore would underreport the length if overstriking were intended. - lset outchars $idx $c - } else { - lappend outchars $c - } - #punk::ansi::internal::printing_length_addchar $idx $c - incr idx - } + set graphemes [punk::char::grapheme_split $line] + foreach g $graphemes { + if {$g eq "\0"} { + #nulls don't print - and backspace will ignore them and remove the preceding char if there is one. + #we need to remove them here or else backspace processing will only remove the null and not the preceding char - which is not how terminals work. + #review - other zero-width chars? + continue + } elseif {$g eq "\r"} { + set idx 0 + } elseif {$g eq "\b"} { + incr idx -1 + set idx [expr {max(0,$idx)}] + } else { + lset outchars $idx $g ;#lset will append if $idx is equal to the current length of the list - since we only increment idx by 1, this should be safe to do without checking the length first + #if {$idx < [llength $outchars]} { + # #overstrike? - should usually have no impact on width - width taken as last grapheme in that column + # #e.g nroff would organise text such that underline written first, then backspace, then the character - so that terminals without overstrike would display something useful if no overstriking is done + # #Conceivably double_wide_char then backspace then underscore would underreport the length if overstriking were intended. + # lset outchars $idx $g + #} else { + # lappend outchars $g + #} + incr idx } } + + + + #consider also that AB\0\bC will usually render as AC not ABC + #foreach g $graphemes { + # switch -exact -- $g { + # { + # if {$idx > 0} { + # incr idx -1 + # } + # } + # { + # set idx 0 + # } + # { + # #nulls don't print - and backspace will ignore them and remove the preceding char if there is one. + # #we need to remove them here or else backspace processing will only remove the null and not the preceding char - which is not how terminals work. + # #review - other zero-width chars? + # continue + # } + # default { + # #set nxt [llength $outchars] + # if {$idx < [llength $outchars]} { + # #overstrike? - should usually have no impact on width - width taken as last grapheme in that column + # #e.g nroff would organise text such that underline written first, then backspace, then the character - so that terminals without overstrike would display something useful if no overstriking is done + # #Conceivably double_wide_char then backspace then underscore would underreport the length if overstriking were intended. + # lset outchars $idx $g + # } else { + # lappend outchars $g + # } + # incr idx + # } + # } + #} #we already have the string split into grapheme clusters. #we should calculate length as the sum of the widths of the graphemes in the output list rather #than passing to a function that will need to split into graphemes again. @@ -6287,7 +6353,7 @@ be as if this was off - ie lone CR. set max_component_width 1 } } - } elseif {$c < 917504 || $c > 917631} { + } elseif {$dec < 917504 || $dec > 917631} { #codepoint not in the zero-width unicode tag block - \UE0000-\UE000F #set w [punk::char::char_width $dec] set w [textutil::wcswidth_char $dec] @@ -6314,19 +6380,6 @@ be as if this was off - ie lone CR. return $sumwidth #return [punk::char::ansifreestring_width [join $outchars ""]] } - namespace eval internal { - proc printing_length_addchar {i c} { - #review - upvar outchars outc - upvar outsizes outs - set nxt [llength $outc] - if {$i < $nxt} { - lset outc $i $c - } else { - lappend outc $c - } - } - } # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- @@ -7070,6 +7123,12 @@ be as if this was off - ie lone CR. set prev_stop_idx [lsearch -integer -bisect $tstops $current_column] set next_stop [lindex $tstops $prev_stop_idx+1] ;#if our current_column is exactly on a stop, we still want to move to the next stop. + if {$next_stop eq ""} { + #if we run out of stops + #Review + break + } + # how far is the next tab position ? #set dist [expr {$num - ($currPos % $num)}] set this_tab_width [expr {$next_stop - $current_column}] ;#diff between two adjacent columns is one. @@ -7515,6 +7574,10 @@ tcl::namespace::eval punk::ansi { #} #------------------------------------------------------- proc sgr_merge {codelist args} { + if {[llength $codelist] == 0 && [llength $args] == 0} { + return "" + } + #pass through even single code or empty codelist to sgr_merge_singles - as there may be arguments such as -info or -filter_* set allparts [list] foreach c $codelist { #set cparts [punk::ansi::ta::split_codes_single $c] @@ -8959,7 +9022,6 @@ tcl::namespace::eval punk::ansi::class { -overflow 0 -appendlines 1 -looplimit 15000 - -experimental {} -cursor_column 1 -cursor_row 1 -insert_mode 0 @@ -8970,7 +9032,7 @@ tcl::namespace::eval punk::ansi::class { foreach {k v} $argsflags { switch -- $k { -width - -height - - -overflow - -appendlines - -looplimit - -experimental - + -overflow - -appendlines - -looplimit - -autowrap_mode - -insert_mode - -initial_ansistring { @@ -9671,7 +9733,8 @@ tcl::namespace::eval punk::ansi::class { upvar ${ns}::o_gx0states new_gx0states upvar ${ns}::o_splitindex new_splitindex - lset o_ansisplits end [tcl::string::cat [lindex $o_ansisplits end] [lindex $new_ansisplits 0]] lappend o_ansisplits {*}[lrange $new_ansisplits 1 end] + lset o_ansisplits end [tcl::string::cat [lindex $o_ansisplits end] [lindex $new_ansisplits 0]] + lappend o_ansisplits {*}[lrange $new_ansisplits 1 end] lset o_ptlist end [tcl::string::cat [lindex $o_ptlist end] [lindex $new_ptlist 0]] lappend o_ptlist {*}[lrange $new_ptlist 1 end] @@ -10286,8 +10349,9 @@ tcl::namespace::eval punk::ansi::ansistring { set hack [tcl::dict::create] tcl::dict::set hack BOM1 [list \uFEFF "${obm}\U1f4a3$cbm"] ;#byte order mark/ ZWNBSP (ZWNBSP usage generally deprecated) - a picture of a bomb(2wide glyph) tcl::dict::set hack ZWSP [list \u200B "${obm}ZWSP$cbm"] - tcl::dict::set hack ZWNJ [list \u200D "${obm}ZWNJ$cbm"] ;#zero width non-joiner. + tcl::dict::set hack ZWNJ [list \u200C "${obm}ZWNJ$cbm"] ;#zero width non-joiner. tcl::dict::set hack ZWJ [list \u200D "${obm}ZWJ$cbm"] + tcl::dict::set hack CGJ [list \u034F "${obm}CGJ$cbm"] ;#combining grapheme joiner (MISNOMER) - zero width, but semantically important in some contexts - for example in indic scripts - where it can affect the shaping of the preceding character(s) #review - other boms? Encoding dependent? @@ -10561,6 +10625,7 @@ tcl::namespace::eval punk::ansi::ansistring { #Note that trim/trimleft/trimright will trim spaces at the extremities that are styled with background colour, underline etc #that may be unexpected, but it's probably the only thing that makes sense. Plain string trim can chop off whitespace that is extraneous to the ansi entirely. proc trimleft {string args} { + #todo - don't just trim whitespace - need to accept optional ?chars? to trim. set intext 0 set out "" #for split_codes only first or last pt can be empty string - but we can also get an empty ansiblock by using foreach with 2 vars on an odd-length list @@ -11808,7 +11873,7 @@ namespace eval punk::ansi::colour { @cmd -name "punk::ansi::colour::byteAnsi" -summary\ "ANSI/BIOS colour codes from attribute byte."\ -help\ - "Convert an attribute-byte (character) to ANSI SGR + "Convert a binarytext (.bin) attribute-byte (character) to ANSI SGR foreground and background colour. This is allows 16 foreground colours and only 8 background colours, with the highest bit being @@ -11828,7 +11893,7 @@ namespace eval punk::ansi::colour { lappend PUNKARGS [list { @id -id "::punk::ansi::colour::byteAnsiIce" @cmd -name "punk::ansi::colour::byteAnsiIce" -summary\ - "iCE colour codes from attribute byte."\ + "iCE colour codes from binarytext (.bin) attribute byte."\ -help\ "Convert an attribute-byte (character) to ANSI SGR foreground and background colour. @@ -11847,6 +11912,945 @@ namespace eval punk::ansi::colour { dict get $byte_to_ansi_ice $char } } +tcl::namespace::eval punk::ansi::xbin { + proc parse_header {str} { + #https://web.archive.org/web/20120204063040/http://www.acid.org/info/xbin/x_spec.htm + if {[string length $str] < 11} { + error "punk::ansi::xbin::parse_header error - invalid XBIN header - less than 11 bytes received" + } + set xbin_header [string range $str 0 10] ;#11 bytes + + set xbin_id [string range $xbin_header 0 3] + if {$xbin_id ne "XBIN"} { + error "punk::ansi::xbin::parse_header error - invalid XBIN header" + } + set xbin_eofchar [string index $xbin_header 4] + set xbin_width_raw [string range $xbin_header 5 6] + binary scan $xbin_width_raw su xbin_width ;#16bit unsigned little-endian + set xbin_height_raw [string range $xbin_header 7 8] + binary scan $xbin_height_raw su xbin_height ;#16bit unsigned little-endian + + set xbin_fontsize_raw [string index $xbin_header 9] + if {[binary scan $xbin_fontsize_raw cu xbin_fontsize]} { + #1 byte - unsigned + #numeric number of pixel rows (scanlines) in font. + #Any value from 1 to 32 is technically possible on VGA. + #Any other values should be considered illegal + if {$xbin_fontsize < 1 || $xbin_fontsize > 32} { + error "punk::ansi::xbin::parse_header error - invalid XBIN header - fontsize not in range 1 to 32 inclusive. received $xbin_fontsize" + } + } + set xbin_flags_raw [string index $xbin_header 10] + #valid flags: 512chars nonblink compress font palette + #bits: + #7 unused 6 unused 5 unused 4 512chars 3 nonblink 2 compress 1 font 0 palette + binary scan $xbin_flags_raw B8 flagbits + set flagbits [lrange [split $flagbits ""] 3 end] ;#skip first 3 unused + set allflags [list 512chars nonblink compress font palette] + set xbin_flags [list] + #puts "flagbits $flagbits" + foreach b $flagbits f $allflags { + if {$b} { + lappend xbin_flags $f + } + } + #width - number of columns, height - number of character rows + return [dict create width $xbin_width height $xbin_height fontsize $xbin_fontsize flags $xbin_flags] + } + proc default_palette {} { + # VGA 16-colour default palette as RGB 0-255 triples. + return { + {0 0 0} + {0 0 170} + {0 170 0} + {0 170 170} + {170 0 0} + {170 0 170} + {170 85 0} + {170 170 170} + {85 85 85} + {0 0 255} + {0 255 0} + {0 255 255} + {255 0 0} + {255 0 255} + {255 255 0} + {255 255 255} + } + } + + proc palette_value_8bit {value} { + if {$value < 0 || $value > 63} { + error "punk::ansi::xbin::palette_value_8bit error - expected palette value from 0 to 63 inclusive. received $value" + } + return [expr {round(($value * 255.0) / 63.0)}] + } + proc parse_palette {str} { + if {[string length $str] < 48} { + error "punk::ansi::xbin::parse_palette error - invalid XBIN palette - less than 48 bytes received" + } + binary scan [string range $str 0 47] cu* components + set palette [list] + foreach {r g b} $components { + lappend palette [list [palette_value_8bit $r] [palette_value_8bit $g] [palette_value_8bit $b]] + } + #for {set i 0} {$i < 48} {incr i 3} { + # set r [palette_value_8bit [lindex $components $i]] + # set g [palette_value_8bit [lindex $components $i+1]] + # set b [palette_value_8bit [lindex $components $i+2]] + # lappend palette [list $r $g $b] + #} + return $palette + } + proc attribute_ansi {char palette nonblink} { + #convert a binarytext (.bin) attribute byte (character) to ANSI SGR + #foreground and background colour. + #When nonblink is false, this allows 16 foreground colours and only 8 + #background colours, with the highest bit being + #used to set 'blink' on. + if {![binary scan $char cu value]} { + error "punk::ansi::xbin::attribute_ansi error - expected a single character for attribute byte. received string of length [string length $char] - '[ansistring VIEW $char]'" + } + + set fg_index [expr {$value & 0x0F}] + if {$nonblink} { + set bg_index [expr {($value >> 4) & 0x0F}] + set blink noblink + } else { + set bg_index [expr {($value >> 4) & 0x07}] + if {$value & 0x80} { + set blink blink + } else { + set blink noblink + } + } + lassign [lindex $palette $fg_index] fr fg fb + lassign [lindex $palette $bg_index] br bg bb + return [punk::ansi::a+ $blink rgb-$fr-$fg-$fb Rgb-$br-$bg-$bb] + } + + proc parse {xbindata} { + set bytenum 0 + set xbin_header [string range $xbindata 0 10] ;#11 bytes + set xbin_header_info [punk::ansi::xbin::parse_header $xbin_header] + set xbin_body [string range $xbindata 11 end] + incr bytenum 11 + + set flags [dict get $xbin_header_info flags] + set xbin_width [dict get $xbin_header_info width] + set xbin_height [dict get $xbin_header_info height] + set expected_cells [expr {$xbin_width * $xbin_height}] + set xbin_nonblink [expr {"nonblink" in $flags}] ;# ice. + set xbin_palette [punk::ansi::xbin::default_palette] + + set parse_warnings [list] + + #optional 16-entry palette, 3 bytes per entry, RGB values 0..63 + if {"palette" in $flags} { + #puts stderr "renderspace warning - palette unimplemented" + set xbin_palette [punk::ansi::xbin::parse_palette [string range $xbin_body 0 47]] + set xbin_body_after_palette [string range $xbin_body 48 end] + incr bytenum 48 + } else { + set xbin_body_after_palette $xbin_body + } + + #todo - font. + #hack - skip over font 256 x fontsize or 512 x fontsize + if {"512chars" in $flags} { + set sz 512 + } else { + set sz 256 + } + #temp + set skip [expr {$sz * [dict get $xbin_header_info fontsize]}] + if {"font" in $flags} { + #todo - consider sixel or similar for font data - but for now we just skip over it. + #puts stderr "punk::ansi::xbin::parse warning - xbin font unimplemented" + lappend parse_warnings "XBIN_FONT_UNIMPLEMENTED skipping over font data" + set celldata [string range $xbin_body_after_palette $skip end] + incr bytenum $skip + } else { + set celldata $xbin_body_after_palette + } + set celldata_bytes [split $celldata ""] + #puts stdout "xbin image data size [llength $celldata_bytes]" + + set decoded_cells 0 + set ansisplit [list ""] + if {"compress" in $flags} { + #puts stderr "renderspace warning - compress experimental" + #process 'repeatcounter' bytes + #first 2 bits - compression type + # 00 - no compression + # 01 - character compression + # 10 - attribute compression + # 11 - character/attribute compression + #remaining 6 bits - counter + set input "" + set byte_count [llength $celldata_bytes] + for {set b 0} {$b < $byte_count} {} { + set rc [lindex $celldata_bytes $b] + set dec [scan $rc %c] + set ctype [expr {$dec >> 6}] + #0x3F - 00111111 + set count [expr {$dec & 0x3F}] + incr count ;#count stored as 1 less than actual number of repeats + if {$count < 1 || $count > 64} { + #generally unlikely to occur if we are decoding 6 bits of count correctly. + # - but will be zero for example if we have a trailing carriage return. + puts stderr "punk::ansi::xbin::parse - max count must be between 1 and 64 inclusive. received $count" + } + incr b + if {$decoded_cells + $count > $expected_cells} { + #some of the more common causes of this could be additional non xbin data after the expected end of celldata, eg: + #\x1a (ctrl-z) decimal value 26 (= count 27) delimiter for start of SAUCE record. + #\r (carriage regurn) decimal value 13 (= count 14) + #\n (line feed) decimal value 10 (= count 11) + # or it could be more celldata but the header dimensions are wrong + #- either way we should probably just warn and stop processing. + lappend parse_warnings "XBIN_OVERFLOW - record would emit $count cells at decoded offset $decoded_cells, expected total $expected_cells cells for header dimensions ${xbin_width}x${xbin_height} (possible trailing SAUCE record or newlines)" + break + } + switch -exact -- $ctype { + 0 { + set needed [expr {$count * 2}] + } + 1 - + 2 { + set needed [expr {$count + 1}] + } + 3 { + set needed 2 + } + default { + #hard error - will probably cause desynchronization between decoder and byte stream + error "punk::ansi::xbin::parse - invalid compression type $ctype in repeatcounter byte '$rc' at offset $b" + } + } + if {$b + $needed > $byte_count} { + lappend parse_warnings "XBIN_BAD_RECORD - truncated record: type $ctype requires $needed bytes at payload offset $b, but only [expr {$byte_count - $b}] bytes remain." + #abort processing - would probably raise an error in the compression switch cases below. + #This may indicate a truncated file, but it could also be a file with additional data after the expected end of celldata. + #This is likely to happen if the xbindata includes a trailing SAUCE record. + #we shouldn't raise a hard error - as the caller may want to salvage what data they can from the file, and report the issue via warnings. + break + } + switch -exact -- $ctype { + 0 { + #no compression + for {set c 0} {$c < $count*2} {incr c 2} { + set ch [lindex $celldata_bytes $b+$c] + set ch [encoding convertfrom cp437 $ch] + set at [lindex $celldata_bytes [expr {$b+$c+1}]] + #binary scan $at cu code + #set clr [a+ term-$code] + #set clr [a+ red] ;#debug + set clr [punk::ansi::xbin::attribute_ansi $at $xbin_palette $xbin_nonblink] + lappend ansisplit $clr $ch + } + incr b [expr {$count*2}] + } + 1 { + #char compression + set ch [lindex $celldata_bytes $b] + set ch [encoding convertfrom cp437 $ch] + incr b + for {set c 0} {$c < $count} {incr c} { + set at [lindex $celldata_bytes $b+$c] + #binary scan $at cu code + #set clr [a+ term-$code] + #set clr [a+ cyan] ;#debug + set clr [punk::ansi::xbin::attribute_ansi $at $xbin_palette $xbin_nonblink] + lappend ansisplit $clr $ch + } + incr b [expr {$count}] + } + 2 { + #attribute compression + set at [lindex $celldata_bytes $b] + #binary scan $at cu code + #set clr [a+ term-$code] + #set clr [a+ green] ;#debug + set clr [punk::ansi::xbin::attribute_ansi $at $xbin_palette $xbin_nonblink] + incr b + for {set c 0} {$c < $count} {incr c} { + set ch [lindex $celldata_bytes $b+$c] + set ch [encoding convertfrom cp437 $ch] + lappend ansisplit $clr $ch + } + incr b $count + } + 3 { + #attribute and char compression + set ch [lindex $celldata_bytes $b] + set ch [encoding convertfrom cp437 $ch] + set at [lindex $celldata_bytes $b+1] + #binary scan $at cu code + #set clr [a+ term-$code] + #set clr [a+ white] ;#debug + set clr [punk::ansi::xbin::attribute_ansi $at $xbin_palette $xbin_nonblink] + for {set c 0} {$c < $count} {incr c} { + lappend ansisplit $clr $ch + } + incr b 2 + } + } + incr decoded_cells $count + } + if {$decoded_cells != $expected_cells} { + lappend parse_warnings "XBIN_CELLCOUNT_MISMATCH decoded $decoded_cells cells, expected $expected_cells cells for image dimensions ${xbin_width}x${xbin_height}" + } + } else { + foreach {ch at} $celldata_bytes { + #binary scan $at cu code + #set clr [a+ term-$code] + if {$at eq ""} { + #eg src/testansi/formatsamples/image/xbin/test.xb + #has missing last byte. for now just warn. + #puts stderr "renderspace warning - xbin attribute byte is empty at char '[ansistring VIEW $ch]'" + lappend parse_warnings "XBIN_MISSING_BYTE attribute byte is empty at byte [expr {$bytenum + 1}] char '[ansistring VIEW $ch]'" + #experiment - treat as a reset. + lappend ansisplit [a+] $ch + } else { + set clr [punk::ansi::xbin::attribute_ansi $at $xbin_palette $xbin_nonblink] + set ch [encoding convertfrom cp437 $ch] + lappend ansisplit $clr $ch + } + incr bytenum 2 + incr decoded_cells + } + } + #lappend inputchunks [list ansisplit $ansisplit] + + #_reset key with ansi reset to ensure direct display of dict in terminal is readable. + return [dict create header $xbin_header_info palette $xbin_palette ansisplit $ansisplit _reset \x1b\[m warnings $parse_warnings decoded_cells $decoded_cells expected_cells $expected_cells] + } + +} +tcl::namespace::eval punk::ansi::png { + + proc paethPredictor {a b c} { + #A Paeth PNG filter is a pre-compression image processing algorithm used in the Portable Network Graphics (PNG) format. + #It is designed to prepare image data for the format's lossless compression by predicting the color of a pixel based on + #its neighbors + set p [expr {$a + $b - $c}] + set pa [expr {abs($p - $a)}] + set pb [expr {abs($p - $b)}] + set pc [expr {abs($p - $c)}] + if {$pa <= $pb && $pa <= $pc} { return $a } + if {$pb <= $pc} { return $b } + return $c + } + + proc pngdataToAnsi {pngdata} { + #This will create very large ansi images as the smallest possible colorised cell is the half-block character. + #To create smaller images, we could consider some kind of lossy conversion to a smaller palette, or even to monochrome with dithering. + #A better alternative might be sixel or similar. + + #if {[::png::validate $filename] ne "OK"} { + # error "Invalid PNG file." + #} + # Extract PNG header metadata + #set info [::png::imageInfo $filename] + + if {[string range $pngdata 0 7] ne "\x89PNG\r\n\x1a\n"} { + error "pngdataToAnsi: Invalid PNG data - missing PNG signature" + } + + #----------------------------------------------------------------------------------------- + #set info [::png::imageInfo $filename] + #----------------------------------------------------------------------------------------- + set posn [expr {8}] ;# Skip PNG signature + binary scan [string range $pngdata $posn [expr {$posn + 7}]] Ia4 len type + incr posn 8 + set r [string range $pngdata $posn [expr {$posn + $len - 1}]] + incr posn $len + if {$type eq "IHDR"} { + binary scan $r IIccccc width height depth color compression filter interlace + binary scan [string range $pngdata $posn [expr {$posn + 3}]] I check + if {$check < 0} { + set check [format %u [expr {$check & 0xffffffff}]] + } + if {![catch {package present crc32}] && [::crc32::crc32 IHDR$r] != $check} { + error "pngdataToAnsi: Invalid PNG data - IHDR chunk CRC mismatch" + } + set info [list width $width height $height depth $depth color $color compression $compression filter $filter interlace $interlace] + } else { + error "pngdataToAnsi: Invalid PNG data - missing IHDR chunk" + } + #----------------------------------------------------------------------------------------- + + + set width [dict get $info width] + set height [dict get $info height] + set depth [dict get $info depth] + set color [dict get $info color] + set filter [dict get $info filter] + set interlace [dict get $info interlace] + set compression [dict get $info compression] + if {$compression != 0} { + #true as at PNG-3 2025 + error "pngdataToAnsi: Unsupported PNG compression method $compression - only method 0 (deflate/inflate) is supported." + } + puts stderr "pngdataToAnsi: PNG image info - width $width height $height depth $depth color $color interlace $interlace filter $filter" + + set color_types { + 0 Grayscale + 2 TrueColor (RGB) + 3 Indexed-color + 4 Grayscale with alpha + 6 TrueColor with alpha (RGBA) + } + switch -exact $color { + 0 { + error "pngdataToAnsi warning - PNG color type 0 (grayscale) not supported - todo: treat as RGB with R=G=B ?" + set ctype "grayscale" + if {$depth ni {1 2 4 8 16}} { + error "Unsupported format. Only grayscale PNGs with bit depths of 1, 2, 4, 8, or 16 are supported." + } + } + 2 { + # RGB TrueColor - supported + set ctype "rgb" + #todo depth 16 + if {$depth != 8} { + error "Unsupported format. Only 8-bit RGB or RGBA PNGs are supported." + } + set bpp 3 + } + 3 { + set ctype "indexed" + puts stderr "pngdataToAnsi warning - PNG color type 3 (indexed colour)" + if {$depth ni {1 2 4 8}} { + error "Unsupported format. Only indexed-color PNGs with 1,2,4 or 8 bit depth are supported." + } + set bpp 1 + } + 4 { + error "pngdataToAnsi warning - PNG color type 4 (grayscale with alpha) not supported - todo: treat as RGBA with R=G=B and alpha channel" + set ctype "grayscale_alpha" + set bpp 3 ;#Bytes per pixel + if {$depth ni {8 16}} { + error "Unsupported format. Only grayscale PNGs with bit depths of 8 or 16 are supported." + } + } + 6 { + puts stderr "pngdataToAnsi warning - PNG color type 6 (truecolor with alpha)" + set ctype "rgba" + if {$depth == 8} { + set bpp 4 ;#Bytes per pixel + } elseif {$depth == 16} { + set bpp 8 ;#Bytes per pixel + } else { + error "Unsupported format. Only depths of 8 or 16 bits per channel are supported for RGBA PNGs." + } + } + default { + error "pngdataToAnsi: Unsupported PNG color type $color" + } + } + + + #------------------------------------------ + # Extract raw compressed IDAT stream chunks + #set chunks [::png::getChunks $filename] + set chunks [list] + set posn [expr {8}] ;# Skip PNG signature + while {[set r [string range $pngdata $posn [incr posn 8]]] ne ""} { + binary scan $r Ia4 len type + if {$type eq "IEND"} { + #end of PNG data - stop processing chunks + #(important to stop before we try to process any trailing non-PNG data such as a SAUCE record) + break + } + lappend chunks [list $type $posn $len] + incr posn [expr {$len + 4}] + } + #------------------------------------------ + puts stderr "pngdataToAnsi: found [llength $chunks] chunks in PNG data" + foreach chunk $chunks { + puts stderr "pngdataToAnsi: chunk type '[lindex $chunk 0]' length [lindex $chunk 2]" + } + + + set paletteRaw "" + + set idatData "" + foreach chunk $chunks { + switch -exact -- [lindex $chunk 0] { + "IDAT" { + set posn [lindex $chunk 1] + append idatData [string range $pngdata $posn [expr {$posn + [lindex $chunk 2] - 1}]] + } + "PLTE" { + set posn [lindex $chunk 1] + puts stderr "pngdataToAnsi warning - PNG PLTE chunk" + #implement PLTE chunk parsing and support for indexed colour PNGs + append paletteRaw [string range $pngdata $posn [expr {$posn + [lindex $chunk 2] - 1}]] + } + "tEXt" { + set posn [lindex $chunk 1] + #todo - consider supporting tEXt chunks for metadata such as title, author, description etc. + set textData [string range $pngdata $posn [expr {$posn + [lindex $chunk 2] - 1}]] + set nullpos [string first \x00 $textData] + #neither the keyword nor text data is supposed to contain nulls. + if {$nullpos >= 0} { + set keyword [string range $textData 0 [expr {$nullpos - 1}]] + set text [string range $textData [expr {$nullpos + 1}] end]] + puts stderr "pngdataToAnsi warning - PNG tEXt chunk - keyword '$keyword' text '$text'" + } else { + puts stderr "pngdataToAnsi warning - PNG tEXt chunk - no separator null found: $textData" + } + } + "zTXt" { + #set posn [lindex $chunk 1] + #todo - consider supporting zTXt chunks for compressed metadata such as title, author, description etc. + #puts stderr "pngdataToAnsi warning - PNG zTXt chunk - [string range $pngdata $posn [expr {$posn + [lindex $chunk 2] - 1}]]" + } + "iTXt" { + #set posn [lindex $chunk 1] + #todo - consider supporting iTXt chunks for international text metadata such as title, author, description etc. + #puts stderr "pngdataToAnsi warning - PNG iTXt chunk - [string range $pngdata $posn [expr {$posn + [lindex $chunk 2] - 1}]]" + } + "IEND" { + } + default { + #ignore other chunk types for now + } + } + } + if {$ctype eq "indexed" && $paletteRaw eq ""} { + error "pngdataToAnsi: Indexed colour PNG missing PLTE chunk" + } + if {[string match grayscale* $ctype] && $paletteRaw ne ""} { + puts stderr "pngdataToAnsi warning - PNG PLTE chunk present in grayscale image - ignoring palette data" + } + if {$paletteRaw ne ""} { + set palette [list] + binary scan $paletteRaw c* components + puts "components: $components '[ansistring VIEW $paletteRaw]'" + foreach {r g b} $components { + lappend palette [list [expr {$r & 0xFF}] [expr {$g & 0xFF}] [expr {$b & 0xFF}]] + } + } + + # Decompress using raw Tcl zlib inflation + set decompressed [zlib decompress $idatData] + #set decompressed [zlib deflate $idatData] + #PLTE data is not compressed. + + #set stride [expr {1 + ($width * $bpp)}] + #set prevLine [binary format x[expr {$width * $bpp}]] ;# Row 0 baseline + + if {$ctype eq "indexed"} { + set bytesPerLine [expr {($width * $depth + 7) / 8}] + } else { + set bytesPerLine [expr {$width * $bpp}] + } + set stride [expr {1 + $bytesPerLine}] ;# Filter type byte + pixel data bytes + set prevLine [binary format x$bytesPerLine] ;# Row 0 baseline + set allRows [list] + + + # Process rows + for {set y 0} {$y < $height} {incr y} { + set offset [expr {$y * $stride}] + + # Unpack the filter type byte at start of each scanline + #puts "---> filter type byte: [ansistring VIEW [string range $decompressed $offset $offset]] at offset $offset for row $y" + binary scan [string range $decompressed $offset $offset] c filterType + set filterType [expr {$filterType & 0xFF}] + if {$filterType < 0 || $filterType > 4} { + puts stderr "pngdataToAnsi warning - invalid filter type $filterType at row $y - treating as no filter" + set filterType 0 + } + + # Get filtered pixel payload bytes for the row + set rawRow [string range $decompressed [expr {$offset + 1}] [expr {$offset + $stride - 1}]] + set currentLine "" + + # Defilter scanline bytes based on specification types + for {set xBytes 0} {$xBytes < $bytesPerLine} {incr xBytes} { + binary scan [string range $rawRow $xBytes $xBytes] c origByte + set origByte [expr {$origByte & 0xFF}] + + # Get left byte (A) and upper byte (B) and upper-left byte (C) + #set leftVal [expr {$xBytes >= $bpp ? [string index $currentLine [expr {$xBytes - $bpp}]] : 0}] + #binary scan $leftVal c a + #set a [expr {$a & 0xFF}] + if {$xBytes >= $bpp} { + binary scan [string index $currentLine [expr {$xBytes - $bpp}]] c a + set a [expr {$a & 0xFF}] + } else { + set a 0 + } + + binary scan [string range $prevLine $xBytes $xBytes] c b; + set b [expr {$b & 0xFF}] + + #set upLeftVal [expr {$xBytes >= $bpp ? [string index $prevLine [expr {$xBytes - $bpp}]] : 0}] + #binary scan $upLeftVal c c + #set c [expr {$c & 0xFF}] + if {$xBytes >= $bpp} { + binary scan [string index $prevLine [expr {$xBytes - $bpp}]] c c + set c [expr {$c & 0xFF}] + } else { + set c 0 + } + + # Reverse the PNG filter transformations + switch -- $filterType { + 0 { set reconByte $origByte } ;# None + 1 { set reconByte [expr {($origByte + $a) % 256}] } ;# Sub + 2 { set reconByte [expr {($origByte + $b) % 256}] } ;# Up + 3 { set reconByte [expr {($origByte + (($a + $b) / 2)) % 256}] } ;# Average + 4 { set reconByte [expr {($origByte + [paethPredictor $a $b $c]) % 256}] } ;# Paeth + default { + } + } + append currentLine [binary format c $reconByte] + } + set prevLine $currentLine + + if {$ctype eq "indexed"} { + # For indexed colour PNGs, map pixel values to RGB using the PLTE chunk palette + set pixelRow [list] + set pixelCount 0 + + #pre-calculate masks and steps based on depth + # depth 4: mask = 15 (0x0F), pixels per byte = 2 + # depth 2: mask = 3 (0x03), pixels per byte = 4 + # depth 1: mask = 1 (0x01), pixels per byte = 8 + set mask [expr {(1 << $depth) - 1}] + set pixelsPerByte [expr {8 / $depth}] + + for {set x 0} {$x < $bytesPerLine} {incr x} { + binary scan [string range $currentLine $x $x] c packedByte + set byteVal [expr {$packedByte & 0xFF}] + + #read left-to-right within the byte, extracting pixel values based on depth and mask + for {set p 0} {$p < $pixelsPerByte} {incr p} { + if {$pixelCount < $width} { + #set shift [expr {($pixelsPerByte - 1 - $p) * $depth}] + set shift [expr {8 - $depth - ($p * $depth)}] + set idx [expr {($byteVal >> $shift) & $mask}] + set rgb [lindex $palette $idx] + #append outputBuffer [format "\x1b\[48\;2\;%d\;%d\;%dm " [lindex $rgb 0] [lindex $rgb 1] [lindex $rgb 2]] + #lappend pixelRow $idx + lappend pixelRow [list [lindex $rgb 0] [lindex $rgb 1] [lindex $rgb 2]] + incr pixelCount + } + } + + } + } else { + #RGB + set pixelRow [list] + for {set x 0} {$x < $width} {incr x} { + set idx [expr {$x * $bpp}] + #pull either 3 bytes (RGB) or 4 bytes (RGBA) for the pixel, depending on bpp + if {$depth == 16} { + binary scan [string range $currentLine $idx [expr {$idx + 3}]] c4 rgba + set r [expr {[lindex $rgba 0] & 0xFF}] + set g [expr {[lindex $rgba 1] & 0xFF}] + set b [expr {[lindex $rgba 2] & 0xFF}] + set a [expr {[lindex $rgba 3] & 0xFF}] + + #terminal fallback background colour .eg dark terminal grey + set bgR 30 + set bgG 30 + set bgB 30 + set alpha [expr {$a / 255.0}] + + set r [expr {int(($r * $alpha) + ($bgR * (1 - $alpha)))}] + set g [expr {int(($g * $alpha) + ($bgG * (1 - $alpha)))}] + set b [expr {int(($b * $alpha) + ($bgB * (1 - $alpha)))}] + } else { + binary scan [string range $currentLine $idx [expr {$idx + 2}]] c3 rgb + set r [expr {[lindex $rgb 0] & 0xFF}] + set g [expr {[lindex $rgb 1] & 0xFF}] + set b [expr {[lindex $rgb 2] & 0xFF}] + #puts stderr "pixel $x,$y - RGB($r,$g,$b)" + } + + + # Use background-color escape sequence with two blank spaces to build a square pixel + #append outputBuffer "\x1b\[48\;2\;${r}\;${g}\;${b}m " + lappend pixelRow [list $r $g $b] + } + #append outputBuffer "\x1b\[m\n" ;# Reset row styling + } + lappend allRows $pixelRow + } + + set symbols 1 + # ------------------------------------------------------------- + # Unicode Quadrant Mosaic Definition Matrix + # ------------------------------------------------------------- + # Maps a 4-bit representation of a 2x2 grid to a structural character. + # Layout: Bit 3 = TopLeft, Bit 2 = TopRight, Bit 1 = BottomLeft, Bit 0 = BottomRight + variable MOSAIC_MAP + array set MOSAIC_MAP { + 0 " " 1 "▗" 2 "▖" 3 "▄" + 4 "▝" 5 "▐" 6 "▞" 7 "▟" + 8 "▘" 9 "▚" 10 "▌" 11 "▙" + 12 "▀" 13 "▜" 14 "▛" 15 "█" + } + + # ------------------------------------------------------------- + # Sub-Pixel Structural Rendering Engine + # ------------------------------------------------------------- + proc renderSymbols {allRows width height} { + variable MOSAIC_MAP + set outputBuffer "" + fconfigure stdout -encoding utf-8 + + # Process chunks of 2 vertical rows and 2 horizontal columns + for {set y 0} {$y < $height} {incr y 2} { + set rowTop [lindex $allRows $y] + + # Edge safety padding for odd vertical bounds + if {($y + 1) < $height} { + set rowBottom [lindex $allRows [expr {$y + 1}]] + } else { + set rowBottom $rowTop + } + + for {set x 0} {$x < $width} {incr x 2} { + # Extract 4 pixels of the 2x2 cluster + set p_tl [lindex $rowTop $x] + + if {($x + 1) < $width} { + set p_tr [lindex $rowTop [expr {$x + 1}]] + set p_bl [lindex $rowBottom $x] + set p_br [lindex $rowBottom [expr {$x + 1}]] + } else { + # Pad horizontally if image width is odd + set p_tr $p_tl; set p_bl $p_tl; set p_br $p_tl + } + + # Calculate individual pixel luminance values (Standard Rec. 601 weights) + set l_tl [expr {[lindex $p_tl 0]*0.299 + [lindex $p_tl 1]*0.587 + [lindex $p_tl 2]*0.114}] + set l_tr [expr {[lindex $p_tr 0]*0.299 + [lindex $p_tr 1]*0.587 + [lindex $p_tr 2]*0.114}] + set l_bl [expr {[lindex $p_bl 0]*0.299 + [lindex $p_bl 1]*0.587 + [lindex $p_bl 2]*0.114}] + set l_br [expr {[lindex $p_br 0]*0.299 + [lindex $p_br 1]*0.587 + [lindex $p_br 2]*0.114}] + + # Block Threshold: Local average brightness + set avg_lum [expr {($l_tl + $l_tr + $l_bl + $l_br) / 4.0}] + + # Build the 4-bit structure index mapping bitwise states + set bitmask 0 + if {$l_tl >= $avg_lum} { set bitmask [expr {$bitmask | 8}] } + if {$l_tr >= $avg_lum} { set bitmask [expr {$bitmask | 4}] } + if {$l_bl >= $avg_lum} { set bitmask [expr {$bitmask | 2}] } + if {$l_br >= $avg_lum} { set bitmask [expr {$bitmask | 1}] } + + # Segregate pixels into foreground (bright) and background (dark) sets + set fg_r 0; set fg_g 0; set fg_b 0; set fg_count 0 + set bg_r 0; set bg_g 0; set bg_b 0; set bg_count 0 + + foreach p [list $p_tl $p_tr $p_bl $p_br] lum [list $l_tl $l_tr $l_bl $l_br] { + if {$lum >= $avg_lum} { + incr fg_r [lindex $p 0]; incr fg_g [lindex $p 1]; incr fg_b [lindex $p 2] + incr fg_count + } else { + incr bg_r [lindex $p 0]; incr bg_g [lindex $p 1]; incr bg_b [lindex $p 2] + incr bg_count + } + } + + # Compute color averages for both states + if {$fg_count > 0} { + set fR [expr {$fg_r / $fg_count}]; set fG [expr {$fg_g / $fg_count}]; set fB [expr {$fg_b / $fg_count}] + } else { + set fR 0; set fG 0; set fB 0 + } + if {$bg_count > 0} { + set bR [expr {$bg_r / $bg_count}]; set bG [expr {$bg_g / $bg_count}]; set bB [expr {$bg_b / $bg_count}] + } else { + # If everything is uniform, match foreground color to prevent ghosting borders + set bR $fR; set bG $fG; set bB $fB + } + + # Pull symbol match out of the layout map + set symbol $MOSAIC_MAP($bitmask) + + # Generate the combined true color escape output string + append outputBuffer "\x1b\[48\;2\;${bR}\;${bG}\;${bB}m\x1b\[38\;2\;${fR}\;${fG}\;${fB}m${symbol}" + } + append outputBuffer "\x1b\[m\n" + } + return $outputBuffer + } + # ------------------------------------------------------------- + # High-Density 8x4 Block (Braille Mosaic) Rendering Engine + # ------------------------------------------------------------- + proc renderBrailleDensity {allRows width height} { + set outputBuffer "" + fconfigure stdout -encoding utf-8 + + # We skip 8 vertical rows and 4 horizontal pixels per cell cycle + # to achieve a 4x reduction factor (accounting for terminal aspect ratios) + for {set y 0} {$y < $height} {incr y 8} { + + # Buffer up to 8 rows for processing this line + set activeRows [list] + for {set r 0} {$r < 8} {incr r} { + if {($y + $r) < $height} { + lappend activeRows [lindex $allRows [expr {$y + $r}]] + } else { + lappend activeRows "" ;# Pad vertical overflow with empty lines + } + } + + for {set x 0} {$x < $width} {incr x 4} { + + # --- 1. Downsample the 8x4 cluster into a 4x2 grid for Braille --- + # Each cell in our 4x2 grid averages a 2x2 pixel area from the image + set subGridLums [list 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0] + set subGridRgbs [list] + set totalBlockLum 0.0 + + set cellIdx 0 + for {set subY 0} {$subY < 8} {incr subY 2} { + for {set subX 0} {$subX < 4} {incr subX 2} { + + # Accumulate colors for this specific 2x2 sub-pixel zone + set sR 0; set sG 0; set sB 0; set sCount 0 + for {set dy 0} {$dy < 2} {incr dy} { + set rowIdx [expr {$subY + $dy}] + set currRow [lindex $activeRows $rowIdx] + if {$currRow eq ""} { continue } + + for {set dx 0} {$dx < 2} {incr dx} { + set pixelX [expr {$x + $subX + $dx}] + if {$pixelX >= $width} { continue } + + set pixel [lindex $currRow $pixelX] + incr sR [lindex $pixel 0] + incr sG [lindex $pixel 1] + incr sB [lindex $pixel 2] + incr sCount + } + } + + # Store sub-zone averages + if {$sCount > 0} { + set sR [expr {$sR / $sCount}]; set sG [expr {$sG / $sCount}]; set sB [expr {$sB / $sCount}] + } else { + set sR 0; set sG 0; set sB 0 + } + + set sLum [expr {$sR*0.299 + $sG*0.587 + $sB*0.114}] + lset subGridLums $cellIdx $sLum + lappend subGridRgbs [list $sR $sG $sB] + set totalBlockLum [expr {$totalBlockLum + $sLum}] + incr cellIdx + } + } + + # --- 2. Calculate Thresholding & Grouping --- + set avgBlockLum [expr {$totalBlockLum / 8.0}] + + set fg_r 0; set fg_g 0; set fg_b 0; set fg_count 0 + set bg_r 0; set bg_g 0; set bg_b 0; set bg_count 0 + set brailleOffset 0 + + # Unicode Braille bitmask generation table for 4x2 cells + # Maps sequential list index (0-7) to Unicode Braille bit flags + set bitWeights [list 1 8 2 16 4 32 64 128] + + for {set i 0} {$i < 8} {incr i} { + set sLum [lindex $subGridLums $i] + set sRgb [lindex $subGridRgbs $i] + + if {$sLum >= $avgBlockLum} { + # This sub-zone is bright: Turn on the Braille dot + set brailleOffset [expr {$brailleOffset | [lindex $bitWeights $i]}] + incr fg_r [lindex $sRgb 0]; incr fg_g [lindex $sRgb 1]; incr fg_b [lindex $sRgb 2] + incr fg_count + } else { + # This sub-zone is dark + incr bg_r [lindex $sRgb 0]; incr bg_g [lindex $sRgb 1]; incr bg_b [lindex $sRgb 2] + incr bg_count + } + } + + # --- 3. Compute Final Colors --- + if {$fg_count > 0} { + set fR [expr {$fg_r / $fg_count}]; set fG [expr {$fg_g / $fg_count}]; set fB [expr {$fg_b / $fg_count}] + } else { + set fR 0; set fG 0; set fB 0 + } + if {$bg_count > 0} { + set bR [expr {$bg_r / $bg_count}]; set bG [expr {$bg_g / $bg_count}]; set bB [expr {$bg_b / $bg_count}] + } else { + set bR $fR; set bG $fG; set bB $fB + } + + # Construct the final Unicode character using the Braille base boundary block (\u2800) + set brailleChar [format %c [expr {0x2800 + $brailleOffset}]] + + # Append the ANSI sequence + append outputBuffer "\x1b\[48\;2\;${bR}\;${bG}\;${bB}m\x1b\[38\;2\;${fR}\;${fG}\;${fB}m${brailleChar}" + } + append outputBuffer "\x1b\[m\n" + } + return $outputBuffer + } + + if {$symbols} { + # return [renderSymbols $allRows $width $height] + return [renderBrailleDensity $allRows $width $height] + } + + set outputBuffer "" + for {set y 0} {$y < $height} {incr y 2} { + set topRow [lindex $allRows $y] + #if image has an odd height, use pure black {0 0 0} for the missing bottom row of the final half-block character row. + set hasBottom [expr {$y + 1 < $height}] + if {$hasBottom} { + set bottomRow [lindex $allRows [expr {$y + 1}]] + } + for {set x 0} {$x < $width } {incr x} { + #set topIdx [lindex $topRow $x] + set topRgb [lindex $topRow $x] + set tR [lindex $topRgb 0] + set tG [lindex $topRgb 1] + set tB [lindex $topRgb 2] + if {$hasBottom} { + #set bottomIdx [lindex $bottomRow $x] + set bottomRgb [lindex $bottomRow $x] + set bR [lindex $bottomRgb 0] + set bG [lindex $bottomRgb 1] + set bB [lindex $bottomRgb 2] + } else { + set bR 0 + set bG 0 + set bB 0 + } + foreach v {bR bG bB tR tG tB} { + if {[set $v] eq ""} { + set $v 0 + } + } + append outputBuffer [format "\x1b\[38\;2\;%d\;%d\;%dm\x1b\[48\;2\;%d\;%d\;%dm▄" $tR $tG $tB $bR $bG $bB] + } + append outputBuffer "\x1b\[m\n" ;# Reset row styling + } + + return $outputBuffer + } + + proc pngfileToAnsi {filename} { + set f [open $filename rb] + set pngdata [read $f] + close $f + return [pngdataToAnsi $pngdata] + } + +} tcl::namespace::eval punk::ansi::internal { proc splitn {str {len 1}} { #from textutil::split::splitn diff --git a/src/bootsupport/modules/punk/ansi/sauce-0.1.0.tm b/src/bootsupport/modules/punk/ansi/sauce-0.1.0.tm index e7428d84..0d3b53de 100644 --- a/src/bootsupport/modules/punk/ansi/sauce-0.1.0.tm +++ b/src/bootsupport/modules/punk/ansi/sauce-0.1.0.tm @@ -39,32 +39,35 @@ tcl::namespace::eval punk::ansi::sauce { proc from_file {fname} { if {[file size $fname] < 128} { - return + return [dict create posn -1] } set fd [open $fname r] chan conf $fd -translation binary chan seek $fd -128 end + set sauce_block_posn [expr {[chan tell $fd] -1}] ;#entire sauce block including ctrl-z and any comments - initial value assuming no comments + #If we treat the ctrl-z (\x1a) as part of the sauce - actual start of entire sauce info is 1 before sauce_header_posn, + #or further back if there are comments. set srec [read $fd] set srec_len 128 ;#This is the normal length of a SAUCE record - we may need to set it shorter if truncation detected if {[catch {set sdict [to_dict $srec]}]} { #review - have seen truncated SAUCE records < 128 bytes #we could search for SAUCE00 in the tail and see what records can be parsed? #specifically publicdomain roysac images sometimes only 99 Bytes of sauce - suspect remaining were null \x0 padded and trimmed - set sauceposn [string first SAUCE00 $srec] - if {$sauceposn <= 0} { + set saucestart [string first SAUCE00 $srec] + if {$saucestart <= 0} { close $fd - return + return [dict create posn -1] } #emit something to give user an indication something isn't right puts stderr "punk::ansi::sauce::from_file WARNING SAUCE record seems to be truncated - padding rhs with nulls and trying again.." #SAUCE00 is not at the beginning #pad the tail with nulls and try again - set srec [string range $srec $sauceposn end] + set srec [string range $srec $saucestart end] set srec_len [string length $srec] set srec ${srec}[string repeat \x0 [expr {128 - [string length $srec]}]] if {[catch {set sdict [to_dict $srec]}]} { close $fd - return + return [dict create posn -1] } dict set sdict warning "SAUCE truncation to $srec_len bytes detected" } @@ -73,6 +76,7 @@ tcl::namespace::eval punk::ansi::sauce { #Use srec_len instead of 128 - in case we had truncated source record which we padded and were able to parse set offset [expr {-1 *($srec_len + ($clines * 64) + 5)}] chan seek $fd $offset end + set sauce_block_posn [expr {[chan tell $fd] -1}] ;#entire sauce block including ctrl-z and any comments set tag [chan read $fd 5] if {$tag eq "COMNT"} { #'character' data - shouldn't be null terminated c-style string - but can be @@ -95,6 +99,7 @@ tcl::namespace::eval punk::ansi::sauce { dict set sdict commentlines $commentlines } } + dict set sdict posn $sauce_block_posn close $fd return $sdict } @@ -213,7 +218,9 @@ tcl::namespace::eval punk::ansi::sauce { - + #--------------------------------------------------------------------------------------------------------------------------------------------- + # This data comes from the sauce spec. + #--------------------------------------------------------------------------------------------------------------------------------------------- #todo - fontName - which can also specify e.g code page 437 ## Font name [1] Font size Resolution [2] Aspect ratio [3] Vertical stretch [6] Description ## Display [4] Pixel [5] @@ -221,7 +228,14 @@ tcl::namespace::eval punk::ansi::sauce { set fontnames [dict create] ## IBM VGA 9×16 [7] 720×400 4:3 20:27 (1:1.35) 35% Standard hardware font on VGA cards for 80×25 text mode (code page 437) - dict set fontnames "IBM VGA" [list fontsize "9x16" resolution "720x400" aspect_ratio_display "4:3" aspect_ratio_pixel "20:27 (1:1.35)" vertical_stretch "35%" description "Standard hardware font on VGA cards for 80×25 text mode (code page 437)"] + dict set fontnames "IBM VGA" [list {*}{ + fontsize "9x16" + resolution "720x400" + aspect_ratio_display "4:3" + aspect_ratio_pixel "20:27 (1:1.35)" + vertical_stretch "35%" + description "Standard hardware font on VGA cards for 80×25 text mode (code page 437)" + }] ## IBM VGA ### [8] 9×16 [7] 720×400 4:3 20:27 (1:1.35) 35% Software installed code page font for VGA 80×25 text mode # - where ### is placeholder for 437,720,737 etc @@ -247,6 +261,7 @@ tcl::namespace::eval punk::ansi::sauce { ## C64 PETSCII unshifted 8×8 [10] 320×200 4:3 5:6 (1:1.2) 20% Original Commodore PETSCII font (PET, VIC-20, C64, CBM-II, Plus/4, C16, C116 and C128) in the unshifted mode. Unshifted mode (graphics) only has uppercase letters and additional graphic characters. This is the normal boot font. ## C64 PETSCII shifted 8×8 [10] 320×200 4:3 5:6 (1:1.2) 20% Original PETSCII font in shifted mode. Shifted mode (text) has both uppercase and lowercase letters. This mode is actuated by pressing Shift+Commodore key. ## Atari ATASCII 8×8 [11] 320×192 4:3 4:5 (1:1.25) 25% Original ATASCII font (Atari 400, 800, XL, XE) + #--------------------------------------------------------------------------------------------------------------------------------------------- #expect a 128 Byte sauce record @@ -256,6 +271,7 @@ tcl::namespace::eval punk::ansi::sauce { variable datatypes variable filetypes variable encodings + set warnings [list] if {[string length $saucerecord] != 128} { error "punk::ansi::sauce::to_dict: Unable to interpret data as a SAUCE record - length != 128" } @@ -321,6 +337,8 @@ tcl::namespace::eval punk::ansi::sauce { dict set sdict filetype_name "" } } else { + #how can a byte fail to scan with cu? is this even reachable? + puts stderr "punk::ansi::sauce::to_dict filetype byte failed to scan - setting filetype and filetype_name to empty string byte: [ansistring VIEW -lf 1 [string range $saucerecord 95 95]]" dict set sdict filetype "" dict set sdict filetype_name "" } @@ -417,25 +435,40 @@ tcl::namespace::eval punk::ansi::sauce { 5 { #binarytext #filetype is supposed to represent half the characterwidth (only widths with multiples of 2 can be specified) - #HOWEVER - in the wild we may see width/height specified in tinfo1/tinfo2 with some other value in filetype (eg 1) - #If both tinfo1 and tinfo2 are non zero - we will use them, even though it's not in spec. - set t1 [dict get $sdict tinfo1] - if {$t1 eq ""} { - set t1 0 - } - set t2 [dict get $sdict tinfo2] - if {$t2 eq ""} { - set t2 0 + #HOWEVER - in the wild we may see width/height specified in tinfo1/tinfo2 with some apparently unrelated value in filetype (eg 0 or 1) that doesn't match the intended image dimensions. + #If both tinfo1 and tinfo2 are non zero - we *could* use them, even though it's not in spec. + #An example file (us-used1.bin) has filetype 0 and tinfo1/tinfo2 640/350 + #It's possible tinfo1/tinfo2 represent pixel dimensions for a 'standard' 8x16 font, but this image is 160 columns wide, so we would expect tinfo1 to be 1280. + #The sauce spec seems to indicate we should ignore tinfo1/tinfo2 for binarytext and only use filetype to determine width. + #the default for binarytext is 160 columns. + + #filetype 1 is theoretically possible, representing 2 columns + #in practice we see this value for binarytext images that are definitely not intended to be 2 columns wide. Why? + #is there some assumption that that images are at least a certain width, and filetype has been repurposed to indicate something else? + #The spec would seem to rule out images of a single column due to filetype being half the character width but a value of 0.5 isn't supported. + #It specifically mentions that only even widths up to 510 can be specified. ($filetype * 2 where filetype is 1-255?) + + + #proper mechanism to specify columns for binarytext is the datatype field. + set cols [expr {2*[dict get $sdict filetype]}] + if {$cols == 0} { + lappend warnings "binarytext filetype value of [dict get $sdict filetype] - using binarytext default cols of 160" + #default for binarytext is 160 columns + set cols 160 } - if {$t1 != 0 && $t2 != 0} { + if {$cols == 2 && [dict get $sdict tinfo1] != 0 && [dict get $sdict tinfo2] != 0} { #not to spec - but we will assume these have values for a reason.. - puts stderr "punk::ansi::sauce::to_dict using tinfo1/tinfo2 data for columns/rows (non-compliant SAUCE data)" - dict set sdict columns [expr {2 * $t1}] - dict set sdict rows $t2 + #--------------------------------------------------------------------------------------------------------------------- + #The sample file src/testansi/formatsamples/image/binaryText/test.bin has a filetype 1 and tinfo1 40 and tinfo2 25. + #(similarly ppe-ansi.bin has tinfo1 80 and tinfo2 26) + #They seem to use the 1 in filetype to indicate that the tinfo1/tinfo2 values should be used. + #(The 80 cols wide test.bin binaryText image matches the xbin sample file src/testansi/formatsamples/image/xbin/test.xb which is a more fully specified format using a header) + #--------------------------------------------------------------------------------------------------------------------- + lappend warnings "binarytext filetype of 1 with non-zero tinfo1/tinfo2 - using tinfo1/tinfo2 data for columns/rows (possibly non-conforming SAUCE data - matching observed data in the wild)" + set cols [expr {2 * [dict get $sdict tinfo1]}] + dict set sdict columns $cols + dict set sdict rows [dict get $sdict tinfo2] } else { - #proper mechanism to specify columns for binarytext is the datatype field. - - set cols [expr {2*[dict get $sdict filetype]}] dict set sdict columns $cols #rows must be calculated from file size #rows = (filesize - sauceinfosize)/ filetype * 2 * 2 @@ -447,11 +480,13 @@ tcl::namespace::eval punk::ansi::sauce { } 6 { - #xbin - only filtype is 0 + #xbin - only filetype is 0 #https://web.archive.org/web/20120204063040/http://www.acid.org/info/xbin/x_spec.htm dict set sdict columns [dict get $sdict tinfo1] dict set sdict rows [dict get $sdict tinfo2] dict set sdict fontname [dict get $sdict tinfos] + #Values from sauce record are probably only informational, because xbin has an 11-byte header with width,height,fontsize and flags. + #presumably the header-info should take precedence over all sauce data (? review) } } if {[dict exists $sdict fontname]} { @@ -474,6 +509,9 @@ tcl::namespace::eval punk::ansi::sauce { } } } + if {[llength $warnings]} { + dict set sdict warnings $warnings + } return $sdict } diff --git a/src/bootsupport/modules/punk/args-0.2.1.tm b/src/bootsupport/modules/punk/args-0.2.1.tm index 1ff7fd37..24c2ddf7 100644 --- a/src/bootsupport/modules/punk/args-0.2.1.tm +++ b/src/bootsupport/modules/punk/args-0.2.1.tm @@ -9086,7 +9086,7 @@ tcl::namespace::eval punk::args { } if {!([tcl::string::first " " $a]>=0 || [tcl::string::first \t $a]>=0 || [tcl::string::last \n $a]>=0)} { if {$OPT_ANY} { - #exlude argument with whitespace from being a possible option e.g dict + #exclude argument with whitespace from being a possible option e.g dict #todo - passthrough of unrecognised --longopt=xxx without looking for following flag-value set eposn [string first = $a] if {$eposn > 2 && [string match --* $a]} { diff --git a/src/bootsupport/modules/punk/char-0.1.0.tm b/src/bootsupport/modules/punk/char-0.1.0.tm index 53ef8ec1..349cc3b7 100644 --- a/src/bootsupport/modules/punk/char-0.1.0.tm +++ b/src/bootsupport/modules/punk/char-0.1.0.tm @@ -3033,14 +3033,18 @@ tcl::namespace::eval punk::char { #This still leaves a whole class of clusters.. korean etc unhandled :/ #todo - tk::startOfCluster / tk::endOfCluster - try to get it brought into Tcl #https://core.tcl-lang.org/tcl/tktview/a4c7eeaf63 - proc grapheme_split {text} { + proc grapheme_split {text {return list}} { #we should treat \r\n as a single grapheme cluster (as tk::endOfCluster does) set components [list] set csplits [combiner_split $text] foreach {pt combiners} [lrange $csplits 0 end-1] { set clist [split $pt ""] - lappend components {*}[lrange $clist 0 end-1] - lappend components [tcl::string::cat [lindex $clist end] $combiners] + #review + #lset clist end [tcl::string::cat [lindex $clist end] $combiners] + ledit clist end end [tcl::string::cat [lindex $clist end] $combiners] + lappend components {*}$clist + #lappend components {*}[lrange $clist 0 end-1] + #lappend components [tcl::string::cat [lindex $clist end] $combiners] } #last csplit never has a combiner (_perlish_split style) - and may be empty - in which case we don't append it as a grapheme if {[lindex $csplits end] ne ""} { @@ -3066,127 +3070,126 @@ tcl::namespace::eval punk::char { #review \uFE0F variation selector 16 - forces emoji presentation for preceding char - if 1 { - #This is a basic implementation that does not check that all combinations are valid. - set graphemes [list] - set current_cluster "" - - set cluster_base 0 ;#is the current cluster based on a char that can be combined with modifiers/ZWJs (e.g emoji or other cluster-based char) - # or is it based on a char that can't be combined with modifiers/ZWJs (e.g ascii letter) - set cluster_base_RI 0 ;#is the current cluster based on a regional indicator char - which can only combine in pairs, and don't combine with modifiers or ZWJs to form longer clusters - so not extensible. - - set current_cluster_is_extensible 0 - for {set i 0} {$i < [llength $components] } {incr i} { - set component [lindex $components $i] - if {$component eq "\r" && [lindex $components $i+1] eq "\n"} { - if {$current_cluster ne ""} { - lappend graphemes $current_cluster - } - lappend graphemes "\r\n" - incr i ;#skip the \n as we've already processed it as part of the cluster - set current_cluster "" - grapheme_split::reset_base + #This is a basic implementation that does not check that all combinations are valid. + set graphemes [list] + set current_cluster "" + + set cluster_base 0 ;#is the current cluster based on a char that can be combined with modifiers/ZWJs (e.g emoji or other cluster-based char) + # or is it based on a char that can't be combined with modifiers/ZWJs (e.g ascii letter) + set cluster_base_RI 0 ;#is the current cluster based on a regional indicator char - which can only combine in pairs, and don't combine with modifiers or ZWJs to form longer clusters - so not extensible. + + set current_cluster_is_extensible 0 + for {set i 0} {$i < [llength $components] } {incr i} { + set component [lindex $components $i] + if {$component eq "\r" && [lindex $components $i+1] eq "\n"} { + if {$current_cluster ne ""} { + lappend graphemes $current_cluster + } + lappend graphemes "\r\n" + incr i ;#skip the \n as we've already processed it as part of the cluster + set current_cluster "" + set cluster_base 0; set cluster_base_RI 0 ;#grapheme_split::reset_base + set current_cluster_is_extensible 0 + } elseif {$component eq "\u200d"} { + if {$current_cluster eq ""} { + #ZWJ at start of string - treat as separate grapheme cluster - but isn't a valid base for further combining with more ZWJs or modifiers + set current_cluster $component + set cluster_base 0; set cluster_base_RI 0 ;#grapheme_split::reset_base set current_cluster_is_extensible 0 - } elseif {$component eq "\u200d"} { - if {$current_cluster eq ""} { - #ZWJ at start of string - treat as separate grapheme cluster - but isn't a valid base for further combining with more ZWJs or modifiers - set current_cluster $component - grapheme_split::reset_base - set current_cluster_is_extensible 0 - } else { - if {$cluster_base} { - if {$current_cluster_is_extensible} { - #a double (or longer) ZWJ sequence in a row is part of the last cluster - but not extensible anymore. - append current_cluster $component - set current_is_cluster_extensible 0 - } else { - append current_cluster $component - if {$cluster_base_RI} { - #regional indicators can only combine in pairs, and don't combine with modifiers or ZWJs to form longer clusters - so not extensible. - grapheme_split::reset_base - set current_cluster_is_extensible 0 - #we can keep adding ZWJs or modifiers though - } else { - set current_cluster_is_extensible 1 - } - } + } else { + if {$cluster_base} { + if {$current_cluster_is_extensible} { + #a double (or longer) ZWJ sequence in a row is part of the last cluster - but not extensible anymore. + append current_cluster $component + set current_is_cluster_extensible 0 } else { - #ZWJ after non-cluster-based char - non extensible but we continue appending ZWJs to the current cluster. append current_cluster $component - set current_cluster_is_extensible 0 - } - - } - } elseif {[regexp {[\U1f3fb-\U1f3ff]} $component]} { - #emoji modifier - join with previous component - if {$current_cluster eq ""} { - #modifier at start of string - not a valid base for further combining with more modifiers or ZWJs - but we continue appending modifiers to the current cluster. - set current_cluster $component - grapheme_split::reset_base - } else { - if {$cluster_base} { - if {$current_cluster_is_extensible} { - append current_cluster $component - #invalidate the base! - grapheme_split::reset_base + if {$cluster_base_RI} { + #regional indicators can only combine in pairs, and don't combine with modifiers or ZWJs to form longer clusters - so not extensible. + set cluster_base 0; set cluster_base_RI 0 ;#grapheme_split::reset_base + set current_cluster_is_extensible 0 + #we can keep adding ZWJs or modifiers though } else { - append current_cluster $component + set current_cluster_is_extensible 1 } + } + } else { + #ZWJ after non-cluster-based char - non extensible but we continue appending ZWJs to the current cluster. + append current_cluster $component + set current_cluster_is_extensible 0 + } + + } + } elseif {[regexp {[\U1f3fb-\U1f3ff]} $component]} { + #emoji modifier - join with previous component + if {$current_cluster eq ""} { + #modifier at start of string - not a valid base for further combining with more modifiers or ZWJs - but we continue appending modifiers to the current cluster. + set current_cluster $component + set cluster_base 0; set cluster_base_RI 0 ;#grapheme_split::reset_base + } else { + if {$cluster_base} { + if {$current_cluster_is_extensible} { + append current_cluster $component + #invalidate the base! + set cluster_base 0; set cluster_base_RI 0 ;#grapheme_split::reset_base } else { - #modifier after non-cluster-based char - non extensible but we continue appending modifiers to the current cluster. append current_cluster $component } - #review - # \u1f33e\u1f3fe\u200d\u2f3fe\u200d\u1f33e is 2 clusters - #This is because after first zwj, we applied a modifier - not a valid base. + } else { + #modifier after non-cluster-based char - non extensible but we continue appending modifiers to the current cluster. + append current_cluster $component } - set current_cluster_is_extensible 0 + #review + # \u1f33e\u1f3fe\u200d\u2f3fe\u200d\u1f33e is 2 clusters + #This is because after first zwj, we applied a modifier - not a valid base. + } + set current_cluster_is_extensible 0 + } else { + if {$current_cluster eq ""} { + grapheme_split::start_cluster $component } else { - if {$current_cluster eq ""} { - grapheme_split::start_cluster $component - } else { - #have existing cluster data - if {$current_cluster_is_extensible} { - #assert - if current_cluster_is_extensible then cluster_base should currently be true. - #if the current char is a base - we can append to existing cluster, but if it's not a base, then we start a new cluster even if we had seen a ZWJ before. - if {[regexp {[\U1f600-\U1f64f\U1f300-\U1f5ff\U1f900-\U1f9ff\U1fa70-\U1faff\U1f680-\U1f6ff\U2700-\U27bf\U2600-\u26ff]} $component]} { - append current_cluster $component - set cluster_base 1 - } else { - lappend graphemes $current_cluster - set current_cluster $component - grapheme_split::reset_base - } - set current_cluster_is_extensible 0 - } elseif {$cluster_base_RI} { - #regional indicators can only combine in pairs, and don't combine with modifiers or ZWJs to form longer clusters - so not extensible. - if {[regexp {[\U1f1e6-\U1f1ff]} $component]} { - append current_cluster $component - - #invalidate the base - we can't combine more than 2 RIs in a cluster, and they don't combine with modifiers or ZWJs to form longer clusters. - #we can however add more ZWJs or modifiers to the cluster - but they don't make it extensible for combining with more RIs - grapheme_split::reset_base - } else { - #something else while RI cluster is open - end the current cluster and start a new one with the current char. - lappend graphemes $current_cluster - grapheme_split::start_cluster $component - } - set current_cluster_is_extensible 0 + #have existing cluster data + if {$current_cluster_is_extensible} { + #assert - if current_cluster_is_extensible then cluster_base should currently be true. + #if the current char is a base - we can append to existing cluster, but if it's not a base, then we start a new cluster even if we had seen a ZWJ before. + if {[regexp {[\U1f600-\U1f64f\U1f300-\U1f5ff\U1f900-\U1f9ff\U1fa70-\U1faff\U1f680-\U1f6ff\U2700-\U27bf\U2600-\u26ff]} $component]} { + append current_cluster $component + set cluster_base 1 + } else { + lappend graphemes $current_cluster + set current_cluster $component + set cluster_base 0; set cluster_base_RI 0 ;#grapheme_split::reset_base + } + set current_cluster_is_extensible 0 + } elseif {$cluster_base_RI} { + #regional indicators can only combine in pairs, and don't combine with modifiers or ZWJs to form longer clusters - so not extensible. + if {[regexp {[\U1f1e6-\U1f1ff]} $component]} { + append current_cluster $component + + #invalidate the base - we can't combine more than 2 RIs in a cluster, and they don't combine with modifiers or ZWJs to form longer clusters. + #we can however add more ZWJs or modifiers to the cluster - but they don't make it extensible for combining with more RIs + set cluster_base 0; set cluster_base_RI 0 ;#grapheme_split::reset_base } else { + #something else while RI cluster is open - end the current cluster and start a new one with the current char. lappend graphemes $current_cluster grapheme_split::start_cluster $component } + set current_cluster_is_extensible 0 + } else { + lappend graphemes $current_cluster + grapheme_split::start_cluster $component } } } - if {$current_cluster ne ""} { - lappend graphemes $current_cluster - } + } + if {$current_cluster ne ""} { + lappend graphemes $current_cluster + } + if {$return eq "list"} { + return $graphemes } else { - set graphemes $components + return [dict create list $graphemes last_extensible $current_cluster_is_extensible base $cluster_base RI_base $cluster_base_RI] } - - return $graphemes } namespace eval grapheme_split { proc about {} { diff --git a/src/bootsupport/modules/punk/console-0.1.1.tm b/src/bootsupport/modules/punk/console-0.1.1.tm index b7c4cd7a..913e09ac 100644 --- a/src/bootsupport/modules/punk/console-0.1.1.tm +++ b/src/bootsupport/modules/punk/console-0.1.1.tm @@ -71,11 +71,6 @@ package require punk::args -#if {"windows" eq $::tcl_platform(platform)} { -# #package require zzzload -# #zzzload::pkg_require twapi -#} - #see https://learn.microsoft.com/en-us/windows/console/classic-vs-vt #https://learn.microsoft.com/en-us/windows/console/creating-a-pseudoconsole-session diff --git a/src/bootsupport/modules/punk/du-0.1.0.tm b/src/bootsupport/modules/punk/du-0.1.0.tm index 8dd91089..ca7f58e9 100644 --- a/src/bootsupport/modules/punk/du-0.1.0.tm +++ b/src/bootsupport/modules/punk/du-0.1.0.tm @@ -2529,21 +2529,30 @@ namespace eval punk::du { #jmn disable twapi #tailcall du_dirlisting_generic $folderpath {*}$args - package require zzzload - set loadstate [zzzload::pkg_require twapi] - - if {$loadstate ni [list loading failed]} { - #either already loaded by zzload or ordinary package require - package require twapi ;#should be fast once twapi dll loaded in zzzload thread + #package require zzzload + #set loadstate [zzzload::pkg_require twapi] + + #if {$loadstate ni [list loading failed]} { + # #either already loaded by zzload or ordinary package require + # package require twapi ;#should be fast once twapi dll loaded in zzzload thread + # set ::punk::du::has_twapi 1 + # punk::du::active::set_active_function du_dirlisting du_dirlisting_twapi + # tailcall du_dirlisting_twapi $folderpath {*}$args + #} else { + # if {$loadstate eq "failed"} { + # puts stderr "punk::du defaulting to du_dirlisting_generic because twapi load failed" + # punk::du::active::set_active_function du_dirlisting du_dirlisting_generic + # } + # tailcall du_dirlisting_generic $folderpath {*}$args + #} + if {[catch {package require twapi} errM]} { + puts stderr "punk::du defaulting to du_dirlisting_generic because twapi load failed: $errM" + punk::du::active::set_active_function du_dirlisting du_dirlisting_generic + tailcall du_dirlisting_generic $folderpath {*}$args + } else { set ::punk::du::has_twapi 1 punk::du::active::set_active_function du_dirlisting du_dirlisting_twapi tailcall du_dirlisting_twapi $folderpath {*}$args - } else { - if {$loadstate eq "failed"} { - puts stderr "punk::du defaulting to du_dirlisting_generic because twapi load failed" - punk::du::active::set_active_function du_dirlisting du_dirlisting_generic - } - tailcall du_dirlisting_generic $folderpath {*}$args } } default { diff --git a/src/bootsupport/modules/punk/lib-0.1.6.tm b/src/bootsupport/modules/punk/lib-0.1.6.tm index ada0f900..5fecb48d 100644 --- a/src/bootsupport/modules/punk/lib-0.1.6.tm +++ b/src/bootsupport/modules/punk/lib-0.1.6.tm @@ -138,36 +138,29 @@ tcl::namespace::eval punk::lib::check { if {"windows" ne $::tcl_platform(platform)} { set bug 0 } else { - if {![catch {file tempdir} tmpdir]} { - #tcl 9+ has 'file tempdir' - set testfile [file join $tmpdir "bugtest"] - } else { - #fallback for older tcl versions - use env TEMP/TMP or current directory - set tmpdir "" - foreach e {TEMP TMP} { - if {[info exists ::env($e)] && [file isdirectory ::env($e)]} { - set tmpdir ::env($e) + set tmpdir [punk::lib::tempdir_newfolder] ;#uses 'file tempdir' on tcl9+ or fallback to env vars or current directory on older versions + set testfile [file join $tmpdir "bugtest"] + + try { + set fd [open $testfile w] + puts $fd test + close $fd + set globresult [glob -nocomplain -directory $tmpdir -types f -tail BUGTEST {BUGTES{T}} {[B]UGTEST} {\BUGTEST} BUGTES? BUGTEST*] + if {[file exists $testfile]} { + file delete $testfile + } + foreach r $globresult { + if {$r ne "bugtest"} { + set bug 1 break } } - if {$tmpdir eq ""} { - #no env vars - fallback to current directory - set tmpdir [pwd] + } finally { + if {[file exists $testfile]} { + file delete $testfile } - set testfile [file join $tmpdir "bugtest"] - } - - set fd [open $testfile w] - puts $fd test - close $fd - set globresult [glob -nocomplain -directory $tmpdir -types f -tail BUGTEST {BUGTES{T}} {[B]UGTEST} {\BUGTEST} BUGTES? BUGTEST*] - if {[file exists $testfile]} { - file delete $testfile - } - foreach r $globresult { - if {$r ne "bugtest"} { - set bug 1 - break + if {[file exists $tmpdir]} { + file delete -force $tmpdir } } } @@ -679,7 +672,207 @@ namespace eval punk::lib { } } + namespace eval argdoc { + variable PUNKARGS + lappend PUNKARGS [list { + @id -id ::punk::lib::tempdir + @cmd -name punk::lib::tempdir\ + -summary\ + "Determine an appropriate temp dir for the process we are running under."\ + -help\ + "On windows: + If the process is running under the system account use the modern windows location: %SystemRoot%\SystemTemp + Detection of the system account relies on either twapi, or a combination of the whoami command and the + registry package. + Proceeds with same fallback logic as for other platforms if we fail to detect the system account or its temp location. + + + For other platforms we use the environment variables TMPDIR/TEMP/TMP or fallback to /tmp or /var/tmp if those + env vars aren't set or aren't writable directories. + + Final fallback attempt is the current working directory. + Result is normalized so resulting path will have forward slashes on all platforms. + + Alternatives: see the tcllib fileutil::tempdir function. + " + @values -min 0 -max 0 + }] + } + proc tempdir {} { + set trydirs [list] + if {"windows" eq $::tcl_platform(platform)} { + #review. + #consider also checking for whether running under various service accounts + + if {![catch {package require twapi}]} { + set tok [twapi::open_process_token] ;#first call is a little pricy. + set sid [twapi::get_token_user $tok] + if {$sid eq "S-1-5-18"} { + #system account - use system account temp location + set sysroot [twapi::get_shell_folder csidl_windows] ;#first call is a little pricy. + lappend trydirs [file join $sysroot "SystemTemp"] + } + #if not system account - use env vars as first choice. + } else { + #twapi not available - try to use builtin windows whoami to detect if we're running under system account - but this is less reliable than using twapi to check the process token - so we warn about it. + set whoami_exe [auto_execok whoami] + #test that system32 is somewhere in the whoami path as a basic attempt to avoid non-windows whoami commands that might be present in the path + set whoami_exe_parts [file split $whoami_exe] + if {"system32" in [string tolower $whoami_exe_parts]} { + set whoamiresult [string trim [exec {*}$whoami_exe /USER /FO LIST] \n\r] + set whoamiresult [string map {\r\n \n} $whoamiresult] + set whoamiresult_lines [split $whoamiresult \n] + set sid "" + foreach line $whoamiresult_lines { + if {[string match "SID:*" $line]} { + set sid [lindex $line 1] + break + } + } + set has_registry [expr {![catch {package require registry}]}] + if {$sid eq "S-1-5-18"} { + #system account - use system account temp location + set sysroot "" + if {$has_registry} { + #registry path is case-insensitive. + catch { + set sysroot [registry get {HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows NT\CurrentVersion} SystemRoot] + } + } else { + if {[info exists ::env(SystemRoot)]} { + set sysroot [set ::env(SystemRoot)] + } + } + if {$sysroot ne ""} { + lappend trydirs [file join $sysroot "SystemTemp"] + } + } + #if not system account - use env vars as first choice. + } + } + } + + foreach t {TMPDIR TEMP TMP} { + #TMPDIR is the posix standard as first choice for temp dir env var. + if {[info exists ::env($t)]} { + lappend trydirs $::env($t) + } + } + + if {"windows" ne $::tcl_platform(platform)} { + #suitable for macos,linux and freebsd at least. + lappend trydirs [file join / tmp] [file join / var tmp] + #/usr/tmp is probably not a common location for a temp dir on modern unix-based systems. + } + + foreach d $trydirs { + if {[file isdirectory $d] && [file writable $d]} { + return [file normalize $d] + } + } + + #only even call 'pwd' as a last resort (mildly slow on first call). + set cwd [pwd] + if {[file isdirectory $cwd] && [file writable $cwd]} { + return $cwd + } + + return -code error "punk::lib::tempdir unable to determine a suitable temp directory - tried: $trydirs" + } + + namespace eval argdoc { + variable PUNKARGS + lappend PUNKARGS [list { + @id -id ::punk::lib::tempdir_newfolder + @cmd -name punk::lib::tempdir_newfolder\ + -summary\ + "Create unique folder within temp dir (or cwd as last resort)"\ + -help\ + "Creates a new unique folder within the temp dir determined by punk::lib::tempdir. + The folder is created before returning its full path and will be empty. + The folder is named with a tcl_ prefix followed by a random string. + + See also: 'file tempdir' in tcl 9+ or fileutil::maketempdir from tcllib" + @opts + -dir -type string -default "" -help\ + "Base directory to create the temp folder in - defaults to the result of punk::lib::tempdir" + -prefix -type string -default tcl -help\ + "Prefix for the temp folder name + An underscore is automatically appended to the prefix in the generated folder name. + If prefix is the empty string - then the generated folder name will still be autoprefixed + with tcl_ (consistent with tcl9 'file tempdir')" + @values -min 0 -max 0 + }] + } + proc tempdir_newfolder {args} { + set argd [punk::args::parse $args withid ::punk::lib::tempdir_newfolder] + set opt_dir [dict get $argd opts -dir] + set opt_prefix [dict get $argd opts -prefix] + puts "opt_prefix: $opt_prefix" + if {[llength [file split $opt_prefix]] > 1} { + error "punk::lib::tempdir_newfolder -prefix option should not contain any path separators" + } + if {$opt_prefix eq ""} { + #don't allow empty prefix - for consistency with tcl9 'file tempdir' - which would still prefix with 'tcl_' even if prefix is empty string. + set opt_prefix "tcl" + } + + if {$opt_dir ne ""} { + if {[file isdirectory $opt_dir] && [file writable $opt_dir]} { + set tmpbase [file normalize $opt_dir] + } else { + error "punk::lib::tempdir_newfolder -dir option '$opt_dir' is not a writable directory" + } + } else { + set tmpbase [punk::lib::tempdir] ;#will raise an error if no writable temp dir or cwd found. + } + #assert: tmpbase has no trailing slash - unless it is a root dir (e.g / on unix, or C:/ on windows) + #assert: tmpbase is normalized with forward slashes on all platforms. + + set tcl9_template_base [string trimright $tmpbase "/"] ;#set it to a form that can join along with a forward slash to prefix for tcl 9 'file tempdir' style template. + #tcl9 'file tempdir' separates the prefix in the template from the random string with an underscore. + #now form template by always joining with a slash (even if opt_prefix is empty) + #(avoiding file join and file normalize to ensure template is properly formed) + #whether or not opt_prefix ends with an underscore - another will be added. (by file tempdir, or by our own code if tcl9 'file tempdir' isn't available) + #assert: opt_prefix is not empty string (will have defaulted to 'tcl') and does not contain any path separators. + set tcl9_template "$tcl9_template_base/$opt_prefix" + + + #tcl 9+ has 'file tempdir' + #we don't support the same template as 'file tempdir' + if {[catch {file tempdir $tcl9_template} tmpdir]} { + + set prefix tcl_ ;#todo - accept option: -prefix + + set chars abcddefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789 + set nrand_chars 8 + set maxtries 100 + for {set i 0} {$i < $maxtries} {incr i} { + set dirname ${opt_prefix}_ ;#always add underscore for consistency with tcl9 'file tempdir'. + for {set j 0} {$j < $nrand_chars} {incr j} { + append dirname [string index $chars [expr {int(rand()*62)}]] + } + set path [file join $tmpbase $dirname] + if {[file exists $path]} { + continue + } + if {[catch { + file mkdir $path + if {"windows" ne $::tcl_platform(platform)} { + file attributes $path -permissions 0o700 + } + }]} { + continue + } + return $path + } + return -code error "punk::lib::tempdir_newfolder unable to create unique tempdir in $tmpbase after $maxtries attempts - too many collisions - aborting" + } + #tcl 9 'file tempdir' return. + #normalize because on early tcl 9 versions on windows it can return with mixed forward and backward slashes when a template is supplied with forward slashes. + return [file normalize $tmpdir] + } # == == == == == == == == == == == == == == == == == == == == == == == == == == == == == == == # Maintenance - This is the primary source for tm_version... functions @@ -814,6 +1007,89 @@ namespace eval punk::lib { error "tm_version_required_canonical should have already returned a canonicalised versionspec - or produced an error with reason before this point" } } + proc tm_version_magic {} { + #maintenance instruction: + # This specific 12 character nnnnnn.0a1.0 version number is used in text replacement when installing modules. + # It should not be modified without also considering the impact on existing projects based on punkshell that may have used this version number in their own code or documentation as a placeholder for tm version handling. + # A copy of this is also present in punk::lib. + # Essentially this should probably never be changed - and instead deprecated if we want to stop using it and replaced with a different mechanism/placeholder. + + #tm versioning is not quite the same as semantic versioning - but similarly we should see extremely high major version numbers rarely if ever in real use, + #even over decades of development. + set magicbase 999999 ;#deliberately large so given load-preference when testing! + #we split the literal to avoid the literal appearing here - reduce risk of accidentally converting to a release version + return ${magicbase}.0a1.0 + } + + namespace eval argdoc { + lappend PUNKARGS [list { + @id -id ::punk::lib::tm_split_name + @cmd -name punk::lib::tm_split_name\ + -summary\ + "Split a versioned module name into name and version parts, dropping trailing .tcl/.tm if any."\ + -help\ + "Splits a versioned module name (as present in a filename or namespaced name) into name and version parts, + Ignores any trailing .tm or .tcl file extension. + + If the fullmodulename given is a namespaced name - then the returned modulename will also be namespaced, + but with any leading :: removed. + + Returns a two element list - with the first element being the modulename and the second element being the version. + + Tcl module version numbers are understood with leading zeros in each dotted part, but leading zeros are not canonical. + + This split does not canonicalise the version number. + If the last dash-separated segment of the name doesn't look like a valid version number + - then it is treated as part of the modulename and an empty version string is returned. + e.g + mymod-1.2.3.tm -> mymod 1.2.3 + mymod-1aa2.3.tm -> mymod-1aa2.3 {} + (repeated a is not a valid version segment - so the entire '1aa2.3' is treated as part of the modulename) + + see also: tm_version_canonical + " + @values -min 1 -max 1 + fullmodulename -type string -help\ + "The full module name to split - as present in a filename or namespaced name. E.g: + mymod-1.2.3 + mymod-1.2.3.tm + mymod-1.2.3.tcl + /some/where/mymod-123.0a4.0.tm + mymod + mymod.tm + mymod.tcl + ns1::ns2::mymod-1.2.3 + ::ns1::ns2::mymod" + }] + } + proc tm_split_name {fullmodulename} { + #split modulename (as present in a filename or namespaced name) into name/version ignoring leading namespace path + #ignore trailing .tm .TM if present + #if version doesn't pass validation - treat it as part of the modulename and return empty version string without error + #Up to caller to validate. + set lastpart [namespace tail $fullmodulename] + set lastpart [file tail $lastpart] ;# should be ok to use file tail now that we've ensured no namespace components + if {[string tolower [file extension $fullmodulename]] in {.tcl .tm}} { + set fileparts [split [file rootname $lastpart] -] + } else { + set fileparts [split $lastpart -] + } + if {[tm_version_isvalid [lindex $fileparts end]]} { + set versionsegment [lindex $fileparts end] + set namesegment [join [lrange $fileparts 0 end-1] -];#re-stitch + } else { + set namesegment [join $fileparts -] + set versionsegment "" + } + set base [string trimleft [namespace qualifiers $fullmodulename] :] + if {$base ne ""} { + set modulename "${base}::$namesegment" + } else { + set modulename $namesegment + } + return [list $modulename $versionsegment] + } + # end tm_version... functions # == == == == == == == == == == == == == == == == == == == == == == == == == == == == == == == @@ -4210,6 +4486,9 @@ namespace eval punk::lib { if {[string index $key 0] ne "%"} { set key %$key } + #puts "---key:'$key'" + set key [string map {; \\;} $key] ;#review + #puts "---key:'$key'" #pipeline - use punk patterns. % thisval.= $key= $thisval } diff --git a/src/bootsupport/modules/punk/mix/cli-0.3.1.tm b/src/bootsupport/modules/punk/mix/cli-0.3.1.tm index 793736b8..6ac3cc1e 100644 --- a/src/bootsupport/modules/punk/mix/cli-0.3.1.tm +++ b/src/bootsupport/modules/punk/mix/cli-0.3.1.tm @@ -499,7 +499,7 @@ namespace eval punk::mix::cli { # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- set opt_punkcheck_eventobj [dict get $opts -punkcheck_eventobj] - set magicversion [punk::mix::util::magic_tm_version] ;#deliberately large so given load-preference when testing + set magicversion [punk::mix::util::tm_version_magic] ;#deliberately large so given load-preference when testing set module_list [list] if {[file tail [file dirname $srcdir]] ne "src"} { diff --git a/src/bootsupport/modules/punk/mix/commandset/loadedlib-0.1.0.tm b/src/bootsupport/modules/punk/mix/commandset/loadedlib-0.1.0.tm index a07aca09..2cc6ff98 100644 --- a/src/bootsupport/modules/punk/mix/commandset/loadedlib-0.1.0.tm +++ b/src/bootsupport/modules/punk/mix/commandset/loadedlib-0.1.0.tm @@ -54,13 +54,18 @@ namespace eval punk::mix::commandset::loadedlib { if {$opt_refresh} { catch {package require frobznodule666} ;#ensure pkg system has loaded/searched for everything REVIEW - this doesn't result in full scans foreach tm_path [tcl::tm::list] { + #review - todo - adjust punk::path::subfolders to take arguments to do some filtering itself rather than recurse down unnecessary branches. set paths_below [punk::path::subfolders -recursive $tm_path] foreach folder $paths_below { + if {[string match */_build/* $folder]} {continue} set tail [file tail $folder] - if {[string match #modpod-* $tail] || [string match #tarjar-* $tail]} { + if {[string match #tarjar-* $tail]} { + continue + } + if {[string match #modpod-* $tail]} { + #manually do a 'package ifneeded' fore each module found here. continue } - if {[string match */_build/* $folder]} {continue} set relpath [string tolower [punk::path::relative $tm_path $folder]] set modpath [string map {/ ::} $relpath] catch {package require ${modpath}::flobrudder99} diff --git a/src/bootsupport/modules/punk/mix/commandset/module-0.1.0.tm b/src/bootsupport/modules/punk/mix/commandset/module-0.1.0.tm index 4c75b10e..3626d2d0 100644 --- a/src/bootsupport/modules/punk/mix/commandset/module-0.1.0.tm +++ b/src/bootsupport/modules/punk/mix/commandset/module-0.1.0.tm @@ -362,7 +362,7 @@ namespace eval punk::mix::commandset::module { file mkdir $modulefolder set moduletail [namespace tail $modulename] - set magicversion [punk::mix::util::magic_tm_version] ;#deliberately large so given load-preference when testing + set magicversion [punk::mix::util::tm_version_magic] ;#deliberately large so given load-preference when testing diff --git a/src/bootsupport/modules/punk/mix/commandset/project-0.1.0.tm b/src/bootsupport/modules/punk/mix/commandset/project-0.1.0.tm index 8384197a..9b1263e3 100644 --- a/src/bootsupport/modules/punk/mix/commandset/project-0.1.0.tm +++ b/src/bootsupport/modules/punk/mix/commandset/project-0.1.0.tm @@ -380,25 +380,25 @@ namespace eval punk::mix::commandset::project { puts stdout ">>> about to call punkcheck::install $layout_path $projectdir" set resultdict [dict create] - set antipaths [list\ - src/doc/*\ - src/doc/include/*\ - src/PROJECT_LAYOUTS_*\ - ] - - #set antiglob_dir [list\ - # _ignore_*\ - #] - set antiglob_dir [list\ - ] - - #default antiglob_dir_core will stop .fossil* from being updated - which is generally desirable as these are likely to be customized + set antipaths [list {*}{ + src/doc/* + src/doc/include/* + src/PROJECT_LAYOUTS_* + }] + + #set exclude_dirsegments [list {*}{ + # _ignore_* + #}] + set exclude_dirsegments [list {*}{ + }] + + #default -exclude-dirsegments_core will stop .fossil* from being updated - which is generally desirable as these are likely to be customized if {$opt_force} { puts stdout "copying layout files - with force applied - overwrite all-targets" - set resultdict [punkcheck::install $layout_path $projectdir -installer project.new -createempty 1 -overwrite ALL-TARGETS -antiglob_paths $antipaths -antiglob_dir $antiglob_dir] + set resultdict [punkcheck::install $layout_path $projectdir -installer project.new -createempty 1 -overwrite ALL-TARGETS -antiglob_paths $antipaths -exclude-dirsegments $exclude_dirsegments] } else { puts stdout "copying layout files - (if source file changed)" - set resultdict [punkcheck::install $layout_path $projectdir -installer project.new -createempty 1 -overwrite installedsourcechanged-targets -antiglob_paths $antipaths -antiglob_dir $antiglob_dir] + set resultdict [punkcheck::install $layout_path $projectdir -installer project.new -createempty 1 -overwrite installedsourcechanged-targets -antiglob_paths $antipaths -exclude-dirsegments $exclude_dirsegments] } puts stdout [punkcheck::summarize_install_resultdict $resultdict] @@ -412,11 +412,11 @@ namespace eval punk::mix::commandset::project { #target folders .fossil-custom and .fossil-settings may not exist. use -createdir 1 to ensure existence. #In this case we need to override the default dir antiglob - as .fossil-xxx folders need to be installed from template if missing, or if target is uncustomized. - ## default_antiglob_dir_core [list "#*" "_aside" ".git" ".fossil*"] - set override_antiglob_dir_core [list #* _aside .git] + ## default_exclude_dirsegments_core [list "#*" "_aside" ".git" ".fossil*"] + set override_exclude_dirsegments_core [list #* _aside .git] if {[file exists $layout_path/.fossil-custom]} { puts stdout "copying layout src/.fossil-custom files (if target missing or uncustomised)" - set resultdict [punkcheck::install $layout_path/.fossil-custom $projectdir/.fossil-custom -createdir 1 -createempty 1 -punkcheck_folder $projectdir -installer project.new -antiglob_dir_core $override_antiglob_dir_core -overwrite SYNCED-TARGETS] + set resultdict [punkcheck::install $layout_path/.fossil-custom $projectdir/.fossil-custom -createdir 1 -createempty 1 -punkcheck_folder $projectdir -installer project.new -exclude-dirsegments_core $override_exclude_dirsegments_core -overwrite SYNCED-TARGETS] puts stdout [punkcheck::summarize_install_resultdict $resultdict] } else { puts stdout "no .fossil-custom in source template - update not required" @@ -424,7 +424,7 @@ namespace eval punk::mix::commandset::project { if {[file exists $layout_path/.fossil-settings]} { puts stdout "copying layout src/.fossil-settings files (if target missing or uncustomised)" - set resultdict [punkcheck::install $layout_path/.fossil-settings $projectdir/.fossil-settings -createdir 1 -createempty 1 -punkcheck_folder $projectdir -installer project.new -antiglob_dir_core $override_antiglob_dir_core -overwrite SYNCED-TARGETS] + set resultdict [punkcheck::install $layout_path/.fossil-settings $projectdir/.fossil-settings -createdir 1 -createempty 1 -punkcheck_folder $projectdir -installer project.new -exclude-dirsegments_core $override_exclude_dirsegments_core -overwrite SYNCED-TARGETS] puts stdout [punkcheck::summarize_install_resultdict $resultdict] } else { puts stdout "no .fossil-settings in source template - update not required" @@ -470,8 +470,8 @@ namespace eval punk::mix::commandset::project { if {[file exists $projectdir/src/modules]} { foreach m $opt_modules { #check if mod-ver.tm file or #modpod-mod-ver folder exist - set tmfile $projectdir/src/modules/$m-[punk::mix::util::magic_tm_version].tm - set podfile $projectdir/src/modules/#modpod-$m-[punk::mix::util::magic_tm_version]/$m-[punk::mix::util::magic_tm_version].tm + set tmfile $projectdir/src/modules/$m-[punk::mix::util::tm_version_magic].tm + set podfile $projectdir/src/modules/#modpod-$m-[punk::mix::util::tm_version_magic]/$m-[punk::mix::util::tm_version_magic].tm set has_tm [file exists $tmfile] set has_pod [file exists $podfile] diff --git a/src/bootsupport/modules/punk/mix/util-0.1.0.tm b/src/bootsupport/modules/punk/mix/util-0.1.0.tm index 7f55005b..8dbe8feb 100644 --- a/src/bootsupport/modules/punk/mix/util-0.1.0.tm +++ b/src/bootsupport/modules/punk/mix/util-0.1.0.tm @@ -367,7 +367,16 @@ namespace eval punk::mix::util { } #todo - semver conversion/validation for other systems? - proc magic_tm_version {} { + proc tm_version_magic {} { + #maintenance instruction: + # This specific 12 character nnnnnn.0a1.0 version number is used in text replacement when installing modules. + # It should not be modified without also considering the impact on existing projects based on punkshell that may have used this version number in their own code or documentation as a placeholder for tm version handling. + # A copy of this is also present in punk::lib to aid in dependency management. + # These 2 copies should be kept in sync. + # Essentially this should probably never be changed - and instead deprecated if we want to stop using it and replaced with a different mechanism/placeholder. + + #tm versioning is not quite the same as semantic versioning - but similarly we should see extremely high major version numbers rarely if ever in real use, + #even over decades of development. set magicbase 999999 ;#deliberately large so given load-preference when testing! #we split the literal to avoid the literal appearing here - reduce risk of accidentally converting to a release version return ${magicbase}.0a1.0 diff --git a/src/bootsupport/modules/punk/mod-0.1.1.tm b/src/bootsupport/modules/punk/mod-0.1.1.tm new file mode 100644 index 00000000..e09ff748 --- /dev/null +++ b/src/bootsupport/modules/punk/mod-0.1.1.tm @@ -0,0 +1,158 @@ +#punkapps app manager +# deck cli + +namespace eval punk::mod::cli { + namespace export help list run + namespace ensemble create + + # namespace ensemble configure [namespace current] -unknown punk::mod::cli::_unknown + if 0 { + proc _unknown {ns args} { + puts stderr "punk::mod::cli::_unknown '$ns' '$args'" + puts stderr "punk::mod::cli::help $args" + puts stderr "arglen:[llength $args]" + punk::mod::cli::help {*}$args + } + } + + #cli must have _init method - usually used to load commandsets lazily + # + variable initialised 0 + proc _init {args} { + variable initialised + if {$initialised} { + return + } + #... + set initialised 1 + } + + proc help {args} { + set basehelp [punk::mix::base help {*}$args] + #namespace export + return $basehelp + } + proc getraw {appname} { + set app_folders [punk::config::configure running apps] + #todo search each app folder + set bases [::list] + set versions [::list] + set mains [::list] + set appinfo [::list bases {} mains {} versions {}] + + foreach containerfolder $app_folders { + lappend bases $containerfolder + if {[file exists $containerfolder]} { + if {[file exists $containerfolder/$appname/main.tcl]} { + #exact match - only return info for the exact one specified + set namematches $appname + set parts [split $appname -] + } else { + set namematches [glob -nocomplain -dir $containerfolder -type d -tail ${appname}-*] + set namematches [lsort $namematches] ;#todo - -ascii? -dictionary? natsort? + } + foreach nm $namematches { + set mainfile $containerfolder/$nm/main.tcl + set parts [split $nm -] + if {[llength $parts] == 1} { + set ver "" + } else { + set ver [lindex $parts end] + } + if {$ver ni $versions} { + lappend versions $ver + lappend mains $ver $mainfile + } else { + puts stderr "punk::apps::app version '$ver' of app '$appname' already encountered at $mainfile. (will use earliest encountered in running-config apps and ignore others of same version)" + } + } + } else { + puts stderr "punk::apps::app missing apps_folder:'$containerfolder' Ensure apps_folder is set in punk::config" + } + } + dict set appinfo versions $versions + #todo - natsort! + set sorted_versions [lsort $versions] + set latest [lindex $sorted_versions 0] + if {$latest eq "" && [llength $sorted_versions] > 1} { + set latest [lindex $sorted_versions 1] + } + dict set appinfo latest $latest + + dict set appinfo bases $bases + dict set appinfo mains $mains + return $appinfo + } + + proc list {{glob *}} { + set apps_folder [punk::config::configure running apps] + if {[file exists $apps_folder]} { + if {[file exists $apps_folder/$glob]} { + #tailcall source $apps_folder/$glob/main.tcl + return $glob + } + set apps [glob -nocomplain -dir $apps_folder -type d -tail $glob] + if {[llength $apps] == 0} { + if {[string first * $glob] <0 && [string first ? $glob] <0} { + #no glob chars supplied - only launch if exact match for name part + set namematches [glob -nocomplain -dir $apps_folder -type d -tail ${glob}-*] + set namematches [lsort $namematches] ;#todo - -ascii? -dictionary? natsort? + if {[llength $namematches] > 0} { + set latest [lindex $namematches end] + lassign $latest nm ver + #tailcall source $apps_folder/$latest/main.tcl + } + } + } + return $apps + } + } + + #todo - way to launch as separate process + # solo-opts only before appname - args following appname are passed to the app + proc run {args} { + set nameposn [lsearch -not $args -*] + if {$nameposn < 0} { + error "punkapp::run unable to determine application name" + } + set appname [lindex $args $nameposn] + set controlargs [lrange $args 0 $nameposn-1] + set appargs [lrange $args $nameposn+1 end] + + set appinfo [punk::mod::cli::getraw $appname] + if {[llength [dict get $appinfo versions]]} { + set ver [dict get $appinfo latest] + puts stdout "info: $appinfo" + set ::argc [llength $appargs] + set ::argv $appargs + source [dict get $appinfo mains $ver] + if {"-hideconsole" in $controlargs} { + puts stderr "attempting console hide" + #todo - something better - a callback when window mapped? + after 500 {::punkapp::hide_console} + } + return $appinfo + } else { + error "punk::mod::cli unable to run '$appname'. main.tcl not found in [dict get $appinfo bases]" + } + } +} + +namespace eval punk::mod::cli { + proc _cli {args} { + #don't use tailcall - base uses info level to determine caller + ::punk::mix::base::_cli {*}$args + } + variable default_command help + package require punk::mix::base + package require punk::overlay + punk::overlay::custom_from_base [namespace current] ::punk::mix::base +} + +package provide punk::mod [namespace eval punk::mod { + variable version + set version 0.1.1 +}] + + + diff --git a/src/bootsupport/modules/punk/nav/fs-0.1.0.tm b/src/bootsupport/modules/punk/nav/fs-0.1.0.tm index 7d85e311..e0f29d66 100644 --- a/src/bootsupport/modules/punk/nav/fs-0.1.0.tm +++ b/src/bootsupport/modules/punk/nav/fs-0.1.0.tm @@ -847,7 +847,7 @@ tcl::namespace::eval punk::nav::fs { Regardless of whether -nonportable is supplied or not, some characters are not suitable for windows or most other platforms and will be rejected with an error. - An example of this is the null character (\0)." + An example of this is the null character (\\0)." @values -min 1 -max -1 -type string path -type string -multiple 1 -help\ "Path(s) to create. Can be absolute or relative. diff --git a/src/bootsupport/modules/punk/ns-0.1.0.tm b/src/bootsupport/modules/punk/ns-0.1.0.tm index db6acbb4..ad3cd57e 100644 --- a/src/bootsupport/modules/punk/ns-0.1.0.tm +++ b/src/bootsupport/modules/punk/ns-0.1.0.tm @@ -721,6 +721,22 @@ tcl::namespace::eval punk::ns { } + punk::args::define { + @id -id ::punk::ns::nstree_list + @cmd -name punk::ns::nstree_list\ + -summary\ + ""\ + -help\ + "" + @leaders + location -type path -optional 0 + @opts + -subnslist -type list -default {} -help\ + "" + -allbelow -type boolean -default 1 -help\ + "" + @values -min 0 -max 0 + } #important: add tests for tricky cases - e.g punk::m**::util vs punk::m*::util vs punk::m*::**::util - these should all be able to return different results depending on namespace structure. #e.g punk::m**::util will return punk::mix::util but punk::m*::**::util will not because punk::mix::util is too short to match. Both will return deeper matches such as: punk::mix::commandset::repo::util proc nstree_list {location args} { @@ -775,13 +791,8 @@ tcl::namespace::eval punk::ns { #set parent [nsprefix $ns_absolute] #set tail [nstail $ns_absolute] - #jjj #set allchildren [lsort [nseval $base [list ::namespace children]]] - #set allchildren [lsort [tcl::namespace::eval $base [list ::namespace children]]] - set allchildren [lsort [nseval $base [list ::namespace children]]] - #puts "->base:$base tailparts:$tailparts allchildren: $allchildren" - #puts "->base:$base tailparts:$tailparts childcount: [llength $allchildren]" #** only significant when it is the trailing part of a segment eg ::**::xxx ::a**::xxx if {[llength $tailparts]} { @@ -790,6 +801,7 @@ tcl::namespace::eval punk::ns { set nslist [nstree_list $base -subnslist {} -allbelow 1] } elseif {[regexp {[*]{2}$} $nextglob]} { set nslist [list] + set allchildren [lsort [nseval $base [list ::namespace children]]] lappend nsmatches {*}[lsearch -all -inline -glob $allchildren [nsjoin ${base} $nextglob]] foreach ch $nsmatches { lappend nslist $ch @@ -799,6 +811,7 @@ tcl::namespace::eval punk::ns { } else { #lsearch with -glob ok even if nextglob has no globchars (no discernable speed diff, and earlier parts may have globchars anyway) set nslist [list] + set allchildren [lsort [nseval $base [list ::namespace children]]] lappend nsmatches {*}[lsearch -all -inline -glob $allchildren [nsjoin ${base} $nextglob]] if {[llength $tailparts] >1 || $allbelow} { foreach ch $nsmatches { @@ -812,6 +825,7 @@ tcl::namespace::eval punk::ns { } } else { #puts "nstree_list: no tailparts base:$base" + set allchildren [lsort [nseval $base [list ::namespace children]]] if {$allbelow} { set nsmatches $allchildren set nslist [list] @@ -2134,8 +2148,8 @@ y" {return quirkykeyscript} tcl::dict::set tinfo($target) procoffset 0 tcl::dict::set tinfo($target) level [expr {[::tcl::info::level]+1}] tcl::dict::set tinfo($target) subcmds 0 - puts "enter: $target -- $args" - puts "frame-2: [::tcl::info::frame -2]" + puts stderr "enter: $target -- $args" + #puts stderr "frame-2: [::tcl::info::frame -2]" set _cmdtrace_disabled false } @@ -2481,7 +2495,7 @@ y" {return quirkykeyscript} set line $traceline dict set linedict $target eval_base $traceline dict set linedict $target eval_offset 1 - puts " step type: proc traceline:$traceline ** $args" + puts " step type: proc traceline:$traceline ** $args\x1b\[m" #puts "** $callinfo" if {[dict exists $callinfo cmd]} { #set cmd [string trim [dict get $callinfo cmd]] ;#raw 'unexpanded' script from the stack frame @@ -2504,8 +2518,8 @@ y" {return quirkykeyscript} set eval_base [dict get $linedict $target eval_base] set eval_offset [dict get $linedict $target eval_offset] set line [expr {$eval_base + ($eval_offset-1) + ($traceline-1)}] - puts "stack-- $callinfo" - puts " step type: eval traceline: $traceline -- " + #puts "stack-- $callinfo" + puts stderr " step type: eval traceline: $traceline -- " if {[dict exists $callinfo cmd]} { #set cmd [string trim [dict get $callinfo cmd]] set cmdlist [lindex $args 0] @@ -2627,6 +2641,8 @@ y" {return quirkykeyscript} }] } proc cmdtrace {args} { + #review - displaying argument values has to be done carefully. Small values are ok, but large lists or dicts can be overwhelming. + #Potentially we could apply some heuristics to truncate or summarise them. package require dictn ;#convenience to allow dictn::incr d {key subkey} variable tinfo array unset tinfo @@ -2676,7 +2692,7 @@ y" {return quirkykeyscript} #if the target command has a leading colon (e.g expr alternative :) we can't put a trace directly on a fully qualified name with a triple colon such as ::: #we will need to evaluate in the namespace foreach {tgt_cmd ns nscmd} $resolved_targets { - puts "tracing target: $tgt_cmd whilst running: $origin $arglist" + puts stderr "tracing target: $tgt_cmd whilst running: $origin $arglist" #::tcl::namespace::eval $ns [list ::trace add execution $nscmd enter [list ::punk::ns::_cmdtrace_enter ::punk::ns::linedict $tgt_cmd]] #::tcl::namespace::eval $ns [list ::trace add execution $nscmd enterstep [list ::punk::ns::_cmdtrace_enterstep ::punk::ns::linedict $tgt_cmd]] diff --git a/src/bootsupport/modules/punk/overlay-0.1.1.tm b/src/bootsupport/modules/punk/overlay-0.1.1.tm new file mode 100644 index 00000000..eff01253 --- /dev/null +++ b/src/bootsupport/modules/punk/overlay-0.1.1.tm @@ -0,0 +1,192 @@ + + +package require punk::mix::util +package require punk::args + +tcl::namespace::eval ::punk::overlay { + #based *loosely* on: wiki.tcl-lang.org/page/ensemble+extend + # extend an ensemble-like routine with the routines in some namespace + # + # e.g custom_from_base ::punk::mix::cli ::punk::mix::base + # + proc custom_from_base {routine base} { + if {![tcl::string::match ::* $routine]} { + set resolved [uplevel 1 [list ::tcl::namespace::which $routine]] + if {$resolved eq {}} { + error [list {no such routine} $routine] + } + set routine $resolved + } + set routinens [tcl::namespace::qualifiers $routine] + if {$routinens eq {::}} { + set routinens {} + } + set routinetail [tcl::namespace::tail $routine] + + if {![tcl::string::match ::* $base]} { + set base [uplevel 1 [ + list [tcl::namespace::which namespace] current]]::$base + } + + if {![tcl::namespace::exists $base]} { + error [list {no such namespace} $base] + } + + set base [tcl::namespace::eval $base [ + list [tcl::namespace::which namespace] current]] + + + #while 1 { + # set renamed ${routinens}::${routinetail}_[info cmdcount] + # if {[namespace which $renamed] eq {}} break + #} + + tcl::namespace::eval $routine [ + ::list tcl::namespace::ensemble configure $routine -unknown [ + ::list ::apply {{base ensemble subcommand args} { + ::list ${base}::_redirected $ensemble $subcommand + }} $base + ] + ] + + punk::mix::util::namespace_import_pattern_to_namespace_noclobber ::punk::mix::util::* ${routine}::util + #namespace eval ${routine}::util { + #::namespace import ::punk::mix::util::* + #} + punk::mix::util::namespace_import_pattern_to_namespace_noclobber ${base}::lib::* ${routine}::lib + #namespace eval ${routine}::lib [string map [list $base] { + # ::namespace import ::lib::* + #}] + + tcl::namespace::eval ${routine}::lib [tcl::string::map [list $base $routine] { + if {[tcl::namespace::exists ::lib]} { + ::set current_paths [tcl::namespace::path] + if {"" ni $current_paths} { + ::lappend current_paths + } + tcl::namespace::path $current_paths + } + }] + + tcl::namespace::eval $routine { + ::set exportlist [::list] + ::foreach cmd [tcl::info::commands [tcl::namespace::current]::*] { + ::set c [tcl::namespace::tail $cmd] + if {![tcl::string::match _* $c]} { + ::lappend exportlist $c + } + } + tcl::namespace::export {*}$exportlist + } + + return $routine + } + punk::args::define { + @id -id ::punk::overlay::import_commandset + @cmd -name punk::overlay::import_commandset\ + -summary\ + "Import commands into caller's namespace with optional prefix and separator."\ + -help\ + "Import commands that have been exported by another namespace into the caller's + namespace. Usually a prefix and optionally a separator should be used. + This is part of the punk::mix CLI commandset infrastructure - design in flux. + Todo - .toml configuration files for defining CLI configurations." + @values + prefix -type string + separator -type string -help\ + "A string, usually punctuation, to separate the prefix and the command name + of the final imported command. The value \"::\" is disallowed in this context." + cmdnamespace -type string -help\ + "Namespace from which to import commands. Commands are those that have been exported." + } + #load *exported* commands from cmdnamespace into caller's namespace - prefixing each command with $prefix + #Note: commandset may be imported by different CLIs with different bases *at the same time* + #so we don't make commands from the cli or its base available automatically (will generally require fully-qualified commands to use code from cli/base) + #we do load punk::mix::util::* into the util subnamespace even though the commandset might not be loaded in a cli using punk::mix::base i.e punk::mix::util is a common dependency for CLIs. + #commandsets designed to be used with a specific cli/base may choose to do their own import e.g with util::namespace_import_pattern_to_namespace_noclobber and/or set namespace path if they + #want the convenience of using lib:xxx with commands coming from those packages. + #This won't stop the commandset being used with other cli/bases unless the import is done by looking up the callers namespace. + #The basic principle is that the commandset is loaded into the caller(s) with a prefix + #- but commandsets should explicitly package require if they have any backwards dependencies on cli/base (which they may or may not be loaded into) + proc import_commandset {prefix separator cmdnamespace} { + set bad_seps [list "::"] + if {$separator in $bad_seps} { + error "import_commandset invalid separator '$separator'" + } + if {$prefix in $bad_seps} { + error "import_commandset invalid prefix '$prefix'" + } + if {"$prefix$separator" in $bad_seps} { + error "import_commandset invalid prefix/separator combination '$prefix$separator'" + } + if {"[string index $prefix end][string index $separator 0]" in $bad_seps} { + error "import_commandset invalid prefix/separator combination '$prefix$separator'" + } + #review - do we allow prefixes/separators such as a::b? + + #namespace may or may not be a package + # allow with or without leading :: + if {[tcl::string::range $cmdnamespace 0 1] eq "::"} { + set cmdpackage [tcl::string::range $cmdnamespace 2 end] + } else { + set cmdpackage $cmdnamespace + set cmdnamespace ::$cmdnamespace + } + + if {![tcl::namespace::exists $cmdnamespace]} { + #only do package require if the namespace not already present + catch {package require $cmdpackage} pkg_load_info + #recheck + if {![tcl::namespace::exists $cmdnamespace]} { + set prov [package provide $cmdpackage] + if {[tcl::string::length $prov]} { + set provinfo "(package $cmdpackage is present with version $prov)" + } else { + set provinfo "(package $cmdpackage not present)" + } + error "punk::overlay::import_commandset supplied namespace '$cmdnamespace' doesn't exist. $provinfo Pkg_load_result: $pkg_load_info Usage: import_commandset prefix separator namespace" + } + } + + punk::mix::util::namespace_import_pattern_to_namespace_noclobber ::punk::mix::util::* ${cmdnamespace}::util + + #let child namespace 'lib' resolve parent namespace and thus util::xxx + tcl::namespace::eval ${cmdnamespace}::lib [tcl::string::map [list $cmdnamespace] { + ::set nspaths [tcl::namespace::path] + if {"" ni $nspaths} { + ::lappend nspaths + } + tcl::namespace::path $nspaths + }] + + set imported_commands [list] + set imported_tails [list] + set nscaller [uplevel 1 [list tcl::namespace::current]] + if {[catch { + #review - noclobber? + tcl::namespace::eval ${nscaller}::temp_import [list tcl::namespace::import ${cmdnamespace}::*] + foreach cmd [tcl::info::commands ${nscaller}::temp_import::*] { + set cmdtail [tcl::namespace::tail $cmd] + if {$cmdtail eq "_default"} { + set import_as ${nscaller}::${prefix} + } else { + set import_as ${nscaller}::${prefix}${separator}${cmdtail} + } + rename $cmd $import_as + lappend imported_commands $import_as + lappend imported_tails [namespace tail $import_as] + } + #make imported commands exported so they are available to the ensemble + tcl::namespace::eval ${nscaller} [list namespace export {*}$imported_tails] + } errM]} { + puts stderr "Error loading commandset $prefix $separator $cmdnamespace" + puts stderr "err: $errM" + } + return $imported_commands + } +} + +package provide punk::overlay [tcl::namespace::eval punk::overlay { + variable version + set version 0.1.1 +}] diff --git a/src/bootsupport/modules/punk/path-0.1.0.tm b/src/bootsupport/modules/punk/path-0.1.0.tm index aff97595..4527dbb2 100644 --- a/src/bootsupport/modules/punk/path-0.1.0.tm +++ b/src/bootsupport/modules/punk/path-0.1.0.tm @@ -565,10 +565,45 @@ namespace eval punk::path { end]] } + + ## for comparison + #proc nsglob_as_re {glob} { + # #any segment that is not just * must match exactly one segment in the path + # set pats [list] + # foreach seg [nsparts_cached $glob] { + # switch -exact -- $seg { + # "" { + # lappend pats "" + # } + # * { + # #review - ::g*t will not find ::got:it (won't match single inner colon) - this should be fixed + # #lappend pats {[^:]*} + # #negative lookahead + # #any number of chars not followed by ::, followed by any number of non : + # lappend pats {(?:.(?!::))*[^:]*} + # } + # ** { + # lappend pats {.*} + # } + # default { + # set seg [string map {. [.]} $seg] + # if {[regexp {[*?]} $seg]} { + # #set pat [string map [list ** {.*} * {[^:]*} ? {[^:]}] $seg] + # set pat [string map [list ** {.*} * {(?:.(?!::))*[^:]*} ? {[^:]}] $seg] + # lappend pats "$pat" + # } else { + # lappend pats "$seg" + # } + # } + # } + # } + # return "^[join $pats ::]\$" + #} proc pathglob_as_re {pathglob} { #*** !doctools #[call [fun pathglob_as_re] [arg pathglob]] #[para] Returns a regular expression for matching a path to a glob pattern which can contain glob chars *|? in any segment of the path structure + #[para] Does not support square bracket globs or character classes. #[para] ** matches any number of subdirectories. #[para] e.g /etc/**/*.txt will match any .txt files at any depth below /etc (except directly within /etc itself) #[para] e.g /etc/**.txt will match any .txt files at any depth below /etc @@ -589,7 +624,7 @@ namespace eval punk::path { * {lappend pats {[^/]*}} ** {lappend pats {.*}} default { - set seg [string map [list {^ {\^} $ {\$} [} {\[} ( {\(} \{ \\\{ \\ {\\}] $seg] ;#treat regex characters in the input as literals + set seg [string map [list ^ {\^} $ {\$} \[ {\[} \] {\]} ( {\(} ) {\)} \{ \\\{ \\ {\\}] $seg] ;#treat regex characters (or tcl glob square bracket chars) in the input as literals #set seg [string map [list . {[.]}] $seg] set seg [string map {. [.]} $seg] if {[regexp {[*?]} $seg]} { @@ -603,6 +638,52 @@ namespace eval punk::path { } return "^[join $pats /]\$" } + + punk::args::define { + @id -id ::punk::path::globmatchpath + @cmd -name punk::path::globmatchpath\ + -summary\ + "Match path to *|**|? glob patterns"\ + -help\ + "Return a boolean indicating whether the path matches the specialised glob pattern. + A pattern such as /usr/*/bin will match any path that has /usr as the first segment and bin as the third segment, + with any single segment in between. + A pattern such as /usr/**/bin will match any path that has /usr as the first segment and bin as the last segment, + with 1 or more segments in between (so it will not match /usr/bin). + A pattern such as /usr/** will match any path that has /usr as the first segment, with 1 or more segments + following (so it will not match /usr itself). + A pattern such as **/*.txt will match any path that ends with .txt, with 1 or more leading segments + (so it will not match test.txt or .txt). + A pattern such as ** will match any path. + The glob characters * and ? are the only special characters in the pathglob syntax. + - they are treated as glob characters regardless of where they appear in the pathglob string. + Note that this is different from other Tcl glob contexts where square brackets can be used. + The pathglob syntax treats other characters, including square brackets as literals. + For example, the pattern /usr/te?t will match /usr/test and /usr/text but not /usr/texxt, and the pattern /usr/te*t + will match /usr/test, /usr/teat, and /usr/teeeet but not /usr/te/t. + The pathglob syntax does not support escaping of glob characters - any glob characters in the pathglob are treated + as glob characters. For example, the pattern /usr/* will match any path that has /usr as the first segment and any + single segment as the second segment, but there is no way to specify a pattern that matches any path that has /usr + as the first segment and a literal * as the second segment. + Caller must ensure that file separator is forward slash. (e.g use file normalize on windows) + + options: + -nocase 0|1 (default 0 - case sensitive) + If -nocase is not supplied - default to case sensitive *except for driveletter* + ie - the driveletter alone in paths such as c:/etc will still be case insensitive. (ie c:/ETC/* will match C:/ETC/blah but not C:/etc/blah) + Explicitly specifying -nocase 0 will require the entire case to match including the driveletter. + " + @leaders + pathglob -type string -help "glob pattern to match path against. See [fun pathglob_as_re] for syntax of glob patterns" + path -type string -help "path to match against glob pattern" + @opts + -nocase -type boolean -default 0 -help\ + "case insensitive matching (default false - case sensitive) + - except for driveletter on windows which is always case insensitive + unless -nocase 0 is explicitly specified" + @values -min 0 -max 0 + } + # -id proc globmatchpath {pathglob path args} { #*** !doctools #[call [fun globmatchpath] [arg pathglob] [arg path] [opt {option value...}]] @@ -659,349 +740,689 @@ namespace eval punk::path { return $ismatch } punk::args::define { - @id -id ::punk::path::subfolders - @cmd -name punk::path::subfolders\ + @id -id ::punk::path::subfolders1 + @cmd -name punk::path::subfolders1\ -summary\ - "Listing of directories within supplied path."\ + "Listing of directories below supplied path."\ -help\ "List of folders below path. The resulting list is unsorted." @opts -recursive -type none -help\ "" + -exclude-paths -type list -default {} -help\ + "list of path patterns to exclude from results. + May include * and ** path segments e.g /usr/** + A single /*/ will match any single segment in the path, and a single /**/ will match any number of segments in the path. + + e.g to exclude any path with _aside as a segment in the middle: -exclude-paths **/_aside/** + i.e this would exclude /usr/_aside/etc and /usr/x/_aside/etc but not /usr/x/_aside or _aside/etc + + To exclude all paths with _aside as a segment anywhere: -exclude-paths { **/_aside/** **/_aside _aside/**} + " #todo -depth @values -min 0 -max 1 path -type directory -optional 1 -help\ - "Path of folder. If not supplied current directory is used." + "Path of folder. If not supplied current directory is used. + This may be a relative or absolute path. Relative paths are treated as relative to current directory. + When using relative paths - the result will also be relative paths with the same relative prefix. + (e.g if path is ../test - the results will be ../test/subfolder1 ../test/subfolder2 etc) + Patterns in -exclude-paths are matched against the resulting paths + (so should be written to match the same relative prefix if path is relative)" } - proc subfolders {args} { - set argd [punk::args::parse $args withid ::punk::path::subfolders] + + proc subfolders1 {args} { + #NOTE - this algorithm based on omit_only_patterns and prune_base_patterns was suggested by a 2026 AI model - it is apparent to this programmer that it is inadequate for the purpose. + #e.g consider subfolders1 -recursion -exclude {**/vfs/** **/src/**} + #This can still return something like c:/repo/etc/src/vfs - which should be excluded by the pattern **/src/** + #todo - review and fix properly. + set argd [punk::args::parse $args withid ::punk::path::subfolders1] lassign [dict values $argd] leaders opts values received - set do_recursion [dict exists $received -recursive] + set do_recursion [dict exists $received -recursive] + set exclude_paths [dict get $opts -exclude-paths] + if {"**" in $exclude_paths} { + #if ** is in exclude_paths - then we can skip all glob matching and just return empty list + #This is likely user error - so we'll be loud about it for now but will still return empty list rather than erroring. + #If user code is building exclude_paths dynamically - they can check for this case themselves and avoid the call to subfolders1 to suppress this message. + puts stderr "punk::path::subfolders1 Warning - exclude_paths contains '**' - all paths will be excluded" + return [list] + } if {[dict exists $received path]} { set path [dict get $values path] } else { set path [pwd] } - set folders [glob -nocomplain -directory $path -types d *] + + set all_subfolders [glob -nocomplain -directory $path -types d *] + + + #example of expected exclude_paths pattern behaviour when recursion is enabled: + # **/dirname -> omit /x/y/dirname, but still visit /x/y/dirname/* + + # **/dirname/* -> include /x/y/dirname and /x/y/dirname/a/b but omit directories that are a single level below /x/y/dirname such as /x/y/dirname/a + + #c:/** - would exclude all subfolders below c: but not c: itself + + # **/test/** - would exclude any path with test as a segment and all its subfolders + #- but not paths with test as a segment that is the final segment + + set folders [list] + set recurse_subdirs [list] + + foreach f $all_subfolders { + set include_in_results 1 + set allow_recurse 1 + foreach pat $exclude_paths { + set pat_parts [file split $pat] ;#note file split c:/test gives {c:/ test} but file split **/test gives {** test} + #also note that file split on windows treats forward slashes and backslashes the same. + #by using file split, we gain some flexibility in syntax of paths and patterns, + #but lose the ability to use backslashes as escapes to allow literal glob characters in path segments. + #This is almost always a non-issue on windows since * and ? are not valid in path segments there, and is rarely an issue on unix even though + # * and ? are technically valid in path segments, but it is inadvisable there anyway for compatibility with shells etc. + if {[llength $pat_parts] >= 2 && [lindex $pat_parts end] eq "**"} { + set base_pat [file join {*}[lrange $pat_parts 0 end-1]] + if {[globmatchpath $pat $f]} { + set include_in_results 0 + set allow_recurse 0 + } elseif {[globmatchpath $base_pat $f]} { + set allow_recurse 0 + } + } elseif {[globmatchpath $pat $f]} { + set include_in_results 0 + } + if {!$include_in_results && !$allow_recurse} { + break + } + } + if {$include_in_results} { + lappend folders $f + } + if {$allow_recurse} { + lappend recurse_subdirs $f + } + } if {$do_recursion} { - foreach subdir $folders { - lappend folders {*}[subfolders -recursive $subdir] + foreach subdir $recurse_subdirs { + lappend folders {*}[subfolders1 -exclude-paths $exclude_paths -recursive $subdir] } } return $folders } - #todo - treefolders with similar search caps as treefilenames + namespace eval subfolder_priv { + proc classify_exclude_pattern {pat} { + set parts [file split $pat] + if {[llength $parts] >= 2 && [lindex $parts end] eq "**"} { + set boundary_pat [file join {*}[lrange $parts 0 end-1]] + return [dict create \ + pattern $pat \ + kind subtree \ + boundary_pat $boundary_pat \ + descend_pat $pat] + } + if {[llength $parts] >= 2 && [lindex $parts end] eq "*"} { + return [dict create \ + pattern $pat \ + kind child_only \ + match_pat $pat] + } + return [dict create \ + pattern $pat \ + kind exact \ + match_pat $pat] + } - punk::args::define { - @id -id ::punk::path::treefilenames - -directory -type directory -help\ - "folder in which to begin recursive scan for files." - -call-depth-internal -default 0 -type integer - -sort -type any -default natural -choices {none ascii dictionary natural} - -antiglob_paths -default {} -help\ - "list of path patterns to exclude - may include * and ** path segments e.g - /usr/** (exlude subfolders based at /usr but not - files within /usr itself) - **/_aside (exlude files where _aside is last segment) - **/_aside/* (exclude folders one below an _aside folder) - **/_aside/** (exclude all folders with _aside as a segment)" - -antiglob_files -default {} - @values -min 0 -max -1 -optional 1 -type string - tailglobs -default * -multiple 1 -help\ - "Patterns to match against filename portion (last segment) of each file path - within the directory tree being searched." + proc compile_exclude_rules {exclude_paths} { + set rules [list] + foreach pat $exclude_paths { + lappend rules [classify_exclude_pattern $pat] + } + return $rules + } + + proc match_rule_at_node {rule path} { + set kind [dict get $rule kind] + switch -- $kind { + exact - child_only { + if {[::punk::path::globmatchpath [dict get $rule match_pat] $path]} { + return [dict create include_current 0 recurse_below 1 child_rules [list $rule]] + } + return [dict create include_current 1 recurse_below 1 child_rules [list $rule]] + } + subtree { + set descend_pat [dict get $rule descend_pat] + set boundary_pat [dict get $rule boundary_pat] + if {[::punk::path::globmatchpath $descend_pat $path]} { + return [dict create include_current 0 recurse_below 0 child_rules [list]] + } + if {[::punk::path::globmatchpath $boundary_pat $path]} { + return [dict create include_current 1 recurse_below 0 child_rules [list]] + } + return [dict create include_current 1 recurse_below 1 child_rules [list $rule]] + } + default { + error "Unknown exclude rule kind '$kind'" + } + } + } + + proc walk_subfolders {path rules do_recursion} { + set all_subfolders [glob -nocomplain -directory $path -types d *] + set folders [list] + foreach f $all_subfolders { + set include_current 1 + set recurse_below $do_recursion + set child_rules [list] + foreach rule $rules { + set outcome [match_rule_at_node $rule $f] + if {![dict get $outcome include_current]} { + set include_current 0 + } + if {![dict get $outcome recurse_below]} { + set recurse_below 0 + } + if {$do_recursion} { + lappend child_rules {*}[dict get $outcome child_rules] + } + if {!$include_current && !$recurse_below} { + break + } + } + if {$include_current} { + lappend folders $f + } + if {$do_recursion && $recurse_below} { + lappend folders {*}[walk_subfolders $f $child_rules $do_recursion] + } + } + return $folders + } } - #todo - implement treefiles which acts like dirfiles but allows path globbing in the same way as punk::ns::ns/ - #then review if treefiles can replace dirfiles or if both should exist (dirfiles can have literal glob chars in path segments - but that is a rare usecase) - proc treefilenames {args} { - #*** !doctools - #[call [fun treefilenames] [opt {option value...}] [opt {globpattern...}]] - #[para]basic (glob based) list of filenames matching each pattern in tailglobs - recursive - #[para] options: - #[para] [opt -dir] - #[para] defaults to [lb]pwd[rb] - base path for tree to search - #[para] [opt -antiglob_paths] - #[para] list of path patterns to exclude - may include * and ** path segments e.g /usr/** - #[para]no natsorting - so order is dependent on filesystem + punk::args::define { + @id -id ::punk::path::subfolders + @cmd -name punk::path::subfolders\ + -summary\ + "Listing of directories below supplied path."\ + -help\ + "List of folders below path. + The resulting list is unsorted. + " + @opts + -recursive -type none -help\ + "" + -exclude-paths -type list -default {} -help\ + "list of path patterns to exclude from results. + May include * and ** path segments e.g /usr/** + A single /*/ will match any single segment in the path, and a single /**/ will match any number of segments in the path. - set argd [punk::args::parse $args withid ::punk::path::treefilenames] + e.g to exclude any path with _aside as a segment in the middle: -exclude-paths **/_aside/** + i.e this would exclude /usr/_aside/etc and /usr/x/_aside/etc but not /usr/x/_aside or _aside/etc + + To exclude all paths with _aside as a segment anywhere: -exclude-paths { **/_aside/** **/_aside ./_aside/**} + " + #todo -depth + @values -min 0 -max 1 + path -type directory -optional 1 -help\ + "Path of base folder. If not supplied current directory is used. + This may be a relative or absolute path. Relative paths are treated as relative to current directory. + When using relative paths - the result will also be relative paths with the same relative prefix. + (e.g if path is ../test - the results will be ../test/subfolder1 ../test/subfolder2 etc) + Patterns in -exclude-paths are matched against the resulting paths + (so should be written to match the same relative prefix if path is relative)" + } + + proc subfolders {args} { + set argd [punk::args::parse $args withid ::punk::path::subfolders] lassign [dict values $argd] leaders opts values received - set tailglobs [dict get $values tailglobs] - # -- --- --- --- --- --- --- - set opt_sort [dict get $opts -sort] - set opt_antiglob_paths [dict get $opts -antiglob_paths] - set opt_antiglob_files [dict get $opts -antiglob_files] - set CALLDEPTH [dict get $opts -call-depth-internal] - # -- --- --- --- --- --- --- - # -- --- --- --- --- --- --- - - set files [list] - if {$CALLDEPTH == 0} { - if {$opt_sort eq "natural"} { - package require natsort + set do_recursion [dict exists $received -recursive] + set exclude_paths [dict get $opts -exclude-paths] + if {"**" in $exclude_paths} { + puts stderr "punk::path::subfolders Warning - exclude_paths contains '**' - all paths will be excluded" + return [list] + } + if {[dict exists $received path]} { + set path [dict get $values path] + } else { + set path [pwd] + } + set compiled_rules [subfolder_priv::compile_exclude_rules $exclude_paths] + return [subfolder_priv::walk_subfolders $path $compiled_rules $do_recursion] + } + + namespace eval treefile_priv { + proc _pattern_prefix_viable_parts {pattern_parts path_parts} { + if {![llength $path_parts]} { + return 1 } - #set opts [dict merge $opts [list -directory $opt_dir]] - if {![dict exists $received -directory]} { - set opt_dir [pwd] - } else { - set opt_dir [dict get $opts -directory] + if {![llength $pattern_parts]} { + return 0 } - if {![file isdirectory $opt_dir]} { - return [list] + + set pattern_head [lindex $pattern_parts 0] + set path_head [lindex $path_parts 0] + + if {$pattern_head eq "**"} { + if {[_pattern_prefix_viable_parts [lrange $pattern_parts 1 end] $path_parts]} { + return 1 + } + return [_pattern_prefix_viable_parts $pattern_parts [lrange $path_parts 1 end]] } - } else { - #assume/require to exist in any recursive call - set opt_dir [dict get $opts -directory] + + if {[::punk::path::globmatchpath $pattern_head $path_head]} { + return [_pattern_prefix_viable_parts [lrange $pattern_parts 1 end] [lrange $path_parts 1 end]] + } + return 0 } - #comment out to compare timings with treefilenames_zipfs - if {[string match //zipfs:/* $opt_dir]} { - return [treefilenames_zipfs {*}$args] + proc pattern_prefix_viable {pattern path} { + return [_pattern_prefix_viable_parts [file split $pattern] [file split $path]] } - set skip 0 - foreach anti $opt_antiglob_paths { - if {[globmatchpath $anti $opt_dir]} { - set skip 1 - break + proc pattern_boundary {pattern} { + set parts [file split $pattern] + if {[llength $parts] >= 2 && [lindex $parts end] eq "**"} { + return [file join {*}[lrange $parts 0 end-1]] } - } - if {$skip} { - return [list] + return "" } - #todo - account for vfs where matched path could appear to be a directory but is mounted so could be a desired match? - if {[catch {glob -nocomplain -dir $opt_dir -type f {*}$tailglobs} matches]} { - #we can get for example a permissions error - puts stderr "treefilenames error while listing files in dir $opt_dir\n $matches" - set dirfiles [list] - } else { - set retained [list] - if {[llength $opt_antiglob_files]} { - foreach m $matches { - set skip 0 - set ftail [file tail $m] - foreach anti $opt_antiglob_files { - if {[string match $anti $ftail]} { - set skip 1; break - } - } - if {!$skip} { - lappend retained $m + proc directory_state {glob_paths path inherited_allbelow} { + if {$inherited_allbelow} { + return [dict create include_files 1 recurse_below 1 next_allbelow 1] + } + + set include_files 0 + set recurse_below 0 + set next_allbelow 0 + + foreach gp $glob_paths { + if {[::punk::path::globmatchpath $gp $path]} { + set include_files 1 + set recurse_below 1 + set next_allbelow 1 + break + } + + set boundary [pattern_boundary $gp] + if {$boundary ne "" && [::punk::path::globmatchpath $boundary $path]} { + set recurse_below 1 + set next_allbelow 1 + continue + } + + if {[pattern_prefix_viable $gp $path]} { + set recurse_below 1 + } + } + + return [dict create {*}{ + } include_files $include_files {*}{ + } recurse_below $recurse_below {*}{ + } next_allbelow $next_allbelow {*}{ } + ] + } + + proc child_path_state {glob_paths child_path inherited_allbelow} { + if {$inherited_allbelow} { + return 1 + } + foreach gp $glob_paths { + if {[pattern_prefix_viable $gp $child_path]} { + return 1 } - } else { - set retained $matches } - switch -- $opt_sort { + return 0 + } + + proc _sort_paths {paths sortmode} { + switch -- $sortmode { ascii { - set dirfiles [lsort $retained] + return [lsort $paths] } dictionary { - set dirfiles [lsort -dictionary $retained] + return [lsort -dictionary $paths] } natural { - set dirfiles [natsort::sort $retained] + return [natsort::sort $paths] } default { - set dirfiles $retained + return $paths } } } - lappend files {*}$dirfiles - if {[catch {glob -nocomplain -dir $opt_dir -type d *} dirdirs]} { - puts stderr "treefilenames error while listing subdirs in dir $opt_dir\n $dirdirs" - set dirdirs [list] - } - set okdirs [list] - foreach dir $dirdirs { - set skip 0 - foreach anti $opt_antiglob_paths { - if {[globmatchpath $anti $dir]} { - set skip 1 - break + proc _path_matches_any {patterns path} { + foreach pattern $patterns { + if {[::punk::path::globmatchpath $pattern $path]} { + return 1 } } - if {!$skip} { - lappend okdirs $dir + return 0 + } + + proc _tailbase_relative {tailbase path} { + if {$tailbase eq ""} { + return $path } + return [::punk::path::relative $tailbase $path] } - if {[llength $okdirs]} { - switch -- $opt_sort { - ascii { - set finaldirs [lsort $okdirs] + + proc _tailbase_match_path {tailbase path} { + set match_path [_tailbase_relative $tailbase $path] + if {$match_path eq "."} { + return "" + } + return $match_path + } + + proc _tailbase_relative_list {tailbase paths} { + if {$tailbase eq ""} { + return $paths + } + set relative_paths [list] + foreach path $paths { + lappend relative_paths [_tailbase_relative $tailbase $path] + } + return $relative_paths + } + + proc _retain_files {matches exclude_files sortmode} { + set retained [list] + foreach match $matches { + set skip 0 + set file_tail [file tail $match] + foreach anti $exclude_files { + if {[string match $anti $file_tail]} { + set skip 1 + break + } } - dictionary { - set finaldirs [lsort -dictionary $okdirs] + if {!$skip} { + lappend retained $match } - natural { - set finaldirs [natsort::sort $okdirs] + } + return [_sort_paths $retained $sortmode] + } + + proc _state_from_argd {argd} { + set opts [dict get $argd opts] + set values [dict get $argd values] + set received [dict get $argd received] + + if {[dict exists $received -directory]} { + set directory [dict get $opts -directory] + } else { + set directory [pwd] + } + + set glob_paths [dict get $opts -include-paths] + if {"*" in $glob_paths} { + set glob_paths {*} + } + + set sortmode [dict get $opts -sort] + if {$sortmode eq "natural"} { + package require natsort + } + + return [dict create {*}{ + depth 0 + subvector {} + allbelow 0 + } sort $sortmode {*}{ + } directory $directory {*}{ + } tailbase [dict get $opts -tailbase] {*}{ + } exclude_paths [dict get $opts -exclude-paths] {*}{ + } exclude_files [dict get $opts -exclude-files] {*}{ + } glob_paths $glob_paths {*}{ + } tailglobs [dict get $values tailglobs] {*}{ } - default { - set finaldirs $okdirs + ] + } + + proc walk_treefilenames {state} { + set opt_dir [dict get $state directory] + set opt_tailbase [dict get $state tailbase] + set depth [dict get $state depth] + set subvector [dict get $state subvector] + set callallbelow [dict get $state allbelow] + set opt_sort [dict get $state sort] + set opt_exclude_paths [dict get $state exclude_paths] + set opt_exclude_files [dict get $state exclude_files] + set opt_glob_paths [dict get $state glob_paths] + set tailglobs [dict get $state tailglobs] + + if {![file isdirectory $opt_dir]} { + return [list] + } + if {[string match //zipfs:/* $opt_dir]} { + return [walk_treefilenames_zipfs $state] + } + set opt_dir_match [_tailbase_match_path $opt_tailbase $opt_dir] + if {[_path_matches_any $opt_exclude_paths $opt_dir_match]} { + return [list] + } + + set files [list] + set dir_state [directory_state $opt_glob_paths $opt_dir_match $callallbelow] + if {[dict get $dir_state include_files]} { + if {[catch {glob -nocomplain -dir $opt_dir -type f {*}$tailglobs} matches]} { + puts stderr "treefilenames error while listing files in dir $opt_dir\n $matches" + set dirfiles [list] + } else { + set dirfiles [_retain_files $matches $opt_exclude_files $opt_sort] } + lappend files {*}[_tailbase_relative_list $opt_tailbase $dirfiles] } - foreach dir $finaldirs { - set nextopts [dict merge $opts [list -directory $dir -call-depth-internal [incr CALLDEPTH]]] - lappend files {*}[treefilenames {*}$nextopts {*}$tailglobs] + + if {![dict get $dir_state recurse_below]} { + return $files } - } - return $files - } - proc treefilenames_zipfs {args} { - #seems to be 2 or 3 times faster than treefilenames for //zipfs:/ paths - REVIEW - # is sort order the same? - set argd [punk::args::parse $args withid ::punk::path::treefilenames] - lassign [dict values $argd] leaders opts values received - set tailglobs [dict get $values tailglobs] - # -- --- --- --- --- --- --- - set opt_antiglob_paths [dict get $opts -antiglob_paths] - set opt_antiglob_files [dict get $opts -antiglob_files] - set opt_sort [dict get $opts -sort] - set CALLDEPTH [dict get $opts -call-depth-internal] - # -- --- --- --- --- --- --- - # -- --- --- --- --- --- --- - - set files [list] - if {$CALLDEPTH == 0} { - if {$opt_sort eq "natural"} { - package require natsort + + if {[catch {glob -nocomplain -dir $opt_dir -type d *} dirdirs]} { + puts stderr "treefilenames error while listing subdirs in dir $opt_dir\n $dirdirs" + set dirdirs [list] + } + set okdirs [list] + foreach dir $dirdirs { + if {![_path_matches_any $opt_exclude_paths [_tailbase_match_path $opt_tailbase $dir]]} { + lappend okdirs $dir + } } - #set opts [dict merge $opts [list -directory $opt_dir]] - if {![dict exists $received -directory]} { - set opt_dir [pwd] + + if {$opt_glob_paths eq "*"} { + set matchdirs $okdirs } else { - set opt_dir [dict get $opts -directory] + set matchdirs [list] + foreach dir $okdirs { + if {$callallbelow || [child_path_state $opt_glob_paths [_tailbase_match_path $opt_tailbase $dir] $callallbelow]} { + lappend matchdirs $dir + } + } } - if {![file isdirectory $opt_dir]} { - return [list] + + set finaldirs [_sort_paths $matchdirs $opt_sort] + set childallbelow [expr {$callallbelow || [dict get $dir_state next_allbelow]}] + set nextsubvector [list {*}$subvector [file tail $opt_dir]] + foreach dir $finaldirs { + set child_state [dict merge $state [dict create {*}{} \ + directory $dir \ + depth [expr {$depth + 1}] \ + subvector $nextsubvector \ + allbelow $childallbelow]] + lappend files {*}[walk_treefilenames $child_state] } - } else { - #assume/require to exist in any recursive call - set opt_dir [dict get $opts -directory] - } - if {![string match [zipfs root]* $opt_dir]} { - error "treefilenames_zipfs can only be used on paths beginning with [zipfs root] on this systems" + return $files } - set dir [string trimright $opt_dir "/"] ;#e.g normalize //zipfs:/x/ to //zipfs:/x - set dirlen [string length $dir] - - set skip 0 - foreach anti $opt_antiglob_paths { - if {[globmatchpath $anti $dir]} { - set skip 1 - break + + proc walk_treefilenames_zipfs {state} { + set opt_dir [dict get $state directory] + set opt_tailbase [dict get $state tailbase] + set opt_exclude_paths [dict get $state exclude_paths] + set opt_exclude_files [dict get $state exclude_files] + set opt_glob_paths [dict get $state glob_paths] + set opt_sort [dict get $state sort] + set tailglobs [dict get $state tailglobs] + + if {![string match [zipfs root]* $opt_dir]} { + error "treefilenames_zipfs can only be used on paths beginning with [zipfs root] on this systems" } - } - if {$skip} { - return [list] - } - set subpaths [zipfs list $dir/*] - set dirlist [list] - set skipdirs [list] - set filelist [list] - #process in the order they came - sorting large list more expensive?? review - foreach sub $subpaths { - set tail [string range $sub $dirlen+1 end] ;#dirlen is without trailing slash - set tailparts [file split $tail] - set accum "" - set skipdir 0 - foreach tp [lrange $tailparts 0 end-1] { - append accum "/$tp" - set superpath "${dir}${accum}" - if {$superpath in $skipdirs} { - #subpart already in skipdirs - set skipdir 1 - break - } - if {$superpath ni $dirlist} { - set skip2 0 - foreach anti $opt_antiglob_paths { - if {[globmatchpath $anti $superpath]} { - set skip2 1 + set dir [string trimright $opt_dir "/"] + if {[_path_matches_any $opt_exclude_paths [_tailbase_match_path $opt_tailbase $dir]]} { + return [list] + } + set dirlen [string length $dir] + set subpaths [zipfs list $dir/*] + set dirlist [list] + set skipdirs [list] + set filelist [list] + foreach sub $subpaths { + set tail [string range $sub $dirlen+1 end] + set tailparts [file split $tail] + set accum "" + set skipdir 0 + foreach tailpart [lrange $tailparts 0 end-1] { + append accum "/$tailpart" + set superpath "${dir}${accum}" + if {$superpath in $skipdirs} { + set skipdir 1 + break + } + if {$superpath ni $dirlist} { + if {[_path_matches_any $opt_exclude_paths [_tailbase_match_path $opt_tailbase $superpath]]} { lappend skipdirs $superpath + set skipdir 1 break + } else { + lappend dirlist $superpath } } - if {!$skip2} { - lappend dirlist $superpath - } else { - set skipdir 1 - break - } } - } - if {!$skipdir} { - #process final part of path - append accum "/[lindex $tailparts end]" - set finalpart "${dir}${accum}" - if {$finalpart ni $dirlist} { - if {[file type $finalpart] eq "file"} { - set ftail [lindex $tailparts end] - set match 0 - if {"*" ni $tailglobs} { - foreach tg $tailglobs { - if {[string match $tg $ftail]} { - set match 1 - break + if {!$skipdir} { + append accum "/[lindex $tailparts end]" + set finalpart "${dir}${accum}" + if {$finalpart ni $dirlist} { + if {[file type $finalpart] eq "file"} { + set file_tail [lindex $tailparts end] + set match 0 + if {"*" ni $tailglobs} { + foreach tailglob $tailglobs { + if {[string match $tailglob $file_tail]} { + set match 1 + break + } + } + } else { + set match 1 + } + if {$match} { + if {$opt_glob_paths ne "*"} { + set file_dir_match [_tailbase_match_path $opt_tailbase [file dirname $finalpart]] + set file_dir_state [directory_state $opt_glob_paths $file_dir_match 0] + set match [dict get $file_dir_state include_files] } } - } else { - set match 1 - } - if {$match} { - if {[llength $opt_antiglob_files]} { + if {$match} { set skipfile 0 - foreach anti $opt_antiglob_files { - if {[string match $anti $ftail]} { - set skipfile 1; break + foreach anti $opt_exclude_files { + if {[string match $anti $file_tail]} { + set skipfile 1 + break } } if {!$skipfile} { - lappend filelist $finalpart + lappend filelist [_tailbase_relative $opt_tailbase $finalpart] } - } else { - lappend filelist $finalpart } - } - } else { - if {$finalpart ni $dirlist} { - set skip2 0 - foreach anti $opt_antiglob_paths { - if {[globmatchpath $anti $finalpart]} { - set skip2 1 + } else { + if {$finalpart ni $dirlist} { + if {[_path_matches_any $opt_exclude_paths [_tailbase_match_path $opt_tailbase $finalpart]]} { lappend skipdirs $finalpart - break + } else { + lappend dirlist $finalpart } } - if {!$skip2} { - lappend dirlist $finalpart - } } } } } + return [_sort_paths $filelist $opt_sort] } - switch -- $opt_sort { - ascii { - set finalfilelist [lsort $filelist] - } - dictionary { - set finalfilelist [lsort -dictionary $filelist] - } - natural { - set finalfilelist [natsort::sort $filelist] - } - default { - set finalfilelist $filelist - } + } + + #todo - treefolders with similar search caps as treefilenames + + punk::args::define { + @id -id ::punk::path::treefilenames + @cmd -name punk::path::treefilenames\ + -summary\ + "List of filenames below supplied path."\ + -help\ + "List of filenames below path. + The resulting list is unsorted. + + The path globbing syntax supports *, ** and ? as glob characters in any segment of the path, with the following semantics: + * matches any single segment in the path + ** matches 1 or more segments in the path (so /usr/**/bin will match /usr/x/bin and user/x/y/bin but not /usr/bin ) + ? matches any single character in a single segment of the path (so /usr/te?t will match /usr/test and /usr/text but not /usr/texxt) + " + -directory -type directory -help\ + "folder in which to begin recursive scan for files." + -tailbase -type string -default "" -help\ + "if supplied, only the relative path compared to the tailbase will be returned for each file. + So if tailbase is /usr and a file is found at /usr/x/y/file.txt, the returned path for that file would be x/y/file.txt. + If tailbase is not supplied, the full path to each file will be returned. + + If tailbase is supplied, it should be a prefix of the directory supplied (or the directory itself) + The patterns in -exclude-paths should be written to match the returned paths (i.e with the tailbase prefix removed) if -tailbase is supplied. + If the tailbase is not a prefix of the directory supplied, the resulting paths may have /../ components in them to account for the difference, + but the behaviour is not well defined in this case and it is recommended to ensure tailbase is a prefix of the directory supplied if using -tailbase. + + see: punk::path::relative to compute relative paths + " + -sort -type any -default natural -choices {none ascii dictionary natural} + -exclude-paths -default {} -help\ + "list of path patterns to exclude + may include * and ** path segments e.g + /usr/** (exclude subfolders based at /usr but not + files within /usr itself) + **/_aside (exclude files where _aside is last segment) + **/_aside/* (exclude folders one below an _aside folder) + **/_aside/** (exclude files in all folders with _aside as a segment)" + -exclude-files -default {} + -include-paths -default {**} -help\ + "list of path patterns to include + may include * and ** path segments e.g + /usr/** (include files in subfolders based at /usr but not + files within /usr itself) + **/_aside (include files where _aside is last segment in the folder) + **/_aside/* (include files in folders one below an _aside folder) + **/_aside/** (include all files in folders with _aside as a segment)" + @values -min 0 -max -1 -optional 1 -type string + tailglobs -default * -multiple 1 -help\ + "Patterns to match against filename portion (last segment) of each file path + within the directory tree being searched." + } + + #todo - implement treefiles which acts like dirfiles but allows path globbing in the same way as punk::ns::ns/ + #then review if treefiles can replace dirfiles or if both should exist (dirfiles can have literal glob chars in path segments - but that is a rare usecase) + proc treefilenames {args} { + set argd [punk::args::parse $args withid ::punk::path::treefilenames] + set state [treefile_priv::_state_from_argd $argd] + return [treefile_priv::walk_treefilenames $state] + } + punk::args::set_idalias ::punk::path::treefilenames_zipfs ::punk::path::treefilenames + proc treefilenames_zipfs {args} { + #seems to be 2 or 3 times faster than treefilenames for //zipfs:/ paths - REVIEW + # is sort order the same? + set argd [punk::args::parse $args withid ::punk::path::treefilenames] + set state [treefile_priv::_state_from_argd $argd] + if {![file isdirectory [dict get $state directory]]} { + return [list] } - return $finalfilelist + return [treefile_priv::walk_treefilenames_zipfs $state] } #maint warning - also in punkcheck diff --git a/src/bootsupport/modules/punk/pipe-1.0.tm b/src/bootsupport/modules/punk/pipe-1.0.tm index 034fae01..eae8731c 100644 --- a/src/bootsupport/modules/punk/pipe-1.0.tm +++ b/src/bootsupport/modules/punk/pipe-1.0.tm @@ -169,8 +169,8 @@ tcl::namespace::eval punk::pipe::lib { #This stops us matching {/@**@x x} vs {/@**@x x} #--- - set rhs [tcl::string::map {: ? * [ ] \\ {"} " " } $rhs] - #review - we don't expect other command-incompatible chars such as colon? + set rhs [tcl::string::map {: ; ? * [ ] \\ {"} " " } $rhs] + #review - we don't expect other command-incompatible chars? return $rhs } @@ -187,6 +187,7 @@ tcl::namespace::eval punk::pipe::lib { #exclude quoted whitespace proc arg_is_script_shaped {arg} { + set arg [string map {\\; ""} $arg] if {[tcl::string::first \n $arg] >= 0} { return 1 } elseif {[tcl::string::first ";" $arg] >= 0} { diff --git a/src/bootsupport/modules/punk/repo-0.1.1.tm b/src/bootsupport/modules/punk/repo-0.1.1.tm index 5fd534dc..049ed2e7 100644 --- a/src/bootsupport/modules/punk/repo-0.1.1.tm +++ b/src/bootsupport/modules/punk/repo-0.1.1.tm @@ -1817,17 +1817,13 @@ namespace eval punk::repo { error "unimplemented" } - #file normalize is expensive so this is too + #file normalize can be a little expensive so this is too proc norm {path {platform env}} { - #kettle::path::norm - #see also wiki - #full path normalization - - set platform [string tolower $platform] - if {$platform eq "env"} { - set platform $::tcl_platform(platform) - } + #set platform [string tolower $platform] + #if {$platform eq "env"} { + # set platform $::tcl_platform(platform) + #} #No - don't do this sort of path translation here - leave as option for specific utils only such as ./ #Windows volume-relative syntax with specific volume specified is somewhat broken in Tcl - but leading slash volume-relative does work #We shouldn't break it totally just because accessing WSL/mingw paths is slightly more useful @@ -1835,6 +1831,9 @@ namespace eval punk::repo { #return [file dirname [file normalize [punk::unixywindows::towinpath $path]/__]] #} + #kettle::path::norm + #see also wiki + #full path normalization return [file dirname [file normalize $path/__]] } diff --git a/src/bootsupport/modules/punkapp-0.1.1.tm b/src/bootsupport/modules/punkapp-0.1.1.tm new file mode 100644 index 00000000..2ccf6afa --- /dev/null +++ b/src/bootsupport/modules/punkapp-0.1.1.tm @@ -0,0 +1,240 @@ +#utilities for punk apps to call + + +namespace eval punkapp { + variable result + variable waiting "no" + proc hide_dot_window {} { + #alternative to wm withdraw . + #see https://wiki.tcl-lang.org/page/wm+withdraw + wm geometry . 1x1+0+0 + wm overrideredirect . 1 + wm transient . + } + proc is_toplevel {w} { + if {![llength [info commands winfo]]} { + return 0 + } + expr {[winfo toplevel $w] eq $w && ![catch {$w cget -menu}]} + } + proc get_toplevels {{w .}} { + if {![llength [info commands winfo]]} { + return [list] + } + set list {} + if {[is_toplevel $w]} { + lappend list $w + } + foreach w [winfo children $w] { + lappend list {*}[get_toplevels $w] + } + return $list + } + + proc make_toplevel_next {prefix} { + set top [get_toplevel_next $prefix] + return [toplevel $top] + } + #possible race condition if multiple calls made without actually creating the toplevel, or gap if highest existing closed in the meantime + #todo - reserve_toplevel_next ? keep list of toplevels considered 'allocated' even if never created or already destroyed? what usecase? + #can call wm withdraw to to reserve newly created toplevel. To stop re-use of existing names after destruction would require a list or at least a record of highest created for each prefix + proc get_toplevel_next {prefix} { + set base [string trim $prefix .] ;# .myapp -> myapp .myapp.somewindow -> myapp.somewindow . -> "" + + + + } + proc exit {{toplevel ""}} { + variable waiting + variable result + variable default_result + set toplevels [get_toplevels] + if {[string length $toplevel]} { + set wposn [lsearch $toplevels $toplevel] + if {$wposn > 0} { + destroy $toplevel + } + } else { + #review + if {[package provide punk::repl::codethread] ne "" && [punk::repl::codethread::is_running]} { + puts stderr "punkapp::exit called without toplevel - showing console" + show_console + return 0 + } else { + puts stderr "punkapp::exit called without toplevel - exiting" + if {$waiting ne "no"} { + if {[info exists result(shell)]} { + set temp [set result(shell)] + unset result(shell) + set waiting $temp + } else { + set waiting "" + } + } else { + ::exit + } + } + } + + set controllable [get_user_controllable_toplevels] + if {![llength $controllable]} { + if {[package provide punk::repl::codethread] ne "" && [punk::repl::codethread::is_running]} { + show_console + } else { + if {$waiting ne "no"} { + if {[info exists result(shell)]} { + set temp [set result(shell)] + unset result(shell) + set waiting $temp + } elseif {[info exists result($toplevel)]} { + set temp [set result($toplevel)] + unset result($toplevel) + set waiting $temp + } elseif {[info exists default_result]} { + set temp $default_result + unset default_result + set waiting $temp + } else { + set waiting "" + } + } else { + ::exit + } + } + } + } + proc close_window {toplevel} { + wm withdraw $toplevel + if {![llength [get_user_controllable_toplevels]]} { + punkapp::exit $toplevel + } + destroy $toplevel + } + proc wait {args} { + variable waiting + variable default_result + if {[dict exists $args -defaultresult]} { + set default_result [dict get $args -defaultresult] + } + foreach t [punkapp::get_toplevels] { + if {[wm protocol $t WM_DELETE_WINDOW] eq ""} { + wm protocol $t WM_DELETE_WINDOW [list punkapp::close_window $t] + } + } + if {[package provide punk::repl::codethread] ne "" && [punk::repl::codethread::is_running]} { + puts stderr "repl eventloop seems to be running - punkapp::wait not required" + } else { + if {$waiting eq "no"} { + set waiting "waiting" + vwait ::punkapp::waiting + return $::punkapp::waiting + } + } + } + + #A window can be 'visible' according to this - but underneath other windows etc + #REVIEW - change name? + proc get_visible_toplevels {{w .}} { + if {![llength [info commands winfo]]} { + return [list] + } + set list [get_toplevels $w] + set mapped [lmap v $list {expr {[winfo ismapped $v] ? $v : {}}}] + set mapped [concat {*}$mapped] ;#ignore {} + set visible [list] + foreach m $mapped { + if {[wm overrideredirect $m] == 0 } { + lappend visible $m + } else { + if {[winfo height $m] >1 && [winfo width $m] > 1} { + #technically even a 1x1 is visible.. but in practice even a 10x10 is hardly likely to be noticeable when overrideredirect == 1 + #as a convention - 1x1 with no controls is used to make a window invisible so we'll treat anything larger as visible + lappend visible $m + } + } + } + return $visible + } + proc get_user_controllable_toplevels {{w .}} { + set visible [get_visible_toplevels $w] + set controllable [list] + foreach v $visible { + if {[wm overrideredirect $v] == 0} { + lappend controllable $v + } + } + #only return visible windows with overrideredirect == 0 because there exists some user control. + #todo - review.. consider checking if position is outside screen areas? Technically controllable.. but not easily + return $controllable + } + proc hide_console {args} { + set opts [dict create -force 0] + if {([llength $args] % 2) != 0} { + error "hide_console expects pairs of arguments. e.g -force 1" + } + #set known_opts [dict keys $defaults] + foreach {k v} $args { + switch -- $k { + -force { + dict set opts $k $v + } + default { + error "Unrecognised options '$k' known options: [dict keys $opts]" + } + } + } + set force [dict get $opts -force] + + if {!$force} { + if {![llength [get_user_controllable_toplevels]]} { + puts stderr "Cannot hide console while no user-controllable windows available" + return 0 + } + } + if {$::tcl_platform(platform) eq "windows"} { + #hide won't work for certain consoles cush as conemu,wezterm - and doesn't really make sense for tabbed windows anyway. + #It would be nice if we could tell the console window to hide just the relevant tab - or the whole window if only one tab present - but this is unlikely to be possible in any standard way. + #an ordinary cmd.exe or pwsh.exe or powershell.exe window can be hidden ok though. + #(but with wezterm - process is cmd.exe - but it has style popup and can't be hidden with a twapi::hide_window call) + package require twapi + set h [twapi::get_console_window] + set pid [twapi::get_window_process $h] + set pinfo [twapi::get_process_info $pid -name] + set pname [dict get $pinfo -name] + set wstyle [twapi::get_window_style $h] + #tclkitsh/tclsh? + if {($pname in [list cmd.exe pwsh.exe powershell.exe] || [string match punk*.exe $pname]) && "popup" ni $wstyle} { + twapi::hide_window $h + return 1 + } else { + puts stderr "punkapp::hide_console unable to hide this type of console window" + return 0 + } + } else { + #todo + puts stderr "punkapp::hide_console unimplemented on this platform (todo)" + return 0 + } + } + + proc show_console {} { + if {$::tcl_platform(platform) eq "windows"} { + package require twapi + if {![catch {set h [twapi::get_console_window]} errM]} { + twapi::show_window $h -activate -normal + } else { + #no console - assume launched from something like wish? + catch {console show} + } + } else { + #todo + puts stderr "punkapp::show_console unimplemented on this platform" + } + } + +} + +package provide punkapp [namespace eval punkapp { + variable version + set version 0.1.1 +}] \ No newline at end of file diff --git a/src/bootsupport/modules/punkcheck-0.1.1.tm b/src/bootsupport/modules/punkcheck-0.1.1.tm new file mode 100644 index 00000000..bdff666e --- /dev/null +++ b/src/bootsupport/modules/punkcheck-0.1.1.tm @@ -0,0 +1,2458 @@ +# -*- tcl -*- +# Maintenance Instruction: leave the 999999.xxx.x as is and use 'dev make' or src/make.tcl to update from -buildversion.txt +# +# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. +# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# (C) 2023 +# +# @@ Meta Begin +# Application punkcheck 0.1.0 +# Meta platform tcl +# Meta license +# @@ Meta End + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +##e.g package require frobz + +package require punk::tdl +package require punk::path +package require punk::repo +package require punk::mix::util + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# Punkcheck uses the TDL format which is a list of lists in Tcl format +# It is intended primarily for source build/distribution tracking within a punk project or single filesystem - with relative paths. +# +#see following article regarding the many problems with using mtime for build-decisions: https://apenwarr.ca/log/20181113 +# +namespace eval punkcheck { + namespace export {*}{ + uuid + installtrack + install + install_tm_files + install_non_tm_files + summarize_install_resultdict + } + + #exclude-dir & exclude-file entries match the pattern at any level - should not contain path separators + variable default_excludedirseg_core [list "#*" "_aside" "_build" ".git" ".fossil*"] + variable default_excludefiletail_core "" + + set has_twapi 0 + if {"windows" eq $::tcl_platform(platform)} { + set has_twapi [expr {![catch {package require twapi}]}] + } + if {$has_twapi} { + interp alias "" ::punkcheck::uuid "" ::twapi::new_uuid + } else { + catch {package require uuid} + interp alias "" ::punkcheck::uuid "" ::uuid::uuid generate + } + + proc default_excludedirseg_core {} { + variable default_excludedirseg_core + return $default_excludedirseg_core + } + proc default_excludefiletail_core {} { + variable default_excludefiletail_core + if {$default_excludefiletail_core eq ""} { + set default_excludefiletail_core [list "*.swp" "*[punk::mix::util::tm_version_magic]*" "*-buildversion.txt" ".punkcheck"] + } + return $default_excludefiletail_core + } + + + proc load_records_from_file {punkcheck_file} { + set record_list [list] + if {[file exists $punkcheck_file]} { + set tdlscript [punk::mix::util::fcat $punkcheck_file] + if {[catch { + set record_list [punk::tdl::prettyparse $tdlscript] + } errparse]} { + error "punkcheck::load_records_from_file failed to parse '$punkcheck_file'\n error:$errparse" + } + } + return $record_list + } + proc save_records_to_file {recordlist punkcheck_file {trigger {}} {debugchannel ""}} { + set newtdl [punk::tdl::prettyprint $recordlist] + set linecount [llength [split $newtdl \n]] + + if {$debugchannel ne "" && $trigger ne ""} { + puts $debugchannel "\x1b\[36mSaving [llength $recordlist] records as $linecount lines to file '$punkcheck_file' trigger: \x1b\[32m$trigger\x1b\[m" + } + #puts stdout $newtdl + set fd [open $punkcheck_file w] + chan configure $fd -translation binary + puts -nonewline $fd $newtdl + flush $fd + close $fd + return [list recordcount [llength $recordlist] linecount $linecount] + } + + + #todo - work out way to use same punkcheck file for multiple installers running concurrently. Thread? + #an installtrack objects represents an installation path from sourceroot to targetroot + #The source and target folders should be as specific as possible but it is valid to specify for example c:/ -> c:/ (or / -> /) if source and targets within the installation operation are spread around. + # + set objname [namespace current]::installtrack + if {$objname ni [info commands $objname]} { + package require oolib + + #FILEINFO record - target fileset with body records: INSTALL-RECORD,INSTALL-INPROGRESS,INSTALL-SKIPPED,DELETE-RECORD,DELETE-INPROGRESS,MODIFY-INPROGRESS,MODIFY-RECORD + #each FILEINFO body being a list of SOURCE records + oo::class create targetset { + variable o_targets + variable o_keep_installrecords + variable o_keep_skipped + variable o_keep_inprogress + variable o_records + constructor {args} { + #set o_records [oolib::collection create [namespace current]::recordcollection] + set o_records [list] + + } + + method as_record {} { + dict create {*}{ + } tag FILEINFO {*}{ + } -targets $o_targets {*}{ + } -keep_installrecords $o_keep_installrecords {*}{ + } -keep_skipped $o_keep_skipped {*}{ + } -keep_inprogress $o_keep_inprogress {*}{ + } body $o_records {*}{ + } + } + + #retrieve last completed record for the fileset ie exclude SKIPPED,INSTALL-INPROGRESS,DELETE-INPROGRESS,MODIFY-INPROGRESS + method get_last_record {fileset_record} { + set body [dict_getwithdefault $fileset_record body [list]] + set previous_records [lrange $body 0 end-1] + #get last previous that is tagged INSTALL-RECORD,MODIFY-RECORD,DELETE-RECORD + set revlist [lreverse $previous_records] + foreach rec $revlist { + switch -- [dict get $rec tag] { + INSTALL-RECORD - MODIFY-RECORD - DELETE-RECORD - VIRTUAL-RECORD { + return $rec + } + } + } + return [list] + } + } + + #instances created by an installtrack object in method start_event + #also in installtrack constructor - to represent existing events from the .punkcheck data + oo::class create installevent { + variable o_id + variable o_rel_sourceroot + variable o_rel_targetroot + variable o_ts_begin + variable o_ts_end + variable o_types + variable o_configdict + variable o_targets + variable o_operation + variable o_operation_start_ts + variable o_path_cksum_cache + variable o_fileset_record + variable o_installer ;#parent object + variable o_debugchannel + constructor {installer rel_sourceroot rel_targetroot args} { + set o_installer $installer + set o_debugchannel [$installer get_debugchannel] + set o_operation_start_ts "" + set o_path_cksum_cache [dict create] + set o_operation "" + set defaults [dict create {*}{ + -id "" + -tsbegin "" + -config {} + -tsend "" + -types {} + }] + set opts [dict merge $defaults $args] + if {[dict get $opts -id] eq ""} { + set o_id [punkcheck::uuid] + } else { + set o_id [dict get $opts -id] + } + if {[dict get $opts -tsbegin] eq ""} { + set o_ts_begin [clock microseconds] + } else { + set o_ts_begin [dict get $opts -tsbegin] + } + set o_ts_end [dict get $opts -tsend] + set o_types [dict get $opts -types] + set o_configdict [dict get $opts -config] + + set o_rel_sourceroot $rel_sourceroot + set o_rel_targetroot $rel_targetroot + } + destructor { + #puts "[self] destructor called" + } + method as_record {} { + set begin_seconds [expr {$o_ts_begin / 1000000}] + set tsiso_begin [clock format $begin_seconds -format "%Y-%m-%dT%H:%M:%S"] + if {$o_ts_end ne ""} { + set end_seconds [expr {$o_ts_end / 1000000}] + set tsiso_end [clock format $end_seconds -format "%Y-%m-%dT%H:%M:%S"] + } else { + set tsiso_end "" + } + + dict create {*}{ + } tag EVENT {*}{ + } -tsiso_begin $tsiso_begin {*}{ + } -ts_begin $o_ts_begin {*}{ + } -tsiso_end $tsiso_end {*}{ + } -ts_end $o_ts_end {*}{ + } -id $o_id {*}{ + } -source $o_rel_sourceroot {*}{ + } -targets $o_rel_targetroot {*}{ + } -types $o_types {*}{ + } -config $o_configdict {*}{ + } + } + method get_id {} { + return $o_id + } + method get_operation {} { + return $o_operation + } + method get_targets {} { + return $o_targets + } + method get_targets_exist {} { + set punkcheck_folder [file dirname [$o_installer get_checkfile]] + #puts stdout "### punkcheck glob -dir $punkcheck_folder -tails {*}$o_targets" + #targets can be paths such as punk/mix/commandset/module-0.1.0.tm - glob can search levels below supplied -dir + set existing [glob -nocomplain -dir $punkcheck_folder -tails {*}$o_targets] + + return $existing + } + method end {} { + set o_ts_end [clock microseconds] + } + method targetset_dict {} { + punk::records_as_target_dict [$o_installer get_recordlist] + } + + #related - installfile_begin + #call init before we know if we are going to run the operation vs skip + method targetset_init {operation targetset} { + set known_ops [list QUERY INSTALL MODIFY DELETE VIRTUAL] + if {[string toupper $operation] ni $known_ops} { + error "[self] add_target unknown operation '$operation'. Known operations $known_ops" + } + set o_operation [string toupper $operation] + + if {$o_operation_start_ts ne ""} { + error "[self] targetset_init $o_operation operation already in progress. Use targetset_finished or targetset_complete to finish." + } + set o_operation_start_ts [clock microseconds] + set seconds [expr {$o_operation_start_ts / 1000000}] + set tsiso [clock format $seconds -format "%Y-%m-%dT%H:%M:%S"] + set punkcheck_file [$o_installer get_checkfile] + set punkcheck_folder [file dirname $punkcheck_file] + + set relativepath_targetset [list] + if {$o_operation eq "VIRTUAL"} { + foreach p $targetset { + lappend relativepath_targetset $p + } + } else { + foreach p $targetset { + if {[file pathtype $p] eq "absolute"} { + lappend relativepath_targetset [punkcheck::lib::path_relative $punkcheck_folder $p] + } else { + lappend relativepath_targetset $p + } + } + } + + + set fields [list {*}{ + } -tsiso $tsiso {*}{ + } -ts $o_operation_start_ts {*}{ + } -installer [$o_installer get_name] {*}{ + } -eventid $o_id {*}{ + } + ] + + set o_targets [lsort -dictionary -increasing $relativepath_targetset] ;#exact sort order not critical - but must be consistent + + + set record_list [punkcheck::load_records_from_file $punkcheck_file] + + #--------------------------------------------------------------------------- + #load as dict to test for dupes + #set _targetdict [my targetset_dict] + if {[catch { + set _targetdict [punkcheck::recordlist::records_as_target_dict $record_list] + } errMsg]} { + error "targetset_init operation:$operation error verifying existing records from file $punkcheck_file. Error: $errMsg" + } + #--------------------------------------------------------------------------- + + set extractioninfo [punkcheck::recordlist::extract_or_create_fileset_record $o_targets $record_list] + set o_fileset_record [dict get $extractioninfo record] + set record_list [dict get $extractioninfo recordset] ;#if fileset wasn't present, same as original record_list, otherwise full recordset with the fileset record removed, ready for reinsertion. + set isnew [dict get $extractioninfo isnew] + set oldposition [dict get $extractioninfo oldposition] + unset extractioninfo + + #INSTALL-INPROGRESS will become INSTALL-RECORD or INSTALL-FAILED or INSTALL-SKIPPED upon finalisation + #-installer and -eventid keys are added here + set new_inprogress_record [dict create tag [string toupper $operation]-INPROGRESS {*}$fields -tempcontext [my as_record] body {}] + #set existing_body [dict_getwithdefault $o_fileset_record body [list]] + #todo - look for existing "-INPROGRESS" records - mark as failed or incomplete? + dict lappend o_fileset_record body $new_inprogress_record + + if {$isnew} { + lappend record_list $o_fileset_record + } else { + #set record_list [linsert $record_list[unset record_list] $oldposition $o_fileset_record] + ledit record_list $oldposition -1 $o_fileset_record + } + if {$o_operation ne "QUERY"} { + punkcheck::save_records_to_file $record_list $punkcheck_file "targetset_init $o_operation [llength $targetset] targets" + } + return $o_fileset_record + + } + #operation has been started + #todo - upgrade .punkcheck format to hold more than just list of SOURCE entries in each record. + # - allow arbitrary targetset_startphase targetset_endphase calls to store timestamps and calculate elapsed time + method targetset_started {} { + set punkcheck_folder [file dirname [$o_installer get_checkfile]] + if {$o_operation eq "QUERY"} { + set fileinfo_body [dict get $o_fileset_record body] ;#body of FILEINFO record + set installing_record [lindex $fileinfo_body end] + + set ts_start [dict get $installing_record -ts] + set ts_now [clock microseconds] + set metadata_us [expr {$ts_now - $ts_start}] + + #?? + #JJJ + #dict set installing_record -metadata_us $metadata_us + dict set installing_record -ts_start_transfer $ts_now + + lset fileinfo_body end $installing_record + + return [dict set o_fileset_record body $fileinfo_body] + } else { + #legacy call + #saves to .punkcheck file + return [set o_fileset_record [punkcheck::installfile_started_install $punkcheck_folder $o_fileset_record]] + } + } + method targetset_end {status args} { + set defaults [dict create {*}{ + -note \uFFFF + }] + set known_opts [dict keys $defaults] + if {[llength $args] % 2} { + error "targetset_end arguments after status must be in the form of -flag value pairs. known flags: $known_opts" + } + set opts [dict merge $defaults $args] + if {[dict get $opts -note] eq "\uFFFF"} { + dict unset opts -note + } + + set status [string toupper $status] + set statusdict [dict create OK RECORD SKIPPED SKIPPED FAILED FAILED] + if {$o_operation_start_ts eq ""} { + error "[self] targetset_end $status - no current operation - call targetset_started first" + } + if {$status ni [dict keys $statusdict]} { + error "[self] targetset_end unrecognized status:$status known values: [dict keys $statusdict]" + } + if {![punkcheck::lib::is_file_record_inprogress $o_fileset_record]} { + error "targetset_end $status error: bad fileset_record - expected FILEINFO with last body element *-INPROGRESS" + } + set targetlist [dict get $o_fileset_record -targets] + if {$targetlist ne $o_targets} { + error "targetset_end $status error. targetlist mismatch between file : $targetlist vs $o_targets" + } + set operation_end_ts [clock microseconds] + set elapsed_us [expr {$operation_end_ts - $o_operation_start_ts}] + set file_record_body [dict get $o_fileset_record body] + set installing_record [lindex $file_record_body end] + set punkcheck_file [$o_installer get_checkfile] + set punkcheck_folder [file dirname $punkcheck_file] + set record_list [punkcheck::load_records_from_file $punkcheck_file] + if {[dict exists $installing_record -ts_start_transfer]} { + set ts_start_transfer [dict get $installing_record -ts_start_transfer] + set transfer_us [expr {$operation_end_ts - $ts_start_transfer}] + dict set installing_record -transfer_us $transfer_us + } + if {[dict exists $opts -note]} { + dict set installing_record -note [dict get $opts -note] + } + + dict set installing_record -elapsed_us $elapsed_us + dict unset installing_record -tempcontext + dict set installing_record tag "${o_operation}-[dict get $statusdict $status]" ;# e.g INSTALL-RECORD, INSTALL-SKIPPED + if {$o_operation in [list INSTALL MODIFY] && [dict get $statusdict $status] eq "RECORD"} { + #only calculate and store post operation target cksums on successful INSTALL or MODIFY, doesn't make sense for DELETE or VIRTUAL operations + set new_targets_cksums [list] ;#ordered list of cksums matching targetset order + set cksum_all_opts "" ;#same cksum opts for each target so we store it once + set ts_begin_cksum [clock microseconds] + foreach p $o_targets { + set tgt_cksum_info [punk::mix::base::lib::cksum_path [file join $punkcheck_folder $p]] + lappend new_targets_cksums [dict get $tgt_cksum_info cksum] + if {$cksum_all_opts eq ""} { + set cksum_all_opts [dict get $tgt_cksum_info opts] + } + } + set cksum_us [expr {[clock microseconds] - $ts_begin_cksum}] + dict set installing_record -targets_cksums $new_targets_cksums + dict set installing_record -cksum_all_opts $cksum_all_opts + dict set installing_record -cksum_us $cksum_us + } + lset file_record_body end $installing_record + dict set o_fileset_record body $file_record_body + set o_fileset_record [punkcheck::recordlist::file_record_prune $o_fileset_record] + + set oldrecordinfo [punkcheck::recordlist::get_file_record $targetlist $record_list] + set old_posn [dict get $oldrecordinfo position] + if {$old_posn == -1} { + lappend record_list $o_fileset_record + } else { + lset record_list $old_posn $o_fileset_record + } + if {$o_operation ne "QUERY"} { + punkcheck::save_records_to_file $record_list $punkcheck_file "targetset_end $o_operation $status [llength $o_targets] targets" + } + set o_operation_start_ts "" + set o_operation "" + return $o_fileset_record + } + #can supply empty cksum value + # - that will influence the opts used if there is no existing install record + method targetset_cksumcache_set {path_cksum_dict} { + set o_path_cksum_cache $path_cksum_dict + } + method targetset_cksumcache_configure {path {cksuminfodict {}}} { + if {$cksuminfodict eq {}} { + if {[dict exists $o_path_cksum_cache $path]} { + return [dict get $o_path_cksum_cache $path] + } else { + return + } + } + dict for {k v} $cksuminfodict { + switch -- $k { + cksum - opts {} + default { + error "targetset_cksumcache_configure error. Unknown dict value $k. Allowed values {cksum opts}" + } + } + } + dict set o_path_cksum_cache $path $cksuminfodict + } + method targetset_addsource {source_path} { + set punkcheck_file [$o_installer get_checkfile] + set punkcheck_folder [file dirname $punkcheck_file] + if {[file pathtype $source_path] eq "absolute"} { + set rel_source_path [punkcheck::lib::path_relative $punkcheck_folder $source_path] + } else { + set rel_source_path $source_path + } + + #installfile_add_source_and_fetch_metadata accepts list of {cksum opt } dictionaries - although we only have one per path from our configured cksumcache + if {[dict exists $o_path_cksum_cache $rel_source_path]} { + set path_cksum_caches [list [dict get $o_path_cksum_cache $rel_source_path]] + } else { + set path_cksum_caches [list] + } + set o_fileset_record [punkcheck::installfile_add_source_and_fetch_metadata $punkcheck_folder $rel_source_path $o_fileset_record $path_cksum_caches] + #JJJ - update -metadata_us here? + + } + method targetset_last_complete {} { + #retrieve last completed record for the fileset ie exclude SKIPPED,INSTALL-INPROGRESS,DELETE-INPROGRESS,MODIFY-INPROGRESS + set body [punkcheck::dict_getwithdefault $o_fileset_record body [list]] + set previous_records [lrange $body 0 end] + #get last that is tagged INSTALL-RECORD,MODIFY-RECORD,DELETE-RECORD + set revlist [lreverse $previous_records] + foreach rec $revlist { + if {[dict get $rec tag] in [list "INSTALL-RECORD" "MODIFY-RECORD" "DELETE-RECORD" "VIRTUAL-RECORD"]} { + return $rec + } + } + return [list] + + } + method targetset_source_changes {} { + punkcheck::recordlist::file_install_record_source_changes [lindex [dict get $o_fileset_record body] end] + } + + } + + + oo::class create installtrack { + variable o_name + variable o_tsiso + variable o_ts + variable o_keep_events + variable o_checkfile + variable o_sourceroot + variable o_rel_sourceroot + variable o_targetroot + variable o_rel_targetroot + variable o_record_list + variable o_active_event + variable o_events + variable o_debugchannel + constructor {installername punkcheck_file {debugchannel ""}} { + set o_debugchannel $debugchannel + set o_active_event "" + set o_name $installername + + set o_checkfile [file normalize $punkcheck_file] + set o_sourceroot "" + set o_targetroot "" + set o_rel_sourceroot "" + set o_rel_targetroot "" + set o_record_list [list] + + #todo - validate punkcheck file location further?? + set punkcheck_folder [file dirname $o_checkfile] + if {![file isdirectory $punkcheck_folder]} { + error "[self] constructor error. Folder for punkcheck_file not found - $o_checkfile" + } + + my load_all_records + if {![llength $o_record_list] && $o_debugchannel ne ""} { + puts $o_debugchannel "\x1b\[32mNo existing records found in punkcheck file '$o_checkfile' for installer '$installername'. Starting with empty record list.\x1b\[m" + } else { + #verify no duplicate installer records for this installer. + #JMN + set sanity_dict [dict create] + set insane "" + foreach rec $o_record_list { + if {[dict get $rec tag] eq "INSTALLER"} { + set name [dict get $rec -name] + if {[dict exists $sanity_dict $name]} { + #todo - warn - duplicate record for same targetlist - shouldn't happen as we should be using get_file_record to find existing records + if {$o_debugchannel ne ""} { + puts $o_debugchannel "\x1b\[31mpunkcheck installtrack - multiple INSTALLER records with same name '$name'\x1b\[m" + } + set insane "$name" + break + } + dict set sanity_dict $name {} + } + } + if {$insane ne ""} { + set msg "Sanity check: punkcheck file '$o_checkfile' contains multiple records for INSTALLER -name '$insane'." + append msg \n "This may indicate a problem such as multiple concurrent installtrack instances using the same punkcheck file," + append msg \n " or a previous installtrack instance that did not complete properly." + append msg \n " Do you want to DELETE the .punkcheck file?" + append msg \n " It is safe to delete .punkcheck files, at the cost of loss of history and checksums used to optimize installs." + append msg \n " They are a record of installation events and checksums used to avoid unnecessary reinstalls." + append msg \n " If not confirmed, an error will be raised - likely aborting the current operation." + append msg \n "confirm deletion and continue by regenerating the file, by typing the 3 letters: 'yes'." + set answer [punk::lib::askuser $msg] + if {[string tolower $answer] ne "yes"} { + error "Failing due to sanity check failure. User did not confirm with 'yes'." + } + if {[file exists $o_checkfile] && [file isfile $o_checkfile]} { + file delete $o_checkfile + } + if {[file exists $o_checkfile]} { + error "Failed to delete punkcheck file '$o_checkfile' after sanity check failure. Please investigate and resolve the issue before proceeding." + } + set o_record_list [list] + } else { + if {$o_debugchannel ne ""} { + puts $o_debugchannel "\x1b\[32mSanity check passed: no duplicate INSTALLER records found for installer '$installername' in punkcheck file '$o_checkfile'.\x1b\[m" + } + } + unset sanity_dict + } + + set resultinfo [punkcheck::recordlist::get_installer_record $o_name $o_record_list] + set existing_header_posn [dict get $resultinfo position] + if {$existing_header_posn == -1} { + set this_installer_record [punkcheck::recordlist::new_installer_record $o_name] + #set o_record_list [linsert $o_record_list 0 $this_installer_record] + ledit o_record_list -1 -1 $this_installer_record + } else { + set this_installer_record [dict get $resultinfo record] + } + set o_tsiso [dict get $this_installer_record -tsiso] + set o_ts [dict get $this_installer_record -ts] + set o_keep_events [dict get $this_installer_record -keep_events] + + set o_events [oolib::collection create [namespace current]::eventcollection] + set eventlist [punkcheck::dict_getwithdefault $this_installer_record body [list]] + foreach e $eventlist { + set eobj [punkcheck::installevent create [namespace current]::event_[my events count] [self] [dict get $e -source] [dict get $e -targets] {*}$e] + #$o_events add $e [dict get $e -id] + $o_events add $eobj [dict get $e -id] + } + + } + destructor { + #puts "[self] destructor called" + } + method test {} { + return [self] + } + method get_name {} { + return $o_name + } + method get_checkfile {} { + return $o_checkfile + } + method get_debugchannel {} { + return $o_debugchannel + } + + #call set_source_target before calling start_event/end_event + #each event can have different source->target pairs - but may often have same, so set on installtrack as defaults. Only persisted in event records. + method set_source_target {sourceroot targetroot} { + if {[file pathtype $sourceroot] ne "absolute"} { + error "[self] set_source_target error: sourceroot must be absolute path. Received '$sourceroot'" + } + if {[file pathtype $targetroot] ne "absolute"} { + error "[self] set_source_target error: targetroot must be absolute path. Received '$targetroot'" + } + set punkcheck_folder [file dirname $o_checkfile] + set o_sourceroot $sourceroot + set o_targetroot $targetroot + set o_rel_sourceroot [punkcheck::lib::path_relative $punkcheck_folder $sourceroot] + set o_rel_targetroot [punkcheck::lib::path_relative $punkcheck_folder $targetroot] + return [list $o_rel_sourceroot $o_rel_targetroot] + } + #review/fix to allow multiple installtrack objects on same punkcheck file. + method load_all_records {} { + set o_record_list [punkcheck::load_records_from_file $o_checkfile] + } + + #does not include associated FILEINFO records - as a targetset (FILEINFO record) can be associated with events from multiple installers over time. + #e.g a logfile common to installers, or a separate installer that updates a previous output. + method as_record {} { + set eventrecords [list] + foreach eobj [my events items] { + lappend eventrecords [$eobj as_record] + } + set fields [list {*}{ + } -tsiso $o_tsiso {*}{ + } -ts $o_ts {*}{ + } -name $o_name\ {*}{ + } -keep_events $o_keep_events {*}{ + } body $eventrecords {*}{ + } + ] + set record [dict create tag INSTALLER {*}$fields] + } + #open file and save only own records + method save_all_records {} { + my save_installer_record + #todo - save FILEINFO targetset records + } + method save_installer_record {} { + set file_records [punkcheck::load_records_from_file $o_checkfile] + + set this_installer_record [my as_record] + + set persistedinfo [punkcheck::recordlist::get_installer_record $o_name $file_records] + set existing_header_posn [dict get $persistedinfo position] + if {$existing_header_posn == -1} { + #set file_records [linsert $file_records 0 $this_installer_record] + ledit file_records -1 -1 $this_installer_record + } else { + lset file_records $existing_header_posn $this_installer_record + } + punkcheck::save_records_to_file $file_records $o_checkfile "save_installer_record" + } + method events {args} { + tailcall $o_events {*}$args + } + method start_event {configdict} { + if {$o_active_event ne ""} { + error "[self] start_event error - event already started: $o_active_event" + } + if {$o_rel_sourceroot eq "" || $o_rel_targetroot eq ""} { + error "[self] No configured sourceroot or targetroot. Call [self] set_source_target first" + } + + if {[llength $configdict] %2 != 0} { + error "[self] new_event configdict must have an even number of elements" + } + set resultinfo [punkcheck::recordlist::get_installer_record $o_name $o_record_list] + set existing_header_posn [dict get $resultinfo position] + if {$existing_header_posn == -1} { + error "[self] start_event - installer record missing. installer: $o_name" + } else { + set this_installer_record [dict get $resultinfo record] + } + + set eventobj [punkcheck::installevent create [namespace current]::event_[my events count] [self] $o_rel_sourceroot $o_rel_targetroot -config $configdict] + set eventid [$eventobj get_id] + set event_record [$eventobj as_record] + + set this_installer_record [punkcheck::recordlist::installer_record_add_event $this_installer_record $event_record] + set this_installer_record [punkcheck::recordlist::installer_record_pruneevents $this_installer_record $o_record_list] + + #replace + lset o_record_list $existing_header_posn $this_installer_record + + punkcheck::save_records_to_file $o_record_list $o_checkfile "start_event $eventid" + set o_active_event $eventobj + my events add $eventobj $eventid + return $eventobj + } + method installer_record_from_file {} { + set resultinfo [punkcheck::recordlist::get_installer_record $o_name $o_record_list] + } + method get_recordlist {} { + return $o_recordlist + } + method end_event {} { + if {$o_active_event eq ""} { + error "[self] end_event error - no active event" + } + $o_active_event end + } + method get_event {} { + return $o_active_event + } + } + } + proc start_installer_event {punkcheck_file installername from_fullpath to_fullpath config} { + set eventid [punkcheck::uuid] + if {[file pathtype $from_fullpath] ne "absolute"} { + error "start_installer_event error: from_fullpath must be absolute path. Received '$from_fullpath'" + } + if {[file pathtype $to_fullpath] ne "absolute"} { + error "start_installer_event error: to_fullpath must be absolute path. Received '$to_fullpath'" + } + set punkcheck_folder [file dirname $punkcheck_file] + set rel_source [punkcheck::lib::path_relative $punkcheck_folder $from_fullpath] + set rel_target [punkcheck::lib::path_relative $punkcheck_folder $to_fullpath] + + + set record_list [punkcheck::load_records_from_file $punkcheck_file] + set resultinfo [punkcheck::recordlist::get_installer_record $installername $record_list] + set existing_header_posn [dict get $resultinfo position] + if {$existing_header_posn == -1} { + set this_installer_record [punkcheck::recordlist::new_installer_record $installername] + } else { + set this_installer_record [dict get $resultinfo record] + } + + set event_record [punkcheck::recordlist::new_installer_event_record install {*}{ + -id $eventid + -source $rel_source + -targets $rel_target + -config $config + }] + + set this_installer_record [punkcheck::recordlist::installer_record_add_event $this_installer_record $event_record] + set this_installer_record [punkcheck::recordlist::installer_record_pruneevents $this_installer_record $record_list] + + if {$existing_header_posn == -1} { + #not found - prepend + #set record_list [linsert $record_list 0 $this_installer_record] + ledit record_list -1 -1 $this_installer_record + } else { + #replace + lset record_list $existing_header_posn $this_installer_record + } + + punkcheck::save_records_to_file $record_list $punkcheck_file "start_installer_event $eventid" + return [list eventid $eventid recordset $record_list] + } + #----------------------------------------------- + proc installfile_help {} { + set msg "" + append msg "Call in order:" \n + append msg " start_installer_event (get dict with eventid and recordset keys)" + append msg " installfile_begin (to return a new INSTALLING record) - must pass in a valid eventid" \n + append msg " installfile_add_source_and_fetch_metadata (1+ times to update SOURCE record with checksum/timestamp info from source)" \n + append msg " ( - possibly with same algorithm as previous installrecord)" \n + append msg " ( - todo - search/load metadata for this source from other FILEINFO records for same installer)" \n + append msg "Finalize by calling:" \n + append msg " installfile_started_install" \n + append msg " (install the file e.g file copy)" \n + append msg " installfile_finished_install" \n + append msg " OR" \n + append msg " installfile_skipped_install" \n + } + proc installfile_begin {punkcheck_folder target_relpath installername args} { + if {[llength $args] %2 !=0} { + error "punkcheck installfile_begin args must be name-value pairs" + } + set target_relpath [lsort -dictionary -increasing $target_relpath] ;#exact sort order not critical - but must be consistent + set ts [clock microseconds] + set seconds [expr {$ts / 1000000}] + set tsiso [clock format $seconds -format "%Y-%m-%dT%H:%M:%S"] + set defaults [list {*}{ + } -tsiso $tsiso {*}{ + } -ts $ts {*}{ + } -installer $installername {*}{ + } -eventid unspecified {*}{ + } + ] + set opts [dict merge $defaults $args] + set opt_eventid [dict get $opts -eventid] + + set punkcheck_file [file join $punkcheck_folder/.punkcheck] + set record_list [load_records_from_file $punkcheck_file] + + set resultinfo [punkcheck::recordlist::get_installer_record $installername $record_list] + set installer_record_position [dict get $resultinfo position] + if {$installer_record_position == -1} { + error "installfile_begin error: Failed to retrieve installer record for installer name:'$installername' - ensure start_installer_event has been called with same installer, and -eventid is passed to installfile_begin" + } + set this_installer_record [dict get $resultinfo record] + set events [dict get $this_installer_record body] + set active_event [list] + foreach evt [lreverse $events] { + if {[dict get $evt -id] eq $opt_eventid} { + set active_event $evt + break + } + } + if {![llength $active_event]} { + error "installfile_begin error: eventid $opt_eventid not found for installer '$installername' - aborting" + } + + + set extractioninfo [punkcheck::recordlist::extract_or_create_fileset_record $target_relpath $record_list] + set file_record [dict get $extractioninfo record] + set record_list [dict get $extractioninfo recordset] + set isnew [dict get $extractioninfo isnew] + set oldposition [dict get $extractioninfo oldposition] + unset extractioninfo + + #INSTALL-INPROGRESS will become INSTALL-RECORD or INSTALL-FAILED or INSTALL-SKIPPED upon finalisation + #-installer and -eventid keys are added here + set new_installing_record [dict create tag INSTALL-INPROGRESS {*}$opts -tempcontext $active_event body {}] + #set existing_body [dict_getwithdefault $file_record body [list]] + #todo - look for existing "INSTALL-INPROGRESS" records - mark as failed? + dict lappend file_record body $new_installing_record + + if {$isnew} { + lappend record_list $file_record + } else { + #set record_list [linsert $record_list[unset record_list] $oldposition $file_record] + ledit record_list $oldposition -1 $file_record + } + + save_records_to_file $record_list $punkcheck_file "installfile_begin $installername $opt_eventid $target_relpath" + return $file_record + } + + #todo - ensure that removing a dependency is noticed as a change + #e.g previous installrecord had 2 source records - but we now only depend on one. + #The files we depended on for the previous record haven't changed themselves - but the list of files has (reduced by one) + #cached_cksums is list of dicts with keys cksum & opts + #Will only be used if any opts values present match those from file_record's -cksum_all_opts (in last install record) or first cached_cksum will be used if no last install record values + proc installfile_add_source_and_fetch_metadata {punkcheck_folder source_relpath file_record {cached_cksums {}}} { + if {![lib::is_file_record_inprogress $file_record]} { + error "installfile_add_source_and_fetch_metadata error: bad file_record - expected FILEINFO with last body element *-INPROGRESS ($file_record)" + } + #validate any passed cached_cksums + foreach cacheinfo $cached_cksums { + if {[llength $cacheinfo] % 2 != 0} { + error "installfile_add_source_and_fetch_metadata error.If cached_cksums is supplied, it must be a list of dicts containing keys cksum & opts" + } + dict for {k v} $cacheinfo { + switch -- $k { + cksum {} + opts { + #todo - validate $v keys + } + default { + error "installfile_add_source_and_fetch_metadata error. Unrecognised key $k. Known keys {cksum opts}" + } + } + + } + } + set ts_start [clock microseconds] + set last_installrecord [lib::file_record_get_last_installrecord $file_record] + set prev_ftype "" + set prev_fsize "" + set prev_cksum "" + set prev_cksum_opts "" + if {[llength $last_installrecord]} { + set src [lib::install_record_get_matching_source_record $last_installrecord $source_relpath] + if {[llength $src]} { + if {[dict_getwithdefault $src -path ""] eq $source_relpath} { + set prev_ftype [dict_getwithdefault $src -type ""] + set prev_fsize [dict_getwithdefault $src -size ""] + set prev_cksum [dict_getwithdefault $src -cksum ""] + set prev_cksum_opts [dict_getwithdefault $src -cksum_all_opts ""] + } + } + } + #check that this relpath not already added as child of *-INPROGRESS + set file_record_body [dict_getwithdefault $file_record body [list]] ;#new file_record may have no body + set installing_record [lindex $file_record_body end] + set already_present_record [lib::install_record_get_matching_source_record $installing_record $source_relpath] + if {[llength $already_present_record]} { + error "installfile_add_source_and_fetch_metadata error: source path $source_relpath already exists in the file_record - cannot add again" + } + + set use_cache 0 + if {$prev_cksum_opts ne ""} { + set cksum_opts $prev_cksum_opts + #find first cached_cksum that is compatible with cksum opts used in latest install record + foreach cacheinfo $cached_cksums { + set cachedopts [dict get $cacheinfo opts] + set cache_is_match 1 + dict for {k v} $cachedopts { + if {[dict exists $prev_cksum_opts $k] && $v ne [dict get $prev_cksum_opts $k]} { + set cache_is_match 0 + break + } + } + if {$cache_is_match} { + set use_cache_record $cacheinfo + set use_cache 1 + break + } + } + + } else { + #no cksum opts available from an install record + set cksum_opts "" + #use first entry in cached_cksums if we can + if {[llength $cached_cksums]} { + set use_cache 1 + set use_cache_record [lindex $cached_cksums 0] + } + } + + #todo - accept argument of cached source cksum info (for client calling multiple targets with same source in quick succession e.g when building .vfs kits with multiple runtimes) + #if same cksum_opts - then use cached data instead of checksumming here. + + #allow nonexistant as a source + set fpath [file join $punkcheck_folder $source_relpath] + #windows: file exist + file type = 2ms vs 500ms for 2x glob + set floc [file dirname $fpath] + set fname [file tail $fpath] + set file_set [glob -nocomplain -dir $floc -type f -tails $fname] + set dir_set [glob -nocomplain -dir $floc -type d -tails $fname] + set link_set [glob -nocomplain -dir $floc -type l -tails $fname] + if {[llength $file_set] == 0 && [llength $dir_set] == 0 && [llength $link_set] == 0} { + #could also theoretically exist as less common types, b,c,p,s (block,char,pipe,socket) + #- we don't expect them here - REVIEW - ever possible? + #- installing/examining such things an unlikely usecase and would require special handling anyway. + set ftype "missing" + set fsize "" + } else { + if {[llength $dir_set]} { + set ftype "directory" + set fsize "NA" + } elseif {[llength $link_set]} { + set ftype "link" + set fsize 0 + } else { + set ftype "file" + #todo - optionally use mtime instead of cksum (for files only)? + #mtime is not reliable across platforms and filesystems though.. see article linked at top. + set fsize [file size $fpath] + } + } + + #if {![file exists $fpath]} { + # set ftype "missing" + # set fsize "" + #} else { + # set ftype [file type $fpath] + # if {$ftype eq "directory"} { + # set fsize "NA" + # } else { + # #todo - optionally use mtime instead of cksum (for files only)? + # #mtime is not reliable across platforms and filesystems though.. see article linked at top. + # set fsize [file size $fpath] + # } + #} + #get_relativecksum_from_base and fill_relativecksums_from_base_and_relativepathdict will set cksum to if fpath doesn't exist + if {$use_cache} { + set source_cksum_info [punk::mix::base::lib::fill_relativecksums_from_base_and_relativepathdict $punkcheck_folder [dict create $source_relpath $use_cache_record]] + } else { + set source_cksum_info [punk::mix::base::lib::get_relativecksum_from_base $punkcheck_folder $source_relpath {*}$cksum_opts] + } + + + lassign $source_cksum_info pathkey ckinfo + if {$pathkey ne $source_relpath} { + error "installfile_add_source_and_fetch_metadata error: cksum returned wrong path info '$pathkey' expected '$source_relpath'" + } + set cksum [dict get $ckinfo cksum] + #set cksum_all_opts [dict get $ckinfo cksum_all_opts] + set cksum_all_opts [dict get $ckinfo opts] + if {$cksum ne $prev_cksum || $ftype ne $prev_ftype || $fsize ne $prev_fsize} { + set changed 1 + } else { + set changed 0 + } + set installing_record_sources [dict_getwithdefault $installing_record body [list]] + set ts_now [clock microseconds] ;#gathering metadata - especially checksums on folder can take some time - calc and store elapsed us for time taken to gather metadata + set metadata_us [expr {$ts_now - $ts_start}] + set this_source_record [dict create tag SOURCE -type $ftype -size $fsize -path $source_relpath -cksum $cksum -cksum_all_opts $cksum_all_opts -changed $changed -metadata_us $metadata_us] + lappend installing_record_sources $this_source_record + dict set installing_record body $installing_record_sources + + lset file_record_body end $installing_record + + dict set file_record body $file_record_body + return $file_record + } + + #write back to punkcheck - don't accept recordset - invalid to update anything other than the installing_record at this time + proc installfile_started_install {punkcheck_folder file_record} { + if {![lib::is_file_record_inprogress $file_record]} { + error "installfile_started_install error: bad file_record - expected FILEINFO with last body element *-INPROGRESS" + } + set punkcheck_file [file join $punkcheck_folder/.punkcheck] + set record_list [load_records_from_file $punkcheck_file] + + set file_record_body [dict get $file_record body] + set targetlist [dict get $file_record -targets] + set installing_record [lindex $file_record_body end] + + set ts_start [dict get $installing_record -ts] + set ts_now [clock microseconds] + set metadata_us [expr {$ts_now - $ts_start}] + + dict set installing_record -metadata_us $metadata_us + dict set installing_record -ts_start_transfer $ts_now + + lset file_record_body end $installing_record + + dict set file_record body $file_record_body + + + set getresult [punkcheck::recordlist::get_file_record $targetlist $record_list] + set old_posn [dict get $getresult position] + if {$old_posn == -1} { + lappend record_list $file_record + } else { + lset record_list $old_posn $file_record + } + + save_records_to_file $record_list $punkcheck_file "installfile_started_install [llength $targetlist] targets" + return $file_record + } + proc installfile_finished_install {punkcheck_folder file_record} { + if {![lib::is_file_record_inprogress $file_record]} { + error "installfile_finished_install error: bad file_record - expected FILEINFO with last body element *-INPROGRESS" + } + set punkcheck_file [file join $punkcheck_folder/.punkcheck] + set record_list [load_records_from_file $punkcheck_file] + + set file_record_body [dict get $file_record body] + set targetlist [dict get $file_record -targets] + set installing_record [lindex $file_record_body end] + + set ts_start [dict get $installing_record -ts] + set ts_start_transfer [dict get $installing_record -ts_start_transfer] + set ts_now [clock microseconds] + set elapsed_us [expr {$ts_now - $ts_start}] + set transfer_us [expr {$ts_now - $ts_start_transfer}] + dict set installing_record -transfer_us $transfer_us + dict set installing_record -elapsed_us $elapsed_us + dict unset installing_record -tempcontext + dict set installing_record tag "INSTALL-RECORD" + + lset file_record_body end $installing_record + dict set file_record body $file_record_body + + set file_record [punkcheck::recordlist::file_record_prune $file_record] + + set oldrecordinfo [punkcheck::recordlist::get_file_record $targetlist $record_list] + set old_posn [dict get $oldrecordinfo position] + if {$old_posn == -1} { + lappend record_list $file_record + } else { + lset record_list $old_posn $file_record + } + + save_records_to_file $record_list $punkcheck_file "installfile_finished_install [llength $targetlist] targets" + return $file_record + } + proc installfile_skipped_install {punkcheck_folder file_record} { + if {![lib::is_file_record_inprogress $file_record]} { + set msg "installfile_skipped_install error: bad file_record - expected FILEINFO with last body element *-INPROGRESS" + append msg \n "received:" + append msg \n $file_record + error $msg + } + set punkcheck_file [file join $punkcheck_folder/.punkcheck] + set record_list [load_records_from_file $punkcheck_file] + + set file_record_body [dict get $file_record body] + set targetlist [dict get $file_record -targets] + set installing_record [lindex $file_record_body end] + + set ts_start [dict get $installing_record -ts] + set tsnow [clock microseconds] + set elapsed_us [expr {$tsnow - $ts_start}] + dict set installing_record -elapsed_us $elapsed_us + dict set installing_record tag "INSTALL-SKIPPED" + + lset file_record_body end $installing_record + dict set file_record body $file_record_body + + set file_record [punkcheck::recordlist::file_record_prune $file_record] + + set getresult [punkcheck::recordlist::get_file_record $targetlist $record_list] + set old_posn [dict get $getresult position] + if {$old_posn == -1} { + lappend record_list $file_record + } else { + lset record_list $old_posn $file_record + } + + save_records_to_file $record_list $punkcheck_file "installfile_skipped_install [llength $targetlist] targets" + return $file_record + } + #----------------------------------------------- + #then: file_record_add_installrecord + + namespace eval lib { + set pkg punkcheck + namespace path ::punkcheck + proc is_file_record_inprogress {file_record} { + if {[dict get $file_record tag] ne "FILEINFO"} { + return 0 + } + set installing_record [lindex [dict_getwithdefault $file_record body [list]] end] + if {[dict_getwithdefault $installing_record tag [list]] ni [list QUERY-INPROGRESS INSTALL-INPROGRESS MODIFY-INPROGRESS DELETE-INPROGRESS VIRTUAL-INPROGRESS]} { + return 0 + } + return 1 + } + proc is_file_record_installing {file_record} { + if {[dict get $file_record tag] ne "FILEINFO"} { + return 0 + } + set installing_record [lindex [dict_getwithdefault $file_record body [list]] end] + if {[dict_getwithdefault $installing_record tag [list]] ne "INSTALL-INPROGRESS"} { + return 0 + } + return 1 + } + proc file_record_get_last_installrecord {file_record} { + set body [dict_getwithdefault $file_record body [list]] + set previous_install_records [lrange $body 0 end-1] + #get last previous that is tagged INSTALL-RECORD,MODIFY-RECORD,VIRTUAL-RECORD + #REVIEW DELETERECORD ??? + set revlist [lreverse $previous_install_records] + foreach rec $revlist { + if {[dict get $rec tag] in [list "INSTALL-RECORD" "MODIFY-RECORD" "VIRTUAL-RECORD"]} { + return $rec + } + } + return [list] + } + + #should work on *-INPROGRESS or INSTALL(etc) record - don't restrict tag to INSTALL + proc install_record_get_matching_source_record {install_record source_relpath} { + set body [dict_getwithdefault $install_record body [list]] + foreach src $body { + if {[dict get $src tag] eq "SOURCE"} { + if {[dict_getwithdefault $src -path ""] eq $source_relpath} { + return $src + } + } + } + return [list] + } + + + + #maint warning - also in punk::mix::util + proc path_relative {base dst} { + #see also kettle + # Modified copy of ::fileutil::relative (tcllib) + # Adapted to 8.5 ({*}). + # + # Taking two _directory_ paths, a base and a destination, computes the path + # of the destination relative to the base. + # + # Arguments: + # base The path to make the destination relative to. + # dst The destination path + # + # Results: + # The path of the destination, relative to the base. + + # Ensure that the link to directory 'dst' is properly done relative to + # the directory 'base'. + + #review - check volume info on windows.. UNC paths? + if {[file pathtype $base] ne [file pathtype $dst]} { + return -code error "Unable to compute relation for paths of different pathtypes: [file pathtype $base] vs. [file pathtype $dst], ($base vs. $dst)" + } + + #avoid normalizing if possible - at least for relative paths which we are likely to loop on (file normalize *very* expensive on windows) + set do_normalize 0 + if {[file pathtype $base] eq "relative"} { + #if base is relative so is dst + if {[regexp {[.]{2}} [list $base $dst]]} { + set do_normalize 1 + } + if {[regexp {[.]/} [list $base $dst]]} { + set do_normalize 1 + } + } else { + #case differences in volumes is common on windows + set do_normalize 1 + } + if {$do_normalize} { + set base [file normalize $base] + set dst [file normalize $dst] + } + + set save $dst + set base [file split $base] + set dst [file split $dst] + + while {[lindex $dst 0] eq [lindex $base 0]} { + set dst [lrange $dst 1 end] + set base [lrange $base 1 end] + if {![llength $dst]} {break} + } + + set dstlen [llength $dst] + set baselen [llength $base] + + if {($dstlen == 0) && ($baselen == 0)} { + # Cases: + # (a) base == dst + + set dst . + } else { + # Cases: + # (b) base is: base/sub = sub + # dst is: base = {} + + # (c) base is: base = {} + # dst is: base/sub = sub + + while {$baselen > 0} { + #set dst [linsert $dst 0 ..] + ledit dst -1 -1 .. + incr baselen -1 + } + set dst [file join {*}$dst] + } + + return $dst + } + } + #skip writing punkcheck during checksum/timestamp checks + + #todo - punk::args - fetch from punkcheck::install (with overrides) + proc install_tm_files {srcdir basedir args} { + set defaults [list {*}{ + -glob *.tm + -installer punkcheck::install_tm_files + } -exclude-filetails [list "*[punk::mix::util::tm_version_magic]*"] {*}{ + } + ] + set opts [dict merge $defaults $args] + punkcheck::install $srcdir $basedir {*}$opts + } + proc install_non_tm_files {srcdir basedir args} { + #set keys [dict keys $args] + #adjust the default excludedirseg_core entries so that .fossil-custom, .fossil-settings are copied + set excludedirseg_core [punkcheck::default_excludedirseg_core] + set posn [lsearch $excludedirseg_core ".fossil*"] + if {$posn >=0} { + ledit excludedirseg_core $posn $posn + } + set defaults [list {*}{ + } -glob * {*}{ + } -exclude-filetails [list "*.tm" "*-buildversion.txt" "*.exe"] {*}{ + } -exclude-dirsegments_core $excludedirseg_core {*}{ + } -installer punkcheck::install_non_tm_files {*}{ + } + ] + set opts [dict merge $defaults $args] + punkcheck::install $srcdir $basedir {*}$opts + } + + #for tcl8.6 - tcl8.7+ has dict getwithdefault (dict getdef) + proc dict_getwithdefault {dictValue args} { + if {[llength $args] < 2} { + error {wrong # args: should be "dict_getdef dictionary ?key ...? key default"} + } + set keys [lrange $args 0 end-1] + if {[dict exists $dictValue {*}$keys]} { + return [dict get $dictValue {*}$keys] + } else { + return [lindex $args end] + } + } + lappend PUNKARGS [list { + @id -id ::punkcheck::install + @cmd -name ::punkcheck::install -help\ + "Unidirectional file transfer to possibly non-empty target folder. + This is the simpler form of the API, performing a transfer from one + directory tree to another, copying each file when changes in the source + file are detected. + Changes are detected by content checksum. The first install will record + source checksums in a .punkcheck file (ideally located at the root of the + target folder). Subsequent installs will compare stored checksums with + the current checksums of the source files. + For more advanced install operations, the object command installtrack + can be used to define install operations. e.g when the transfer is not + one-to-one and a target file depends on multiple source files." + @leaders -min 2 -max 2 + srcdir -type directory + tgtdir -type directory + -call-depth-internal -type integer -default 0 -help "(internal recursion tracker)" + -subdirlist -type list -default "" -help "(primarily internal - length generally matching -call-depth-internal)" + -max_depth -type integer -default 1000 -help\ + "Deepest subdirectory - use -1 for no limit." + -createdir -type boolean -default 0 -help\ + "Whether to create the folder at tgtdir. + Any required subdirectories are created regardless of this setting." + -createempty -type boolean -default 0 -help\ + "Whether to create folders at target that had no matches for our glob" + -glob -type string -default "*" -help\ + "Pattern matching for source file(s) to copy. Can be glob based or exact match." + -exclude-filetails_core -default {${[::punkcheck::default_excludefiltail_core]}} + -exclude-filetails -default "" + -exclude-dirsegments_core -default {${[::punkcheck::default_excludedirseg_core]}} + -exclude-dirsegments -default "" + -antiglob_paths -default {} + -overwrite -default no-targets\ + -choices {no-targets newer-targets older-targets all-targets installedsourcechanged-targets synced-targets}\ + -choicecolumns 1\ + -choicelabels { + no-targets "only copy files that are missing at the target" + newer-targets "copy files with older source timestamp over newer + target timestamp and those missing at the target + (a form of 'restore' operation)" + older-targets "copy files with newer source timestamp over older + target timestamp and those missing at the target" + all-targets "copy regardless of timestamp at target" + installedsourcechanged-targets "copy if the target doesn't exist or the source changed" + synced-targets "copy if the target doesn't exist or the source changed + and the target cksum is the same as the last INSTALL-RECORD -targets_cksums entry" + } + -source_checksum -default comparestore -choicecolumns 3 -choices {compare store comparestore false true}\ + -choicelabels { + true "same as comparestore" + } + -punkcheck_folder -default target -choices {target source project} -choicerestricted 0 -help\ + "The location of the .punkcheck file to track installations and checksums. + The default value 'target' is generally recommended. + Can also be an absolute path to a folder." + -punkcheck_records -default "" -help\ + "Empty string or a parsed TDL records structure. + e.g + {tag FILEINFO - ... body { + {tag INSTALL-RECORD - ... body {}} + ... + }... + }" + -installer -default "punkcheck::install" -help\ + "A user nominated string that is stored in the .punkcheck file + This might be the name of a script or installation process." + -progresschannel -default none -type string -help\ + "Name of channel e.g stderr, stdout to which progress messages are written. + This includes the tree-like output consisting of dots (or green U) for each + file processed. As the number of files in a tree is not known beforehand, + it isn't useful for a percentage-based progress meter, but it could potentially + be used to drive a spinner if the textual data is not desired. + Setting to none or an invalid channel will deactivate the output." + }] + ## unidirectional file transfer to possibly non empty folder + #default of -overwrite no-targets will only copy files that are missing at the target + # -overwrite newer-targets will copy files with older source timestamp over newer target timestamp and those missing at the target (a form of 'restore' operation) + # -overwrite older-targets will copy files with newer source timestamp over older target timestamp and those missing at the target + # -overwrite all-targets will copy regardless of timestamp at target + # -overwrite installedsourcechanged-targets will copy if the target doesn't exist or the source changed + # -overwrite synced-targets will copy if the target doesn't exist or the source changed and the target cksum is the same as the last INSTALL-RECORD -targets_cksums entry + # review - timestamps unreliable + # - what about slightly mismatched system clocks and mounted filesystems? caller responsibility to verify first? + # if timestamp exactly equal - should we check content-hash? This is presumably only likely to occur deliberately(maliciously?) + # e.g some process that digitally signs or otherwise modifies a file and preserves update timestmp? + # if such a content-mismatch - what default behaviour and what options would make sense? + # probably it's reasonable that only all-targets would overwrite such files. + # consider -source_fudge_seconds +-X ?, -source_override_timestamp ts ??? etc which only adjust timestamp for calculation purposes? Define a specific need/usecase when reviewing. + # + # valid filetypes for src tgt + # src dir tgt dir + # todo - review and consider enabling symlink src and dst + # no need for src file - as we use -glob with no glob characters to match one source file file + # no ability to target file with different name - keep it simpler and caller will have to use an intermediate folder/file if they need to rename something? + # + # todo - determine what happens if mismatch between file type of a src vs target e.g target has dir matching filename at source + # A pre-scan to determine no such conflict - before attempting to copy anything might provide the most integrity at slight cost in speed. + # REVIEW we should only expect dirs to be created as necessary to hold files? i.e target folder won't be created if no source file matches for that folder + # -source_checksum compare|store|comparestore|false|true where true == comparestore + # -punkcheck_folder target|source|project| target is default and is generally recommended + # -punkcheck_records empty string | parsed TDL records ie {tag xxx k v} structure + # install creates FILEINFO records with a single entry in the -targets field (it is legitimate to have a list of targets for an installation operation - the oo interface supports this) + proc install {srcdir tgtdir args} { + set defaults [list {*}{ + -call-depth-internal 0 + -max_depth 1000 + -subdirlist {} + -createdir 0 + -createempty 0 + -glob * + -exclude-filetails_core "\uFFFF" + -exclude-filetails "" + -exclude-dirsegments_core "\uFFFF" + -exclude-dirsegments {} + -antiglob_paths {} + -overwrite no-targets + -source_checksum comparestore + -punkcheck_folder target + -punkcheck_eventid "\uFFFF" + -punkcheck_records "" + -installer punkcheck::install + -progresschannel none + }] + + if {([llength $args] %2) != 0} { + error "punkcheck::install requires option-style arguments to be in pairs. Received args: $args" + } + foreach {k -} $args { + if {$k ni [dict keys $defaults]} { + error "punkcheck::install unrecognised option '$k' known options: '[dict keys $defaults]'" + } + } + set opts [dict merge $defaults $args] + + #The choice to recurse using the original values of srcdir & tgtdir, and passing the subpath down as a list in -subdirlist seems an odd one. + #(as opposed to a more 'standard' mechanism of adjusting srcdir & tgtdir as we move down the tree) + #It comes from build_modules_from_source_to_base where we need to keep track of position relative to our targetdir starting point to handle submodules e.g pkg::something::mypkg-0.1.tm + #It could have been handled with some other parameter such as -depth, but this -subdirlist mechanism, whilst perhaps not beautiful, is straightforward enough + #and may be less error prone than doing slightly more opaque path manipulations at each recursion level to determine where we started + #For consistency - we'll use the same mechanism in various recursive directory walking procedures such as this one. + set CALLDEPTH [dict get $opts -call-depth-internal] ;#added for extra debug/sanity checking - clearer test for initial function call ie CALLDEPTH = 0 + set max_depth [dict get $opts -max_depth] ;# -1 for no limit + set subdirlist [dict get $opts -subdirlist] ;# generally should be same length as CALLDEPTH - but user could prefill + set fileglob [dict get $opts -glob] + set createdir [dict get $opts -createdir] ;#defaults to zero to help avoid mistakes with initial target dir - required target subdirs are created regardless of this setting + set opt_createempty [dict get $opts -createempty] + set opt_progresschannel [dict get $opts -progresschannel] + if {$opt_progresschannel in {"" none} || [catch {chan configure $opt_progresschannel}]} { + set opt_progresschannel "" + } + + if {$CALLDEPTH == 0} { + #expensive to normalize but we need to do it at least once + set srcdir [file normalize $srcdir] + set tgtdir [file normalize $tgtdir] + if {$createdir} { + file mkdir $tgtdir + } else { + if {![file exists $tgtdir]} { + error "punkcheck::install base target dir:'$tgtdir' doesn't exist (srcdir:$srcdir tgtdir:$tgtdir args:'$args')" + } + } + if {([file type $srcdir] ni [list directory]) || ([file type $tgtdir] ni [list directory])} { + error "punkcheck::install requires source and target dirs to be of type 'directory' type current source: [file type $srcdir] type current target: [file type $tgtdir]" + } + #now the values we build from these will be properly cased + } + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + set opt_excludefiletail_core [dict get $opts -exclude-filetails_core] + if {$opt_excludefiletail_core eq "\uFFFF"} { + set opt_excludefiletail_core [default_excludefiletail_core] + dict set opts -exclude-filetails_core $opt_excludefiletail_core + } + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + set opt_excludefiletail [dict get $opts -exclude-filetails] + #validate no path seps + foreach af $opt_excludefiletail { + if {[llength [file split $af]] > 1} { + error "punkcheck::install received invalid -exclude-filetails entry '$af'. -exclude-filetails entries are meant to match to a file name at any level so cannot contain path separators" + } + } + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + set opt_excludedirseg_core [dict get $opts -exclude-dirsegments_core] + if {$opt_excludedirseg_core eq "\uFFFF"} { + set opt_excludedirseg_core [default_excludedirseg_core] + dict set opts -exclude-dirsegments_core $opt_excludedirseg_core + } + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + set opt_excludedirseg [dict get $opts -exclude-dirsegments] + #validate no path seps + foreach ad $opt_excludedirseg { + if {[llength [file split $ad]] > 1} { + error "punkcheck::install received invalid -exclude-dirsegments entry '$ad'. -exclude-dirsegments entries are meant to match to a directory name at any level so cannot contain path separators" + } + } + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + set opt_antiglob_paths [dict get $opts -antiglob_paths] ;#todo - combine with config file in source tree .punkcheckpublish (?) + #antiglob_paths will usually contain file separators - and may contain glob patterns within each segment + set antiglob_paths_matched [list] + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + set known_whats [list no-targets newer-targets older-targets all-targets installedsourcechanged-targets synced-targets] + set overwrite_what [string tolower [dict get $opts -overwrite]]; #accept any case for value to allow emphasis by caller e.g -overwrite NEWER-TARGETS + if {$overwrite_what ni $known_whats} { + error "punkcheck::install received unrecognised value for -overwrite. Received value '$overwrite_what' vs known values '$known_whats'" + } + if {$overwrite_what in [list newer-targets older-targets]} { + error "punkcheck::install newer-target, older-targets not implemented - sorry" + #TODO - check crossplatform availability of ctime (on windows it still seems to be creation time, but on bsd/linux it's last attribute mod time) + # external pkg? use twapi and ctime only on other platforms? + } + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + set opt_source_checksum [dict get $opts -source_checksum] + if {[string is boolean $opt_source_checksum]} { + if {$opt_source_checksum} { + set opt_source_checksum "comparestore" + } else { + set opt_source_checksum 0 + } + dict set opts -source_checksum $opt_source_checksum + } + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + set opt_punkcheck_folder [dict get $opts -punkcheck_folder] + if {$opt_punkcheck_folder eq "target"} { + set punkcheck_folder $tgtdir + } elseif {$opt_punkcheck_folder eq "source"} { + set punkcheck_folder $srcdir + } elseif {$opt_punkcheck_folder eq "project"} { + set sourceprojectinfo [punk::repo::find_repos $srcdir] + set targetprojectinfo [punk::repo::find_repos $tgtdir] + set srcproj [lindex [dict get $sourceprojectinfo project] 0] + set tgtproj [lindex [dict get $targetprojectinfo project] 0] + if {$srcproj eq $tgtproj} { + set punkcheck_folder $tgtproj + } else { + error "copy_files_from_source_to_target error: Unable to find common project dir for source and target folder - use absolutepath for -punkcheck_folder if source and target are not within same project" + } + } else { + set punkcheck_folder $opt_punkcheck_folder + } + if {$punkcheck_folder ne ""} { + if {[file pathtype $punkcheck_folder] ne "absolute"} { + error "copy_files_from_source_to_target error: -punkcheck_folder '$punkcheck_folder' must be an absolute path, or one of: target|source|project" + } + if {![file isdirectory $punkcheck_folder]} { + error "copy_files_from_source_to_target error: -punkcheck_folder '$punkcheck_folder' not found" + } + } else { + #review - leave empty? use pwd? + } + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + set punkcheck_records [dict get $opts -punkcheck_records] + set punkcheck_records_init $punkcheck_records ;#change-detection + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + set opt_installer [dict get $opts -installer] + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + set opt_punkcheck_eventid [dict get $opts -punkcheck_eventid] + + + + set punkcheck_file [file join $punkcheck_folder/.punkcheck] + + if {$CALLDEPTH == 0} { + set punkcheck_eventid "" + if {$punkcheck_folder ne ""} { + set config $opts + dict unset config -call-depth-internal + dict unset config -max_depth + dict unset config -subdirlist + dict unset config -progresschannel + tcl::dict::for {k v} $config { + if {$v eq "\uFFFF"} { + dict unset config $k + } + } + lassign [punkcheck::start_installer_event $punkcheck_file $opt_installer $srcdir $tgtdir $config] _eventid punkcheck_eventid _recordset punkcheck_records + } + } else { + set punkcheck_eventid $opt_punkcheck_eventid + } + + + + if {$opt_source_checksum != 0} { + #we need to read the file even if only set to store (or we would overwrite entries) + set compare_cksums 1 + } else { + set compare_cksums 0 + } + + if {[string match *store* $opt_source_checksum]} { + set store_source_cksums 1 + } else { + set store_source_cksums 0 + } + + + + + + if {[llength $subdirlist] == 0} { + set current_source_dir $srcdir + set current_target_dir $tgtdir + } else { + set current_source_dir $srcdir/[file join {*}$subdirlist] + set current_target_dir $tgtdir/[file join {*}$subdirlist] + } + + + set relative_target_dir [lib::path_relative $tgtdir $current_target_dir] + if {$relative_target_dir eq "."} { + set relative_target_dir "" + } + set relative_source_dir [lib::path_relative $srcdir $current_source_dir] + if {$relative_source_dir eq "."} { + set relative_source_dir "" + } + set target_relative_to_punkcheck_dir [lib::path_relative $punkcheck_folder $current_target_dir] + if {$target_relative_to_punkcheck_dir eq "."} { + set target_relative_to_punkcheck_dir "" + } + foreach unpub $opt_antiglob_paths { + #puts "testing folder - globmatchpath $unpub $relative_source_dir" + if {[punk::path::globmatchpath $unpub $relative_source_dir]} { + lappend antiglob_paths_matched $current_source_dir + return [list files_copied {} files_skipped {} sources_unchanged {} punkcheck_records $punkcheck_records antiglob_paths_matched $antiglob_paths_matched srcdir $srcdir tgtdir $tgtdir punkcheck_folder $punkcheck_folder] + } + } + + + if {![file exists $current_source_dir]} { + error "punkcheck::install current source dir:'$current_source_dir' doesn't exist (srcdir:$srcdir tgtdir:$tgtdir args:'$args')" + } + + set files_copied [list] + set files_skipped [list] + set sources_unchanged [list] + + + set candidate_list [glob -nocomplain -dir $current_source_dir -type f -tail $fileglob] + set hidden_candidate_list [glob -nocomplain -dir $current_source_dir -types {hidden f} -tail $fileglob] + foreach h $hidden_candidate_list { + if {$h ni $candidate_list} { + lappend candidate_list $h + } + } + set match_list [list] + foreach m $candidate_list { + set suppress 0 + foreach anti [concat $opt_excludefiletail_core $opt_excludefiletail] { + if {[string match $anti $m]} { + #puts stderr "anti: $anti vs m:$m" + set suppress 1 + break + } + } + if {$suppress == 0} { + lappend match_list $m + } + } + + #sample .punkcheck file record (raw form) to make the code clearer + #punk::tdl converts to dict form e.g: tag FILEINFO -targets filename body sublist + #Valid installrecord types are INSTALL-RECORD SKIPPED INSTALL-INPROGRESS, MODIFY-RECORD MODIFY-INPROGRESS DELETE-RECORD DELETE-INPROGRESS + # + #FILEINFO -targets jjjetc-0.1.0.tm -keep_installrecords 2 -keep_skipped 1 -keep_inprogress 2 { + # INSTALL-RECORD -tsiso 2023-09-20T07:30:30 -ts 1695159030266610 -installer punk::mix::cli::build_modules_from_source_to_base -metadata_us 18426 -ts_start_transfer 1695159030285036 -transfer_us 10194 -elapsed_us 28620 { + # SOURCE -type file -path ../src/modules/jjjetc-buildversion.txt -cksum c7c71839c36b3d21c8370fed106192fcd659eca9 -cksum_all_opts {-cksum_content 1 -cksum_meta 0 -cksum_acls 0 -cksum_usetar 0 -cksum_algorithm sha1} -changed 1 -metadata_us 3423 + # SOURCE -type file -path ../src/modules/jjjetc-0.1.1.tm -cksum b646fc2ee88cbd068d2e946fe929b7aea96bd39d -cksum_all_opts {-cksum_content 1 -cksum_meta 0 -cksum_acls 0 -cksum_usetar 0 -cksum_algorithm sha1} -changed 1 -metadata_us 3413 + # } + # INSTALL-SKIPPED -tsiso 2023-09-20T08:14:26 -ts 1695161666087880 -installer punk::mix::cli::build_modules_from_source_to_base -elapsed_us 18914 { + # SOURCE -type file -path ../src/modules/jjjetc-buildversion.txt -cksum c7c71839c36b3d21c8370fed106192fcd659eca9 -cksum_all_opts {-cksum_content 1 -cksum_meta 0 -cksum_acls 0 -cksum_usetar 0 -cksum_algorithm sha1} -changed 0 -metadata_us 3435 + # SOURCE -type file -path ../src/modules/jjjetc-0.1.1.tm -cksum b646fc2ee88cbd068d2e946fe929b7aea96bd39d -cksum_all_opts {-cksum_content 1 -cksum_meta 0 -cksum_acls 0 -cksum_usetar 0 -cksum_algorithm sha1} -changed 0 -metadata_us 3338 + # } + #} + + if {[llength $match_list]} { + #example - target dir has a file where there is a directory at the source + if {[file exists $current_target_dir] && ([file type $current_target_dir] ni [list directory])} { + error "punkcheck::install target subfolder $current_target_dir exists but is not of type 'directory'. Type current target folder: [file type $current_target_dir]" + } + } + + #proc get_relativecksum_from_base_and_fullpath {base fullpath args} + + + #puts stdout "Current target dir: $current_target_dir" + set last_depth "" + foreach m $match_list { + set new_tgt_cksum_info [list] + set relative_target_path [file join $relative_target_dir $m] + set relative_source_path [file join $relative_source_dir $m] + set punkcheck_target_relpath [file join $target_relative_to_punkcheck_dir $m] + set is_antipath 0 + foreach antipath $opt_antiglob_paths { + #puts "testing file - globmatchpath $antipath vs $relative_source_path" + if {[punk::path::globmatchpath $antipath $relative_source_path]} { + lappend antiglob_paths_matched $current_source_dir + set is_antipath 1 + break + } + } + if {$is_antipath} { + continue + } + + set ts_start [clock microseconds] + set seconds [expr {$ts_start / 1000000}] + set ts_start_iso [clock format $seconds -format "%Y-%m-%dT%H:%M:%S"] + + + #puts stdout " rel_target: $punkcheck_target_relpath" + + set fetch_filerec_result [punkcheck::recordlist::get_file_record $punkcheck_target_relpath $punkcheck_records] + #change to use extract_or_create_fileset_record ? + set existing_filerec_posn [dict get $fetch_filerec_result position] + if {$existing_filerec_posn == -1} { + if {$opt_progresschannel ne ""} { + puts stdout "\nNO existing record for $punkcheck_target_relpath" + } + set has_filerec 0 + set new_filerec [dict create tag FILEINFO -targets $punkcheck_target_relpath] + set filerec $new_filerec + } else { + set has_filerec 1 + #puts stdout " TDL existing FILEINFO record for $punkcheck_target_relpath" + #puts stdout " $existing_install_record" + set filerec [dict get $fetch_filerec_result record] + } + set filerec [punkcheck::recordlist::file_record_set_defaults $filerec] + + #new INSTALLREC must be tagged as INSTALL-INPROGRESS to use recordlist::installfile_ method + set new_install_record [dict create tag INSTALL-INPROGRESS -tsiso $ts_start_iso -ts $ts_start -installer $opt_installer -eventid $punkcheck_eventid] + dict lappend filerec body $new_install_record ;#can't use recordlist::file_record_add_installrecord as '*-INPROGRESS' isn't a final tag - so pruning would be mucked up. No need to prune now anyway. + unset new_install_record + + + if {$opt_progresschannel ne ""} { + if {$last_depth ne $CALLDEPTH} { + if {$CALLDEPTH <=1} { + puts -nonewline $opt_progresschannel \n[string repeat " " $CALLDEPTH][file tail $relative_source_dir] + } + flush $opt_progresschannel + ##set last_depth $CALLDEPTH ;# done down below + } + } + + + + set relative_source_path [lib::path_relative $punkcheck_folder $current_source_dir/$m] + #puts stdout " rel_source: $relative_source_path" + #if {[file pathtype $relative_source_path] ne "relative"} { + #REVIEW + #different volume or root + #} + #Note this isn't a recordlist function - so it doesn't purely operate on the records + #this hits the filesystem for the sourcepath - gets checksums/timestamps depending on config. + #It doesn't save to .punkcheck (the only punkcheck::installfile_ method which doesn't) + set ts1 [clock milliseconds] + set filerec [punkcheck::installfile_add_source_and_fetch_metadata $punkcheck_folder $relative_source_path $filerec] + set ts2 [clock milliseconds] + set diff [expr {$ts2 - $ts1}] + if {$diff > 100} { + #todo -errorchannel + set errprefix ">>> punkcheck:" + puts stderr "\n$errprefix performance warning: fetch_metadata for $m took $diff ms." + set lb [lindex [dict get $filerec body] end] + #puts stderr "$errprefix filerec last body record:$lb" + set records [dict get $lb body] + set lr [lindex $records end] + set alg [dict get $lr -cksum_all_opts -cksum_algorithm] + if {$alg eq "sha1"} { + puts stderr "$errprefix cksum_algorithm: sha1 (accelerators: [::sha1::Implementations])" + puts stderr "$errprefix sha1 from: [package ifneeded sha1 [package present sha1]]" + } else { + puts stderr "$errprefix cksum_algorithm: $alg" + } + } + + + + #changeinfo comes from last record in body - which is the record we are working on and so will always exist + set changeinfo [punkcheck::recordlist::file_install_record_source_changes [lindex [dict get $filerec body] end]] + set changed [dict get $changeinfo changed] + set unchanged [dict get $changeinfo unchanged] + + if {[llength $unchanged]} { + lappend sources_unchanged $current_source_dir/$m + } + + set is_skip 0 + set is_new 0 + if {$overwrite_what eq "all-targets"} { + file mkdir $current_target_dir + #-------------------------------------------- + #sometimes we get the error: 'error copying "file1" to "file2": invalid argument' + #-------------------------------------------- + puts stderr "punkcheck: about to: file copy -force $current_source_dir/$m $current_target_dir" + file copy -force $current_source_dir/$m $current_target_dir + lappend files_copied $current_source_dir/$m + } else { + if {![file exists $current_target_dir/$m]} { + #puts stderr "punkcheck: first copy to $current_target_dir/$m " + file mkdir $current_target_dir + puts stderr "punkcheck: about to: file copy $current_source_dir/$m $current_target_dir" + file copy $current_source_dir/$m $current_target_dir + set new_tgt_cksum_info [punk::mix::base::lib::cksum_path $current_target_dir/$m] + lappend files_copied $current_source_dir/$m + incr filecount_new + set is_new 1 + } else { + switch -- $overwrite_what { + installedsourcechanged-targets { + if {[llength $changed]} { + #An unrecorded installation is considered a source change (from unknown/unrecorded source to recorded) + puts -nonewline stderr "punkcheck: about to: file copy -force $current_source_dir/$m $current_target_dir" + set ts1 [clock milliseconds] + file mkdir $current_target_dir + file copy -force $current_source_dir/$m $current_target_dir + set ts2 [clock milliseconds] + puts -nonewline stderr " (copy time [expr {$ts2 - $ts1}] ms)" + set new_tgt_cksum_info [punk::mix::base::lib::cksum_path $current_target_dir/$m] + set ts3 [clock milliseconds] + puts stderr " (cksum time [expr {$ts2 - $ts1}] ms)" + lappend files_copied $current_source_dir/$m + } else { + set is_skip 1 + lappend files_skipped $current_source_dir/$m + } + } + synced-targets { + #disallow overwriting of target that has been modified by some other mechanism + #review + if {[llength $changed]} { + #only overwrite if the target file checksum equals the last installed checksum (ie target is in sync with previous source-set and so hasn't been customized) + set existing_tgt_cksum_info [punk::mix::base::lib::cksum_path $current_target_dir/$m] + set is_target_unmodified_since_install 0 + set target_cksum_compare "unknown" + set latest_install_record [punkcheck::recordlist::file_record_latest_installrecord $filerec] ;#may be no such record - in which case we get an empty list + if {[dict exists $latest_install_record -targets_cksums]} { + set last_install_cksum [dict get $latest_install_record -targets_cksums] ;#in this case we know there is only one as 'install' always uses targetset size of 1. (FILEINFO record per file in source folder) + if {[dict get $existing_tgt_cksum_info cksum] eq $last_install_cksum} { + set is_target_unmodified_since_install 1 + set target_cksum_compare "match" + } else { + set target_cksum_compare "nomatch" + } + } else { + set target_cksum_compare "norecord" + } + if {$is_target_unmodified_since_install} { + file mkdir $current_target_dir + puts stderr "punkcheck: synced-targets about to: file copy -force $current_source_dir/$m $current_target_dir" + file copy -force $current_source_dir/$m $current_target_dir + set new_tgt_cksum_info [punk::mix::base::lib::cksum_path $current_target_dir/$m] + lappend files_copied $current_source_dir/$m + } else { + #either cksum is different or we were unable to verify the record. Either way we can't know if the target is in sync so we must skip it + set is_skip 1 + puts stderr "Skipping file copy $m target $current_target_dir/$m - require synced_target to overwrite - current target cksum compared to previous install: $target_cksum_compare" + lappend files_skipped $current_source_dir/$m + } + } else { + set is_skip 1 + lappend files_skipped $current_source_dir/$m + } + } + default { + set is_skip 1 + puts stderr "Skipping file copy $m target $current_target_dir/$m already exists (use -overwrite all-targets to overwrite)" + #TODO! implement newer-targets older-targets? (note ctimes/mtimes are unreliable - may not be worth implementing) + lappend files_skipped $current_source_dir/$m + } + } + } + } + #target dir was created as necessary if files matched above + #now ensure target dir exists if -createempty true + if {$opt_createempty && ![file exists $current_target_dir]} { + file mkdir $current_target_dir + } + + + + + set ts_now [clock microseconds] + set elapsed_us [expr {$ts_now - $ts_start}] + + #if {$store_source_cksums} { + #} + + set install_records [dict get $filerec body] + set current_install_record [lindex $install_records end] + #change the tag from *-INPROGRESS to INSTALL-RECORD/SKIPPED + if {$is_skip} { + set tag INSTALL-SKIPPED + } else { + set tag INSTALL-RECORD + } + dict set current_install_record tag $tag + dict set current_install_record -elapsed_us $elapsed_us + if {[llength $new_tgt_cksum_info]} { + dict set current_install_record -targets_cksums [list [dict get $new_tgt_cksum_info cksum]] + dict set current_install_record -cksum_all_opts [dict get $new_tgt_cksum_info opts] + } + lset install_records end $current_install_record + dict set filerec body $install_records + set filerec [punkcheck::recordlist::file_record_prune $filerec] ;#prune now that tag is finalized + if {!$has_filerec} { + #not found in original recordlist - append + lappend punkcheck_records $filerec + } else { + lset punkcheck_records $existing_filerec_posn $filerec + } + + + #------------------------------------------------------------ + if {$is_skip} { + set mark . + } else { + if {$is_new} { + set mark \x1b\[32\;1mN\x1b\[m + } else { + #updated + set mark \x1b\[32\;1mU\x1b\[m + } + } + if {$opt_progresschannel ne ""} { + if {$last_depth ne $CALLDEPTH} { + puts -nonewline $opt_progresschannel \n[string repeat " " $CALLDEPTH]$mark + flush $opt_progresschannel + set last_depth $CALLDEPTH + } else { + puts -nonewline $opt_progresschannel $mark + } + } + #------------------------------------------------------------ + + } + + if {$max_depth != -1 && $CALLDEPTH >= $max_depth} { + #don't process any more subdirs + #sometimes deliberately called with max_depth 1 - so don't warn here. review + #puts stderr "punkcheck::install warning - reached max_depth $max_depth" + set subdirs [list] + } else { + set subdirs [glob -nocomplain -dir $current_source_dir -type d -tail *] + set hiddensubdirs [glob -nocomplain -dir $current_source_dir -type {hidden d} -tail *] + foreach h $hiddensubdirs { + switch -- $h { + "." - ".." { + continue + } + default { + if {$h ni $subdirs} { + lappend subdirs $h + } + } + } + } + } + #puts stderr "subdirs: $subdirs" + foreach d $subdirs { + set skipd 0 + foreach dg [concat $opt_excludedirseg_core $opt_excludedirseg] { + if {[string match $dg $d]} { + #puts stdout "SKIPPING FOLDER $d due to excludedirseg-match: $dg " + set skipd 1 + break + } + } + if {$skipd} { + continue + } + + set relative_source_path [file join $relative_source_dir $d] + set is_antipath 0 + foreach antipath $opt_antiglob_paths { + #puts "testing folder - globmatchpath $antipath vs $relative_source_path" + if {[punk::path::globmatchpath $antipath $relative_source_path]} { + lappend antiglob_paths_matched [file join $current_source_dir $d] + #puts stdout "SKIPPING FOLDER $relative_source_path due to antiglob_path-match: $antipath " + set is_antipath 1 + break + } + } + if {$is_antipath} { + continue + } + + #if {![file exists $current_target_dir/$d]} { + # file mkdir $current_target_dir/$d + #} + + + set sub_opts_1 [list {*}{ + } -call-depth-internal [expr {$CALLDEPTH + 1}] {*}{ + } -subdirlist [list {*}$subdirlist $d] {*}{ + } -glob $fileglob {*}{ + } -exclude-filetails_core $opt_excludefiletail_core {*}{ + } -exclude-filetails $opt_excludefiletail {*}{ + } -exclude-dirsegments_core $opt_excludedirseg_core {*}{ + } -exclude-dirsegments $opt_excludedirseg {*}{ + } -overwrite $overwrite_what {*}{ + } -source_checksum $opt_source_checksum {*}{ + } -punkcheck_folder $punkcheck_folder {*}{ + } -punkcheck_eventid $punkcheck_eventid {*}{ + } -punkcheck_records $punkcheck_records {*}{ + } -installer $opt_installer {*}{ + } + ] + set sub_opts [list {*}{ + } -call-depth-internal [expr {$CALLDEPTH + 1}] {*}{ + } -subdirlist [list {*}$subdirlist $d] {*}{ + } -punkcheck_folder $punkcheck_folder {*}{ + } -punkcheck_eventid $punkcheck_eventid {*}{ + } -punkcheck_records $punkcheck_records {*}{ + } -progresschannel $opt_progresschannel {*}{ + } + ] + set sub_opts [dict merge $opts $sub_opts] + set sub_result [punkcheck::install $srcdir $tgtdir {*}$sub_opts] + + lappend files_copied {*}[dict get $sub_result files_copied] + lappend files_skipped {*}[dict get $sub_result files_skipped] + lappend sources_unchanged {*}[dict get $sub_result sources_unchanged] + lappend antiglob_paths_matched {*}[dict get $sub_result antiglob_paths_matched] + set punkcheck_records [dict get $sub_result punkcheck_records] + } + + if {[string match *store* $opt_source_checksum]} { + #puts "subdirlist: $subdirlist" + if {$CALLDEPTH == 0} { + if {[llength $files_copied] || [llength $files_skipped]} { + #puts stdout ">>>>>>>>>>>>>>>>>>>" + set saveresult [punkcheck::save_records_to_file $punkcheck_records $punkcheck_file "install $srcdir to $tgtdir"] + puts stdout "\npunkcheck::install [dict get $saveresult recordcount] records saved as [dict get $saveresult linecount] lines to $punkcheck_file copied: [llength $files_copied] skipped: [llength $files_skipped]" + #puts stdout ">>>>>>>>>>>>>>>>>>>" + } else { + #todo - write db INSTALLER record if -debug true + + } + #puts stdout "sources_unchanged" + #puts stdout "$sources_unchanged" + #puts stdout "- -- --- --- --- ---" + } + } + + return [list files_copied $files_copied files_skipped $files_skipped sources_unchanged $sources_unchanged antiglob_paths_matched $antiglob_paths_matched punkcheck_records $punkcheck_records punkcheck_folder $punkcheck_folder srcdir $srcdir tgtdir $tgtdir] + } + + + lappend PUNKARGS [list { + @id -id ::punkcheck::summarize_install_resultdict + @cmd -name punkcheck::summarize_install_resultdict -help\ + "Emits a string summarizing a punkcheck resultdict, showing + how many items were copied, and the source, target locations" + @opts + -title -type string -default "" + -forcecolour -type boolean -default 0 -help\ + "When true, passes the forcecolour tag to punk::ansi functions. + This enables ANSI sgr colours even when colour + is off. (ignoring env(NO_COLOR)) + To disable colour - ensure the NO_COLOR env var is set, + or use: + namespace eval ::punk::console {variable colour_disabled 1}" + @values -min 1 -max 1 + resultdict -type dict + }] + proc summarize_install_resultdict {args} { + set argd [punk::args::parse $args withid ::punkcheck::summarize_install_resultdict] + lassign [dict values $argd] leaders opts values received + set title [dict get $opts -title] + set forcecolour [dict get $opts -forcecolour] + set resultdict [dict get $values resultdict] + + set has_ansi [expr {![catch {package require punk::ansi}]}] + if {$has_ansi} { + if {$forcecolour} { + set fc "forcecolour" + } else { + set fc "" + } + set R [punk::ansi::a] ;#reset + set LINE_COLOUR [punk::ansi::a+ {*}$forcecolour bold cyan] + set LOW_COLOUR [punk::ansi::a+ {*}$forcecolour bold green] + set HIGH_COLOUR [punk::ansi::a+ {*}$forcecolour bold yellow] + } else { + set R "" + set LINE_COLOUR "" + set LOW_COLOUR "" + set HIGH_COLOUR "" + } + + set msg "" + if {[dict size $resultdict]} { + set copied [dict get $resultdict files_copied] + if {[llength $copied] == 0} { + set HIGHLIGHT $LOW_COLOUR + } else { + set HIGHLIGHT $HIGH_COLOUR + } + set ruler $LINE_COLOUR[string repeat - 78]$R + if {$title ne ""} { + append msg $ruler \n + append msg $title \n + } + append msg $ruler \n + #append msg "[dict keys $resultdict]" \n + set tgtdir [dict get $resultdict tgtdir] + set checkfolder [dict get $resultdict punkcheck_folder] + append msg "${HIGHLIGHT}Copied [llength $copied] files from [dict get $resultdict srcdir] to [dict get $resultdict tgtdir]$R" \n + foreach f $copied { + append msg "COPIED [punkcheck::lib::path_relative $checkfolder $f]" \n + append msg " TO $tgtdir" \n + } + append msg "[llength [dict get $resultdict sources_unchanged]] unchanged source files" \n + append msg "[llength [dict get $resultdict files_skipped]] skipped files" \n + append msg $ruler \n + } + return $msg + } + + namespace eval recordlist { + set pkg punkcheck + namespace path ::punkcheck + + proc records_as_target_dict {record_list} { + set result [dict create] + foreach rec $record_list { + if {[dict get $rec tag] eq "FILEINFO"} { + set tgtlist [dict get $rec -targets] + if {[dict exists $result $tgtlist]} { + #todo - warn - duplicate record for same targetlist - shouldn't happen as we should be using get_file_record to find existing records + error "punkcheck::recordlist::records_as_target_dict - multiple records with same targetlist '$tgtlist'" + } + dict set result $tgtlist $rec + } + } + return $result + } + + + #will only match if same base was used.. and same targetlist + proc get_file_record {targetlist record_list} { + set posn 0 + set found_posn -1 + set record "" + foreach rec $record_list { + if {[dict get $rec tag] eq "FILEINFO"} { + if {[dict get $rec -targets] eq $targetlist} { + set found_posn $posn + set record $rec + break + } + } + incr posn + } + return [list position $found_posn record $record] + } + proc file_install_record_source_changes {install_record} { + #reject INSTALLFAILED items ? + switch -- [dict get $install_record tag] { + "QUERY-INPROGRESS" - + "INSTALL-RECORD" - + "INSTALL-SKIPPED" - + "INSTALL-INPROGRESS" - + "MODIFY-INPROGRESS" - + "MODIFY-RECORD" - + "MODIFY-SKIPPED" - + "VIRTUAL-INPROGRESS" - + "VIRTUAL-RECORD" - + "VIRTUAL-SKIPPED" - + "DELETE-RECORD" - + "DELETE-INPROGRESS" - + "DELETE-SKIPPED" { + } + default { + error "file_install_record_source_changes bad install record: tag '[dict get $install_record tag]' not INSTALL-RECORD|SKIPPED|INSTALL-INPROGRESS|MODIFY-RECORD|MODIFY-INPROGRESS|VIRTUAL-RECORD|VIRTUAL-INPROGRESS|DELETE-RECORD|DELETE-INPROGRESS" + } + } + set source_list [dict_getwithdefault $install_record body [list]] + set changed [list] + set unchanged [list] + foreach src $source_list { + if {[dict exists $src -changed]} { + if {[dict get $src -changed] !=0} { + lappend changed [dict get $src -path] + } else { + lappend unchanged [dict get $src -path] + } + } else { + lappend changed [dict get $src -path] + } + } + return [dict create changed $changed unchanged $unchanged] + } + + #assume only one for name - use first encountered? + proc get_installer_record {name record_list} { + set posn 0 + set found_posns [list] + set record "" + #puts ">>>> checking [llength $record_list] punkcheck records" + foreach rec $record_list { + if {[dict get $rec tag] eq "INSTALLER"} { + if {[dict get $rec -name] eq $name} { + set found_posn $posn + set record $rec + lappend found_posns $posn + } + } + incr posn + } + if {[llength $found_posns] > 1} { + error "punkcheck::recordlist::get_installer_record - multiple installer records with name '$name' found at positions $found_posns" + } elseif {[llength $found_posns] == 0} { + return [list position -1 record ""] + } else { + #single record found + return [list position [lindex $found_posn 0] record $record] + } + + } + + proc new_installer_record {name args} { + if {[llength $args] %2 !=0} { + error "punkcheck new_installer_record args must be name-value pairs" + } + set ts [clock microseconds] + set seconds [expr {$ts / 1000000}] + set tsiso [clock format $seconds -format "%Y-%m-%dT%H:%M:%S"] + + #put -tsiso first so it lines up with -tsiso in event records + set defaults [list {*}{ + } -tsiso $tsiso {*}{ + } -ts $ts {*}{ + } -name $name {*}{ + } -keep_events 5 {*}{ + } + ] + set opts [dict merge $defaults $args] + + #set this_installer_record_list [punk::tdl::prettyparse [list INSTALLER name $opt_installer ts $ts tsiso $tsiso keep_events 5 {}]] + #set this_installer_record [lindex $this_installer_record_list 0] + + set record [dict create tag INSTALLER {*}$opts body {}] + + + return $record + } + proc new_installer_event_record {type args} { + if {[llength $args] %2 !=0} { + error "punkcheck new_installer_event_record args must be name-value pairs" + } + set ts [clock microseconds] + set seconds [expr {$ts / 1000000}] + set tsiso [clock format $seconds -format "%Y-%m-%dT%H:%M:%S"] + set defaults [list {*}{ + } -tsiso $tsiso {*}{ + } -ts $ts {*}{ + } -type $type {*}{ + } + ] + set opts [dict merge $defaults $args] + + set record [dict create tag EVENT {*}$opts] + } + #need to scan entire set if filerecords to check if event is still referenced + proc installer_record_pruneevents {installer_record record_list} { + set keep 5 + if {[dict exists $installer_record -keep_events]} { + set keep [dict get $installer_record -keep_events] + } + + if {[dict exists $installer_record body]} { + set body_items [dict get $installer_record body] + } else { + set body_items [list] + } + set kept_body_items [list] + set kcount 0 + foreach item [lreverse $body_items] { + if {[dict get $item tag] eq "EVENT"} { + incr kcount + if {$keep < 0 || $kcount <= $keep} { + lappend kept_body_items $item + } else { + set eventid "" + if {[dict exists $item -id]} { + set eventid [dict get $item -id] + } + if {$eventid ne "" && $eventid ne "unspecified"} { + #keep if referenced, discard if not, or if eventid empty/unspecified + set is_referenced 0 + foreach rec $record_list { + if {[dict get $rec tag] eq "FILEINFO"} { + if {[dict exists $rec body]} { + foreach install [dict get $rec body] { + if {[dict exists $install -eventid] && [dict get $install -eventid] eq $eventid} { + set is_referenced 1 + break + } + } + } + } + if {$is_referenced} { + break + } + } + if {$is_referenced} { + lappend kept_body_items $item + } + } + } + } else { + lappend kept_body_items $item + } + } + set kept_body_items [lreverse $kept_body_items] + dict set installer_record body $kept_body_items + return $installer_record + } + proc installer_record_add_event {installer_record event} { + if {[dict get $installer_record tag] ne "INSTALLER"} { + error "installer_record_add_event bad installer record: tag not INSTALLER" + } + if {[dict get $event tag] ne "EVENT"} { + error "installer_record_add_event bad event record: tag not EVENT" + } + if {[dict exists $installer_record body]} { + set body_items [dict get $installer_record body] + } else { + set body_items [list] + } + lappend body_items $event + dict set installer_record body $body_items + return $installer_record + } + proc file_record_latest_installrecord {file_record} { + tailcall file_record_latest_operationrecord INSTALL $file_record + } + proc file_record_latest_operationrecord {operation file_record} { + set operation [string toupper $operation] + if {[dict get $file_record tag] ne "FILEINFO"} { + error "file_record_latest_operationrecord bad file_record: tag not FILEINFO" + } + if {![dict exists $file_record body]} { + return [list] + } + set body_items [dict get $file_record body] + foreach item [lreverse $body_items] { + if {[dict get $item tag] eq "$operation-RECORD"} { + return $item + } + } + return [list] + } + + + proc file_record_set_defaults {file_record} { + if {[dict get $file_record tag] ne "FILEINFO"} { + error "file_record_set_defaults bad file_record: tag not FILEINFO" + } + set defaults [list -keep_installrecords 3 -keep_skipped 1 -keep_inprogress 2] + foreach {k v} $defaults { + if {![dict exists $file_record $k]} { + dict set file_record $k $v + } + } + return $file_record + } + + #negative keep_ value will keep all + proc file_record_prune {file_record} { + if {[dict get $file_record tag] ne "FILEINFO"} { + error "file_record_prune bad file_record: tag not FILEINFO" + } + set file_record [file_record_set_defaults $file_record] + set kmap [list -keep_installrecords *-RECORD -keep_skipped *-SKIPPED -keep_inprogress *-INPROGRESS] + foreach {key rtype} $kmap { + set keep [dict get $file_record $key] + if {[dict exists $file_record body]} { + set body_items [dict get $file_record body] + } else { + set body_items [list] + } + set kept_body_items [list] + set kcount 0 + foreach item [lreverse $body_items] { + if {[string match $rtype [dict get $item tag]]} { + incr kcount + if {$keep < 0 || $kcount <= $keep} { + lappend kept_body_items $item + } + } else { + lappend kept_body_items $item + } + } + set kept_body_items [lreverse $kept_body_items] + dict set file_record body $kept_body_items + } + return $file_record + } + + #extract new or existing filerecord for path given + #REVIEW - locking/concurrency + proc extract_or_create_fileset_record {relative_target_paths recordset} { + set fetch_record_result [punkcheck::recordlist::get_file_record $relative_target_paths $recordset] + set existing_posn [dict get $fetch_record_result position] + if {$existing_posn == -1} { + puts stdout "punkcheck NO existing record for $relative_target_paths" + set isnew 1 + set fileset_record [dict create tag FILEINFO -targets $relative_target_paths body {}] + } else { + #set recordset [lreplace $recordset[unset recordset] $existing_posn $existing_posn] + #set recordset [lreplace $recordset[set recordset {}] $existing_posn $existing_posn] + ledit recordset $existing_posn $existing_posn + set isnew 0 + set fileset_record [dict get $fetch_record_result record] + } + return [list record $fileset_record recordset $recordset isnew $isnew oldposition $existing_posn] + } + + } + +} + + + + +namespace eval ::punk::args::register { + #use fully qualified so 8.6 doesn't find existing var in global namespace + lappend ::punk::args::register::NAMESPACES ::punkcheck +} + + + + + + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Ready +package provide punkcheck [namespace eval punkcheck { + set pkg punkcheck + variable version + set version 0.1.1 +}] +return diff --git a/src/bootsupport/modules/punkcheck/cli-0.1.0.tm b/src/bootsupport/modules/punkcheck/cli-0.1.0.tm index bbf882a0..ed3a5b5e 100644 --- a/src/bootsupport/modules/punkcheck/cli-0.1.0.tm +++ b/src/bootsupport/modules/punkcheck/cli-0.1.0.tm @@ -64,7 +64,7 @@ namespace eval punkcheck::cli { #vfs can mask mounted files - so we can't just use 'file type' or glob with -type f ##set files [glob -nocomplain -dir $fullpath -type f *] package require punk::nav::fs - + #TODO - get all files in tree!!! set folderinfo [punk::nav::fs::dirfiles_dict $fullpath] set files [concat [dict get $folderinfo files] [dict get $folderinfo underlayfiles]] @@ -81,7 +81,7 @@ namespace eval punkcheck::cli { foreach p $punkcheck_files { set basedir [file dirname $p] set recordlist [punkcheck::load_records_from_file $p] - set tgt_dict [punkcheck::recordlist::records_as_target_dict $recordlist] + set tgt_dict [punkcheck::recordlist::records_as_target_dict $recordlist] foreach f $files { set relpath [punkcheck::lib::path_relative $basedir $f] @@ -137,13 +137,13 @@ namespace eval punkcheck::cli { } } } - } + } } if {[llength $source_files]} { - append pcheck " source files : [llength $source_files] (changed [llength $source_files_changed])" + append pcheck " source files : [llength $source_files] (changed [llength $source_files_changed])" } if {[llength $source_folders]} { - append pcheck " source folders: [llength $source_folders] (changed [llength $source_folders_changed])" + append pcheck " source folders: [llength $source_folders] (changed [llength $source_folders_changed])" } append pcheck \n @@ -152,7 +152,7 @@ namespace eval punkcheck::cli { } } } - append table "$f $pcheck" \n + append table "$f $pcheck" \n } } } @@ -182,7 +182,7 @@ namespace eval punkcheck::cli { foreach p $punkcheck_files { set basedir [file dirname $p] set recordlist [punkcheck::load_records_from_file $p] - set tgt_dict [punkcheck::recordlist::records_as_target_dict $recordlist] + set tgt_dict [punkcheck::recordlist::records_as_target_dict $recordlist] foreach f $files { set relpath [punkcheck::lib::path_relative $basedir $f] @@ -235,13 +235,13 @@ namespace eval punkcheck::cli { } } } - } + } } if {[llength $source_files]} { - append pcheck " source files : [llength $source_files] (changed [llength $source_files_changed])" + append pcheck " source files : [llength $source_files] (changed [llength $source_files_changed])" } if {[llength $source_folders]} { - append pcheck " source folders: [llength $source_folders] (changed [llength $source_folders_changed])" + append pcheck " source folders: [llength $source_folders] (changed [llength $source_folders_changed])" } append pcheck \n @@ -250,7 +250,7 @@ namespace eval punkcheck::cli { } } } - append table "$f $pcheck" \n + append table "$f $pcheck" \n } } } @@ -259,14 +259,13 @@ namespace eval punkcheck::cli { } - # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ namespace eval punkcheck::cli::lib { namespace path ::punk::mix::util ;#askuser, do_in_path, foreach-file etc proc find_nearest_file {{path {}}} { if {$path eq {}} { set path [pwd] } - set folder [lib::scanup $path lib::is_punkchecked_folder] + set folder [lib::scanup $path lib::is_punkchecked_folder] if {$folder eq ""} { return "" } else { @@ -307,7 +306,6 @@ namespace eval punkcheck::cli::lib { } return {} } - } @@ -320,15 +318,15 @@ namespace eval punkcheck::cli { variable default_command status package require punk::mix::base package require punk::overlay - punk::overlay::custom_from_base [namespace current] ::punk::mix::base + punk::overlay::custom_from_base [namespace current] ::punk::mix::base } # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready +## Ready package provide punkcheck::cli [namespace eval punkcheck::cli { variable version - set version 0.1.0 + set version 0.1.0 }] return diff --git a/src/bootsupport/modules/shellfilter-0.2.2.tm b/src/bootsupport/modules/shellfilter-0.2.2.tm index 6a948593..a841bd6e 100644 --- a/src/bootsupport/modules/shellfilter-0.2.2.tm +++ b/src/bootsupport/modules/shellfilter-0.2.2.tm @@ -326,18 +326,34 @@ namespace eval shellfilter::chan { #method flush {ch} { # return "" #} + #method flush {transform_handle} { + # #puts stdout "" + # #review - just clear o_encbuf and emit nothing? + # #we wouldn't have a value there if it was convertable from the channel encoding? + # if {[string length $o_encbuf]} { + # #if we have data in the buffer that we haven't been able to convert to a string + # #- then we probably have some kind of encoding mismatch. Is it safer to discard it than to emit garbage chars to the channel or var? + # #REVIEW - log that we are discarding the buffer contents on flush? + # puts stderr "WARNING: flush called on tee_to_var with non-empty buffer. This probably indicates an encoding mismatch between the channel encoding and the encoding expected by the transform. Discarding buffer contents: '$o_encbuf'" + # } + # set clear $o_encbuf + # set o_encbuf "" + # return $clear + #} method flush {transform_handle} { - #puts stdout "" - #review - just clear o_encbuf and emit nothing? - #we wouldn't have a value there if it was convertable from the channel encoding? - if {[string length $o_encbuf]} { - #if we have data in the buffer that we haven't been able to convert to a string - #- then we probably have some kind of encoding mismatch. Is it safer to discard it than to emit garbage chars to the channel or var? - #REVIEW - log that we are discarding the buffer contents on flush? - puts stderr "WARNING: flush called on tee_to_var with non-empty buffer. This probably indicates an encoding mismatch between the channel encoding and the encoding expected by the transform. Discarding buffer contents: '$o_encbuf'" + #puts stderr " $transform_handle o_encbuf: '$o_encbuf' datavars: $o_datavars" + set clear $o_encbuf + if {[catch {tcl::encoding::convertfrom $o_enc $clear} stringdata]} { + #if we can't convert the buffer contents to a string - does it make sense to emit the raw bytes? + # - probably not. + #REVIEW? + return "" } set o_encbuf "" - return "" + foreach v $o_datavars { + append $v $stringdata + } + return $stringdata } method write {ch bytes} { #test with set x [string repeat " \U1f6c8" 2043] @@ -442,16 +458,29 @@ namespace eval shellfilter::chan { # flush $o_localchan # return $clear #} + #method flush {transform_handle} { + # #we wouldn't have a value in o_encbuf if it was convertable from the channel encoding? + # if {[string length $o_encbuf]} { + # #if we have data in the buffer that we haven't been able to convert to a string + # #- then we probably have some kind of encoding mismatch. Is it safer to discard it than to emit garbage chars to the channel or var? + # #REVIEW - log that we are discarding the buffer contents on flush? + # puts stderr "WARNING: flush called on tee_to_pipe with non-empty buffer. This probably indicates an encoding mismatch between the channel encoding and the encoding expected by the transform. Discarding buffer contents: '$o_encbuf'" + # } + # set clear $o_encbuf + # set o_encbuf "" + # return $clear + #} method flush {transform_handle} { - #we wouldn't have a value in o_encbuf if it was convertable from the channel encoding? - if {[string length $o_encbuf]} { - #if we have data in the buffer that we haven't been able to convert to a string - #- then we probably have some kind of encoding mismatch. Is it safer to discard it than to emit garbage chars to the channel or var? - #REVIEW - log that we are discarding the buffer contents on flush? - puts stderr "WARNING: flush called on tee_to_pipe with non-empty buffer. This probably indicates an encoding mismatch between the channel encoding and the encoding expected by the transform. Discarding buffer contents: '$o_encbuf'" + set clear $o_buffered$o_encbuf + if {[catch {tcl::encoding::convertfrom $o_enc $clear} stringdata]} { + #if we can't convert the buffer contents to a string - does it make sense to emit the raw bytes? + # - probably not. + #REVIEW? + return "" } + set o_buffered "" set o_encbuf "" - return "" + return $stringdata } method write {transform_handle bytes} { #set logdata [tcl::encoding::convertfrom $o_enc $bytes] @@ -533,11 +562,24 @@ namespace eval shellfilter::chan { ::shellfilter::log::write $o_logsource $logdata return $bytes } + #method flush {transform_handle} { + # #return "" + # set clear $o_encbuf + # set o_encbuf "" + # #review + # return $clear + #} method flush {transform_handle} { - #return "" - set clear $o_encbuf + set clear $o_buffered$o_encbuf + if {[catch {tcl::encoding::convertfrom $o_enc $clear} stringdata]} { + #if we can't convert the buffer contents to a string - does it make sense to emit the raw bytes? + # - probably not. + #REVIEW? + return "" + } + set o_buffered "" set o_encbuf "" - return $o_encbuf + return $stringdata } method write {ch bytes} { #set logdata [tcl::encoding::convertfrom $o_enc $bytes] @@ -613,9 +655,21 @@ namespace eval shellfilter::chan { my destroy } #clear? + #method flush {transform_handle} { + # #we wouldn't have a value in o_encbuf if it was convertable from the channel encoding? + # if {[string length $o_encbuf]} { + # #if we have data in the buffer that we haven't been able to convert to a string + # #- then we probably have some kind of encoding mismatch. Is it safer to discard it than to emit garbage chars to the log? + # #REVIEW. - we are writing the raw bytes to the log here because we can't convert them to a string. + # #This may be useful for debugging issues, but it may also result in garbage data in the log. + # ::shellfilter::log::write $o_logsource $o_encbuf + # set o_encbuf "" + # } + # return + #} method flush {transform_handle} { - #we wouldn't have a value in o_encbuf if it was convertable from the channel encoding? - if {[string length $o_encbuf]} { + set clear $o_buffered$o_encbuf + if {[catch {tcl::encoding::convertfrom $o_enc $clear} stringdata]} { #if we have data in the buffer that we haven't been able to convert to a string #- then we probably have some kind of encoding mismatch. Is it safer to discard it than to emit garbage chars to the log? #REVIEW. - we are writing the raw bytes to the log here because we can't convert them to a string. @@ -755,6 +809,110 @@ namespace eval shellfilter::chan { } } + + #experimental + #applying this to stdout breaks console query/responses - why? + #- probably because we are splitting graphemes across writes and flushes and the console doesn't know how to handle that? + oo::class create unicode_normalize { + variable o_trecord + variable o_enc + variable o_encbuf + variable o_graphemebuf + variable o_mode + variable o_is_junction + constructor {tf} { + package require punk::ansi + set o_trecord $tf + set o_enc [::tcl::dict::get $tf -encoding] + set o_encbuf "" + set o_graphemebuf "" + set settingsdict [tcl::dict::get $tf -settings] + if {[dict exists $settingsdict -mode]} { + set o_mode [dict get $settingsdict -mode] + if {$o_mode ni {nfc nfd nfkc nfkd none}} { + error "unicode_normalize transform - invalid mode '$o_mode' in settings" + } + if {$o_mode ne "none"} { + #we get dll dependent load errors on windows sometimes - but still seems to work - REVIEW/FIX. + catch {::tcl::unsupported::loadIcu} + } + } else { + #if no mode specified - default to 'none' which just does grapheme splitting without any unicode normalization + set o_mode "none" + } + if {[::tcl::dict::exists $tf -junction]} { + set o_is_junction [::tcl::dict::get $tf -junction] + } else { + set o_is_junction 0 + } + } + method initialize {transform_handle mode} { + return [list initialize write flush finalize] + } + method finalize {transform_handle} { + my destroy + } + method flush {transform_handle} { + #flush seems to do nothing - why? + set clear $o_encbuf[unset o_encbuf] + if {[catch {tcl::encoding::convertfrom $o_enc $clear} stringdata]} { + #if we can't convert the buffer contents to a string - put it back and try again with more data later + #REVIEW? + set o_encbuf $clear + return "" + } + #review + + set graphemes [punk::char::grapheme_split $o_graphemebuf$stringdata] + set outstring [join $graphemes ""] + #puts "outstring: '$outstring' graphemes: $graphemes" + if {$o_mode ne "none"} { + set outstring [::tcl::unsupported::icu::normalize -mode $o_mode $outstring] + } + set o_graphemebuf "" + return [tcl::encoding::convertto $o_enc $outstring] + } + method write {transform_handle bytes} { + set inputbytes $o_encbuf$bytes + set o_encbuf "" + set tail_offset 0 + + if {$inputbytes eq ""} { + #review - do we even get empty writes? + puts stderr "WARNING: write called on unicode_normalize with empty inputbytes. This may be a no-op, but it may also indicate an issue with the upstream transform or channel. Emitting no data for this write." + set stringdata "" + } + + while {$tail_offset < [::tcl::string::length $inputbytes] && [catch {tcl::encoding::convertfrom $o_enc [::tcl::string::range $inputbytes 0 end-$tail_offset]} stringdata]} { + incr tail_offset + } + if {$tail_offset > 0} { + if {$tail_offset < [::tcl::string::length $inputbytes]} { + #stringdata from catch statement must be a valid result + set t [expr {$tail_offset - 1}] + set o_encbuf [::tcl::string::range $inputbytes end-$t end] + } else { + set stringdata "" + set o_encbuf $inputbytes + return "" + } + } + set graphemes [punk::char::grapheme_split $o_graphemebuf$stringdata] + set outstring [join [lrange $graphemes 0 end-1] ""] + set o_graphemebuf [lindex $graphemes end] + + if {$o_mode ne "none"} { + set outstring [::tcl::unsupported::icu::normalize -mode $o_mode $outstring] + } + + return [tcl::encoding::convertto $o_enc $outstring] + } + method meta_is_redirection {} { + return $o_is_junction + } + } + + #a test oo::class create reconvert { variable o_trecord @@ -1114,7 +1272,6 @@ namespace eval shellfilter::chan { # return $emit #} method flush {transform_handle} { - #return "" set clear $o_buffered$o_encbuf if {[catch {tcl::encoding::convertfrom $o_enc $clear} stringdata]} { #if we can't convert the buffer contents to a string - does it make sense to emit the raw bytes? diff --git a/src/bootsupport/modules/shellrun-0.1.2.tm b/src/bootsupport/modules/shellrun-0.1.2.tm new file mode 100644 index 00000000..7a353961 --- /dev/null +++ b/src/bootsupport/modules/shellrun-0.1.2.tm @@ -0,0 +1,897 @@ +# vim: set ft=tcl +# +#purpose: handle the run commands that call shellfilter::run +#e.g run,runout,runerr,runx + +package require shellfilter +package require punk::ansi + +#NOTE: the run,runout,runerr,runx commands only produce an error if the command didn't run. +# - If it did run, but there was a non-zero exitcode it is up to the application to check that. +#This is deliberate, but means 'catch' doesn't catch errors within the command itself - the exitcode has to be checked. +#The user can always use exec for different process error semantics (they don't get exitcode with exec) + +namespace eval shellrun { + variable PUNKARGS + variable runout + variable runerr + + #do we need these? + #variable punkout + #variable punkerr + + #some ugly coupling with punk/punk::config for now + #todo - something better + if {[info exists ::punk::config::configdata]} { + set conf_running [punk::config::configure running] + set syslog_stdout [dict get $conf_running syslog_stdout] + set syslog_stderr [dict get $conf_running syslog_stderr] + set logfile_stdout [dict get $conf_running logfile_stdout] + set logfile_stderr [dict get $conf_running logfile_stderr] + } else { + lassign [list "" "" "" ""] syslog_stdout syslog_stderr logfile_stdout logfile_stderr + } + if {"punkshout" ni [shellfilter::stack::items]} { + set outdevice [shellfilter::stack::new punkshout -settings [list -tag "punkshout" -buffering none -raw 1 -syslog $syslog_stdout -file $logfile_stdout]] + set out [dict get $outdevice localchan] + } else { + set out [dict get [shellfilter::stack::item punkshout] device localchan] + } + if {"punksherr" ni [shellfilter::stack::items]} { + set errdevice [shellfilter::stack::new punksherr -settings [list -tag "punksherr" -buffering none -raw 1 -syslog $syslog_stderr -file $logfile_stderr]] + set err [dict get $errdevice localchan] + } else { + set err [dict get [shellfilter::stack::item punksherr] device localchan] + } + + namespace import ::punk::ansi::a+ + namespace import ::punk::ansi::a + + + + + #repltelemetry - additional/alternative display info used in a repl context i.e info directed towards the screen + #todo - package up in repltelemetry module and rewrite proc based on whether the module was found/loaded. + #somewhat strong coupling to punk - but let's try to behave decently if it's not loaded + #The last_run_display is actually intended for the repl - but is resident in the punk namespace with a view to the possibility of a different repl being in use. + proc set_last_run_display {chunklist} { + #chunklist as understood by the + if {![info exists ::punk::repltelemetry_emmitters]} { + namespace eval ::punk { + variable repltelemetry_emmitters + set repltelemetry_emmitters "shellrun" + } + } else { + if {"shellrun" ni $::punk::repltelemetry_emmitters} { + lappend punk::repltelemetry_emmitters "shellrun" + } + } + + #most basic of validity tests here.. just that it is a list (can be empty). We don't want to duplicate or over-constrain the way repls/shells/terminals interpet the info + if {[catch {llength $chunklist} errMsg]} { + error "set_last_run_display expects a list. Value supplied doesn't appear to be a well formed tcl list. '$errMsg'" + } + #todo - + tsv::lappend repl runchunks-[tsv::get repl runid] {*}$chunklist + } + + + + #maintenance: similar used in punk::ns & punk::winrun + #todo - take runopts + aliases as args + #longopts must be passed as a single item ie --timeout=100 not --timeout 100 + proc get_run_opts {arglist} { + if {[catch { + set callerinfo [info level -1] + } errM]} { + set caller "" + } else { + set caller [lindex $callerinfo 0] + } + + #we provide -nonewline even for 'run' even though run doesn't deliver stderr or stdout to the tcl return value + #This is for compatibility with other runX commands, and the difference is also visible when calling from repl. + set known_runopts [list "-echo" "-e" "-nonewline" "-n" "-tcl" "-debug"] + set known_longopts [list "--timeout"] + set known_longopts_msg "" + foreach lng $known_longopts { + append known_longopts_msg "${lng}=val " + } + set aliases [list "-e" "-echo" "-echo" "-echo" "-n" "-nonewline" "-nonewline" "-nonewline" "-tcl" "-tcl" "-debug" "-debug"] ;#include map to self + set runopts [list] + set runoptslong [list] + set cmdargs [list] + + set idx_first_cmdarg [lsearch -not $arglist "-*"] + + set allopts [lrange $arglist 0 $idx_first_cmdarg-1] + set cmdargs [lrange $arglist $idx_first_cmdarg end] + foreach o $allopts { + if {[string match --* $o]} { + lassign [split $o =] flagpart valpart + if {$valpart eq ""} { + error "$caller: longopt $o seems to be missing a value - must be of form --option=value" + } + if {$flagpart ni $known_longopts} { + error "$caller: Unknown runoption $o - known options $known_runopts $known_longopts_msg" + } + lappend runoptslong $flagpart $valpart + } else { + if {$o ni $known_runopts} { + error "$caller: Unknown runoption $o - known options $known_runopts $known_longopts_msg" + } + lappend runopts [dict get $aliases $o] + } + } + return [list runopts $runopts runoptslong $runoptslong cmdargs $cmdargs] + } + + + #todo - investigate cause of punk86 run hanging sometimes. An 'after 500' before exit in the called script fixes the issue. punk87 doesn't seem to be affected. + lappend PUNKARGS [list { + @id -id ::shellrun::run + @leaders -min 0 -max 0 + @opts + -nonewline -type none + -tcl -type none -default 0 + -debug -type none -default 0 + --timeout= -type integer + @values -min 1 -max -1 + cmdname -type string + cmdarg -type any -multiple 1 -optional 1 + }] + proc run {args} { + #set_last_run_display [list] + + #set splitargs [get_run_opts $args] + #set runopts [dict get $splitargs runopts] + #set runoptslong [dict get $splitargs runoptslong] + #set cmdargs [dict get $splitargs cmdargs] + set argd [punk::args::parse $args withid ::shellrun::run] + lassign [dict values $argd] leaders opts values received + + if {[dict exists $received "-nonewline"]} { + set nonewline 1 + } else { + set nonewline 0 + } + #review nonewline does nothing here.. + + set idlist_stderr [list] + #we leave stdout without imposed ansi colouring - because the source may be colourised and because ansi-wrapping a stream at whatever boundaries it comes in at isn't a really nice thing to do. + #stderr might have source colouring - but it usually doesn't seem to, and the visual distiction of red stderr can be very handy for the run command. + #A further enhancement could be to detect well-known options such as --color and/or use a configuration for specific commands that have useful colourised stderr, + #but having an option to configure stderr to red is a compromise. + #Note that the other run commands, runout,runerr, runx don't emit in real-time - so for those commands there may be options to detect and/or post-process stdout and stderr. + #TODO - fix. This has no effect if/when the repl adds an ansiwrap transform + # what we probably want to do is 'aside' that transform for runxxx commands only. + #lappend idlist_stderr [shellfilter::stack::add stderr ansiwrap -settings {-colour {red bold}}] + + set callopts [dict create] + if {[dict exists $received "-tcl"]} { + dict set callopts -tclscript 1 + } + if {[dict exists $received "-debug"]} { + dict set callopts -debug 1 + } + if {[dict exists $received --timeout]} { + dict set callopts -timeout [dict get $opts --timeout] ;#convert to single dash + } + set cmdname [dict get $values cmdname] + if {[dict exists $received cmdarg]} { + set cmdarglist [dict get $values cmdarg] + } else { + set cmdarglist {} + } + set cmdargs [concat $cmdname $cmdarglist] + #--------------------------------------------------------------------------------------------- + set exitinfo [shellfilter::run $cmdargs {*}$callopts -teehandle punksh -inbuffering none -outbuffering none ] + #--------------------------------------------------------------------------------------------- + foreach id $idlist_stderr { + shellfilter::stack::remove stderr $id + } + #puts stderr "shellrun::run exitinfo: $exitinfo" + + flush stderr + flush stdout + + if {[dict exists $exitinfo error]} { + error "[dict get $exitinfo error]\n$exitinfo" + } + + return $exitinfo + } + + lappend PUNKARGS [list { + @id -id ::shellrun::runconsole + @leaders -min 0 -max 0 + @opts + @values -min 1 -max -1 + cmdname -type string + cmdarg -type any -multiple 1 -optional 1 + }] + #run in the way tcl unknown does - but without regard to auto_noexec + proc runconsole {args} { + set argd [punk::args::parse $args withid ::shellrun::runconsole] + lassign [dict values $argd] leaders opts values received + set cmdname [dict get $values cmdname] + if {[dict exists $received cmdarg]} { + set arglist [dict get $values cmdarg] + } else { + set arglist {} + } + + set resolved_cmdname [auto_execok $cmdname] + if {$resolved_cmdname eq ""} { + error "Cannot find path for executable '$cmdname'" + } + set repl_runid [punk::get_repl_runid] + #set ::punk::last_run_display [list] + + set redir ">&@stdout <@stdin" + uplevel 1 [list ::catch [concat exec $redir $resolved_cmdname $arglist] ::tcl::UnknownResult ::tcl::UnknownOptions] + #we can't detect stdout/stderr output from the exec + #for now emit an extra \n on stderr + #todo - there is probably no way around this but to somehow exec in the context of a completely separate console + #This is probably a tricky problem - especially to do cross-platform + # + # - use [dict get $::tcl::UnknownOptions -code] (0|1) exit + if {[dict get $::tcl::UnknownOptions -code] == 0} { + set c green + set m "ok" + } else { + set c yellow + set m "errorCode $::errorCode" + } + set chunklist [list] + lappend chunklist [list "info" "[a $c]$m[a] " ] + if {$repl_runid != 0} { + tsv::lappend repl runchunks-$repl_runid {*}$chunklist + } + + dict incr ::tcl::UnknownOptions -level + return -options $::tcl::UnknownOptions $::tcl::UnknownResult + } + lappend PUNKARGS [list { + @id -id ::shellrun::runout + @leaders -min 0 -max 0 + @opts + -echo -type none + -nonewline -type none + -tcl -type none -default 0 + -debug -type none -default 0 + --timeout= -type integer + @values -min 1 -max -1 + cmdname -type string + cmdarg -type any -multiple 1 -optional 1 + }] + proc runout {args} { + set argd [punk::args::parse $args withid ::shellrun::runout] + lassign [dict values $argd] leaders opts values received + + if {[dict exists $received "-nonewline"]} { + set nonewline 1 + } else { + set nonewline 0 + } + + #set_last_run_display [list] + variable runout + variable runerr + set runout "" + set runerr "" + set RST [a] + + #set splitargs [get_run_opts $args] + #set runopts [dict get $splitargs runopts] + #set cmdargs [dict get $splitargs cmdargs] + + + #puts stdout "RUNOUT cmdargs: $cmdargs" + + #todo add -data boolean and -data lastwrite to -settings with default being -data all + # because sometimes we're only interested in last char (e.g to detect something was output) + + #set outvar_stackid [shellfilter::stack::add commandout tee_to_var -action float -settings {-varname ::runout}] + # + #when not echoing - use float-locked so that the repl's stack is bypassed + if {[dict exists $received "-echo"]} { + set stdout_stackid [shellfilter::stack::add stdout tee_to_var -action float-locked -settings {-varname ::shellrun::runout}] + set stderr_stackid [shellfilter::stack::add stderr tee_to_var -action float-locked -settings {-varname ::shellrun::runerr}] + #set stderr_stackid [shellfilter::stack::add stderr tee_to_var -action sink-locked -settings {-varname ::shellrun::runerr}] + } else { + set stdout_stackid [shellfilter::stack::add stdout var -action float-locked -settings {-varname ::shellrun::runout}] + set stderr_stackid [shellfilter::stack::add stderr var -action float-locked -settings {-varname ::shellrun::runerr}] + } + + set callopts [dict create] + if {[dict exists $received "-tcl"]} { + dict set callopts -tclscript 1 + } + if {[dict exists $received "-debug"]} { + dict set callopts -debug 1 + } + if {[dict exists $received --timeout]} { + dict set callopts -timeout [dict get $opts --timeout] ;#convert to single dash + } + set cmdname [dict get $values cmdname] + if {[dict exists $received cmdarg]} { + set cmdarglist [dict get $values cmdarg] + } else { + set cmdarglist {} + } + set cmdargs [concat $cmdname $cmdarglist] + + #shellfilter::run [lrange $args 1 end] -teehandle punksh -outchan stdout -inbuffering none -outbuffering none -stdinhandler ::repl::repl_handler + set exitinfo [shellfilter::run $cmdargs {*}$callopts -teehandle punksh -inbuffering none -outbuffering none ] + + flush stderr + flush stdout + + shellfilter::stack::remove stdout $stdout_stackid + shellfilter::stack::remove stderr $stderr_stackid + + #shellfilter::stack::remove commandout $outvar_stackid + + if {[dict exists $exitinfo error]} { + if {[dict exists $received "-tcl"]} { + + } else { + #we must raise an error. + #todo - check errorInfo makes sense.. return -code? tailcall? + # + set msg "" + append msg [dict get $exitinfo error] + append msg "\n(add -tcl option to run as a tcl command/script instead of an external command)" + error $msg + } + } + + set chunklist [list] + + #exitcode not part of return value for runout - colourcode appropriately + set n $RST + set c "" + + if {[dict exists $exitinfo exitcode]} { + set code [dict get $exitinfo exitcode] + if {$code == 0} { + set c [a+ green] + } else { + set c [a+ white bold] + } + lappend chunklist [list "info" "$c$exitinfo$n"] + } elseif {[dict exists $exitinfo error]} { + # -tcl (with error) + set c [a+ yellow bold] + lappend chunklist [list "info" "${c}error [dict get $exitinfo error]$n"] + lappend chunklist [list "info" "errorCode [dict get $exitinfo errorCode]"] + #lappend chunklist [list "info" "errorInfo [list [dict get $exitinfo errorInfo]]"] + lappend chunklist [list "info" errorInfo] + lappend chunklist [list "stderr" [dict get $exitinfo errorInfo]] + } else { + # -tcl (without error) + set c [a+ Green white bold] + #lappend chunklist [list "info" "$c$exitinfo$n"] + lappend chunklist [list "info" [punk::ansi::ansiwrap_raw $c \x1b\[m "" $exitinfo]] + } + + + set chunk "[a+ red bold]stderr$RST" + lappend chunklist [list "info" $chunk] + + set chunk "" + if {[string length $::shellrun::runerr]} { + if {$nonewline} { + set e [string trimright $::shellrun::runerr \r\n] + } else { + set e $::shellrun::runerr + } + #append chunk "[a+ red normal]$e$RST\n" + append chunk "[a+ red normal]$e$RST" + } + lappend chunklist [list stderr $chunk] + + + + + lappend chunklist [list "info" "[a+ white bold]stdout$RST"] + set chunk "" + if {[string length $::shellrun::runout]} { + if {$nonewline} { + set o [string trimright $::shellrun::runout \r\n] + } else { + set o $::shellrun::runout + } + append chunk "$o" + } + lappend chunklist [list result $chunk] + + + #set_last_run_display $chunklist + tsv::lappend repl runchunks-[tsv::get repl runid] {*}$chunklist + + if {$nonewline} { + return [string trimright $::shellrun::runout \r\n] + } else { + return $::shellrun::runout + } + } + + lappend PUNKARGS [list { + @id -id ::shellrun::runerr + @leaders -min 0 -max 0 + @opts + -echo -type none + -nonewline -type none + -tcl -type none -default 0 + -debug -type none -default 0 + --timeout= -type integer + @values -min 1 -max -1 + cmdname -type string + cmdarg -type any -multiple 1 -optional 1 + }] + proc runerr {args} { + set argd [punk::args::parse $args withid ::shellrun::runerr] + lassign [dict values $argd] leaders opts values received + + if {[dict exists $received "-nonewline"]} { + set nonewline 1 + } else { + set nonewline 0 + } + + #set_last_run_display [list] + variable runout + variable runerr + set runout "" + set runerr "" + + #set splitargs [get_run_opts $args] + #set runopts [dict get $splitargs runopts] + #set cmdargs [dict get $splitargs cmdargs] + + set callopts [dict create] + if {[dict exists $received "-tcl"]} { + dict set callopts -tclscript 1 + } + if {[dict exists $received "-debug"]} { + dict set callopts -debug 1 + } + if {[dict exists $received --timeout]} { + dict set callopts -timeout [dict get $opts --timeout] ;#convert to single dash + } + set cmdname [dict get $values cmdname] + if {[dict exists $received cmdarg]} { + set cmdarglist [dict get $values cmdarg] + } else { + set cmdarglist {} + } + set cmdargs [concat $cmdname $cmdarglist] + + if {[dict exists $received "-tcl"]} { + append callopts " -tclscript 1" + } + if {[dict exists $received "-echo"]} { + set stderr_stackid [shellfilter::stack::add stderr tee_to_var -action float-locked -settings {-varname ::shellrun::runerr}] + set stdout_stackid [shellfilter::stack::add stdout tee_to_var -action float-locked -settings {-varname ::shellrun::runout}] + } else { + set stderr_stackid [shellfilter::stack::add stderr var -action float-locked -settings {-varname ::shellrun::runerr}] + set stdout_stackid [shellfilter::stack::add stdout var -action float-locked -settings {-varname ::shellrun::runout}] + } + + + set exitinfo [shellfilter::run $cmdargs {*}$callopts -teehandle punksh -inbuffering none -outbuffering none -stdinhandler ::repl::repl_handler] + shellfilter::stack::remove stderr $stderr_stackid + shellfilter::stack::remove stdout $stdout_stackid + + + flush stderr + flush stdout + + #we raise an error because an error during calling is different to collecting stderr from a command, and the caller should be able to wrap in a catch + # to determine something other than just a nonzero exit code or output on stderr. + if {[dict exists $exitinfo error]} { + if {[dict exists $received "-tcl"]} { + + } else { + #todo - check errorInfo makes sense.. return -code? tailcall? + error [dict get $exitinfo error] + } + } + + set chunklist [list] + + set n [a] + set c "" + if {[dict exists $exitinfo exitcode]} { + set code [dict get $exitinfo exitcode] + if {$code == 0} { + set c [a+ green] + } else { + set c [a+ white bold] + } + lappend chunklist [list "info" "$c$exitinfo$n"] + } elseif {[dict exists $exitinfo error]} { + # -tcl (with error) + set c [a+ yellow bold] + lappend chunklist [list "info" "error [dict get $exitinfo error]"] + lappend chunklist [list "info" "errorCode [dict get $exitinfo errorCode]"] + lappend chunklist [list "info" "errorInfo [list [dict get $exitinfo errorInfo]]"] + } else { + # -tcl (without error) + set c [a+ Green white bold] + #lappend chunklist [list "info" "$c$exitinfo$n"] + lappend chunklist [list "info" [punk::ansi::ansiwrap_raw $c "\x1b\[m" "" $exitinfo]] + } + + + lappend chunklist [list "info" "[a+ white bold]stdout[a]"] + set chunk "" + if {[string length $::shellrun::runout]} { + if {$nonewline} { + set o [string trimright $::shellrun::runout \r\n] + } else { + set o $::shellrun::runout + } + append chunk "[a+ white normal]$o[a]\n" ;#this newline is the display output separator - always there whether data has trailing newline or not. + } + lappend chunklist [list stdout $chunk] + + + #set c_stderr [punk::config] + set chunk "[a+ red bold]stderr[a]" + lappend chunklist [list "info" $chunk] + + set chunk "" + if {[string length $::shellrun::runerr]} { + if {$nonewline} { + set e [string trimright $::shellrun::runerr \r\n] + } else { + set e $::shellrun::runerr + } + append chunk "$e" + } + lappend chunklist [list resulterr $chunk] + + + #set_last_run_display $chunklist + tsv::lappend repl runchunks-[tsv::get repl runid] {*}$chunklist + + if {$nonewline} { + return [string trimright $::shellrun::runerr \r\n] + } + return $::shellrun::runerr + } + + + proc runx {args} { + #set_last_run_display [list] + variable runout + variable runerr + set runout "" + set runerr "" + + set splitargs [get_run_opts $args] + set runopts [dict get $splitargs runopts] + set cmdargs [dict get $splitargs cmdargs] + + if {"-nonewline" in $runopts} { + set nonewline 1 + } else { + set nonewline 0 + } + + #shellfilter::stack::remove stdout $::repl::id_outstack + + if {"-echo" in $runopts} { + #float to ensure repl transform doesn't interfere with the output data + set stderr_stackid [shellfilter::stack::add stderr tee_to_var -action float -settings {-varname ::shellrun::runerr}] + set stdout_stackid [shellfilter::stack::add stdout tee_to_var -action float -settings {-varname ::shellrun::runout}] + } else { + #set stderr_stackid [shellfilter::stack::add stderr var -action sink-locked -settings {-varname ::shellrun::runerr}] + #set stdout_stackid [shellfilter::stack::add stdout var -action sink-locked -settings {-varname ::shellrun::runout}] + + #float above the repl's tee_to_var to deliberately block it. + #a var transform is naturally a junction point because there is no flow-through.. + # - but mark it with -junction 1 just to be explicit + set stderr_stackid [shellfilter::stack::add stderr var -action float-locked -junction 1 -settings {-varname ::shellrun::runerr}] + set stdout_stackid [shellfilter::stack::add stdout var -action float-locked -junction 1 -settings {-varname ::shellrun::runout}] + } + + set callopts "" + if {"-tcl" in $runopts} { + append callopts " -tclscript 1" + } + #set exitinfo [shellfilter::run $cmdargs -teehandle punksh -inbuffering none -outbuffering none -stdinhandler ::repl::repl_handler] + set exitinfo [shellfilter::run $cmdargs {*}$callopts -teehandle punksh -inbuffering none -outbuffering none] + + shellfilter::stack::remove stdout $stdout_stackid + shellfilter::stack::remove stderr $stderr_stackid + + + flush stderr + flush stdout + + if {[dict exists $exitinfo error]} { + if {"-tcl" in $runopts} { + + } else { + #todo - check errorInfo makes sense.. return -code? tailcall? + error [dict get $exitinfo error] + } + } + + #set x [shellfilter::stack::add stdout var -action sink-locked -settings {-varname ::repl::runxoutput}] + + set chunk "" + if {[string length $::shellrun::runout]} { + if {$nonewline} { + set o [string trimright $::shellrun::runout \r\n] + } else { + set o $::shellrun::runout + } + set chunk $o + } + set chunklist [list] + lappend chunklist [list "info" " "] + lappend chunklist [list "result" stdout] ;#key 'stdout' forms part of the resulting dictionary output + lappend chunklist [list "info" "[a+ white bold]stdout[a]"] + lappend chunklist [list result $chunk] ;#value corresponding to 'stdout' key in resulting dict + + + lappend chunklist [list "info" " "] + set chunk "[a+ red bold]stderr[a]" + lappend chunklist [list "result" $chunk] + lappend chunklist [list "info" stderr] + + set chunk "" + if {[string length $::shellrun::runerr]} { + if {$nonewline} { + set e [string trimright $::shellrun::runerr \r\n] + } else { + set e $::shellrun::runerr + } + set chunk $e + } + #stderr is part of the result + lappend chunklist [list "resulterr" $chunk] + + + + set n [a] + set c "" + if {[dict exists $exitinfo exitcode]} { + set code [dict get $exitinfo exitcode] + if {$code == 0} { + set c [a+ green] + } else { + set c [a+ yellow bold] + } + lappend chunklist [list "info" " "] + lappend chunklist [list "result" exitcode] + lappend chunklist [list "info" "exitcode $code"] + lappend chunklist [list "result" "$c$code$n"] + set exitdict [list exitcode $code] + } elseif {[dict exists $exitinfo result]} { + # presumably from a -tcl call + set val [dict get $exitinfo result] + lappend chunklist [list "info" " "] + lappend chunklist [list "result" result] + lappend chunklist [list "info" result] + lappend chunklist [list "result" $val] + set exitdict [list result $val] + } elseif {[dict exists $exitinfo error]} { + # -tcl call with error + #set exitdict [dict create] + lappend chunklist [list "info" " "] + lappend chunklist [list "result" error] + lappend chunklist [list "info" error] + lappend chunklist [list "result" [dict get $exitinfo error]] + + lappend chunklist [list "info" " "] + lappend chunklist [list "result" errorCode] + lappend chunklist [list "info" errorCode] + lappend chunklist [list "result" [dict get $exitinfo errorCode]] + + lappend chunklist [list "info" " "] + lappend chunklist [list "result" errorInfo] + lappend chunklist [list "info" errorInfo] + lappend chunklist [list "result" [dict get $exitinfo errorInfo]] + + set exitdict $exitinfo + } else { + #review - if no exitcode or result. then what is it? + lappend chunklist [list "info" exitinfo] + set c [a+ yellow bold] + lappend chunklist [list result "$c$exitinfo$n"] + set exitdict [list exitinfo $exitinfo] + } + + #set_last_run_display $chunklist + tsv::lappend repl runchunks-[tsv::get repl runid] {*}$chunklist + + #set ::repl::result_print 0 + #return [lindex [list [list stdout $::runout stderr $::runerr {*}$exitinfo] [shellfilter::stack::remove stdout $x][puts -nonewline stdout $pretty][set ::repl::output ""]] 0] + + + if {$nonewline} { + return [list {*}$exitdict stdout [string trimright $::shellrun::runout \r\n] stderr [string trimright $::shellrun::runerr \r\n]] + } + #always return exitinfo $code at beginning of dict (so that punk unknown can interpret the exit code as a unix-style bool if double evaluated) + return [list {*}$exitdict stdout $::shellrun::runout stderr $::shellrun::runerr] + } + + #an experiment + # + #run as raw string instead of tcl-list - no variable subst etc + # + #dummy repl_runraw that repl will intercept + proc repl_runraw {args} { + error "runraw: only available in repl as direct call - not from script" + } + #we can only call runraw with a single (presumably braced) string if we want to use it from both repl and tcl scripts (why? todo with unbalanced quotes/braces?) + proc runraw {commandline} { + #runraw fails as intended - because we can't bypass exec/open interference quoting :/ + #set_last_run_display [list] + variable runout + variable runerr + set runout "" + set runerr "" + + #return [shellfilter::run [lrange $args 1 end] -teehandle punksh -inbuffering none -outbuffering none -stdinhandler ::repl::repl_handler] + puts stdout ">>runraw got: $commandline" + + #run always echoes anyway.. as we aren't diverting stdout/stderr off for capturing + #for consistency with other runxxx commands - we'll just consume it. (review) + + set reallyraw 1 + if {$reallyraw} { + set wordparts [regexp -inline -all {\S+} $commandline] + set runwords $wordparts + } else { + #shell style args parsing not suitable for windows where we can't assume matched quotes etc. + package require string::token::shell + set parts [string token shell -indices -- $commandline] + puts stdout ">>shellparts: $parts" + set runwords [list] + foreach p $parts { + set ptype [lindex $p 0] + set pval [lindex $p 3] + if {$ptype eq "PLAIN"} { + lappend runwords [lindex $p 3] + } elseif {$ptype eq "D:QUOTED"} { + set v {"} + append v $pval + append v {"} + lappend runwords $v + } elseif {$ptype eq "S:QUOTED"} { + set v {'} + append v $pval + append v {'} + lappend runwords $v + } + } + } + + puts stdout ">>runraw runwords: $runwords" + set runwords [lrange $runwords 1 end] + + puts stdout ">>runraw runwords: $runwords" + #set args [lrange $args 1 end] + #set runwords [lrange $wordparts 1 end] + + set known_runopts [list "-echo" "-e" "-terminal" "-t"] + set aliases [list "-e" "-echo" "-echo" "-echo" "-t" "-terminal" "-terminal" "-terminal"] ;#include map to self + set runopts [list] + set cmdwords [list] + set idx_first_cmdarg [lsearch -not $runwords "-*"] + set runopts [lrange $runwords 0 $idx_first_cmdarg-1] + set cmdwords [lrange $runwords $idx_first_cmdarg end] + + foreach o $runopts { + if {$o ni $known_runopts} { + error "runraw: Unknown runoption $o" + } + } + set runopts [lmap o $runopts {dict get $aliases $o}] + + set cmd_as_string [join $cmdwords " "] + puts stdout ">>cmd_as_string: $cmd_as_string" + + if {"-terminal" in $runopts} { + #fake terminal using 'script' command. + #not ideal: smushes stdout & stderr together amongst other problems + set tcmd [shellfilter::get_scriptrun_from_cmdlist_dquote_if_not $cmdwords] + puts stdout ">>tcmd: $tcmd" + set exitinfo [shellfilter::run $tcmd -teehandle punksh -inbuffering line -outbuffering none ] + set exitinfo "exitcode not-implemented" + } else { + set exitinfo [shellfilter::run $cmdwords -teehandle punksh -inbuffering line -outbuffering none ] + } + + if {[dict exists $exitinfo error]} { + #todo - check errorInfo makes sense.. return -code? tailcall? + error [dict get $exitinfo error] + } + set code [dict get $exitinfo exitcode] + if {$code == 0} { + set c [a+ green] + } else { + set c [a+ white bold] + } + puts stderr $c + return $exitinfo + } + + proc sh_run {args} { + set splitargs [get_run_opts $args] + set runopts [dict get $splitargs runopts] + set cmdargs [dict get $splitargs cmdargs] + #e.g sh -c "ls -l *" + #we pass cmdargs to sh -c as a list, not individually + tailcall shellrun::run {*}$runopts sh -c $cmdargs + } + proc sh_runout {args} { + set splitargs [get_run_opts $args] + set runopts [dict get $splitargs runopts] + set cmdargs [dict get $splitargs cmdargs] + tailcall shellrun::runout {*}$runopts sh -c $cmdargs + } + proc sh_runerr {args} { + set splitargs [get_run_opts $args] + set runopts [dict get $splitargs runopts] + set cmdargs [dict get $splitargs cmdargs] + tailcall shellrun::runerr {*}$runopts sh -c $cmdargs + } + proc sh_runx {args} { + set splitargs [get_run_opts $args] + set runopts [dict get $splitargs runopts] + set cmdargs [dict get $splitargs cmdargs] + tailcall shellrun::runx {*}$runopts sh -c $cmdargs + } +} + +namespace eval shellrun { + interp alias {} run {} shellrun::run + interp alias {} sh_run {} shellrun::sh_run + interp alias {} runout {} shellrun::runout + interp alias {} sh_runout {} shellrun::sh_runout + interp alias {} runerr {} shellrun::runerr + interp alias {} sh_runerr {} shellrun::sh_runerr + interp alias {} runx {} shellrun::runx + interp alias {} sh_runx {} shellrun::sh_runx + + interp alias {} runc {} shellrun::runconsole + interp alias {} runraw {} shellrun::runraw + + + #the shortened versions deliberately don't get pretty output from the repl + interp alias {} r {} shellrun::run + interp alias {} ro {} shellrun::runout + interp alias {} re {} shellrun::runerr + interp alias {} rx {} shellrun::runx + + +} + +namespace eval shellrun { + proc test_cffi {} { + package require test_cffi + cffi::Wrapper create ::shellrun::kernel32 [file join $env(windir) system32 Kernel32.dll] + ::shellrun::kernel32 stdcall CreateProcessA + #todo - stuff. + return ::shellrun::kernel32 + } + +} +namespace eval ::punk::args::register { + #use fully qualified so 8.6 doesn't find existing var in global namespace + lappend ::punk::args::register::NAMESPACES ::shellrun +} + + +package provide shellrun [namespace eval shellrun { + variable version + set version 0.1.2 +}] diff --git a/src/bootsupport/modules/zipper-0.14.tm b/src/bootsupport/modules/zipper-0.14.tm index 7f7817f1ddce7fa6abfdea66e3c84636d1fe44cd..f1e5eeaed33aed457f26c1fe55bdad783c7406eb 100644 GIT binary patch delta 2479 zcmV;g2~hUNO~_5K6&ew1hr(P@d(l3$2><}W9RL6#lRPFRlS>*{e>jN!xiSksP^6ZA zM4$9xp;B5O5U$$0`$dvwq+^|FKhmER`C+KyEPdb)p-w?MmKO)xJDKXz5#(#>r`jJw zj!D>lHujBbKh2Ur9&Rl0Lp`CDstYq#lO$ENO7SF~k{>^0Gyaez;6go0@>EEZHk8ej z#i8VNh!t8f$*Ib)Q<;u+oT(K0&>~g-93mW-j5WYhe)yP|Ge1S4pZSiHlcSRCaf`Ld zd;pnD?MlQ`QWi@M(}%eNX7Qd;>B6ky#dN$;?CoM&W`xne_7lZ6{2f89lgv2*+rMzC5I9Z@%%>+#e?QnB%1rdVIE&LqolRxW*`3a;ux^_l{+z?fLi><8 zT5pc@owaN4ue6%!UF+8RLrS}apJthPA?)Zf9@DDC{uYI z6gm@FgcZAUJ(sK};ii_ZnE3MLO9Z!9OIYry#L_TRQN(XY+pm$gXuT<)9tJZ6D$?&n zPjdk4ac;^|KQ@t{v0!85P-N7eis8Y6Tc z7^xR0v06ns26?BpX>AS@f0Jq0XKfS|oX#`qZ?-X;&@hOS;ErQx?q?u_wLN#UKKe*U zb2%G0Yf4byP-kVL+nxb#9 z&zoIc4F-0{-0kRk=IgHqC!4zTS)Rr;j5M6q6UH8s8MW{%Yw22&B`geAg)!E7tncT- zy3+x`&=VE4i8VZX?N#g4FLtR2T|IWTfDMv3G$X1xW#k*9r;xL-suguGvRKKZzZ`zJ zevJ~tNg5K5Q3@V7e_PJE+8GWj4ttv+!C?vM*&pkP75x23h`oGLGH>&)MDEuFXnI!U zPpRLu&cgy5ASUV1&Ad)mP;19=+Pne>-sYi{M@`#kTg(S$k=Wj$xAp1Ir13fAhs08P;&F3$F%0~SBZ@vndQ3qYJUy>urVT%7OP&TbyKG2BMhPS$;Hy{g-0dAwQHH|9 zNwmu{BG5K|ymdrZzYo}wVWEND-+sT_SA2> z#6F!$keu31e`1Ed18qn*Ma-rlEEz<(Bz1XfO=-(3G^$z!3iCyz16vT#&k4ff1}VH? zf$(Peg{|dD#_WDO)4zd9Fa$e^T-xSL7%3T@7Cb4)DC@1dL_` zM;XN@qX)8QB-Ghz_q!i&1~=yftorx;^ZwvseA%xj(gk-tMd9xZT{(6&&p!{I8C+Ux zV=lC&cR$j4K<9McN3P&MaM;t$x`vEIktg}i#*kM_&>n}ISI-vsCt0d??IO5le!^~W z{+t@1e~l!gb*dfXTqEVPHMi{Nl0AGnOyXm1?BJpqal_cGx5=$EUT6kyS$Lc?<_j7$ zLi>@obJceIegS-&cvP8+{t(K0i8hh;_IvO)?lyPs$X`Gy^-Hv`4`1+a$cU`s4a3LG~*IWXD2MM&Fa6dBWke$kbglSWo`;_WI;EE!(4O ze^Krgy};)S{J-4gCfgy`iWU=S`fyE`aL}sjY8E*caMn6ro9GT%cYExv-br4J{^tlc zPxpj4{Yg>&>x4@+*Pj#dc3WpxxA1Fav08QdlkFI!qJ3{OGpf|n8}hH$ zFu+fOL!J)B3AuTw*Zj)$pGsS-#qCw+jZIAI5pWL;@$((p7YWdKCbk4oC*4$ec@`FFMjDGPF z+Ag0v8b;-L)Kd~&`o8U=8D-W!>BN*HPfgy>$opo!E3ENfA=*f zZ4RKe<$(ErOA7HV+g5wE9X&n_ReIE0YaCEgk~Kx+y~Q?lsn4>mXjiDzT6P3Ss+L-< zDhA*F{q-B-(DS(~=QMYD^US8XXZ_1YFTTec&aF3CU$~@a8}Tns5O;rBZ*NQ1ehnKp z)UlX3>jPjpp-RJ`?zKV7u(+FMe<+e883MQ)>k%?$>%# zoog1!JM!~5nDJQE4t?i7PA;~2YfIp#(`8@y7dc`sM|%4WPw$k5(#~hTh6~uma%8si z*Yp1Q1*|P6b2puzs#u}M*~t$d3^E;`*?E64ELix#oj+AT>6aV_DZAbIf1l<1@?~w* zI!qRl7ltcEju|ovp%+(v9#+dFnGy`=PcWS7V<_kD))9xJ#cHJQ$L<6 zw_-r>?{gmrsFz9Tu_|>D;-dja}D%TLI+8x$vk{twMrR0p+oL zU$ZP%SUPruqau}+dpQRb;e$%D@6aWAKlLjOd0SA+gCL#y_ t{{sL30Rpo_B-#NDYlp&IQG3xova$!P!p delta 2469 zcmV;W30n5ZO~y^I6&exR2)tY<;pJen2><}V9RL6#lRhRTlS>*{e^~gzoj+ByNRy=w z6@Ai+g-WS^Hn=!Ai2b=TSfNNQ{it}iJ|JARclV1V%}B>O(|)8sDe}Wm#aa5mA3~ji zZ7eSiws$hsr6b7K(oeNNhK!T2{cP+T)qa{Kfjrz;;)i-dD^(X}tR_jSXqDngJS9JV z$Y%T@OTdMCl;o+9Vd->o`*>^Z{hbpF@P>lCcJ`$`2p& za^|Nf^fTXaa&lCXJ#Mi!nGYb7iQM>UFw;xbV-jb3WKs9KW%*WvLP{(DfdZ^sCFvdZ zj`NI6G8ZFLlXV*-f4fnjjMb(koYUfmiV(X3&3wE5jK$(jvC&Bkd6_)8&yqZ1_$W@= zG%d+4Yh!2*eJ4p2B`fkN)RPJJ#~B_Dg`Sir;e+Sz`nTfs^XL0(dv#IPk zyVIE!)@}2{pK~}_Xdg01>&=nAvv%$Ml~ywy%mBunvcMKtQR%vnh+km6(-+ia8ZA zPMnw6=|#lFe;p$RWh$?OLT3Vtuwr+v=aTg#+|<$)6JNf3iQx8X3Clf|SQ=(3iumnl z`!(_wtvBVFE82dQ8W|p9;oQO-(+go)3K2)bHMeCmU#u z&o_e&P0DqgbbW-w`XjxiH-xw#BMZlPe%BBSE)0ty9iql{yWYp%;KlR)$<@`16Z#Kz zy|-6af0z8pd$Va;Q}iwNd9$ml!NBgAyB%H6eEs#{WK)+u%hQ;Kk%rTH!q{UnqZXcJ zEnQ2pgoWX%FvdEM_5EB}cRBzVdZMB>v4&@_y=tBM#V!@0tH;h3ut5@sW<)iojC^DC z6mk|;wW1D27Atx5m%|U&uTf$+Nkif>O2GqXf6F;nJHuhcVQ(`eI4mJO`(r(^g1;XL zv6oLu=55}U$o-lCP0xz_DfOGyd01cr#6%r~NXJD6U^xMB zf4-O_!y3+&oWCEF&W;U*3NU6hq&7`8hJl}PMA4^6k10rlr{|T-wBaXh$v^x-oUs|rNRTA-YqgsMP+8`IJ z@f%l)xoP6tHpd#niZ1nf_}Tf}@D;)4mPy>EiVNOS-8zmgFS|l4Wotw|&lTuee@Z^& ziu{DWtKrMQ0iM^KfYFTLD5Ln)^g#CfggRU8e)r?e;O3lwRsX(!-XC0yFZ=aGy5O#- zDEytFE61+p`RBnigG*~|%!StU?nhb==$y{`$QAqt4tu&;*N~AY@+9Bc81iZf+T(EZ z>e&MSBumwO zHo29?3(epy3y*Wgd_jXoXg~6HuG)^@FMw|ok1A8qA3}LA(I(Q~eh=Qp-R906`3oqe zJ}P|U#bF~>N=rAdfBI3b%DeZhh`Zh>6Qp{f1VKHyHcqXv^eAG2Zs)^w=VZ4y*LC5WG?R=&m@}SOs-!QJcT@Wgb~okY zZyvIew2mj}Tr`RWa`1#t!N_=GLl*;&_6XR0n}pX^e_TH$$bN-@>{v+3=zB6WPdJ&f5VUZ4D?WqWijf6Be07x;XE|ChVmWIN7Ed$KPk$8op7n<`g0=QZtLvo7JjWPR;x~bvK@m|wC`37BJMpf?Kv-f;p0kw z$C;r2`6rU9EkF2E%jg#`q3!ayvr+lKaM`+V7GrQ)x6eAaGGx6)1Km`nX|9;9GK>m? zS~HDWvyS`X6};BUe{)}R(&hkaTMn52x1RubP42!#Ie}*DCk|BV*u^u5~woaT7 zKa#n1hbbIZ_cT^K-cIw_*tuqrydyu4gBg!i?a+7b#s;u?dzL?kir;lxHasgKn|=Il)ISq|?!8wAHMO zIb@MG^3R*J1`@Rq=lb6_XHV>Gvp(2t_L{J6k7%5iTCT%F_9C4-*R-+g+HWg> z+&C8=b*fcJa4MiYmhWqpZ $pkgname $cond] { if {![catch {package require } returnver]} { - tsv::set zzzload_pkg $returnver + tsv::set zzzload_pkg $returnver } else { tsv::set zzzload_pkg "failed" } @@ -85,7 +88,7 @@ namespace eval zzzload { } } proc pkg_wait {pkgname} { - if {[set ver [package provide twapi]] ne ""} { + if {[set ver [package provide $pkgname]] ne ""} { return $ver } @@ -116,22 +119,10 @@ namespace eval zzzload { } - - - - - - - - - - - - # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready +## Ready package provide zzzload [namespace eval zzzload { variable version - set version 0.1.0 + set version 0.1.0 }] return \ No newline at end of file diff --git a/src/make.tcl b/src/make.tcl index 25ba66ae..917cd4d7 100644 --- a/src/make.tcl +++ b/src/make.tcl @@ -2093,12 +2093,16 @@ if {$::punkboot::command in {project packages modules}} { #install .tm *and other files* puts stdout "VENDORMODULES$which: copying from $sourcefolder/$vf to $target_module_folder (if source file changed)" - set resultdict [punkcheck::install $sourcefolder/$vf $target_module_folder\ - -installer make.tcl\ - -overwrite installedsourcechanged-targets\ - -antiglob_paths {README.md AGENTS.md **/AGENTS.md include_modules.config}\ - -progresschannel stdout\ - ] + set resultdict [punkcheck::install $sourcefolder/$vf $target_module_folder {*}{ + -installer make.tcl + -overwrite installedsourcechanged-targets + -progresschannel stdout + -exclude-filetails {AGENTS.md include_modules.config} + -antiglob_paths {README.md} + }] + # -antiglob_paths {README.md AGENTS.md **/AGENTS.md include_modules.config} + #-exclude-filetails {AGENTS.md include_modules.config} + #-antiglob_paths {README.md} puts stdout [punkcheck::summarize_install_resultdict $resultdict] } if {![llength $vendormodulefolders]} { diff --git a/src/modules/punk/args-999999.0a1.0.tm b/src/modules/punk/args-999999.0a1.0.tm index 9f6e329a..9e4f36c1 100644 --- a/src/modules/punk/args-999999.0a1.0.tm +++ b/src/modules/punk/args-999999.0a1.0.tm @@ -9086,7 +9086,7 @@ tcl::namespace::eval punk::args { } if {!([tcl::string::first " " $a]>=0 || [tcl::string::first \t $a]>=0 || [tcl::string::last \n $a]>=0)} { if {$OPT_ANY} { - #exlude argument with whitespace from being a possible option e.g dict + #exclude argument with whitespace from being a possible option e.g dict #todo - passthrough of unrecognised --longopt=xxx without looking for following flag-value set eposn [string first = $a] if {$eposn > 2 && [string match --* $a]} { diff --git a/src/modules/punk/path-999999.0a1.0.tm b/src/modules/punk/path-999999.0a1.0.tm index 7aca41ed..f5ec8d50 100644 --- a/src/modules/punk/path-999999.0a1.0.tm +++ b/src/modules/punk/path-999999.0a1.0.tm @@ -1048,7 +1048,7 @@ namespace eval punk::path { if {$boundary ne "" && [::punk::path::globmatchpath $boundary $path]} { set recurse_below 1 set next_allbelow 1 - break + continue } if {[pattern_prefix_viable $gp $path]} { diff --git a/src/modules/punkcheck-999999.0a1.0.tm b/src/modules/punkcheck-999999.0a1.0.tm index 8097e910..75516f65 100644 --- a/src/modules/punkcheck-999999.0a1.0.tm +++ b/src/modules/punkcheck-999999.0a1.0.tm @@ -42,7 +42,7 @@ namespace eval punkcheck { } #exclude-dir & exclude-file entries match the pattern at any level - should not contain path separators - variable default_exludedirseg_core [list "#*" "_aside" "_build" ".git" ".fossil*"] + variable default_excludedirseg_core [list "#*" "_aside" "_build" ".git" ".fossil*"] variable default_excludefiletail_core "" set has_twapi 0 @@ -1283,10 +1283,10 @@ namespace eval punkcheck { ledit excludedirseg_core $posn $posn } set defaults [list {*}{ - } -glob * {*}{ - } -exclude-filetails [list "*.tm" "*-buildversion.txt" "*.exe"] {*}{ - } -exclude-dirsegment_core $excludedirseg_core {*}{ - } -installer punkcheck::install_non_tm_files {*}{ + } -glob * {*}{ + } -exclude-filetails [list "*.tm" "*-buildversion.txt" "*.exe"] {*}{ + } -exclude-dirsegments_core $excludedirseg_core {*}{ + } -installer punkcheck::install_non_tm_files {*}{ } ] set opts [dict merge $defaults $args] diff --git a/src/project_layouts/custom/_project/punk.basic/src/make.tcl b/src/project_layouts/custom/_project/punk.basic/src/make.tcl index 25ba66ae..917cd4d7 100644 --- a/src/project_layouts/custom/_project/punk.basic/src/make.tcl +++ b/src/project_layouts/custom/_project/punk.basic/src/make.tcl @@ -2093,12 +2093,16 @@ if {$::punkboot::command in {project packages modules}} { #install .tm *and other files* puts stdout "VENDORMODULES$which: copying from $sourcefolder/$vf to $target_module_folder (if source file changed)" - set resultdict [punkcheck::install $sourcefolder/$vf $target_module_folder\ - -installer make.tcl\ - -overwrite installedsourcechanged-targets\ - -antiglob_paths {README.md AGENTS.md **/AGENTS.md include_modules.config}\ - -progresschannel stdout\ - ] + set resultdict [punkcheck::install $sourcefolder/$vf $target_module_folder {*}{ + -installer make.tcl + -overwrite installedsourcechanged-targets + -progresschannel stdout + -exclude-filetails {AGENTS.md include_modules.config} + -antiglob_paths {README.md} + }] + # -antiglob_paths {README.md AGENTS.md **/AGENTS.md include_modules.config} + #-exclude-filetails {AGENTS.md include_modules.config} + #-antiglob_paths {README.md} puts stdout [punkcheck::summarize_install_resultdict $resultdict] } if {![llength $vendormodulefolders]} { diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/fauxlink-0.1.1.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/fauxlink-0.1.1.tm index 970e47da..2fc9c5fb 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/fauxlink-0.1.1.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/fauxlink-0.1.1.tm @@ -205,7 +205,7 @@ namespace eval fauxlink { # %2F "/" # %2f "/" # %7f (del) - #we exlude the forward slash because we already have + for that - and multiple ways to specify it obscure intention. + #we exclude the forward slash because we already have + for that - and multiple ways to specify it obscure intention. # set decode_map [dict merge $decode_map [dict create\ %09 \t\ diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/funcl-0.1.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/funcl-0.1.tm index e8430fb0..f36a1f64 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/funcl-0.1.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/funcl-0.1.tm @@ -1,3 +1,6 @@ + +#experimental. + package provide funcl [namespace eval funcl { variable version set version 0.1 @@ -210,7 +213,7 @@ namespace eval funcl { } append body [join [lreverse $tails] " "] #puts stdout "tails: $tails" - + return $body } @@ -225,7 +228,7 @@ namespace eval funcl { # _fn 0 indicates next item is an unwrapped commandlist (terminal command) # #o_of is equivalent to o_of_n 1 (1 argument o combinator) - #last n args are passed to the prior function + #last n args are passed to the prior function #e.g for n=1 f a b = f(a(b)) #e.g for n=2, e f a b = e(f(a b)) proc o_of_n {n args} { @@ -235,7 +238,7 @@ namespace eval funcl { } set comp [list] ;#composition list set end [lindex $args end] - if {[lindex $end 0] in {_fn _call}]} { + if {[lindex $end 0] in {_fn _call}} { #is_funcl set endfunc [lindex $args end] } else { @@ -246,7 +249,7 @@ namespace eval funcl { set endfunc [list _call 1 3 [list {*}$end]] } } - + if {[llength $args] == 1} { return $endfunc } diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/metaface-1.2.9.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/metaface-1.2.9.tm new file mode 100644 index 00000000..aabb5435 --- /dev/null +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/metaface-1.2.9.tm @@ -0,0 +1,6364 @@ +package provide metaface [namespace eval metaface { + variable version + set version 1.2.9 +}] + +# 2025-09-29 - update outdated 'trace vinfo' to 'trace info variable' - both work for 8.6, but vinfo deprecated for tcl 9+ +# 2023-07 - add .. MetaMethods + + +#example datastructure: +#$_ID_ +#{ +#i +# { +# this +# { +# {16 ::p::16 item ::>x {}} +# } +# role2 +# { +# {17 ::p::17 item ::>y {}} +# {18 ::p::18 item ::>z {}} +# } +# } +#context {} +#} + +#$MAP +#invocantdata {16 ::p::16 item ::>x {}} +#interfaces {level0 +# { +# api0 {stack {123 999}} +# api1 {stack {333}} +# } +# level0_default api0 +# level1 +# { +# } +# level1_default {} +# } +#patterndata {patterndefaultmethod {}} + + +namespace eval ::p::predator {} +#temporary alternative to ::p::internals namespace. +# - place predator functions here until ready to replace internals. + + +namespace eval ::p::snap { + variable id 0 ;#ever-increasing non-reused snapshot-id to identify ::p::snapshot namespaces used to allow overlay-rollbacks. +} + + + + +# not called directly. Retrieved using 'info body ::p::predator::getprop_template' +#review - why use a proc instead of storing it as a string? +proc ::p::predator::getprop_template {_ID_ args} { + set OID [lindex [dict get $_ID_ i this] 0 0] + if {"%varspace%" eq ""} { + set ns ::p::${OID} + } else { + if {[string match "::*" "%varspace%"]} { + set ns "%varspace%" + } else { + set ns ::p::${OID}::%varspace% + } + } + + + if {[llength $args]} { + #lassign [lindex $invocant 0] OID alias itemCmd cmd + if {[array exists ${ns}::o_%prop%]} { + #return [set ${ns}::o_%prop%($args)] + if {[llength $args] == 1} { + return [set ::p::${OID}::o_%prop%([lindex $args 0])] + } else { + return [lindex [set ::p::${OID}::o_%prop%([lindex $args 0])] {*}[lrange $args 1 end]] + } + } else { + set val [set ${ns}::o_%prop%] + + set rType [expr {[scan [namespace tail $val] >%s rType] ? {object} : {unknown}}] + if {$rType eq "object"} { + #return [$val . item {*}$args] + return [$val {*}$args] + } else { + #treat as list? + return [lindex $val $args] + } + } + } else { + return [set ${ns}::o_%prop%] + } +} + + +proc ::p::predator::getprop_template_immediate {_ID_ args} { + if {[llength $args]} { + if {[array exists %ns%::o_%prop%]} { + return [set %ns%::o_%prop%($args)] + } else { + set val [set %ns%::o_%prop%] + set rType [expr {[scan [namespace tail $val] >%s rType] ? {object} : {unknown}}] + if {$rType eq "object"} { + #return [$val . item {*}$args] + #don't assume defaultmethod named 'item'! + return [$val {*}$args] + } else { + #treat as list? + return [lindex $val $args] + } + } + } else { + return [set %ns%::o_%prop%] + } +} + + + + + + + + +proc ::p::predator::getprop_array {_ID_ prop args} { + set OID [lindex [dict get $_ID_ i this] 0 0] + + #upvar 0 ::p::${OID}::o_${prop} prop + #1st try: assume array + if {[catch {array get ::p::${OID}::o_${prop}} result]} { + #treat as list (why?) + #!review + if {[info exists ::p::${OID}::o_${prop}]} { + array set temp [::list] + set i 0 + foreach element ::p::${OID}::o_${prop} { + set temp($i) $element + incr i + } + set result [array get temp] + } else { + error "unable to retrieve [set ::p::${OID}::o_${prop}] contents in 'array get' format" + } + } + return $result +} + +proc ::p::predator::setprop_template {prop _ID_ args} { + set OID [lindex [dict get $_ID_ i this] 0 0] + if {"%varspace%" eq ""} { + set ns ::p::${OID} + } else { + if {[string match "::*" "%varspace%"]} { + set ns "%varspace%" + } else { + set ns ::p::${OID}::%varspace% + } + } + + + if {[llength $args] == 1} { + #return [set ::p::${OID}::o_%prop% [lindex $args 0]] + return [set ${ns}::o_%prop% [lindex $args 0]] + + } else { + if {[array exists ${ns}::o_%prop%] || ![info exists ${ns}::o_%prop%]} { + #treat attempt to perform indexed write to nonexistant var, same as indexed write to array + + #2 args - single index followed by a value + if {[llength $args] == 2} { + return [set ${ns}::o_%prop%([lindex $args 0]) [lindex $args 1]] + } else { + #multiple indices + #return [set ::p::${OID}::o_%prop%([lrange $args 0 end-1]) [lindex $args end]] + return [lset ${ns}::o_%prop%([lindex $args 0]) {*}[lrange $args 1 end-1] [lindex $args end] ] + } + } else { + #treat as list + return [lset ${ns}::o_%prop% [lrange $args 0 end-1] [lindex $args end]] + } + } +} + +#-------------------------------------- +#property read & write traces +#-------------------------------------- + + +proc ::p::predator::propref_trace_read {get_cmd _ID_ refname prop indices vtraced idx op} { + + #puts stderr "\t-->propref_trace_read get_cmd:'$get_cmd' refname:'$refname' prop:'$prop' indices:'$indices' $vtraced idx:'$idx' " + + #set cmd ::p::${OID}::(GET)$prop ;#this is an interp alias to the head of the implementation command-chain. + + if {[llength $idx]} { + if {[llength $idx] == 1} { + set ${refname}($idx) [$get_cmd $_ID_ {*}$indices $idx] + } else { + lset ${refname}([lindex $idx 0]) [lrange $idx 1 end] [$get_cmd $_ID_ {*}$indices {*}$idx] + } + return ;#return value ignored - in a trace we can only return the value by setting the traced variable to a value + } else { + if {![info exists $refname]} { + set $refname [$get_cmd $_ID_ {*}$indices] + } else { + set newval [$get_cmd $_ID_ {*}$indices] + if {[set $refname] ne $newval} { + set $refname $newval + } + } + return + } +} + + + + +proc ::p::predator::propref_trace_write {_ID_ OID full_varspace refname vname idx op} { + #note 'vname' may be upvar-ed local - we need the fully qualified name so must use passed in $refname + #puts stdout "\t-->propref_trace_write $OID ref:'$refname' var:'$vname' idx:'$idx'" + + + #derive the name of the write command from the ref var. + set indices [lassign [split [namespace tail $refname] +] prop] + + + #assert - we will never have both a list in indices and an idx value + if {[llength $indices] && ($idx ne "")} { + #since Tcl has no nested arrays - we can't write to an idx within something like ${prop}+x + #review - are there any datastructures which would/should allow this? + #this assertion is really just here as a sanity check for now + error "propref_trace_write unexpected values. Didn't expect a refname of the form ${prop}+* as well as an idx value" + } + + #upvar #0 ::p::${OID}::_meta::map MAP + #puts "-->propref_trace_write map: $MAP" + + #temporarily deactivate refsync trace + #puts stderr -->1>--removing_trace_o_${field} +### trace remove variable ::p::${OID}::o_${prop} [::list write] [::list ::p::predator::propvar_write_TraceHandler $OID $prop] + + #we need to catch, and re-raise any error that we may receive when writing the property + # because we have to reinstate the propvar_write_TraceHandler after the call. + #(e.g there may be a propertywrite handler that deliberately raises an error) + + set excludesync_refs $refname + set cmd ::p::${OID}::(SET)$prop + + + set f_error 0 + if {[catch { + + if {![llength $indices]} { + if {[string length $idx]} { + $cmd $_ID_ $idx [set ${refname}($idx)] + #::p::predator::refsyncvar_write_manualupdate $OID $excludesync_refs $prop ::p::${OID}::o_${prop}($idx) [list] + ### ::p::predator::refsyncvar_write_manualupdate $OID $excludesync_refs $prop ::p::${OID}::o_${prop} [list $idx] + + } else { + $cmd $_ID_ [set $refname] + ### ::p::predator::refsyncvar_write_manualupdate $OID $excludesync_refs $prop ::p::${OID}::o_${prop} [list] + } + } else { + #puts " ++>> cmd:$cmd indices:'$indices' refname:'$refname'\n" + $cmd $_ID_ {*}$indices [set $refname] + ### ::p::predator::refsyncvar_write_manualupdate $OID $excludesync_refs $prop ::p::${OID}::o_${prop} $indices + } + + } result]} { + set f_error 1 + } + + + + + #::p::predator::propvar_write_TraceHandler $OID $prop ::p::${OID}::o_${prop} $indices write + #reactivate refsync trace + #puts stderr "****** reactivating refsync trace on o_$field" + #puts stderr -->2>--reactivating_trace_o_${field} + ### trace add variable ::p::${OID}::o_${prop} [::list write] [::list ::p::predator::propvar_write_TraceHandler $OID $prop] + + + if {$f_error} { + #!todo - review error & 'return' functions for proper way to throw error, preserving callstack info for debugging. + # ? return -code error $errMsg ? -errorinfo + + #!quick n dirty + #error $errorMsg + return -code error -errorinfo $::errorInfo $result + } else { + return $result + } +} + + + + + +proc ::p::predator::propref_trace_array {_ID_ OID refname vref idx op} { + #puts stderr "\t-->propref_trace_array OID:$OID refname:'$refname' var:'$vref' index:'$idx' operation:'$op'" + #NOTE - do not rely on $vref !!!! (can be upvared - so could be anything. e.g during 'parray' calls it is set to 'array') + + set indices [lassign [split [namespace tail $refname] +] prop] ;#make sure 'prop' is set + + #set updated_value [::p::predator::getprop_array $prop $_ID_] + #puts stderr "-->array_Trace updated_value:$updated_value" + if {[catch {array set $refname [::p::predator::getprop_array $_ID_ $prop ]} errm]} { + puts stderr "-->propref_trace_array error $errm" + array set $refname {} + } + + #return value ignored for +} + + +#-------------------------------------- +# +proc ::p::predator::object_array_trace {OID _ID_ vref idx op} { + upvar #0 ::p::${OID}::_meta::map MAP + lassign [dict get $MAP invocantdata] OID alias itemCmd + + + #don't rely on variable name passed by trace - may have been 'upvar'ed + set refvar ::p::${OID}::_ref::__OBJECT + + #puts "+=====>object_array_trace $map '$vref' '$idx' '$op' refvar: $refvar" + + set iflist [dict get $MAP interfaces level0] + + set plist [list] + + #!todo - get propertylist from cache on object(?) + foreach IFID [lreverse $iflist] { + dict for {prop pdef} [set ::p::${IFID}::_iface::o_properties] { + #lassign $pdef v + if {[catch {lappend plist $prop [set ::p::${OID}::o_${prop}]}]} { + if {[array exists ::p::${OID}::o_${prop}]} { + lappend plist $prop [array get ::p::${OID}::o_${prop}] + } else { + #ignore - array only represents properties that have been set. + #error "property $v is not set" + #!todo - unset corresponding items in $refvar if needed? + } + } + } + } + array set $refvar $plist +} + + +proc ::p::predator::object_read_trace {OID _ID_ vref idx op} { + upvar #0 ::p::${OID}::_meta::map MAP + lassign [dict get $MAP invocantdata] OID alias itemCmd + #don't rely on variable name passed by trace. + set refvar ::p::${OID}::_ref::__OBJECT + + #puts "\n\n+=====>object_read_trace map:'$MAP' '$vref' '$idx' '$op' refvar: $refvar\n\n" + + #!todo? - build a list of all interface properties (cache it on object??) + set iflist [dict get $MAP interfaces level0] + set IID "" + foreach id [lreverse $iflist] { + if {$idx in [dict keys [set ::p::${id}::_iface::o_properties]]} { + set IID $id + break + } + } + + if {[string length $IID]} { + #property + if {[catch {set ${refvar}($idx) [::p::${id}::_iface::(GET)$idx $_ID_]} errmsg]} { + puts stderr "\twarning: ::p::${id}::_iface::(GET)$idx retrieval failed (array?) errmsg:$errmsg" + } + } else { + #method + error "property '$idx' not found" + } +} + + +proc ::p::predator::object_unset_trace {OID _ID_ vref idx op} { + upvar #0 ::p::${OID}::_meta::map MAP + + lassign [dict get $MAP invocantdata] OID alias itemCmd + + #!todo - ??? + + if {![llength [info commands ::p::${OID}::$idx]]} { + error "no such method or property: '$idx'" + } else { + #!todo? - build a list of all interface properties (cache it on object??) + set iflist [dict get $MAP interfaces level0] + set found 0 + foreach id [lreverse $iflist] { + if {$idx in [dict keys [set ::p::${id}::_iface::o_properties]]} { + set found 1 + break + } + } + + if {$found} { + unset ::p::${OID}::o_$idx + } else { + puts stderr "\tWARNING: UNIMPLEMENTED CASE! (unset) object_unset_trace id:$OID objectcmd:[lindex [dict get $MAP invocantdata] 3] var:$vref prop:$idx" + } + } +} + + +proc ::p::predator::object_write_trace {OID _ID_ vref idx op} { + upvar #0 ::p::${OID}::_meta::map MAP + lassign [dict get $MAP invocantdata] OID alias itemCmd + #don't rely on variable name passed by trace. + set refvar ::p::${OID}::_ref::__OBJECT + #puts "+=====>object_write_trace $MAP '$vref' '$idx' '$op' refvar: $refvar" + + + if {![llength [info commands ::p::${OID}::$idx]]} { + #!todo - create new property in interface upon attempt to write to non-existant? + # - or should we require some different kind of object-reference for that? + array unset $refvar $idx ;#make sure 'array names' on the ref doesn't include this $idx + error "no such method or property: '$idx'" + } else { + #!todo? - build a list of all interface properties (cache it on object??) + set iflist [dict get $MAP interfaces level0] + set IID "" + foreach id [lreverse $iflist] { + if {$idx in [dict keys [set ::p::${id}::_iface::o_properties]]} { + set IID $id + break + } + } + + #$IID is now topmost interface in default iStack which has this property + + if {[string length $IID]} { + #write to defined property + + ::p::${IID}::_iface::(SET)$idx $_ID_ [set ${refvar}($idx)] + } else { + #!todo - allow write of method body back to underlying object? + #attempted write to 'method' ..undo(?) + array unset $refvar $idx ;#make sure 'array names' on the ref doesn't include this $idx + error "cannot write to method '$idx'" + #for now - disallow + } + } + +} + + + +proc ::p::predator::propref_trace_unset {_ID_ OID refname vref idx op} { + #note 'vref' may be upvar-ed local - we need the fully qualified name so must use passed in $refname + + set refindices [lassign [split [namespace tail $refname] +] prop] + #derive the name of any potential PropertyUnset command from the refname. i.e (UNSET)$prop + #if there is no PropertyUnset command - we unset the underlying variable directly + + trace remove variable ::p::${OID}::o_${prop} [::list unset] [::list ::p::predator::propvar_unset_TraceHandler $OID $prop] + + + if {[catch { + + #assert if refname is complex (prop+idx etc), we will not get a reference trace with an $idx value + #i.e + if {[llength $refindices] && [string length $idx]} { + puts stderr "\t !!!!! unexpected call to propref_trace_unset oid:'$OID' refname:'$refname' vref:'$vref' idx:'$idx' op:'$op'" + error "unexpected call to propref_trace_unset" + } + + + upvar #0 ::p::${OID}::_meta::map MAP + + set iflist [dict get $MAP interfaces level0] + #find topmost interface containing this $prop + set IID "" + foreach id [lreverse $iflist] { + if {$prop in [dict keys [set ::p::${id}::_iface::o_properties]]} { + set IID $id + break + } + } + if {![string length $IID]} { + error "propref_trace_unset failed to find property '$prop' on objectid $OID ([lindex [dict get $_ID_ i this] 0 3])" + } + + + + if {[string length $idx]} { + #eval "$_alias ${unset_}$field $idx" + #what happens to $refindices??? + + + #!todo varspace + + if {![llength $refindices]} { + #puts stdout "\t 1a@@@@ propref_trace_unset $OID ref:'$refname' var:'$vref' idx:'$idx'" + + if {![llength [info commands ::p::${IID}::_iface::(UNSET)$prop]]} { + unset ::p::${OID}::o_${prop}($idx) + } else { + ::p::${IID}::_iface::(UNSET)$prop $_ID_ $idx + } + + + #manually call refsync, passing it this refvar as an exclusion + ::p::predator::refsyncvar_unset_manualupdate $OID $refname $prop ::p::${OID}::o_${prop} $idx + } else { + #assert - won't get here + error 1a + + } + + } else { + if {[llength $refindices]} { + #error 2a + #puts stdout "\t 2a@@@@ propref_trace_unset $OID ref:'$refname' var:'$vref' idx:'$idx'" + + if {![llength [info commands ::p::${IID}::_iface::(UNSET)$prop]]} { + #review - what about list-type property? + #if {[array exists ::p::${OID}::o_${prop}]} ??? + unset ::p::${OID}::o_${prop}($refindices) + } else { + ::p::${IID}::_iface::(UNSET)$prop $_ID_ $refindices + } + + + + #manually call refsync, passing it this refvar as an exclusion + ::p::predator::refsyncvar_unset_manualupdate $OID $refname $prop ::p::${OID}::o_${prop} $refindices + + + } else { + #puts stdout "\t 2b@@@@ propref_trace_unset $OID ref:'$refname' var:'$vref' idx:'$idx'" + + #ref is not of form prop+x etc and no idx in the trace - this is a plain unset + if {![llength [info commands ::p::${IID}::_iface::(UNSET)$prop]]} { + unset ::p::${OID}::o_${prop} + } else { + ::p::${IID}::_iface::(UNSET)$prop $_ID_ "" + } + #manually call refsync, passing it this refvar as an exclusion + ::p::predator::refsyncvar_unset_manualupdate $OID $refname $prop ::p::${OID}::o_${prop} {} + + } + } + + + } errM]} { + #set ::LAST_UNSET_ERROR "$errM\n[set ::errorInfo]" + set ruler [string repeat - 80] + puts stderr "\t$ruler" + puts stdout "\t @@@@ERROR propref_trace_unset $OID ref:'$refname' var:'$vref' idx:'$idx'" + puts stderr "\t$ruler" + puts stderr $errM + puts stderr "\t$ruler" + + } else { + #puts stdout "\t @@@@ propref_trace_unset $OID ref:'$refname' var:'$vref' idx:'$idx'" + #puts stderr "*@*@*@*@ end propref_trace_unset - no error" + } + + trace add variable ::p::${OID}::o_${prop} [::list unset] [::list ::p::predator::propvar_unset_TraceHandler $OID $prop] + + +} + + + + +proc ::p::predator::refsyncvar_unset_manualupdate {OID triggeringRef prop vtraced vidx} { + #Do not use 'info exists' (avoid triggering read trace) - use info vars + if {[info vars ::p::${OID}::_ref::$prop] eq "::p::${OID}::_ref::$prop"} { + #puts " **> lappending '::p::REF::${OID}::$prop'" + lappend refvars ::p::${OID}::_ref::$prop + } + lappend refvars {*}[info vars ::p::${OID}::_ref::${prop}+*] + + if {[string length $triggeringRef]} { + set idx [lsearch -exact $refvars $triggeringRef] + if {$idx >= 0} { + set refvars [lreplace $refvars[set refvars {}] $idx $idx] ;#note inline K combinator [set refvars {}] + } + } + if {![llength $refvars]} { + #puts stderr " %%%%%%%%%% no refvars for propvar_unset_TraceHandler to update - short circuiting . $OID $triggeringRef $prop $vtraced $vidx" + return + } + + + #*usually* triggeringRef is not in the reflist because the triggeringRef is being unset + # - but this is not the case when we do an array unset of an element using a reference to the whole array e.g "array unset [>obj . arr .] b" + if {([string length $triggeringRef]) && ($triggeringRef in $refvars)} { + #puts stderr "\t@@@@@@@@@@ propvar_unset_TraceHandler unexpected situation. triggeringRef $triggeringRef in refvars:$refvars during unset ???" + puts stderr "\t@@@@@ propvar_unset_TraceHandler triggeringRef $triggeringRef is in refvars list - probably a call of form 'array unset \[>obj .arr .\] someindex'" + } + + + puts stderr "\t refsyncvar_unset_manualupdate OID:'$OID' triggeringRef:'$triggeringRef' prop:'$prop' vtraced:'$vtraced' vidx:'$vidx' " + + + + upvar $vtraced SYNCVARIABLE + + + #We are only interested in suppressing the 'setGet_TraceHandler' traces on refvars + array set traces [::list] + + #puts stderr "*-*-*-*-*-* refvars \n- [join $refvars "\n- "]" + + + foreach rv $refvars { + #puts "--refvar $rv" + foreach tinfo [trace info variable $rv] { + #puts "##trace $tinfo" + set ops {}; set cmd {} + lassign $tinfo ops cmd + #!warning - assumes traces with single operation per handler. + #write & unset traces on refvars need to be suppressed + #we also need to be able to read certain refvars without triggering retrieval of underlying value in order to detect if changed. + if {$ops in {read write unset array}} { + if {[string match "::p::predator::propref_trace_*" $cmd]} { + lappend traces($rv) $tinfo + trace remove variable $rv $ops $cmd + #puts stderr "*-*-*-*-*-* removing $ops trace on $rv -> $cmd" + } + } + } + } + + + if {[array exists SYNCVARIABLE]} { + #underlying variable is an array - we are presumably unsetting just an element + set vtracedIsArray 1 + } else { + #!? maybe the var was an array - but it's been unset? + set vtracedIsArray 0 + } + + #puts stderr "--------------------------------------------------\n\n" + #some things we don't want to repeat for each refvar in case there are lots of them.. + + #set triggeringRefIdx $vidx + + if {[string match "${prop}+*" [namespace tail $triggeringRef]]} { + set triggering_indices [lrange [split [namespace tail $triggeringRef] +] 1 end] + } else { + set triggering_indices [list] + } + + + #puts stderr ">>>...----refsync-trace = $vtraced $op refvars:$refvars" + #puts stderr ">>> [trace info variable $vtraced]" + #puts "--- unset branch refvar:$refvar" + + if {[llength $vidx]} { + #trace called with an index - must be an array + foreach refvar $refvars { + set reftail [namespace tail $refvar] + + if {[string match "${prop}+*" $reftail]} { + #!todo - add test + if {$vidx eq [lrange [split $reftail +] 1 end]} { + #unset if indices match + error "untested, possibly unused branch spuds1" + #puts "1111111111111111111111111" + unset $refvar + } + } else { + #test exists - #!todo - document which one + + #see if we succeeded in unsetting this element in the underlying variables + #(may have been blocked by a PropertyUnset body) + set element_exists [uplevel 1 [::list info exists ${vtraced}($vidx)]] + #puts "JJJJJJ vtraced:$vtraced vidx:$vidx element_exists:$element_exists" + if {$element_exists} { + #do nothing it wasn't actually unset + } else { + #puts "JJJJJ unsetting ${refvar}($vidx)" + unset ${refvar}($vidx) + } + } + } + + } else { + + foreach refvar $refvars { + set reftail [namespace tail $refvar] + + if {[string match "${prop}+*" $reftail]} { + #check indices of triggering refvar match this refvars indices + + if {$reftail eq [namespace tail $triggeringRef]} { + #!todo - add test + error "untested, possibly unused branch spuds2" + #puts "222222222222222222" + unset $refvar + } else { + + #error "untested - branch spuds2a" + + } + + } else { + #!todo -add test + #reference is directly to property var + error "untested, possibly unused branch spuds3" + #theoretically no other non-indexed ref.. so $triggeringRefIdx must contain non-zero-len string? + puts "\t33333333333333333333" + + if {[string length $triggeringRefIdx]} { + unset $refvar($triggeringRefIdx) + } + } + } + + } + + #!todo - understand. + #puts stderr "\n*****\n propvar_unset_TraceHandler $refvar unset $prop $args \n*****\n" + #catch {unset $refvar} ;#oops - Tcl_EventuallyFree called twice - abnormal program termination (tcl8.4?) + + + #reinstall the traces we stored at the beginning of this proc. + foreach rv [array names traces] { + foreach tinfo $traces($rv) { + set ops {}; set cmd {} + lassign $tinfo ops cmd + + #puts stderr "****** re-installing setGet trace '$ops' on variable $rv" + trace add variable $rv $ops $cmd + } + } + + + + + +} + + +proc ::p::predator::propvar_unset_TraceHandler {OID prop vtraced vidx op} { + + upvar $vtraced SYNCVARIABLE + + set refvars [::list] + #Do not use 'info exists' (avoid triggering read trace) - use info vars + if {[info vars ::p::${OID}::_ref::$prop] eq "::p::${OID}::_ref::$prop"} { + lappend refvars ::p::${OID}::_ref::$prop + } + lappend refvars {*}[info vars ::p::${OID}::_ref::${prop}+*] + + #short_circuit breaks unset traces for array elements (why?) + + + if {![llength $refvars]} { + #puts stderr "\t%%%%%%%%%% no refvars for propvar_unset_TraceHandler to update - short circuiting . OID:'$OID' prop:'$prop' vtraced:'$vtraced' vidx:'$vidx'" + return + } else { + puts stderr "\t****** [llength $refvars] refvars for propvar_unset_TraceHandler to update. OID:'$OID' prop:'$prop' vtraced:'$vtraced' vidx:'$vidx'" + } + + if {[catch { + + + + #We are only interested in suppressing the 'setGet_TraceHandler' traces on refvars + array set traces [::list] + + #puts stderr "*-*-*-*-*-* refvars \n- [join $refvars "\n- "]" + + + foreach rv $refvars { + #puts "--refvar $rv" + foreach tinfo [trace info variable $rv] { + #puts "##trace $tinfo" + set ops {}; set cmd {} + lassign $tinfo ops cmd + #!warning - assumes traces with single operation per handler. + #write & unset traces on refvars need to be suppressed + #we also need to be able to read certain refvars without triggering retrieval of underlying value in order to detect if changed. + if {$ops in {read write unset array}} { + if {[string match "::p::predator::propref_trace_*" $cmd]} { + lappend traces($rv) $tinfo + trace remove variable $rv $ops $cmd + #puts stderr "*-*-*-*-*-* removing $ops trace on $rv -> $cmd" + } + } + } + } + + + + + if {[array exists SYNCVARIABLE]} { + + #underlying variable is an array - we are presumably unsetting just an element + set vtracedIsArray 1 + } else { + #!? maybe the var was an array - but it's been unset? + set vtracedIsArray 0 + } + + #puts stderr "--------------------------------------------------\n\n" + #some things we don't want to repeat for each refvar in case there are lots of them.. + set triggeringRefIdx $vidx + + + #puts stderr ">>>...----refsync-trace = $vtraced $op refvars:$refvars" + #puts stderr ">>> [trace info variable $vtraced]" + #puts "--- unset branch refvar:$refvar" + + + if {[llength $vidx]} { + #trace called with an index - must be an array + foreach refvar $refvars { + set reftail [namespace tail $refvar] + + if {[string match "${prop}+*" $reftail]} { + #!todo - add test + if {$vidx eq [lrange [split $reftail +] 1 end]} { + #unset if indices match + error "untested, possibly unused branch spuds1" + #puts "1111111111111111111111111" + unset $refvar + } + } else { + #test exists - #!todo - document which one + + #see if we succeeded in unsetting this element in the underlying variables + #(may have been blocked by a PropertyUnset body) + set element_exists [uplevel 1 [::list info exists ${vtraced}($vidx)]] + #puts "JJJJJJ vtraced:$vtraced vidx:$vidx element_exists:$element_exists" + if {$element_exists} { + #do nothing it wasn't actually unset + } else { + #puts "JJJJJ unsetting ${refvar}($vidx)" + unset ${refvar}($vidx) + } + } + } + + + } else { + + foreach refvar $refvars { + set reftail [namespace tail $refvar] + unset $refvar + + } + + } + + + #!todo - understand. + #puts stderr "\n*****\n propvar_unset_TraceHandler $refvar unset $prop $args \n*****\n" + #catch {unset $refvar} ;#oops - Tcl_EventuallyFree called twice - abnormal program termination (tcl8.4?) + + + #reinstall the traces we stored at the beginning of this proc. + foreach rv [array names traces] { + foreach tinfo $traces($rv) { + set ops {}; set cmd {} + lassign $tinfo ops cmd + + #puts stderr "****** re-installing setGet trace '$ops' on variable $rv" + trace add variable $rv $ops $cmd + } + } + + } errM]} { + set ruler [string repeat * 80] + puts stderr "\t$ruler" + puts stderr "\t>>>>>>>$ propvar_unset_TraceHandler OID:'$OID' prop:'$prop' vtraced:'$vtraced' vidx:'$vidx' $op" + puts stderr "\t$ruler" + puts stderr $::errorInfo + puts stderr "\t$ruler" + + } + +} + +proc ::p::predator::refsyncvar_write_manualupdate {OID triggeringRef prop vtraced indices} { + error hmmmmm + upvar $vtraced SYNCVARIABLE + #puts stderr "\t>>>>>>>$ refsyncvar_write_manualupdate $OID '$triggeringRef' '$prop' vtraced:'$vtraced' indices:'$indices' " + set refvars [::list] + + #avoid info exists ::p::${OID}::_ref::$prop (info exists triggers read unnecessary read trace ) + if {[info vars ::p::${OID}::_ref::$prop] eq "::p::${OID}::_ref::$prop"} { + lappend refvars ::p::${OID}::_ref::$prop ;#this is the basic unindexed reference we normally get when getting a standard property ref (e.g set ref [>obj . prop .]) + } + lappend refvars {*}[info vars ::p::${OID}::_ref::${prop}+*] ;#add any indexed references + #assert triggeringRef is in the list + if {([string length $triggeringRef]) && ($triggeringRef ni $refvars)} { + error "@@@@@@@@@@ refsyncvar_write_manualupdate unexpected situation. triggeringRef $triggeringRef ni refvars:$refvars" + } + set refposn [lsearch -exact $refvars $triggeringRef] + #assert - due to test above, we know $triggeringRef is in the list so refposn > 0 + set refvars [lreplace $refvars[set refvars {}] $refposn $refposn] ;#note inline K combinator [set refvars {}] + if {![llength $refvars]} { + #puts stderr " %%%%%%%%%% no refvars for refsyncvar_write_manualupdate to update - short circuiting . OID:$OID prop:$prop" + return [list refs_updates [list]] + } + + #suppress the propref_trace_* traces on all refvars + array set traces [::list] + array set external_traces [::list] ;#e.g application/3rd party traces on "">obj . prop ." + #we do not support tracing of modifications to refs which occur from inside the pattern system. ie we disable them during refsync + #todo - after finished refsyncing - consider manually firing the external_traces in such a way that writes/unsets raise an error? + #(since an external trace should not be able to affect a change which occured from inside the object - but can affect values from application writes/unsets to the ref) + + foreach rv $refvars { + #puts "--refvar $rv" + foreach tinfo [trace info variable $rv] { + #puts "##trace $tinfo" + set ops {}; set cmd {} + lassign $tinfo ops cmd + #!warning - assumes traces with single operation per handler. + #write & unset traces on refvars need to be suppressed + #we also need to be able to read certain refvars without triggering retrieval of underlying value in order to detect if changed. + + if {[string match "::p::predator::propref_trace_*" $cmd]} { + lappend traces($rv) $tinfo + trace remove variable $rv $ops $cmd + #puts stderr "*-*-*-*-*-* removing $ops trace on $rv -> $cmd" + } else { + #all other traces are 'external' + lappend external_traces($rv) $tinfo + #trace remove variable $rv $ops $cmd + } + + } + } + #-------------------------------------------------------------------------------------------------------------------------- + if {([array exists SYNCVARIABLE]) || (![info exists SYNCVARIABLE])} { + if {![info exists SYNCVARIABLE]} { + error "WARNING: REVIEW why does $vartraced not exist here?" + } + #either the underlying variable is an array + # OR - underlying variable doesn't exist - so we treat the property as an array because of the indexed access pattern + set treat_vtraced_as_array 1 + } else { + set treat_vtraced_as_array 0 + } + + set refs_updated [list] + set refs_deleted [list] ;#unset due to index no longer being relevant + if {$treat_vtraced_as_array} { + foreach refvar $refvars { + #puts stdout "\n\n \tarrayvariable:'$vtraced' examining REFVAR:'$refvar'" + set refvar_tail [namespace tail $refvar] + if {[string match "${prop}+*" $refvar_tail]} { + #refvar to update is curried e.g ::p::${OID}::_ref::${prop}+x+y + set ref_indices [lrange [split $refvar_tail +] 1 end] + if {[llength $indices]} { + if {[llength $indices] == 1} { + if {[lindex $ref_indices 0] eq [lindex $indices 0]} { + #error "untested xxx-a" + set ${refvar} [set SYNCVARIABLE([lindex $indices 0])] + lappend refs_updated $refvar + } else { + #test exists + #error "xxx-ok single index" + #updating a different part of the property - nothing to do + } + } else { + #nested index + if {[lindex $ref_indices 0] eq [lindex $indices 0]} { + if {[llength $ref_indices] == 1} { + #error "untested xxx-b1" + set ${refvar} [lindex [set SYNCVARIABLE([lindex $indices 0])] [lrange $indices 1 end] ] + } else { + #assert llength $ref_indices > 1 + #NOTE - we cannot test index equivalence reliably/simply just by comparing indices + #compare by value + + if {![catch {lindex [set SYNCVARIABLE([lindex $indices 0])] [lrange $indices 1 end]} possiblyNewVal]} { + #puts stderr "\tYYYYYYYYY $refvar:'[set $refvar]'' / possiblyNewVal:'$possiblyNewVal'" + if {[set $refvar] ne $possiblyNewVal} { + set $refvar $possiblyNewVal + } + } else { + #fail to retrieve underlying value corrsponding to these $indices + unset $refvar + } + } + } else { + #test exists + #error "untested xxx-ok deepindex" + #updating a different part of the property - nothing to do + } + } + } else { + error "untested xxx-c" + + } + + } else { + #refvar to update is plain e.g ::p::${OID}::_ref::${prop} + if {[llength $indices]} { + if {[llength $indices] == 1} { + set ${refvar}([lindex $indices 0]) [set SYNCVARIABLE([lindex $indices 0])] + } else { + lset ${refvar}([lindex $indices 0]) {*}[lrange $indices 1 end] [lindex [set SYNCVARIABLE([lindex $indices 0])] {*}[lrange $indices 1 end]] + } + lappend refs_updated $refvar + } else { + error "untested yyy" + set $refvar $SYNCVARIABLE + } + } + } + } else { + #vtraced non array, but could be an array element e.g ::p::${OID}::_ref::ARR(x) + # + foreach refvar $refvars { + #puts stdout "\n\n \tsimplevariable:'$vtraced' examining REFVAR:'$refvar'" + set refvar_tail [namespace tail $refvar] + if {[string match "${prop}+*" $refvar_tail]} { + #refvar to update is curried e.g ::p::${OID}::_ref::${prop}+x+y + set ref_indices [lrange [split $refvar_tail +] 1 end] + + if {[llength $indices]} { + #see if this update would affect this curried ref + #1st see if we can short-circuit our comparison based on numeric-indices + if {[string is digit -strict [join [concat $ref_indices $indices] ""]]} { + #both sets of indices are purely numeric (no end end-1 etc) + set rlen [llength $ref_indices] + set ilen [llength $indices] + set minlen [expr {min($rlen,$ilen)}] + set matched_firstfew_indices 1 ;#assume the best + for {set i 0} {$i < $minlen} {incr i} { + if {[lindex $ref_indices $i] ne [lindex $indices $i]} { + break ;# + } + } + if {!$matched_firstfew_indices} { + #update of this refvar not required + #puts stderr "\t@@@1 SKIPPING refvar $refvar - indices don't match $ref_indices vs $indices" + break ;#break to next refvar in the foreach loop + } + } + #failed to short-circuit + + #just do a simple value comparison - some optimisations are possible, but perhaps unnecessary here + set newval [lindex $SYNCVARIABLE $ref_indices] + if {[set $refvar] ne $newval} { + set $refvar $newval + lappend refs_updated $refvar + } + + } else { + #we must be updating the entire variable - so this curried ref will either need to be updated or unset + set newval [lindex $SYNCVARIABLE $ref_indices] + if {[set ${refvar}] ne $newval} { + set ${refvar} $newval + lappend refs_updated $refvar + } + } + } else { + #refvar to update is plain e.g ::p::${OID}::_ref::${prop} + if {[llength $indices]} { + #error "untested zzz-a" + set newval [lindex $SYNCVARIABLE $indices] + if {[lindex [set $refvar] $indices] ne $newval} { + lset ${refvar} $indices $newval + lappend refs_updated $refvar + } + } else { + if {[set ${refvar}] ne $SYNCVARIABLE} { + set ${refvar} $SYNCVARIABLE + lappend refs_updated $refvar + } + } + + } + + } + } + #-------------------------------------------------------------------------------------------------------------------------- + + #!todo - manually fire $external_traces as appropriate - but somehow raise error if attempt to write/unset + + #reinstall the traces we stored at the beginning of this proc. + foreach rv [array names traces] { + if {$rv ni $refs_deleted} { + foreach tinfo $traces($rv) { + set ops {}; set cmd {} + lassign $tinfo ops cmd + + #puts stderr "****** re-installing trace '$ops' on variable $rv cmd:$cmd" + trace add variable $rv $ops $cmd + } + } + } + foreach rv [array names external_traces] { + if {$rv ni $refs_deleted} { + foreach tinfo $external_traces($rv) { + set ops {}; set cmd {} + lassign $tinfo ops cmd + #trace add variable $rv $ops $cmd + } + } + } + + + return [list updated_refs $refs_updated] +} + +#purpose: update all relevant references when context variable changed directly +proc ::p::predator::propvar_write_TraceHandler {OID prop vtraced vidx op} { + #note that $vtraced may have been upvared in calling scope - so could have any name! only use it for getting/setting values - don't rely on it's name in any other way. + #we upvar it here instead of using uplevel - as presumably upvar is more efficient (don't have to wory about whether uplevelled script is bytecompiled etc) and also makes code simpler + + upvar $vtraced SYNCVARIABLE + #puts stderr "\t>>>>>>>$ propvar_write_TraceHandler OID:$OID propertyname:'$prop' vtraced:'$vtraced' index:'$vidx' operation:$op" + #set t_info [trace info variable $vtraced] + #foreach t_spec $t_info { + # set t_ops [lindex $t_spec 0] + # if {$op in $t_ops} { + # puts stderr "\t!!!!!!!! propvar_write_Tracehandler [lindex $t_spec 1]" + # } + #} + + #puts stderr -*-*-[info vars ::p::_ref::${OID}::[lindex $prop 0]+*]-*-*- + #vtype = array | array-item | list | simple + + set refvars [::list] + + ############################ + #!!!NOTE!!! do not call 'info exists' on a propref here as it will trigger a read trace -which then pulls in the value from the (GET)prop function etc!!! + #This would be extra cpu work - and sets the propref prematurely (breaking proper property-trace functionality plus vwaits on proprefs) + #The alternative 'info vars' does not trigger traces + if {[info vars ::p::${OID}::_ref::$prop] eq "::p::${OID}::_ref::$prop"} { + #puts " **> lappending '::p::REF::${OID}::$prop'" + lappend refvars ::p::${OID}::_ref::$prop ;#this is the basic unindexed reference we normally get when getting a standard property ref (e.g set ref [>obj . prop .]) + } + ############################ + + #lappend refvars ::p::${OID}::_ref::$prop ;#this is the basic unindexed reference we normally get when getting a standard property ref (e.g set ref [>obj . prop .]) + lappend refvars {*}[info vars ::p::${OID}::_ref::${prop}+*] ;#add any indexed references + + + if {![llength $refvars]} { + #puts stderr "\t%%%%%%%%%% no refvars for propvar_write_TraceHandler to update - short circuiting . OID:$OID prop:$prop" + return + } + + + #puts stderr "*-*-*-*-*-* refvars \n- [join $refvars "\n- "]" + + #We are only interested in suppressing the pattern library's 'propref_trace_*' traces and 3rd party 'read' traces on refvars + array set predator_traces [::list] + #maintain two lists of external traces - as we need to temporarily deactivate all non-pattern read traces even if they are part of a more comprehensive trace.. + #ie for something like 'trace add variable someref {write read array} somefunc' + # we need to remove and immediately reinstall it as a {write array} trace - and at the end of this procedure - reinstall it as the original {write read array} trace + array set external_read_traces [::list] ;#pure read traces the library user may have added + array set external_readetc_traces [::list] ;#read + something else traces the library user may have added + foreach rv $refvars { + #puts "--refvar $rv" + foreach tinfo [trace info variable $rv] { + #puts "##trace $tinfo" + set ops {}; set cmd {} + lassign $tinfo ops cmd + #!warning - assumes traces with single operation per handler. + #write & unset traces on refvars need to be suppressed + #we also need to be able to read certain refvars without triggering retrieval of underlying value in order to detect if changed. + #if {$ops in {read write unset array}} {} + + if {[string match "::p::predator::propref_trace_*" $cmd]} { + lappend predator_traces($rv) $tinfo + trace remove variable $rv $ops $cmd + #puts stderr "*-*-*-*-*-* removing $ops trace on $rv -> $cmd" + } else { + #other traces + # puts "##trace $tinfo" + if {"read" in $ops} { + if {[llength $ops] == 1} { + #pure read - + lappend external_read_traces($rv) $tinfo + trace remove variable $rv $ops $cmd + } else { + #mixed operation trace - remove and reinstall without the 'read' + lappend external_readetc_traces($rv) $tinfo + set other_ops [lsearch -all -inline -not $ops "read"] + trace remove variable $rv $ops $cmd + #reinstall trace for non-read operations only + trace add variable $rv $other_ops $cmd + } + } + } + } + } + + + if {([array exists SYNCVARIABLE]) || (![info exists SYNCVARIABLE])} { + #either the underlying variable is an array + # OR - underlying variable doesn't exist - so we treat the property as an array because of the indexed access pattern + set vtracedIsArray 1 + } else { + set vtracedIsArray 0 + } + + #puts stderr "--------------------------------------------------\n\n" + + #puts stderr ">>>...----refsync-trace = $vtraced $op refvars:$refvars" + #puts stderr ">>> [trace info variable $vtraced]" + #puts "**write*********** propvar_write_TraceHandler $prop $vtraced $vidx $op" + #puts "**write*********** refvars: $refvars" + + #!todo? unroll foreach into multiple foreaches within ifs? + #foreach refvar $refvars {} + + + #puts stdout "propvar_write_TraceHandler examining REFVAR $refvar" + if {[string length $vidx]} { + #indexable + if {$vtracedIsArray} { + + foreach refvar $refvars { + #puts stderr " - - a refvar $refvar vidx: $vidx" + set tail [namespace tail $refvar] + if {[string match "${prop}+*" $tail]} { + #refvar is curried + #only set if vidx matches curried index + #!todo -review + set idx [lrange [split $tail +] 1 end] + if {$idx eq $vidx} { + set newval [set SYNCVARIABLE($vidx)] + if {[set $refvar] ne $newval} { + set ${refvar} $newval + } + #puts stderr "=a.1=> updated $refvar" + } + } else { + #refvar is simple + set newval [set SYNCVARIABLE($vidx)] + if {![info exists ${refvar}($vidx)]} { + #new key for this array + #puts stderr "\npropvar_write_TraceHandler------ about to call 'array set $refvar [::list $vidx [set SYNCVARIABLE($vidx)] ]' " + array set ${refvar} [::list $vidx [set SYNCVARIABLE($vidx)] ] + } else { + set oldval [set ${refvar}($vidx)] + if {$oldval ne $newval} { + #puts stderr "\npropvar_write_TraceHandler------ about to call 'array set $refvar [::list $vidx [set SYNCVARIABLE($vidx)] ]' " + array set ${refvar} [::list $vidx [set SYNCVARIABLE($vidx)] ] + } + } + #puts stderr "=a.2=> updated ${refvar} $vidx" + } + } + + } else { + + foreach refvar $refvars { + upvar $refvar internal_property_reference + #puts stderr " - - b vidx: $vidx" + + #!? could be object not list?? + #!!but what is the difference between an object, and a list of object names which happens to only contain one object?? + #For predictability - we probably need to autodetect type on 1st write to o_prop either list, array or object (and maintain after unset operations) + #There would still be an edge case of an initial write of a list of objects of length 1. + if {([llength [set $SYNCVARIABLE]] ==1) && ([string range [set $SYNCVARIABLE] 0 0] eq ">")} { + error "untested review!" + #the o_prop is object-shaped + #assumes object has a defaultmethod which accepts indices + set newval [[set $SYNCVARIABLE] {*}$vidx] + + } else { + set newval [lindex $SYNCVARIABLE {*}$vidx] + #if {[set $refvar] ne $newval} { + # set $refvar $newval + #} + if {$internal_property_reference ne $newval} { + set internal_property_reference $newval + } + + } + #puts stderr "=b=> updated $refvar" + } + + } + + } else { + #no vidx + + if {$vtracedIsArray} { + + foreach refvar $refvars { + set targetref_tail [namespace tail $refvar] + set targetref_is_indexed [string match "${prop}+*" $targetref_tail] + + + #puts stderr " - - c traced: $vtraced refvar:$refvar triggeringRef: $triggeringRef" + if {$targetref_is_indexed} { + #curried array item ref of the form ${prop}+x or ${prop}+x+y etc + + #unindexed write on a property that is acting as an array.. + + #case a) If the underlying variable is actually an array - it will error upon attempt to write it like this - that's ok. + + #case b) If the underlying variable doesn't exist - perhaps a PropertyWrite will accept the unindexed write (e.g by asigning a default for the missing index). + # we can't know here how this write affects other indexed traces on this property... hence we warn but do nothing. + puts stderr "\tc.1 WARNING: write to property without 'array set'. op:'$op' refvar:'$refvar' prop:'$prop' \n\traw: propvar_write_TraceHandler $OID $prop $vtraced $vidx $op" + } else { + #How do we know what to write to array ref? + puts stderr "\tc.2 WARNING: unimplemented/unused?" + #error no_tests_for_branch + + #warning - this would trigger 3rd party unset traces which is undesirable for what is really a 'bookkeeping' operation + #if this branch is actually useful - we probably need to step through the array and unset and set elements as appropriate + array unset ${refvar} + array set ${refvar} [array get SYNCVARIABLE] + } + } + + } else { + foreach refvar $refvars { + #puts stderr "\t\t_________________[namespace current]" + set targetref_tail [namespace tail $refvar] + upvar $refvar INTERNAL_REFERENCE_TO_PROPERTY__$targetref_tail + set targetref_is_indexed [string match "${prop}+*" $targetref_tail] + + if {$targetref_is_indexed} { + #puts "XXXXXXXXX vtraced:$vtraced" + #reference curried with index(es) + #we only set indexed refs if value has changed + # - this not required to be consistent with standard list-containing variable traces, + # as normally list elements can't be traced seperately anyway. + # + + #only bother checking a ref if no setVia index + # i.e some operation on entire variable so need to test synchronisation for each element-ref + set targetref_indices [lrange [split $targetref_tail +] 1 end] + set possiblyNewVal [lindex $SYNCVARIABLE {*}$targetref_indices] + #puts stderr "YYYYYYYYY \[set \$refvar\]: [set $refvar] / possiblyNewVal: $possiblyNewVal" + if {[set INTERNAL_REFERENCE_TO_PROPERTY__$targetref_tail] ne $possiblyNewVal} { + set INTERNAL_REFERENCE_TO_PROPERTY__$targetref_tail $possiblyNewVal + #puts stderr "=d1=> updated $refvar -> [uplevel 1 "lindex \[set $vtraced] $idx"]" + } + + } else { + #for consistency with standard traces on a list-containing variable, we perform the set even if the list value has not changed! + + #puts stderr "- d2 set" + #puts "refvar: [set $refvar]" + #puts "SYNCVARIABLE: $SYNCVARIABLE" + + #if {[set $refvar] ne $SYNCVARIABLE} { + # set $refvar $SYNCVARIABLE + #} + if {[set INTERNAL_REFERENCE_TO_PROPERTY__$targetref_tail] ne $SYNCVARIABLE} { + set INTERNAL_REFERENCE_TO_PROPERTY__$targetref_tail $SYNCVARIABLE + } + + } + } + + } + + } + + + + #reinstall the traces we stored at the beginning of this proc. + foreach rv [array names predator_traces] { + foreach tinfo $predator_traces($rv) { + set ops {}; set cmd {} + lassign $tinfo ops cmd + + #puts stderr "****** re-installing trace '$ops' on variable $rv cmd:$cmd" + trace add variable $rv $ops $cmd + } + } + + foreach rv [array names external_traces] { + foreach tinfo $external_traces($rv) { + set ops {}; set cmd {} + lassign $tinfo ops cmd + + #puts stderr "****** re-installing trace '$ops' on variable $rv cmd:$cmd" + trace add variable $rv $ops $cmd + } + } + + + +} + +# end propvar_write_TraceHandler + + + + + + + + + + + + + + + + +# + +#returns 0 if method implementation not present for interface +proc ::p::predator::method_chainhead {iid method} { + #Interface proc + # examine the existing command-chain + set candidates [info commands ::p::${iid}::_iface::$method.*] ;#rough grab (info commands only allows basic pattern globbing - not a regex) + set cmdchain [list] + + set re [string map [list %m% [string map {( \\( ) \\) . \\.} $method]] {^%m%.([0-9]+)$}] + set maxversion 0 + #loop and test because it is possible there are unrelated commands (having a matching prefix with . character) which were caught in the glob. + foreach test [lsort -dictionary $candidates] { + set c [namespace tail $test] + if {[regexp $re $c _match version]} { + lappend cmdchain $c + if {$version > $maxversion} { + set maxversion $version + } + } + } + return $maxversion +} + + + + + +#this returns a script that upvars vars for all interfaces on the calling object - +# - must be called at runtime from a method +proc ::p::predator::upvar_all {_ID_} { + #::set OID [lindex $_ID_ 0 0] + ::set OID [::lindex [::dict get $_ID_ i this] 0 0] + ::set decl {} + #[set ::p::${OID}::_meta::map] + #[dict get [lindex [dict get $_ID_ i this] 0 1] map] + + ::upvar #0 ::p::${OID}::_meta::map MAP + #puts stdout "\n\n -->-->-->--> _meta::map '$MAP' <-<-<-\n\n" + #set iflist [::lindex [dict get [lindex [dict get $_ID_ i this] 0 1] map] 1 0] + + ::foreach ifid [dict get $MAP interfaces level0] { + if {[::dict size [::set ::p::${ifid}::_iface::o_variables]]} { + ::array unset nsvars + ::array set nsvars [::list] + ::dict for {vname vinfo} [::set ::p::${ifid}::_iface::o_variables] { + ::set varspace [::dict get $vinfo varspace] + ::lappend nsvars($varspace) $vname + } + #nsvars now contains vars grouped by varspace. + + ::foreach varspace [::array names nsvars] { + if {$varspace eq ""} { + ::set ns ::p::${OID} + } else { + if {[::string match "::*" $varspace]} { + ::set ns $varspace + } else { + ::set ns ::p::${OID}::$varspace + } + } + + ::append decl "namespace upvar $ns " + ::foreach vname [::set nsvars($varspace)] { + ::append decl "$vname $vname " + } + ::append decl " ;\n" + } + ::array unset nsvars + } + } + ::return $decl +} + +#we need to use eval because it is potentially a multiline script returned by upvar_all (so can't just use {*} operator) +proc ::p::predator::runtime_vardecls {} { + set result "::eval \[::p::predator::upvar_all \$_ID_\]" + #set result "::apply { {_ID_} ::p::predator::upvar_all } \$_ID_" + + #set result "::apply \[::list {} \[::p::predator::upvar_all \$_ID_\] \[namespace current\]\]" + #set result "::interp eval {} \[::p::predator::upvar_all \$_ID_\]" + #puts stdout "\t>>>[info level -1]\n\t>>>>>>>>>>>>>>>>>>>>> '$result'" + return $result +} + + + + + + +#OBSOLETE!(?) - todo - move stuff out of here. +proc ::p::predator::compile_interface {IFID caller_ID_} { + upvar 0 ::p::${IFID}:: IFACE + + #namespace eval ::p::${IFID} { + # namespace ensemble create + #} + + #'namespace upvar' - from tip.tcl.tk #250: Efficient Access to Namespace Variables + + namespace upvar ::p::${IFID}::_iface o_propertyunset_handlers o_propertyunset_handlers o_variables o_variables o_properties o_properties o_methods o_methods o_unknown o_unknown o_varspace o_varspace o_varspaces o_varspaces + + #set varDecls {} + #if {[llength $o_variables]} { + # #puts "*********!!!! $vlist" + # append varDecls "namespace upvar ::p::\[lindex \$_ID_ 0 0 \] " + # foreach vdef $o_variables { + # append varDecls "[lindex $vdef 0] [lindex $vdef 0] " + # } + # append varDecls \n + #} + + #runtime gathering of vars from other interfaces. + #append varDecls [runtime_vardecls] + + set varDecls [runtime_vardecls] + + + + #implement methods + + #!todo - avoid globs on iface array? maintain list of methods in another slot? + #foreach {n mname} [array get IFACE m-1,name,*] {} + + + #namespace eval ::p::${IFID}::_iface "namespace export {*}$o_methods" ;#make methods available as interface ensemble. + + + + #implement property getters/setters/unsetters + #'setter' overrides + #pw short for propertywrite + foreach {n property} [array get IFACE pw,name,*] { + if {[string length $property]} { + #set property [lindex [split $n ,] end] + + #!todo - next_script + #set next [::p::next_script "\[set ::p::\${_ID_}::(self)]" $IFID $property] + + set maxversion [::p::predator::method_chainhead $IFID (SET)$property] + set chainhead [expr {$maxversion + 1}] + set THISNAME (SET)$property.$chainhead ;#first version will be (SET)$property.1 + + set next [::p::predator::next_script $IFID (SET)$property $THISNAME $caller_ID_] ;#?! caller_ID_ ?? + + set body $IFACE(pw,body,$property) + + + set processed [dict create {*}[::p::predator::expand_var_statements $body $o_varspace]] + if {[llength [dict get $processed varspaces_with_explicit_vars]]} { + foreach vs [dict get $processed varspaces_with_explicit_vars] { + if {[string length $vs] && ($vs ni $o_varspaces)} { + lappend o_varspaces $vs + } + } + set body [dict get $processed body] + } else { + set body $varDecls\n[dict get $processed body] + #puts stderr "\t\timplicit vardecls used for propertywrite $property on interface $IFID ##### \n $body" + } + + #set body [string map [::list @this@ "\[lindex \${_ID_} 0 3 \]" @next@ $next] $body\n] + set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata \] 3\]" @next@ $next] $body\n] + + + + set maxversion [::p::predator::method_chainhead $IFID $property] + set headid [expr {$maxversion + 1}] + + proc ::p::${IFID}::_iface::(SET)$property.$headid [concat _ID_ $IFACE(pw,arg,$property)] $body + + interp alias {} ::p::${IFID}::_iface::(SET)$property {} ::p::${IFID}::_iface::(SET)$property.$headid + + #proc ::p::${IFID}::___system___write_$property [concat _ID_ $IFACE(pw,arg,$property)] $body + } + } + #'unset' overrides + + dict for {property handler_info} $o_propertyunset_handlers { + + set body [dict get $handler_info body] + set arraykeypattern [dict get $handler_info arraykeypattern] ;#array element pattern for unsetting individual elements in an array + + set maxversion [::p::predator::method_chainhead $IFID (UNSET)$property] + set headid [expr {$maxversion + 1}] + + set THISNAME (UNSET)$property.$headid + + set next [::p::predator::next_script $IFID (UNSET)$property $THISNAME $caller_ID_] ;#?! caller_ID_ ??? + + + + + + set processed [dict create {*}[::p::predator::expand_var_statements $body $o_varspace]] + if {[llength [dict get $processed varspaces_with_explicit_vars]]} { + foreach vs [dict get $processed varspaces_with_explicit_vars] { + if {[string length $vs] && ($vs ni $o_varspaces)} { + lappend o_varspaces $vs + } + } + set body [dict get $processed body] + } else { + set body $varDecls\n[dict get $processed body] + #puts stderr "\t\timplicit vardecls used for property unset $property on interface $IFID ##### \n $body" + + } + #set body [string map [::list @this@ "\[lindex \$_ID_ 0 3 \]" @next@ $next] $body\n] + set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata \] 3\]" @next@ $next] $body\n] + + + + + #implement + #always take arraykeypattern argument even though usually empty string (only used for unsetting individual array elements) + if {[string trim $arraykeypattern] eq ""} { + set arraykeypattern "_dontcare_" + } + proc ::p::${IFID}::_iface::(UNSET)$property.$headid [concat _ID_ $arraykeypattern] $body + + + #chainhead pointer + interp alias {} ::p::${IFID}::_iface::(UNSET)$property {} ::p::${IFID}::_iface::(UNSET)$property.$headid + } + + + + interp alias {} ::p::${IFID}::(VIOLATE) {} ::p::internals::(VIOLATE) + + #the usual case will have no destructor - so use info exists to check. + + if {[info exists ::p::${IFID}::_iface::o_destructor_body]} { + #!todo - chained destructors (support @next@). + #set next [::p::next_script_destructor "\[lindex \$_ID_ 0 1\]" $IFID] + set next NEXT + + set body [set ::p::${IFID}::_iface::o_destructor_body] + + + set processed [dict create {*}[::p::predator::expand_var_statements $body $o_varspace]] + if {[llength [dict get $processed varspaces_with_explicit_vars]]} { + foreach vs [dict get $processed varspaces_with_explicit_vars] { + if {[string length $vs] && ($vs ni $o_varspaces)} { + lappend o_varspaces $vs + } + } + set body [dict get $processed body] + } else { + set body $varDecls\n[dict get $processed body] + #puts stderr "\t\t**********************implicit vardecls used for destructor on interface $IFID ##### \n $body" + } + #set body [::p::fixed_var_statements \n@IMPLICITDECLS@\n$body] + #set body [string map [::list @this@ "\[lindex \$_ID_ 0 3 \]" @next@ $next] $body\n] + set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata \] 3\]" @next@ $next] $body\n] + + + proc ::p::${IFID}::___system___destructor _ID_ $body + } + + + if {[info exists o_unknown]} { + #use 'apply' somehow? + interp alias {} ::p::${IFID}::_iface::(UNKNOWN) {} ::p::${IFID}::_iface::$o_unknown + + #namespace eval ::p::${IFID}::_iface [list namespace unknown $o_unknown] + } + + + return +} + + + + + + + +#'info args' - assuming arbitrary chain of 'interp aliases' +proc ::p::predator::command_info_args {cmd} { + if {[llength [set next [interp alias {} $cmd]]]} { + set curriedargs [lrange $next 1 end] + + if {[catch {set arglist [info args [lindex $next 0]]}]} { + set arglist [command_info_args [lindex $next 0]] + } + #trim curriedargs + return [lrange $arglist [llength $curriedargs] end] + } else { + info args $cmd + } +} + + +proc ::p::predator::do_next {_ID_ IFID mname nextArgs args} { + if {[llength $args]} { + tailcall ::p::${IFID}::_iface::$mname $_ID_ {*}$args + } else { + if {[llength $nextArgs] > 1} { + set argVals [::list] + set i 0 + foreach arg [lrange $nextArgs 1 end] { + upvar 1 $arg $i + if {$arg eq "args"} { + #need to check if 'args' is actually available in caller + if {[info exists $i]} { + set argVals [concat $argVals [set $i]] + } + } else { + lappend argVals [set $i] + } + } + tailcall ::p::${IFID}::_iface::$mname $_ID_ {*}$argVals + } else { + tailcall ::p::${IFID}::_iface::$mname $_ID_ + } + } +} + +#---------------------------------------------------------------------------------------------- +proc ::p::predator::next_script {IFID method caller caller_ID_} { + + if {$caller eq "(CONSTRUCTOR).1"} { + return [string map [list %cID% [list $caller_ID_] %ifid% $IFID %m% $method] {::p::predator::do_next_pattern_if $_ID_ %cID% %ifid% %m%}] + } elseif {$caller eq "$method.1"} { + #delegate to next interface lower down the stack which has a member named $method + return [string map [list %ifid% $IFID %m% $method] {::p::predator::do_next_if $_ID_ %ifid% %m%}] + } elseif {[string match "(GET)*.2" $caller]} { + # .1 is the getprop procedure, .2 is the bottom-most PropertyRead. + + #jmn + set prop [string trimright $caller 1234567890] + set prop [string range $prop 5 end-1] ;#string leading (GET) and trailing . + + if {$prop in [dict keys [set ::p::${IFID}::_iface::o_properties]]} { + #return [string map [list %ifid% $IFID %p% $prop ] {::p::%ifid%::_iface::(GET)%p%.1 $_ID_}] + return [string map [list %ifid% $IFID %m% (GET)$prop.1 %nargs% [list]] {::p::predator::do_next $_ID_ %ifid% %m% [list %nargs%]}] + } else { + #we can actually have a property read without a property or a method of that name - but it could also match the name of a method. + # (in which case it could return a different value depending on whether called via set [>obj . something .] vs >obj . something) + return [string map [list %ifid% $IFID %m% $method] {::p::predator::do_next_if $_ID_ %ifid% %m%}] + } + } elseif {[string match "(SET)*.2" $caller]} { + return [string map [list %ifid% $IFID %m% $method] {::p::predator::do_next_if $_ID_ %ifid% %m%}] + } else { + #this branch will also handle (SET)*.x and (GET)*.x where x >2 + + #puts stdout "............next_script IFID:$IFID method:$method caller:$caller" + set callerid [string range $caller [string length "$method."] end] + set nextid [expr {$callerid - 1}] + + if {[catch {set nextArgs [info args ::p::${IFID}::_iface::$method.$nextid]} errMsg]} { + #not a proc directly on this interface - presumably an alias made by something like linkcopy_interface. + #puts ">>>>>>>>::p::predator::next_script IFID:$IFID caller:$caller aaaa@ $method.$nextid" + set nextArgs [command_info_args ::p::${IFID}::_iface::$method.$nextid] + } + + return [string map [list %ifid% $IFID %m% $method.$nextid %nargs% $nextArgs] {::p::predator::do_next $_ID_ %ifid% %m% [list %nargs%]}] + } +} + +proc ::p::predator::do_next_if {_ID_ IFID method args} { + #puts "<>(::p::predator::do_next_if)<> '$_ID_' '$IFID' '$method' '$args' (((" + + #set invocants [dict get $_ID_ i] + #set this_invocantdata [lindex [dict get $invocants this] 0] + #lassign $this_invocantdata OID this_info + set OID [::p::obj_get_this_oid $_ID_] + ::p::map $OID MAP + lassign [dict get $MAP invocantdata] OID alias itemCmd cmd + set interfaces [dict get $MAP interfaces level0] + set patterninterfaces [dict get $MAP interfaces level1] + + set L0_posn [lsearch $interfaces $IFID] + if {$L0_posn == -1} { + error "(::p::predator::do_next_if) called with interface not present at level0 for this object" + } elseif {$L0_posn > 0} { + #set ifid_next [lindex $interfaces $L0_posn-1] ;#1 lower in the iStack + set lower_interfaces [lrange $interfaces 0 $L0_posn-1] + + foreach if_sub [lreverse $lower_interfaces] { + if {[string match "(GET)*" $method]} { + #do not test o_properties here! We need to call even if there is no underlying property on this interface + #(PropertyRead without Property is legal. It results in dispatch to subsequent interface rather than property variable for this interface) + # relevant test: higher_order_propertyread_chaining + return [::p::${if_sub}::_iface::$method $_ID_ {*}$args] + } elseif {[string match "(SET)*" $method]} { + #must be called even if there is no matching $method in o_properties + return [::p::${if_sub}::_iface::$method $_ID_ {*}$args] + } elseif {[string match "(UNSET)*" $method]} { + #review untested + #error "do_next_if (UNSET) untested" + #puts stderr "<>(::p::predator::do_next_if)<> (UNSET) called - dispatching to ::p::${if_sub}::_iface::$method with args:'$args'" + return [::p::${if_sub}::_iface::$method $_ID_ {*}$args] + + } elseif {$method in [dict keys [set ::p::${if_sub}::_iface::o_methods]]} { + if {[llength $args]} { + #puts stdout "<>(::p::predator::do_next_if)<> - - - calling ::p::${if_sub}::_iface::$method on sub interface $if_sub with $args" + + #return [::p::${if_sub}::_iface::$method $_ID_ {*}$args] + #tailcall ::p::${if_sub}::_iface::$method $_ID_ {*}$args + + #!todo - handle case where llength $args is less than number of args for subinterface command + #i.e remaining args will need to be upvared to get values from calling scope (auto-set any values not explicitly set) + + #handle case where next interface has different arguments (masking of sub interfaces in the stack with function with different arity/signature) + set head [interp alias {} ::p::${if_sub}::_iface::$method] + set nextArgs [info args $head] ;#!todo - fix... head not necessarily a proc + set argx [list] + foreach a $nextArgs { + lappend argx "\$a" + } + + #todo - handle func a b args called with func "x" ie short on named vars so b needs to be upvared + + if {([llength $args] == [llength $nextArgs]) || ([lindex $nextArgs end] eq "args")} { + tailcall apply [list $nextArgs [list ::p::${if_sub}::_iface::$method {*}$argx ]] $_ID_ {*}$args + } else { + #todo - upvars required for tail end of arglist + tailcall apply [list $nextArgs [list ::p::${if_sub}::_iface::$method {*}$argx ]] $_ID_ {*}$args + } + + } else { + #auto-set: upvar vars from calling scope + #!todo - robustify? alias not necessarily matching command name.. + set head [interp alias {} ::p::${if_sub}::_iface::$method] + + + set nextArgs [info args $head] ;#!todo - fix... head not necessarily a proc + if {[llength $nextArgs] > 1} { + set argVals [::list] + set i 0 + foreach arg [lrange $nextArgs 1 end] { + upvar 1 $arg $i + if {$arg eq "args"} { + #need to check if 'args' is actually available in caller + if {[info exists $i]} { + set argVals [concat $argVals [set $i]] + } + } else { + lappend argVals [set $i] + } + } + #return [$head $_ID_ {*}$argVals] + tailcall $head $_ID_ {*}$argVals + } else { + #return [$head $_ID_] + tailcall $head $_ID_ + } + } + } elseif {$method eq "(CONSTRUCTOR)"} { + #chained constructors will only get args if the @next@ caller explicitly provided them. + puts stdout "!!!<>(::p::predator::do_next_if)<> CONSTRUCTOR CHAINED CALL via do_next_if _ID_:$_ID_ IFID:$IFID method:$method args:$args!!!" + #return [::p::${if_sub}::_iface::(CONSTRUCTOR) $_ID_ {*}$args] + xtailcall ::p::${if_sub}::_iface::(CONSTRUCTOR) $_ID_ {*}$args + } + } + #no interfaces in the iStack contained a matching method. + return + } else { + #no further interfaces in this iStack + return + } +} + + +#only really makes sense for (CONSTRUCTOR) calls. +#_ID_ is the invocant data for the target. caller_ID_ is the invocant data for the calling(creating,cloning etc) pattern/class. +proc ::p::predator::do_next_pattern_if {_ID_ caller_ID_ IFID method args} { + #puts ")))) do_next_pattern_if _ID_:'$_ID_' IFID:'$IFID' method:'$method' args:'$args' (((" + + #set invocants [dict get $_ID_ i] + #set this_invocant [lindex [dict get $invocants this] 0] + #lassign $this_invocant OID this_info + #set OID [lindex [dict get $invocants this] 0 0] + #upvar #0 ::p::${OID}::_meta::map map + #lassign [lindex $map 0] OID alias itemCmd cmd + + + set caller_OID [lindex [dict get $caller_ID_ i this] 0 0] + upvar #0 ::p::${caller_OID}::_meta::map callermap + + #set interfaces [lindex $map 1 0] + set patterninterfaces [dict get $callermap interfaces level1] + + set L0_posn [lsearch $patterninterfaces $IFID] + if {$L0_posn == -1} { + error "do_next_pattern_if called with interface not present at level1 for this object" + } elseif {$L0_posn > 0} { + + set lower_interfaces [lrange $patterninterfaces 0 $L0_posn-1] + + foreach if_sub [lreverse $lower_interfaces] { + if {$method eq "(CONSTRUCTOR)"} { + #chained constructors will only get args if the @next@ caller explicitly provided them. + #puts stdout "!!! CONSTRUCTOR CHAINED CALL via do_next_pattern_if _ID_:$_ID_ IFID:$IFID method:$method args:$args!!!" + tailcall ::p::${if_sub}::_iface::(CONSTRUCTOR) $_ID_ {*}$args + } + } + #no interfaces in the iStack contained a matching method. + return + } else { + #no further interfaces in this iStack + return + } +} + + + + + +#------------------------------------------------------------------------------------------------ + + + + + +#------------------------------------------------------------------------------------- +####################################################### +####################################################### +####################################################### +####################################################### +####################################################### +####################################################### +####################################################### + + +#!todo - can we just call new_object somehow to create this? + + #until we have a version of Tcl that doesn't have 'creative writing' scope issues - + # - we should either explicity specify the whole namespace when setting variables or make sure we use the 'variable' keyword. + # (see http://mini.net/tcl/1030 'Dangers of creative writing') +namespace eval ::p::-1 { + #namespace ensemble create + + namespace eval _ref {} + namespace eval _meta {} + + namespace eval _iface { + variable o_usedby + variable o_open + variable o_constructor + variable o_variables + variable o_properties + variable o_methods + variable o_definition + variable o_varspace + variable o_varspaces + + array set o_usedby [list i0 1] ;#!todo - review + #'usedby' array the metaface is an exception. All objects use it - so we should list none of them rather than pointless updating of this value? + + set o_open 1 + set o_constructor [list] + set o_variables [list] + set o_properties [dict create] + set o_methods [dict create] + array set o_definition [list] + set o_varspace "" + set o_varspaces [list] + } +} + + +# + +#interp alias {} ::p::internals::>metaface {} ::p::internals::predator [list [list -1 ::p::internals::>metaface item {}] {{} {}}] +interp alias {} ::p::internals::>metaface {} ::p::internals::predator [list i [list this [list [list -1 ::p::internals::>metaface item {}]]] context {}] + + +upvar #0 ::p::-1::_iface::o_definition def + + +#! concatenate -> compose ?? +dict set ::p::-1::_iface::o_methods Concatenate {arglist {target args}} +proc ::p::-1::Concatenate {_ID_ target args} { + set invocants [dict get $_ID_ i] + #set invocant_alias [lindex [dict get $invocants this] 0] + #set invocant [lindex [interp alias {} $invocant_alias] 1] + set OID [lindex [dict get $invocants this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + + lassign [dict get $MAP invocantdata] OID alias itemCmd cmd + + if {![string match "::*" $target]} { + if {[set ns [uplevel 1 {namespace current}]] eq "::"} { + set target ::$target + } else { + set target ${ns}::$target + } + } + #add > character if not already present + set target [namespace qualifiers $target]::>[string trimleft [namespace tail $target] >] + set _target [string map {::> ::} $target] + + set ns [namespace qualifiers $target] + if {$ns eq ""} { + set ns "::" + } else { + namespace eval $ns {} + } + + if {![llength [info commands $target]]} { + #degenerate case - target does not exist + #Probably just 1st of a set of Concatenate calls - so simply delegate to 'Clone' + #review - should be 'Copy' so it has object state from namespaces and variables? + return [::p::-1::Clone $_ID_ $target {*}$args] + + #set TARGETMAP [::p::predator::new_object $target] + #lassign [lindex $TARGETMAP 0] target_ID target_cmd itemCmd + + } else { + #set TARGETMAP [lindex [interp alias {} [namespace origin $target]] 1] + set TARGETMAP [$target --] + + lassign [dict get $TARGETMAP invocantdata] target_ID target_cmd itemCmd + + #Merge lastmodified(?) level0 and level1 interfaces. + + } + + return $target +} + + + +#Object's Base-Interface proc with itself as curried invocant. +#interp alias {} ::p::-1::Create {} ::p::-1::_iface::Create $invocant +#namespace eval ::p::-1 {namespace export Create} +dict set ::p::-1::_iface::o_methods Define {arglist definitions} +#define objects in one step +proc ::p::-1::Define {_ID_ definitions} { + set invocants [dict get $_ID_ i] + #set invocant_alias [lindex [dict get $invocants this] 0] + #set invocant [lindex [interp alias {} $invocant_alias] 1] + set OID [lindex [dict get $invocants this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + + lassign [dict get $MAP invocantdata] OID alias default_method cmd + set interfaces [dict get $MAP interfaces level0] ;#level-0 interfaces + set patterns [dict get $MAP interfaces level1] ;#level-1 interfaces + + #!todo - change these to dicts; key=interface stack name value= a list of interfaces in the stack + #set IFID0 [lindex $interfaces 0] + #set IFID1 [lindex $patterns 0] ;#1st pattern + + #set IFID_TOP [lindex $interfaces end] + set IFID_TOP [::p::predator::get_possibly_new_open_interface $OID] + + #set ns ::p::${OID} + + #set script [string map [list %definitions% $definitions] { + # if {[lindex [namespace path] 0] ne "::p::-1"} { + # namespace path [list ::p::-1 {*}[namespace path]] + # } + # %definitions% + # namespace path [lrange [namespace path] 1 end] + # + #}] + + set script [string map [list %id% $_ID_ %definitions% $definitions] { + set ::p::-1::temp_unknown [namespace unknown] + + namespace unknown [list ::apply {{funcname args} {::p::predator::redirect $funcname [list %id%] {*}$args}}] + + #namespace unknown [list ::apply { {funcname args} {if {![llength [info commands ::p::-1::$funcname]]} {::unknown $funcname {*}$args } else {::p::-1::$funcname [list %id%] {*}$args} }} ] + + %definitions% + + + namespace unknown ${::p::-1::temp_unknown} + return + }] + + + + #uplevel 1 $script ;#this would run the script in the global namespace + #run script in the namespace of the open interface, this allows creating of private helper procs + #namespace inscope ::p::${IFID_TOP}::_iface $script ;#do not use tailcall here! Define belongs on the callstack + #namespace inscope ::p::${OID} $script + namespace eval ::p::${OID} $script + #return $cmd +} + + +proc ::p::predator::redirect {func args} { + #todo - review tailcall - tests? + if {![llength [info commands ::p::-1::$func]]} { + #error "invalid command name \"$func\"" + tailcall uplevel 1 [list ::unknown $func {*}$args] + } else { + tailcall uplevel 1 [list ::p::-1::$func {*}$args] + } +} + + +#'immediate' constructor - this is really like a (VIOLATE) call.. todo - review. +dict set ::p::-1::_iface::o_methods Construct {arglist {argpairs body args}} +proc ::p::-1::Construct {_ID_ argpairs body args} { + set OID [::p::obj_get_this_oid $_ID_] + ::p::map $OID MAP + + set interfaces [dict get $MAP interfaces level0] + set iid_top [lindex $interfaces end] + namespace upvar ::p::${iid_top}::_iface o_varspaces o_varspaces o_varspace o_varspace + + set ARGSETTER {} + foreach {argname argval} $argpairs { + append ARGSETTER "set $argname $argval\n" + } + #$_self (VIOLATE) $ARGSETTER$body + + set body $ARGSETTER\n$body + + + set processed [dict create {*}[::p::predator::expand_var_statements $body $o_varspace]] + if {[llength [dict get $processed varspaces_with_explicit_vars]]} { + foreach vs [dict get $processed varspaces_with_explicit_vars] { + if {[string length $vs] && ($vs ni $o_varspaces)} { + lappend o_varspaces $vs + } + } + set body [dict get $processed body] + } else { + set varDecls [::p::predator::runtime_vardecls] ;#dynamic vardecls can access vars from all interfaces of invocant object. + set body $varDecls\n[dict get $processed body] + # puts stderr "\t runtime_vardecls in Construct $varDecls" + } + + set next "\[error {next not implemented}\]" + #set body [string map [::list @this@ "\[lindex \$_ID_ 0 3 \]"] $body\n] + set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata \] 3\]" @next@ $next] $body\n] + + + #namespace eval ::p::${iid_top} $body + + #return [apply [list {_ID_ args} $body ::p::${iid_top}::_iface] $_ID_] + #does this handle Varspace before constructor? + return [apply [list {_ID_ args} $body ::p::${OID} ] $_ID_ {*}$args] +} + + + + + +#hacked optimized version of ::p::-1::Create for creating ::p::ifaces::>* objects +namespace eval ::p::3 {} +proc ::p::3::_create {child {OID "-2"}} { + #puts stderr "::p::3::_create $child $OID" + set _child [string map {::> ::} $child] + if {$OID eq "-2"} { + #set childmapdata [::p::internals::new_object $child] + #set child_ID [lindex [dict get $childmapdata invocantdata] 0 ] + set child_ID [lindex [dict get [::p::internals::new_object $child] invocantdata] 0] + upvar #0 ::p::${child_ID}::_meta::map CHILDMAP + } else { + set child_ID $OID + #set _childmap [::p::internals::new_object $child "" $child_ID] + ::p::internals::new_object $child "" $child_ID + upvar #0 ::p::${child_ID}::_meta::map CHILDMAP + } + + #-------------- + + set oldinterfaces [dict get $CHILDMAP interfaces] + dict set oldinterfaces level0 [list 2] + set modifiedinterfaces $oldinterfaces + dict set CHILDMAP interfaces $modifiedinterfaces + + #-------------- + + + + + #puts stderr ">>>> creating alias for ::p::$child_ID" + #puts stderr ">>>::p::3::_create $child $OID >>>[interp alias {} ::p::$child_ID]" + + #interp alias ::p::$child_ID already exists at this point - so calling here will do nothing! + #interp alias {} ::p::$child_ID {} ::p::internals::predator [dict create i [dict create this [list [list $child_ID {} ]]]] + #puts stderr ">>>[interp alias {} ::p::$child_ID]" + + + + #--------------- + namespace upvar ::p::2::_iface o_methods o_methods o_properties o_properties + foreach method [dict keys $o_methods] { + #todo - change from interp alias to context proc + interp alias {} ::p::${child_ID}::$method {} ::p::2::_iface::$method + } + #namespace eval ::p::${child_ID} [list namespace export {*}$o_methods] + #implement property even if interface already compiled because we need to create defaults for each new child obj. + # also need to add alias on base interface + #make sure we are only implementing properties from the current CREATOR + dict for {prop pdef} $o_properties { + #lassign $pdef prop default + interp alias {} ::p::${child_ID}::$prop {} ::p::2::_iface::(GET)$prop + interp alias {} ::p::${child_ID}::(GET)$prop {} ::p::2::_iface::(GET)$prop + + } + ::p::2::_iface::(CONSTRUCTOR) [dict create i [dict create this [list [dict get $CHILDMAP invocantdata]]] context {}] + #--------------- + #namespace eval ::p::${child_ID} "namespace ensemble create -command $_child" + return $child +} + +#configure -prop1 val1 -prop2 val2 ... +dict set ::p::-1::_iface::o_methods Configure {arglist args} +proc ::p::-1::Configure {_ID_ args} { + + #!todo - add tests. + set OID [::p::obj_get_this_oid $_ID_] + ::p::map $OID MAP + + lassign [dict get $MAP invocantdata] OID alias itemCmd this + + if {![expr {([llength $args] % 2) == 0}]} { + error "expected even number of Configure args e.g '-property1 value1 -property2 value2'" + } + + #Do a separate loop to check all the arguments before we run the property setting loop + set properties_to_configure [list] + foreach {argprop val} $args { + if {!([string range $argprop 0 0] eq "-") || ([string length $argprop] < 2)} { + error "expected Configure args in the form: '-property1 value1 -property2 value2'" + } + lappend properties_to_configure [string range $argprop 1 end] + } + + #gather all valid property names for all level0 interfaces in the relevant interface stack + set valid_property_names [list] + set iflist [dict get $MAP interfaces level0] + foreach id [lreverse $iflist] { + set interface_property_names [dict keys [set ::p::${id}::_iface::o_properties]] + foreach if_prop $interface_property_names { + if {$if_prop ni $valid_property_names} { + lappend valid_property_names $if_prop + } + } + } + + foreach argprop $properties_to_configure { + if {$argprop ni $valid_property_names} { + error "Configure failed - no changes made. Unable to find property '$argprop' on object $this OID:'$OID' valid properties: $valid_property_names" + } + } + + set top_IID [lindex $iflist end] + #args ok - go ahead and set all properties + foreach {prop val} $args { + set property [string range $prop 1 end] + #------------ + #don't use property ref unnecessarily - leaves property refs hanging around which traces need to update + #ie don't do this here: set [$this . $property .] $val + #------------- + ::p::${top_IID}::_iface::(SET)$property $_ID_ $val ;#equivalent to [$this . (SET)$property $val] + } + return +} + + + + + + +dict set ::p::-1::_iface::o_methods AddPatternInterface {arglist iid} +proc ::p::-1::AddPatternInterface {_ID_ iid} { + #puts stderr "!!!!!!!!!!!!!!! ::p::-1::AddPatternInterface $_ID_ $iid" + if {![string is integer -strict $iid]} { + error "adding interface by name not yet supported. Please use integer id" + } + + set invocants [dict get $_ID_ i] + #set invocant_alias [lindex [dict get $invocants this] 0] + #set invocant [lindex [interp alias {} $invocant_alias] 1] + #lassign [lindex $invocant 0] OID alias itemCmd cmd + + set OID [lindex [dict get $invocants this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + set existing_ifaces [dict get $MAP interfaces level1] ;#pattern interfaces + + + + #it is theoretically possible to have the same interface present multiple times in an iStack. + # #!todo -review why/whether this is useful. should we disallow it and treat as an error? + + lappend existing_ifaces $iid + #lset map {1 1} $existing_ifaces + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level1 $existing_ifaces + dict set MAP interfaces $extracted_sub_dict + + #lset invocant {1 1} $existing_ifaces + +} + + +#!todo - update usedby ?? +dict set ::p::-1::_iface::o_methods AddInterface {arglist iid} +proc ::p::-1::AddInterface {_ID_ iid} { + #puts stderr "::p::-1::AddInterface _ID_:$_ID_ iid:$iid" + if {![string is integer -strict $iid]} { + error "adding interface by name not yet supported. Please use integer id" + } + + + lassign [dict get $_ID_ i this] list_of_invocants_for_role_this ;#Although there is normally only 1 'this' element - it is a 'role' and the structure is nonetheless a list. + set this_invocant [lindex $list_of_invocants_for_role_this 0] + + lassign $this_invocant OID _etc + + upvar #0 ::p::${OID}::_meta::map MAP + set existing_ifaces [dict get $MAP interfaces level0] + + lappend existing_ifaces $iid + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level0 $existing_ifaces + dict set MAP interfaces $extracted_sub_dict + return [dict get $extracted_sub_dict level0] +} + + + +# The 'Create' method on the meta-interface has 2 variants (CreateNew & CreateOverlay) provided to enhance code clarity for the application using the pattern module. +# The 'Create' method could be used in all instances - but 'CreateNew' is designed for the case where the target/child object does not yet exist +# and 'CreateOverlay' for the case where the target/child object already exists. +# If the application writer follows the convention of using 'CreateNew' & 'CreateOverlay' instead of 'Create' - it should be more obvious where a particular object first comes into existence, +# and it should reduce errors where the author was expecting to overlay an existing object, but accidentally created a new object. +# 'CreateNew' will raise an error if the target already exists +# 'CreateOverlay' will raise an error if the target object does not exist. +# 'Create' will work in either case. Creating the target if necessary. + + +#simple form: +# >somepattern .. Create >child +#simple form with arguments to the constructor: +# >somepattern .. Create >child arg1 arg2 etc +#complex form - specify more info about the target (dict keyed on childobject name): +# >somepattern .. Create {>child {-id 1}} +#or +# >somepattern .. Create [list >child {-id 1 -somethingelse etc} >child2 {}] +#complex form - with arguments to the contructor: +# >somepattern .. Create [list >child {-id 1}] arg1 arg2 etc +dict set ::p::-1::_iface::o_methods Create {arglist {target_spec args}} +proc ::p::-1::Create {_ID_ target_spec args} { + #$args are passed to constructor + if {[llength $target_spec] ==1} { + set child $target_spec + set targets [list $child {}] + } else { + set targets $target_spec + } + + set OID [::p::obj_get_this_oid $_ID_] + ::p::map $OID MAP + set invocants [dict get $_ID_ i] + set invocant_roles [dict keys $invocants] ;#usually the only invocant role present will be 'this' (single dispatch case) + + foreach {child target_spec_dict} $targets { + #puts ">>>::p::-1::Create $_ID_ $child $args <<<" + + + + #set invocant_alias [lindex [dict get $invocants this] 0] + #set invocant [lindex [interp alias {} $invocant_alias] 1] + + + #puts ">>Create _ID_:$_ID_ child:$child args:$args map:$map OID:$OID" + + #child should already be fully ns qualified (?) + #ensure it is has a pattern-object marker > + #puts stderr ".... $child (nsqual: [namespace qualifiers $child])" + + + lassign [dict get $MAP invocantdata] OID alias parent_defaultmethod cmd + set interfaces [dict get $MAP interfaces level0] ;#level-0 interfaces + set patterns [dict get $MAP interfaces level1] ;#level-1 interfaces + #puts "parent: $OID -> child:$child Patterns $patterns" + + #todo - change to dict of interface stacks + set IFID0 [lindex $interfaces 0] + set IFID1 [lindex $patterns 0] ;#1st pattern + + #upvar ::p::${OID}:: INFO + + if {![string match {::*} $child]} { + if {[set ns [uplevel 1 {namespace current}]] eq "::"} { + set child ::$child + } else { + set child ${ns}::$child + } + } + + + #add > character if not already present + set child [namespace qualifiers $child]::>[string trimleft [namespace tail $child] >] + set _child [string map {::> ::} $child] + + set ns [namespace qualifiers $child] + if {$ns eq ""} { + set ns "::" + } else { + namespace eval $ns {} + } + + + #maintain a record of interfaces created so that we can clean-up if we get an error during any of the Constructor calls. + set new_interfaces [list] + + if {![llength $patterns]} { + ##puts stderr "===> WARNING: no level-1 interfaces (patterns) on object $cmd when creating $child" + #lappend patterns [::p::internals::new_interface $OID] + + #lset invocant {1 1} $patterns + ##update our command because we changed the interface list. + #set IFID1 [lindex $patterns 0] + + #set patterns [list [::p::internals::new_interface $OID]] + + #set patterns [list [::p::internals::new_interface]] + + #set patterns [list [set iid [expr {$::p::ID + 1}]]] ;#PREDICT the next object's id + #set patterns [list [set iid [incr ::p::ID]]] + set patterns [list [set iid [::p::get_new_object_id]]] + + #--------- + #set iface [::p::>interface .. Create ::p::ifaces::>$iid] + #::p::-1::Create [list {caller ::p::3}] ::p::ifaces::>$iid + + #lappend new_interfaces [::p::3::_create ::p::ifaces::>$iid] ;#interface creation + lappend new_interfaces [::p::3::_create ::p::ifaces::>$iid $iid] + + #--------- + + #puts "??> p::>interface .. Create ::p::ifaces::>$iid" + #puts "??> [::p::ifaces::>$iid --]" + #set [$iface . UsedBy .] + } + set parent_patterndefaultmethod [dict get $MAP patterndata patterndefaultmethod] + + #if {![llength [info commands $child]]} {} + + if {[namespace which $child] eq ""} { + #normal case - target/child does not exist + set is_new_object 1 + + if {[dict exists $target_spec_dict -id]} { + set childmapdata [::p::internals::new_object $child "" [dict get $target_spec_dict -id]] + } else { + set childmapdata [::p::internals::new_object $child] + } + lassign [dict get $childmapdata invocantdata] child_ID child_alias child_defaultmethod + upvar #0 ::p::${child_ID}::_meta::map CHILDMAP + + #child initially uses parent's level1 interface as it's level0 interface + # child has no level1 interface until PatternMethods or PatternProperties are added + # (or applied via clone; or via create with a parent with level2 interface) + #set child_IFID $IFID1 + + #lset CHILDMAP {1 0} [list $IFID1] + #lset CHILDMAP {1 0} $patterns + + set extracted_sub_dict [dict get $CHILDMAP interfaces] + dict set extracted_sub_dict level0 $patterns + dict set CHILDMAP interfaces $extracted_sub_dict + + #why write back when upvared??? + #review + set ::p::${child_ID}::_meta::map $CHILDMAP + + #::p::predator::remap $CHILDMAP + + #interp alias {} $child {} ::p::internals::predator $CHILDMAP + + #set child_IFID $IFID1 + + #upvar ::p::${child_ID}:: child_INFO + + #!todo review + #set n ::p::${child_ID} + #if {![info exists ${n}::-->PATTERN_ANCHOR]} { + # #puts stdout "### target:'$child' Creating ${n}::-->PATTERN_ANCHOR (unset trace to delete namespace '$n'" + # #!todo - keep an eye on tip.tcl.tk #140 - 'Tracing Namespace Modification' - may be able to do away with this hack + # set ${n}::-->PATTERN_ANCHOR "objects within this namespace will be deleted when this var is unset" + # trace add variable ${n}::-->PATTERN_ANCHOR {unset} [list ::p::meta::clear_ns $n] + #} + + set ifaces_added $patterns + + } else { + #overlay/mixin case - target/child already exists + set is_new_object 0 + + #set CHILDMAP [lindex [interp alias {} [namespace origin $child]] 1] + set childmapdata [$child --] + + + #puts stderr " *** $cmd .. Create -> target $child already exists!!!" + #puts " **** CHILDMAP: $CHILDMAP" + #puts " ****" + + #puts stderr " ---> Properties: [$child .. Properties . names]" + #puts stderr " ---> Methods: [$child .. Properties . names]" + + lassign [dict get $childmapdata invocantdata] child_ID child_alias child_default child_cmd + upvar #0 ::p::${child_ID}::_meta::map CHILDMAP + + #set child_IFID [lindex $CHILDMAP 1 0 end] + #if {$child_IFID != [set child_IFID [::p::internals::expand_interface $child_IFID]]} { + # lset CHILDMAP {1 0} [concat [lindex $CHILDMAP 1 0] $child_IFID] + # interp alias {} $child_cmd {} ::p::internals::predator $CHILDMAP + #} + ##!todo? - merge only 'open' parent interfaces onto 'open' target interfaces + #::p::merge_interface $IFID1 $child_IFID + + + set existing_interfaces [dict get $CHILDMAP interfaces level0] + set ifaces_added [list] + foreach p $patterns { + if {$p ni $existing_interfaces} { + lappend ifaces_added $p + } + } + + if {[llength $ifaces_added]} { + #lset CHILDMAP {1 0} [concat [lindex $CHILDMAP 1 0] $ifaces_added] + set extracted_sub_dict [dict get $CHILDMAP interfaces] + dict set extracted_sub_dict level0 [concat $existing_interfaces $ifaces_added] + dict set CHILDMAP interfaces $extracted_sub_dict + #set ::p::${child_ID}::_meta::map $CHILDMAP ;#why? + #::p::predator::remap $CHILDMAP + } + } + + #do not overwrite the child's defaultmethod value if the parent_patterndefaultmethod is empty + if {$parent_patterndefaultmethod ne ""} { + set child_defaultmethod $parent_patterndefaultmethod + set CHILD_INVOCANTDATA [dict get $CHILDMAP invocantdata] + lset CHILD_INVOCANTDATA 2 $child_defaultmethod + dict set CHILDMAP invocantdata $CHILD_INVOCANTDATA + #update the child's _ID_ + interp alias {} $child_alias {} ;#first we must delete it + interp alias {} $child_alias {} ::p::internals::predator [list i [list this [list $CHILD_INVOCANTDATA] ] context {}] + + #! object_command was initially created as the renamed alias - so we have to do it again + rename $child_alias $child + trace add command $child rename [list $child .. Rename] + } + #!todo - review - dont we already have interp alias entries for every method/prop? + #namespace eval ::p::${child_ID} "namespace ensemble create -command $_child" + + + + + + set constructor_failure 0 ;#flag to indicate abortion due to error during a constructor call. + + + + #------------------------------------------------------------------------------------ + #create snapshot of the object-namespaces variables to allow object state to be rolledback if any Constructor calls fail. + # - All variables under the namespace - not just those declared as Variables or Properties + # - use a namespace. For the usual case of success, we just namespace delete, and remove the COW traces. + # - presumably this snapshot should be reasonably efficient even if variables hold large amounts of data, as Tcl implements Copy-On-Write. + + #NOTE - do not use the objectID as the sole identifier for the snapshot namespace. + # - there may be multiple active snapshots for a single object if it overlays itself during a constructor, + # and it may be that a failure of an inner overlay is deliberately caught and not considered reason to raise an error for the initial constructor call. + # - we will use an ever-increasing snapshotid to form part of ns_snap + set ns_snap "::p::snap::[incr ::p::snap::id]_$child_ID" ;#unique snapshot namespace for this call to Create. + + #!todo - this should look at child namespaces (recursively?) + #!todo - this should examine any namespaces implied by the default 'varspace' value for all interfaces. + # (some of these namespaces might not be descendants of the object's ::p::${child_ID} namespace) + + namespace eval $ns_snap {} + foreach vname [info vars ::p::${child_ID}::*] { + set shortname [namespace tail $vname] + if {[array exists $vname]} { + array set ${ns_snap}::${shortname} [array get $vname] + } elseif {[info exists $vname]} { + set ${ns_snap}::${shortname} [set $vname] + } else { + #variable exists without value (e.g created by 'variable' command) + namespace eval $ns_snap [list variable $shortname] ;#create the variable without value, such that it is present, but does not 'info exist' + } + } + #------------------------------------------------------------------------------------ + + + + + + + + + + #puts "====>>> ifaces_added $ifaces_added" + set idx 0 + set idx_count [llength $ifaces_added] + set highest_constructor_IFID "" + foreach IFID $ifaces_added { + incr idx + #puts "--> adding iface $IFID " + namespace upvar ::p::${IFID}::_iface o_usedby o_usedby o_open o_open o_methods o_methods o_properties o_properties o_variables o_variables o_unknown o_unknown o_varspace o_varspace o_varspaces o_varspaces + + if {[llength $o_varspaces]} { + foreach vs $o_varspaces { + #ensure all varspaces for the interface exists so that the 'namespace upvar' entries in methods etc will work. + if {[string match "::*" $vs]} { + namespace eval $vs {} ;#an absolute path to a namespace which may not be under the object's namespace at all. + } else { + namespace eval ::p::${child_ID}::$vs {} + } + } + } + + if {$IFID != 2} { + #>ifinfo interface always has id 2 and is used by all interfaces - no need to add everything to its usedby list. + if {![info exists o_usedby(i$child_ID)]} { + set o_usedby(i$child_ID) $child_alias + } + + #compile and close the interface only if it is shared + if {$o_open} { + ::p::predator::compile_interface $IFID $_ID_ ;#params: IFID , caller_ID_ + set o_open 0 + } + } + + + package require struct::set + + set propcmds [list] + foreach cmd [info commands ::p::${IFID}::_iface::(GET)*] { + set cmd [namespace tail $cmd] + #may contain multiple results for same prop e.g (GET)x.3 + set cmd [string trimright $cmd 0123456789] + set cmd [string trimright $cmd .] ;#do separately in case cmd name also contains numerals + lappend propcmds [string range $cmd 5 end] ;#don't worry about dupes here. + } + set propcmds [struct::set union $propcmds] ;#a way to get rid of dupes. + #$propcmds now holds all Properties as well as PropertyReads with no corresponding Property on this interface. + foreach property $propcmds { + #puts "\n\n ::p::${child_ID}::$property --->>>>>>>>>>>> ::p::${IFID}::_iface::(GET)$property \n" + interp alias {} ::p::${child_ID}::(GET)$property {} ::p::${IFID}::_iface::(GET)$property ;#used by property reference traces + interp alias {} ::p::${child_ID}::$property {} ::p::${IFID}::_iface::(GET)$property + } + + set propcmds [list] + foreach cmd [info commands ::p::${IFID}::_iface::(SET)*] { + set cmd [namespace tail $cmd] + #may contain multiple results for same prop e.g (GET)x.3 + set cmd [string trimright $cmd 0123456789] + set cmd [string trimright $cmd .] ;#do separately in case cmd name also contains numerals + lappend propcmds [string range $cmd 5 end] ;#don't worry about dupes here. + } + set propcmds [struct::set union $propcmds] ;#a way to get rid of dupes. + #$propcmds now holds all Properties as well as PropertyReads with no corresponding Property on this interface. + foreach property $propcmds { + interp alias {} ::p::${child_ID}::(SET)$property {} ::p::${IFID}::_iface::(SET)$property ;#used by property reference traces + } + + + foreach method [dict keys $o_methods] { + set arglist [dict get $o_methods $method arglist] + set argvals "" + foreach argspec $arglist { + if {[llength $argspec] == 2} { + set a [lindex $argspec 0] + } else { + set a $argspec + } + + if {$a eq "args"} { + append argvals " \{*\}\$args" + } else { + append argvals " \$$a" + } + } + set argvals [string trimleft $argvals] + + #interp alias {} ::p::${child_ID}::$method {} ::p::${IFID}::_iface::$method + + #this proc directly on the object is not *just* a forwarding proc + # - it provides a context in which the 'uplevel 1' from the running interface proc runs + #This (in 2018) is faster than a namespace alias forward to an interface proc which used apply to run in the dynamically calculated namespace (it seems the dynamic namespace stopped it from byte-compiling?) + + #proc calls the method in the interface - which is an interp alias to the head of the implementation chain + + proc ::p::${child_ID}::$method [list _ID_ {*}$arglist] [subst { + ::p::${IFID}::_iface::$method \$_ID_ $argvals + }] + + #proc ::p::${child_ID}::$method [list _ID_ {*}$arglist] [string map [list @m@ $method @ID@ $IFID @argvals@ $argvals] { + # ::p::@ID@::_iface::@m@ $_ID_ @argvals@ + #}] + + } + + #namespace eval ::p::${child_ID} [list namespace export {*}$o_methods] + + #implement property even if interface already compiled because we need to create defaults for each new child obj. + # also need to add alias on base interface + #make sure we are only implementing properties from the current CREATOR + dict for {prop pdef} $o_properties { + set varspace [dict get $pdef varspace] + if {![string length $varspace]} { + set ns ::p::${child_ID} + } else { + if {[string match "::*" $varspace]} { + set ns $varspace + } else { + set ns ::p::${child_ID}::$varspace + } + } + if {[dict exists $pdef default]} { + if {![info exists ${ns}::o_$prop]} { + #apply CREATORS defaults - don't trash existing state for matching property (only apply if var unset) + set ${ns}::o_$prop [dict get $pdef default] + } + } + #! May be replaced by a method with the same name + if {$prop ni [dict keys $o_methods]} { + interp alias {} ::p::${child_ID}::$prop {} ::p::${IFID}::_iface::(GET)$prop + } + interp alias {} ::p::${child_ID}::(GET)$prop {} ::p::${IFID}::_iface::(GET)$prop + interp alias {} ::p::${child_ID}::(SET)$prop {} ::p::${IFID}::_iface::(SET)$prop + } + + + + #variables + #foreach vdef $o_variables { + # if {[llength $vdef] == 2} { + # #there is a default value defined. + # lassign $vdef v default + # if {![info exists ::p::${child_ID}::$v]} { + # set ::p::${child_ID}::$v $default + # } + # } + #} + dict for {vname vdef} $o_variables { + if {[dict exists $vdef default]} { + #there is a default value defined. + set varspace [dict get $vdef varspace] + if {$varspace eq ""} { + set ns ::p::${child_ID} + } else { + if {[string match "::*" $varspace]} { + set ns $varspace + } else { + set ns ::p::${child_ID}::$varspace + } + } + set ${ns}::$vname [dict get $vdef default] + } + } + + #!todo - review. Write tests for cases of multiple constructors! + + #We don't want to the run constructor for each added interface with the same set of args! + #run for last one - rely on constructor authors to use @next@ properly? + if {[llength [set ::p::${IFID}::_iface::o_constructor]]} { + set highest_constructor_IFID $IFID + } + + if {$idx == $idx_count} { + #we are processing the last interface that was added - now run the latest constructor found + if {$highest_constructor_IFID ne ""} { + #at least one interface has a constructor + if {[llength [set ::p::${highest_constructor_IFID}::_iface::o_constructor]]} { + #puts ">>!! running constructor ifid:$highest_constructor_IFID child: $CHILDMAP" + if {[catch {::p::${highest_constructor_IFID}::_iface::(CONSTRUCTOR) [dict create i [dict create this [list [dict get $CHILDMAP invocantdata] ] ]] {*}$args} constructor_error]} { + set constructor_failure 1 + set constructor_errorInfo $::errorInfo ;#cache it immediately. + break + } + } + } + } + + if {[info exists o_unknown]} { + interp alias {} ::p::${IFID}::_iface::(UNKNOWN) {} ::p::${IFID}::_iface::$o_unknown + interp alias {} ::p::${child_ID}::(UNKNOWN) {} ::p::${child_ID}::$o_unknown + + #interp alias {} ::p::${IFID}::_iface::(UNKNOWN) {} ::p::${child_ID}::$o_unknown + #namespace eval ::p::${IFID}::_iface [list namespace unknown $o_unknown] + #namespace eval ::p::${child_ID} [list namespace unknown $o_unknown] + } + } + + if {$constructor_failure} { + if {$is_new_object} { + #is Destroy enough to ensure that no new interfaces or objects were left dangling? + $child .. Destroy + } else { + #object needs to be returned to a sensible state.. + #attempt to rollback all interface additions and object state changes! + puts "!!!!!!!!!!!!!!!!>>>constructor rollback object $child_ID \n\n\n\n" + #remove variables from the object's namespace - which don't exist in the snapshot. + set snap_vars [info vars ${ns_snap}::*] + puts "ns_snap '$ns_snap' vars'${snap_vars}'" + foreach vname [info vars ::p::${child_ID}::*] { + set shortname [namespace tail $vname] + if {"${ns_snap}::$shortname" ni "$snap_vars"} { + #puts "--- >>>>> unsetting $shortname " + unset -nocomplain $vname + } + } + + #restore variables from snapshot - but try to do so with minimal writes (don't want to trigger any unnecessary traces) + #values of vars may also have Changed + #todo - consider traces? what is the correct behaviour? + # - some application traces may have fired before the constructor error occurred. + # Should the rollback now also trigger traces? + #probably yes. + + #we need to test both source and dest var for arrayness - as the failed constructor could have changed the variable type, not just the value + foreach vname $snap_vars { + #puts stdout "@@@@@@@@@@@ restoring $vname" + #flush stdout + + + set shortname [namespace tail $vname] + set target ::p::${child_ID}::$shortname + if {$target in [info vars ::p::${child_ID}::*]} { + set present 1 ;#variable exists in one of 3 forms; array, simple, or 'declared only' + } else { + set present 0 + } + + if {[array exists $vname]} { + #restore 'array' variable + if {!$present} { + array set $target [array get $vname] + } else { + if {[array exists $target]} { + #unset superfluous elements + foreach key [array names $target] { + if {$key ni [array names $vname]} { + array unset $target $key + } + } + #.. and write only elements that have changed. + foreach key [array names $vname] { + if {[set ${target}($key)] ne [set ${vname}($key)]} { + set ${target}($key) [set ${vname}($key)] + } + } + } else { + #target has been changed to a simple variable - unset it and recreate the array. + unset $target + array set $target [array get $vname] + } + } + } elseif {[info exists $vname]} { + #restore 'simple' variable + if {!$present} { + set $target [set $vname] + } else { + if {[array exists $target]} { + #target has been changed to array - unset it and recreate the simple variable. + unset $target + set $target [set $vname] + } else { + if {[set $target] ne [set $vname]} { + set $target [set $vname] + } + } + } + } else { + #restore 'declared' variable + if {[array exists $target] || [info exists $target]} { + unset -nocomplain $target + } + namespace eval ::p::${child_ID} [list variable $shortname] + } + } + } + namespace delete $ns_snap + return -code error -errorinfo "oid:${child_ID} constructor_failure for IFID:${IFID}\n$constructor_errorInfo" $constructor_error + } + namespace delete $ns_snap + + } + + return $child +} + +dict set ::p::-1::_iface::o_methods Clone {arglist {clone args}} +#A cloned individual doesn't have the scars of its parent. i.e values (state) not *copied* +# (new 'clean' object with same structure. values as set by constructor or *specified by defaults*) +# Also: Any 'open' interfaces on the parent become closed on clone! +proc ::p::-1::Clone {_ID_ clone args} { + set OID [::p::obj_get_this_oid $_ID_] + ::p::map $OID MAP + + set invocants [dict get $_ID_ i] + lassign [dict get $MAP invocantdata] OID alias parent_defaultmethod cmd + + set _cmd [string map {::> ::} $cmd] + set tail [namespace tail $_cmd] + + + #obsolete? + ##set IFID0 [lindex $map 1 0 end] + #set IFID0 [lindex [dict get $MAP interfaces level0] end] + ##set IFID1 [lindex $map 1 1 end] + #set IFID1 [lindex [dict get $MAP interfaces level1] end] + + + if {![string match "::*" $clone]} { + if {[set ns [uplevel 1 {namespace current}]] eq "::"} { + set clone ::$clone + } else { + set clone ${ns}::$clone + } + } + + + set clone [namespace qualifiers $clone]::>[string trimleft [namespace tail $clone] >] + set _clone [string map {::> ::} $clone] + + + set cTail [namespace tail $_clone] + + set ns [namespace qualifiers $clone] + if {$ns eq ""} { + set ns "::" + } + + namespace eval $ns {} + + + #if {![llength [info commands $clone]]} {} + if {[namespace which $clone] eq ""} { + set clonemapdata [::p::internals::new_object $clone] + } else { + #overlay/mixin case - target/clone already exists + #set CLONEMAP [lindex [interp alias {} [namespace origin $clone]] 1] + set clonemapdata [$clone --] + } + set clone_ID [lindex [dict get $clonemapdata invocantdata] 0] + + upvar #0 ::p::${clone_ID}::_meta::map CLONEMAP + + + #copy patterndata element of MAP straight across + dict set CLONEMAP patterndata [dict get $MAP patterndata] + set CLONE_INVOCANTDATA [dict get $CLONEMAP invocantdata] + lset CLONE_INVOCANTDATA 2 $parent_defaultmethod + dict set CLONEMAP invocantdata $CLONE_INVOCANTDATA + lassign $CLONE_INVOCANTDATA clone_ID clone_alias clone_defaultmethod clone + + #update the clone's _ID_ + interp alias {} $clone_alias {} ;#first we must delete it + interp alias {} $clone_alias {} ::p::internals::predator [list i [list this [list $CLONE_INVOCANTDATA] ] context {}] + + #! object_command was initially created as the renamed alias - so we have to do it again + rename $clone_alias $clone + trace add command $clone rename [list $clone .. Rename] + + + + + #obsolete? + #upvar ::p::${clone_ID}:: clone_INFO + #upvar ::p::${IFID0}:: IFACE ;#same interface on predecessor(self) and clone. + #upvar ::p::${OID}:: INFO + + + array set clone_INFO [array get INFO] + + array set ::p::${clone_ID}::_iface::o_usedby [list] ;#'usedby' + + + #!review! + #if {![catch {set itemCmd $IFACE(m-1,name,item)}]} { + #puts "***************" + #puts "clone" + #parray IFINFO + #puts "***************" + #} + + #we need the parent(s) in order to 'clone'??? - probably, as the defs are usually there unless the object was created with ad-hoc methods/props directly from ::>pattern + + + #clone's interface maps must be a superset of original's + foreach lev {0 1} { + #set parent_ifaces [lindex $map 1 $lev] + set parent_ifaces [dict get $MAP interfaces level$lev] + + #set existing_ifaces [lindex $CLONEMAP 1 $lev] + set existing_ifaces [dict get $CLONEMAP interfaces level$lev] + + set added_ifaces_$lev [list] + foreach ifid $parent_ifaces { + if {$ifid ni $existing_ifaces} { + + #interface must not remain extensible after cloning. + if {[set ::p::${ifid}::_iface::o_open]} { + ::p::predator::compile_interface $ifid $_ID_ + set ::p::${ifid}::_iface::o_open 0 + } + + + + lappend added_ifaces_$lev $ifid + #clone 'uses' all it's predecessor's interfaces, so update each interface's 'usedby' list. + set ::p::${ifid}::_iface::o_usedby(i$clone_ID) $clone + } + } + set extracted_sub_dict [dict get $CLONEMAP interfaces] + dict set extracted_sub_dict level$lev [concat $existing_ifaces [set added_ifaces_$lev]] + dict set CLONEMAP interfaces $extracted_sub_dict + #lset CLONEMAP 1 $lev [concat $existing_ifaces [set added_ifaces_$lev]] + } + + #interp alias {} ::p::${IFID0}::(VIOLATE) {} ::p::internals::(VIOLATE) + + + #foreach *added* level0 interface.. + foreach ifid $added_ifaces_0 { + namespace upvar ::p::${ifid}::_iface o_methods o_methods o_properties o_properties o_variables o_variables o_constructor o_constructor o_unknown o_unknown + + + dict for {prop pdef} $o_properties { + #lassign $pdef prop default + if {[dict exists $pdef default]} { + set varspace [dict get $pdef varspace] + if {$varspace eq ""} { + set ns ::p::${clone_ID} + } else { + if {[string match "::*" $varspace]} { + set ns $varspace + } else { + set ns ::p::${clone_ID}::$varspace + } + } + + if {![info exists ${ns}::o_$prop]} { + #apply CREATORS defaults - don't trash existing state for matching property (only apply if var unset) + set ${ns}::o_$prop [dict get $pdef default] + } + } + + #! May be replaced by method of same name + if {[namespace which ::p::${clone_ID}::$prop] eq ""} { + interp alias {} ::p::${clone_ID}::$prop {} ::p::${ifid}::_iface::(GET)$prop + } + interp alias {} ::p::${clone_ID}::(GET)$prop {} ::p::${ifid}::_iface::(GET)$prop + interp alias {} ::p::${clone_ID}::(SET)$prop {} ::p::${ifid}::_iface::(SET)$prop + } + + #variables + dict for {vname vdef} $o_variables { + if {[dict exists $vdef default]} { + set varspace [dict get $vdef varspace] + if {$varspace eq ""} { + set ns ::p::${clone_ID} + } else { + if {[string match "::*" $varspace]} { + set ns $varspace + } else { + set ns ::p::${clone_ID}::$varspace + } + } + if {![info exists ${ns}::$vname]} { + set ::p::${clone_ID}::$vname [dict get $vdef default] + } + } + } + + + #update the clone object's base interface to reflect the new methods. + #upvar 0 ::p::${ifid}:: IFACE + #set methods [list] + #foreach {key mname} [array get IFACE m-1,name,*] { + # set method [lindex [split $key ,] end] + # interp alias {} ::p::${clone_ID}::$method {} ::p::${ifid}::_iface::$method $CLONEMAP + # lappend methods $method + #} + #namespace eval ::p::${clone_ID} [list namespace export {*}$methods] + + + foreach method [dict keys $o_methods] { + + set arglist [dict get $o_methods $method arglist] + set argvals "" + foreach argspec $arglist { + if {[llength $argspec] == 2} { + set a [lindex $argspec 0] + } else { + set a $argspec + } + + if {$a eq "args"} { + append argvals " \{*\}\$args" + } else { + append argvals " \$$a" + } + } + set argvals [string trimleft $argvals] + #interp alias {} ::p::${clone_ID}::$method {} ::p::${ifid}::_iface::$method + + #this proc directly on the object is not *just* a forwarding proc + # - it provides a context in which the 'uplevel 1' from the running interface proc runs + #This (in 2018) is faster than a namespace alias forward to an interface proc which used apply to run in the dynamically calculated namespace (it seems the dynamic namespace stopped it from byte-compiling?) + + #proc calls the method in the interface - which is an interp alias to the head of the implementation chain + proc ::p::${clone_ID}::$method [list _ID_ {*}$arglist] [subst { + ::p::${ifid}::_iface::$method \$_ID_ $argvals + }] + + } + #namespace eval ::p::${clone_ID} [list namespace export {*}$o_methods] + + + if {[info exists o_unknown]} { + #interp alias {} ::p::${IID}::_iface::(UNKNOWN) {} ::p::${clone_ID}::$o_unknown + interp alias {} ::p::${IID}::_iface::(UNKNOWN) {} ::p::${IID}::_iface::$o_unknown + interp alias {} ::p::${clone_ID}::(UNKNOWN) {} ::p::${clone_ID}::$o_unknown + + #namespace eval ::p::${IID}::_iface [list namespace unknown $o_unknown] + #namespace eval ::p::${clone_ID} [list namespace unknown $o_unknown] + + } + + + #2021 + #Consider >parent with constructor that sets height + #.eg >parent .. Constructor height { + # set o_height $height + #} + #>parent .. Create >child 5 + # - >child has height 5 + # now when we peform a clone operation - it is the >parent's constructor that will run. + # A clone will get default property and var values - but not other variable values unless the constructor sets them. + #>child .. Clone >fakesibling 6 + # - >sibling has height 6 + # Consider if >child had it's own constructor created with .. Construct prior to the clone operation. + # The >child's constructor didn't run - even though we created a >fakesibling - because the paren'ts one ran instead. + # If we now add a constructor to >fakesibling - and put @next@ for constructor chaining... + # when we now do >sibling .. Create >grandchild + # - The constructor on >sibling runs first but chains to >child - the cloner aunt/uncle of the >grandchild + # (while the calling order can't be changed - the positioning of @next@ tag in the contructor can allow code to run before and/or after the chained constructors and chaining can be disabled by providing a constructor without this tag.) + # However - the args supplied in the >clone operation don't get either constructor running on the >grandchild + #(though other arguments can be manually passed) + # #!review - does this make sense? What if we add + # + #constructor for each interface called after properties initialised. + #run each interface's constructor against child object, using the args passed into this clone method. + if {[llength [set constructordef [set o_constructor]]]} { + #error + puts "!!!!!> running constructor for ifid:$ifid on clone:$clone_ID" + ::p::${ifid}::_iface::(CONSTRUCTOR) [dict create i [dict create this [list [dict get $CLONEMAP invocantdata]] ]] {*}$args + + } + + } + + + return $clone + +} + + + +interp alias {} ::p::-1::constructor {} ::p::-1::Constructor ;#for Define compatibility (snit?) +dict set ::p::-1::_iface::o_methods Constructor {arglist {arglist body}} +proc ::p::-1::Constructor {_ID_ arglist body} { + set invocants [dict get $_ID_ i] + #set invocant_alias [lindex [dict get $invocants this] 0] + #set invocant [lindex [interp alias {} $invocant_alias] 1] + #lassign [lindex $invocant 0 ] OID alias itemCmd cmd + + set OID [lindex [dict get $_ID_ i this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + + set patterns [dict get $MAP interfaces level1] + set iid_top [lindex $patterns end] ;#!todo - choose 'open' interface to expand. + set iface ::p::ifaces::>$iid_top + + if {(![string length $iid_top]) || ([$iface . isClosed])} { + #no existing pattern - create a new interface + set iid_top [expr {$::p::ID + 1}] ;#PREDICT the next object's id + #set iid_top [::p::get_new_object_id] + + #the >interface constructor takes a list of IDs for o_usedby + set iface [::p::>interface .. Create ::p::ifaces::>$iid_top [list $OID]] + + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level1 [concat $patterns $iid_top] + dict set MAP interfaces $extracted_sub_dict + #lset map {1 1} [concat $patterns $iid_top] + + #::p::predator::remap $invocant + } + set IID $iid_top + + namespace upvar ::p::${IID}::_iface o_open o_open o_constructor o_constructor o_varspace o_varspace o_varspaces o_varspaces + + + # examine the existing command-chain + set maxversion [::p::predator::method_chainhead $IID (CONSTRUCTOR)] + set headid [expr {$maxversion + 1}] + set THISNAME (CONSTRUCTOR).$headid ;#first version will be $method.1 + + set next [::p::predator::next_script $IID (CONSTRUCTOR) $THISNAME $_ID_] + + #set varspaces [::pattern::varspace_list] + set processed [dict create {*}[::p::predator::expand_var_statements $body $o_varspace]] + + if {[llength [dict get $processed varspaces_with_explicit_vars]]} { + foreach vs [dict get $processed varspaces_with_explicit_vars] { + if {[string length $vs] && ($vs ni $o_varspaces)} { + lappend o_varspaces $vs + } + } + set body [dict get $processed body] + } else { + set varDecls [::p::predator::runtime_vardecls] + set body $varDecls\n[dict get $processed body] + #puts stderr "\t runtime_vardecls in Constructor $varDecls" + } + + #set body [string map [::list @this@ "\[lindex \$_ID_ 0 3]" @next@ $next] $body\n] + set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata \] 3\]" @next@ $next] $body\n] + + #puts stderr ---- + #puts stderr $body + #puts stderr ---- + + proc ::p::${IID}::_iface::(CONSTRUCTOR).$headid [concat _ID_ $arglist] $body + interp alias {} ::p::${IID}::_iface::(CONSTRUCTOR) {} ::p::${IID}::_iface::(CONSTRUCTOR).$headid + + + + set o_constructor [list $arglist $body] + set o_open 1 + + return +} + + + +dict set ::p::-1::_iface::o_methods UsedBy {arglist {}} +proc ::p::-1::UsedBy {_ID_} { + return [array get ::p::[lindex [dict get $_ID_ i this] 0 0]::_iface::o_usedby] +} + + +dict set ::p::-1::_iface::o_methods Ready {arglist {}} +proc ::p::-1::Ready {_ID_} { + return [expr {![set ::p::[lindex [dict get $_ID_ i this] 0 0]::_iface::o_open]}] +} + + + +dict set ::p::-1::_iface::o_methods Destroy {arglist {{force 1}}} + +#'force' 1 indicates object command & variable will also be removed. +#'force' 0 is used when the containing namespace is being destroyed anyway - so no need to destroy cmd & var. +#this is necessary for versions of Tcl that have problems with 'unset' being called multiple times. (e.g Tcl 8.5a4) +# +proc ::p::-1::Destroy {_ID_ {force 1}} { + #puts stdout "\t\tDestroy called with _ID_:$_ID_ force:$force caller:[info level 1]" + set invocants [dict get $_ID_ i] + set OID [lindex [dict get $invocants this] 0 0] + + if {$OID eq "null"} { + puts stderr "warning - review code. Destroy called on object with null OID. _ID_:$_ID_" + return + } + + upvar #0 ::p::${OID}::_meta::map MAP + + lassign [dict get $MAP invocantdata] OID alias itemCmd cmd + + + #puts ">>>>>Explicit Destroy $cmd [clock format [clock seconds] -format %H:%M:%S] info-level-1'[info level 1]'<<<<<" ;flush stdout + + #explicit Destroy - remove traces + #puts ">>TRACES: [trace info variable $cmd]" + #foreach tinfo [trace info variable $cmd] { + # trace remove variable $cmd {*}$tinfo + #} + #foreach tinfo [trace info command $cmd] { + # trace remove command $cmd {*}$tinfo + #} + + + set _cmd [string map {::> ::} $cmd] + + #set ifaces [lindex $map 1] + set iface_stacks [dict get $MAP interfaces level0] + #set patterns [lindex $map 2] + set pattern_stacks [dict get $MAP interfaces level1] + + + + set ifaces $iface_stacks + + + set patterns $pattern_stacks + + + #set i 0 + #foreach iflist $ifaces { + # set IFID$i [lindex $iflist 0] + # incr i + #} + + + set IFTOP [lindex $ifaces end] + + set DESTRUCTOR ::p::${IFTOP}::___system___destructor + #may be a proc, or may be an alias + if {[namespace which $DESTRUCTOR] ne ""} { + set temp_ID_ [dict create i [dict create this [list [dict get $MAP invocantdata]]] context {}] + + if {[catch {$DESTRUCTOR $temp_ID_} prob]} { + #!todo - ensure correct calling order of interfaces referencing the destructor proc + + + #!todo - emit destructor errors somewhere - logger? + #puts stderr "underlying proc already removed??? ---> $prob" + #puts stderr "--------Destructor Error on interface $IFID0 of Object $OID-------------" + #puts stderr $::errorInfo + #puts stderr "---------------------" + } + } + + + #remove ourself from each interfaces list of referencers + #puts stderr "--- $ifaces" + + foreach var {ifaces patterns} { + + foreach i [set $var] { + + if {[string length $i]} { + if {$i == 2} { + #skip the >ifinfo interface which doesn't maintain a usedby list anyway. + continue + } + + if {[catch { + + upvar #0 ::p::${i}::_iface::o_usedby usedby + + array unset usedby i$OID + + #puts "\n***>>***" + #puts "IFACE: $i usedby: $usedby" + #puts "***>>***\n" + + #remove interface if no more referencers + if {![array size usedby]} { + #puts " **************** DESTROYING unused interface $i *****" + #catch {namespace delete ::p::$i} + + #we happen to know where 'interface' object commands are kept: + + ::p::ifaces::>$i .. Destroy + + } + + } errMsg]} { + #warning + puts stderr "warning: error during destruction of object:$OID (removing usedby reference for interface $i) ([lindex [dict get $MAP invocantdata] 3]) \n $errMsg" + } + } + + } + + } + + set ns ::p::${OID} + #puts "-- destroying objects below namespace:'$ns'" + ::p::internals::DestroyObjectsBelowNamespace $ns + #puts "--.destroyed objects below '$ns'" + + + #set ns ::p::${OID}::_sub + #call .. Destroy on each thing that looks like a pattern object anywhere below our 'user-area' namespace + #( ::p::OBJECT::$OID ) + #puts "\n******** [clock format [clock seconds] -format %H:%M:%S] destroyingobjectsbelownamespace ns: $ns *****\n" + #::p::internals::DestroyObjectsBelowNamespace $ns + + #same for _meta objects (e.g Methods,Properties collections) + #set ns ::p::${OID}::_meta + #::p::internals::DestroyObjectsBelowNamespace $ns + + + + #foreach obj [info commands ${ns}::>*] { + # #Assume it's one of ours, and ask it to die. + # catch {::p::meta::Destroy $obj} + # #catch {$cmd .. Destroy} + #} + #just in case the user created subnamespaces.. kill objects there too. + #foreach sub [namespace children $ns] { + # ::p::internals::DestroyObjectsBelowNamespace $sub + #} + + + #!todo - fix. info vars on the namespace is not enough to detect references which were never set to a value! + #use info commands ::p::${OID}::_ref::* to find all references - including variables never set + #remove variable traces on REF vars + #foreach rv [info vars ::p::${OID}::_ref::*] { + # foreach tinfo [trace info variable $rv] { + # #puts "-->removing traces on $rv: $tinfo" + # trace remove variable $rv {*}$tinfo + # } + #} + + #!todo - write tests + #refs create aliases and variables at the same place + #- but variable may not exist if it was never set e.g if it was only used with info exists + foreach rv [info commands ::p::${OID}::_ref::*] { + foreach tinfo [trace info variable $rv] { + #puts "-->removing traces on $rv: $tinfo" + trace remove variable $rv {*}$tinfo + } + } + + + + + + + + #if {[catch {namespace delete $nsMeta} msg]} { + # puts stderr "-----&&&&&&&&&&&&&& ERROR deleting NS $nsMeta : $msg " + #} else { + # #puts stderr "------ -- -- -- -- deleted $nsMeta " + #} + + + #!todo - remove + #temp + #catch {interp alias "" ::>$OID ""} + + if {$force} { + #rename $cmd {} + + #removing the alias will remove the command - even if it's been renamed + interp alias {} $alias {} + + #if {[catch {rename $_cmd {} } why]} { + # #!todo - work out why some objects don't have matching command. + # #puts stderr "\t rename $_cmd {} failed" + #} else { + # puts stderr "\t rename $_cmd {} SUCCEEDED!!!!!!!!!!" + #} + + } + + set refns ::p::${OID}::_ref + #puts "[clock format [clock seconds] -format %H:%M:%S] - tidying up namespace $refns" + #puts "- children: [llength [namespace children $refns]]" + #puts "- vars : [llength [info vars ${refns}::*]]" + #puts "- commands: [llength [info commands ${refns}::*]]" + #puts "- procs : [llength [info procs ${refns}::*]]" + #puts "- aliases : [llength [lsearch -all -inline [interp aliases {}] ${refns}::*]]" + #puts "- matching command: [llength [info commands ${refns}]]" + #puts "[clock format [clock seconds] -format %H:%M:%S] - tidyup DONE $refns" + + + #foreach v [info vars ${refns}::*] { + # unset $v + #} + #foreach p [info procs ${refns}::*] { + # rename $p {} + #} + #foreach a [lsearch -all -inline [interp aliases {}] ${refns}::*] { + # interp alias {} $a {} + #} + + + #set ts1 [clock seconds] + #puts "[clock format $ts1 -format %H:%M:%S] $cmd about to delete $refns." + #puts "- children: [llength [namespace children $refns]]" + #puts "- vars : [llength [info vars ${refns}::*]]" + + #puts "- commands: [llength [info commands ${refns}::*]]" + #puts "- procs : [llength [info procs ${refns}::*]]" + #puts "- aliases : [llength [lsearch -all -inline [interp aliases {}] ${refns}::*]]" + #puts "- exact command: [info commands ${refns}]" + + + + + #puts "--delete ::p::${OID}::_ref" + if {[namespace exists ::p::${OID}::_ref]} { + #could just catch.. but would rather know if there's some other weird reason the namespace can't be deleted. + namespace delete ::p::${OID}::_ref:: + } + set ts2 [clock seconds] + #puts "[clock format $ts2 -format %H:%M:%S] $cmd deleted $refns. ELAPSED: [expr {$ts2 - $ts1}]" + + + #delete namespace where instance variables reside + #catch {namespace delete ::p::$OID} + namespace delete ::p::$OID + + #puts "...... destroyed $cmd [clock format [clock seconds] -format %H:%M:%S] <<<<<" ;flush stdout + return +} + + +interp alias {} ::p::-1::destructor {} ::p::-1::Destructor ;#for Define compatibility + + +dict set ::p::-1::_iface::o_methods Destructor {arglist {args}} +#!todo - destructor arguments? e.g to be able to mark for destruction on next sweep of some collector as opposed to immediate destruction? +#install a Destructor on the invocant's open level1 interface. +proc ::p::-1::Destructor {_ID_ args} { + set OID [::p::obj_get_this_oid $_ID_] + ::p::map $OID MAP + + #lassign [lindex $map 0] OID alias itemCmd cmd + + set patterns [dict get $MAP interfaces level1] + + if {[llength $args] > 2} { + error "too many arguments to 'Destructor' - expected at most 2 (arglist body)" + } + + set existing_IID [lindex $patterns end] ;#!todo - get 'open' interface. + + if {$existing_IID != [set IID [::p::internals::expand_interface $existing_IID]]} { + array unset ::p::${existing_IID}::_iface::o_usedby i$OID + error "NOT TESTED" + set ::p::${IID}::_iface::o_usedby(i$OID) $cmd + + set posn [lsearch $patterns $existing_IID] + + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level1 [concat [lreplace $patterns $posn $posn] $IID] + dict set MAP interfaces $extracted_sub_dict + #lset map {1 1} [concat [lreplace $patterns $posn $posn] $IID] + + #::p::predator::remap $invocant + } + + + set ::p::${IID}::_iface::o_destructor_body [lindex $args end] + + if {[llength $args] > 1} { + #!todo - allow destructor args(?) + set arglist [lindex $args 0] + } else { + set arglist [list] + } + + set ::p::${IID}::_iface::o_destructor_args $arglist + + return +} + + + + + +interp alias {} ::p::-1::method {} ::p::-1::PatternMethod ;#for Define compatibility (with snit) + + +dict set ::p::-1::_iface::o_methods PatternMethod {arglist {method arglist body}} +proc ::p::-1::PatternMethod {_ID_ method arglist body} { + set OID [::p::obj_get_this_oid $_ID_] + ::p::map $OID MAP + lassign [dict get $MAP invocantdata] OID alias default_method object_command _wrapped + + set patterns [dict get $MAP interfaces level1] + set iid_top [lindex $patterns end] ;#!todo - get 'open' interface. + set iface ::p::ifaces::>$iid_top + + if {(![string length $iid_top]) || ([$iface . isClosed])} { + #no existing pattern - create a new interface + set iid_top [expr {$::p::ID + 1}] ;#PREDICT the next object's id + set iface [::p::>interface .. Create ::p::ifaces::>$iid_top $OID] + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level1 [concat $patterns $iid_top] + dict set MAP interfaces $extracted_sub_dict + } + set IID $iid_top + + + namespace upvar ::p::${IID}::_iface o_methods o_methods o_definition o_definition o_varspace o_varspace o_varspaces o_varspaces + + + # examine the existing command-chain + set maxversion [::p::predator::method_chainhead $IID $method] + set headid [expr {$maxversion + 1}] + set THISNAME $method.$headid ;#first version will be $method.1 + + set next [::p::predator::next_script $IID $method $THISNAME $_ID_] + + + set processed [dict create {*}[::p::predator::expand_var_statements $body $o_varspace]] + if {[llength [dict get $processed varspaces_with_explicit_vars]]} { + foreach vs [dict get $processed varspaces_with_explicit_vars] { + if {[string length $vs] && ($vs ni $o_varspaces)} { + lappend o_varspaces $vs + } + } + set body [dict get $processed body] + } else { + set varDecls [::p::predator::runtime_vardecls] ;#dynamic vardecls can access vars from all interfaces of invocant object. + #puts stdout "!!!>!>>>>>$THISNAME VarDecls: $varDecls" + set body $varDecls\n[dict get $processed body] + #puts stderr "\t object $OID runtime_vardecls in PatternMethod $method $varDecls" + } + + + set body [::p::predator::wrap_script_in_apply_object_namespace $o_varspace $body[set body {}] $arglist] + + #set body [string map [::list @this@ "\[lindex \${_ID_} 0 3]" @next@ $next] $body\n] + set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata\] 3\]" @next@ $next] $body[set body {}]\n] + #puts "\t\t--------------------" + #puts "\n" + #puts $body + #puts "\n" + #puts "\t\t--------------------" + proc ::p::${IID}::_iface::$THISNAME [concat _ID_ $arglist] $body + + + + #pointer from method-name to head of the interface's command-chain + interp alias {} ::p::${IID}::_iface::$method {} ::p::${IID}::_iface::$THISNAME + + + + if {$method in [dict keys $o_methods]} { + #error "patternmethod '$method' already present in interface $IID" + set msg "WARNING: patternmethod '$method' already exists on objectid $OID ($object_command). Replacing previous version. (no chaining support here yet...)" + if {[string match "*@next@*" $body]} { + append msg "\n EXTRA-WARNING: method contains @next@" + } + + puts stdout $msg + } else { + dict set o_methods $method [list arglist $arglist] + } + + #::p::-1::update_invocant_aliases $_ID_ + return +} + +#MultiMethod +#invocant_signature records the rolenames and aritys as a dispatch signature to support multimethods which act on any number of invocants +# e.g1 $obj .. MultiMethod add {these 2} $arglist $body +# e.g2 $obj .. MultiMethod add {these n} $arglist $body +# +# e.g3 $collidabletemplate .. MultiMethod collision {vehicles 2 cameras 0..n} $arglist $body +# +# for e.g3 - all vehicles & cameras involved would need to have the interface containing the method named 'collision', with the matching invocant_signature. +# (it is possible for the object, or even the same interface to contain another method named 'collision' with a different signature) +# !todo - review rules for when invocants participating in a multimethod with a particular signature, have different implementations (method from different interfaces) +# - can we avoid the overhead of checking for this at dispatch-time, and simply use which ever implementation we first encounter? +# - should we warn about or enforce a same-implementation rule for all multimethod conflicts found at the time an object-conglomeration is formed? +# - should there be before and after hooks for all invocants involved in a multimethod so they can each add behaviour independent of the shared multimethod code? +# (and how would we define the call order? - presumably as it appears in the conglomerate) +# (or could that be done with a more general method-wrapping mechanism?) +#...should multimethods use some sort of event mechanism, and/or message-passing system? +# +dict set ::p::-1::_iface::o_methods MultiMethod {arglist {method invocant_signature arglist body args}} +proc ::p::-1::MultiMethod {_ID_ method invocant_signature arglist body args} { + set invocants [dict get $_ID_ i] + + error "not implemented" +} + +dict set ::p::-1::_iface::o_methods DefaultMethod {arglist {{methodname "noargsupplied--9e40ec8b-bc31-4400-98b8-d48ee23746c4"}}} +# we could use . to indicate no methodname - as this is one of a few highly confusing names for a method (also for example .. , # -- ) +#we can create a method named "." by using the argprotect operator -- +# e.g >x .. Method -- . {args} $body +#It can then be called like so: >x . . +#This is not guaranteed to work and is not in the test suite +#for now we'll just use a highly unlikely string to indicate no argument was supplied +proc ::p::-1::DefaultMethod {_ID_ {methodname "noargsupplied--9e40ec8b-bc31-4400-98b8-d48ee23746c4"} } { + set non_argument_magicstring "noargsupplied--9e40ec8b-bc31-4400-98b8-d48ee23746c4" + set OID [lindex [dict get $_ID_ i this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + lassign [dict get $MAP invocantdata] OID alias default_method object_command _wrapped + if {$methodname eq $non_argument_magicstring} { + return $default_method + } else { + set extracted_value [dict get $MAP invocantdata] + lset extracted_value 2 $methodname + dict set MAP invocantdata $extracted_value ;#write modified value back + #update the object's command alias to match + interp alias {} $alias {} ;#first we must delete it + interp alias {} $alias {} ::p::internals::predator [list i [list this [list $extracted_value ] ] context {}] + + #! $object_command was initially created as the renamed alias - so we have to do it again + rename $alias $object_command + trace add command $object_command rename [list $object_command .. Rename] + return $methodname + } +} + +dict set ::p::-1::_iface::o_methods PatternDefaultMethod {arglist {{methodname "noargsupplied--9e40ec8b-bc31-4400-98b8-d48ee23746c4"}}} +proc ::p::-1::PatternDefaultMethod {_ID_ {methodname "noargsupplied--9e40ec8b-bc31-4400-98b8-d48ee23746c4"} } { + set non_argument_magicstring "noargsupplied--9e40ec8b-bc31-4400-98b8-d48ee23746c4" + set OID [lindex [dict get $_ID_ i this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + set extracted_patterndata [dict get $MAP patterndata] + set pattern_default_method [dict get $extracted_patterndata patterndefaultmethod] + if {$methodname eq $non_argument_magicstring} { + return $pattern_default_method + } else { + dict set extracted_patterndata patterndefaultmethod $methodname + dict set MAP patterndata $extracted_patterndata + return $methodname + } +} + + +dict set ::p::-1::_iface::o_methods Method {arglist {method arglist bodydef args}} +proc ::p::-1::Method {_ID_ method arglist bodydef args} { + set invocants [dict get $_ID_ i] + + set OID [lindex [dict get $_ID_ i this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + + + set invocant_signature [list] ; + ;# we sort when calculating the sig.. so a different key order will produce the same signature - !todo - this is probably desirable but review anyway. + foreach role [lsort [dict keys $invocants]] { + lappend invocant_signature $role [llength [dict get $invocants $role]] + } + #note: it's expected that by far the most common 'invocant signature' will be {this 1} - which corresponds to a standard method dispatch on a single invocant object - the 'subject' (aka 'this') + + + + lassign [dict get $MAP invocantdata] OID alias default_method object_command + set interfaces [dict get $MAP interfaces level0] + + + + ################################################################################# + if 0 { + set iid_top [lindex $interfaces end] ;#!todo - get 'open' interface + set prev_open [set ::p::${iid_top}::_iface::o_open] + + set iface ::p::ifaces::>$iid_top + + set f_new 0 + if {![string length $iid_top]} { + set f_new 1 + } else { + if {[$iface . isClosed]} { + set f_new 1 + } + } + if {$f_new} { + #create a new interface + set iid_top [expr {$::p::ID + 1}] ;#PREDICT the next object's id + set iface [::p::>interface .. Create ::p::ifaces::>$iid_top $OID] + + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level0 [concat $interfaces $iid_top] + dict set MAP interfaces $extracted_sub_dict + + } + set IID $iid_top + + } + ################################################################################# + + set IID [::p::predator::get_possibly_new_open_interface $OID] + + #upvar 0 ::p::${IID}:: IFACE + + namespace upvar ::p::${IID}::_iface o_methods o_methods o_definition o_definition o_varspace o_varspace o_varspaces o_varspaces + + + #Interface proc + # examine the existing command-chain + set maxversion [::p::predator::method_chainhead $IID $method] + set headid [expr {$maxversion + 1}] + set THISNAME $method.$headid ;#first version will be $method.1 + + if {$method ni [dict keys $o_methods]} { + dict set o_methods $method [list arglist $arglist] + } + + #next_script will call to lower interface in iStack if we are $method.1 + set next [::p::predator::next_script $IID $method $THISNAME $_ID_] ;#last parameter is caller_ID_ + #puts ">!>>$THISNAME>>>>> next: '$next'<<<<<<" + + + #implement + #----------------------------------- + set processed [dict create {*}[::p::predator::expand_var_statements $bodydef $o_varspace]] + if {[llength [dict get $processed varspaces_with_explicit_vars]]} { + foreach vs [dict get $processed varspaces_with_explicit_vars] { + if {[string length $vs] && ($vs ni $o_varspaces)} { + lappend o_varspaces $vs + } + } + set body [dict get $processed body] + set varDecls "" + } else { + set varDecls [::p::predator::runtime_vardecls] ;#dynamic vardecls can access vars from all interfaces of invocant object. + set body $varDecls\n[dict get $processed body] + } + + + set body [::p::predator::wrap_script_in_apply_object_namespace $o_varspace $body $arglist] + + + + #set body [string map [::list @this@ "\[lindex \$_ID_ 0 3 \]" @next@ $next] $body\n] + set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata \] 3\]" @next@ $next] $body\n] + + #if {[string length $varDecls]} { + # puts stdout "\t---------------------------------------------------------------" + # puts stdout "\t----- efficiency warning - implicit var declarations used -----" + # puts stdout "\t-------- $object_command .. Method $method $arglist ---------" + # puts stdout "\t[string map [list \n \t\t\n] $body]" + # puts stdout "\t--------------------------" + #} + #invocants are stored as a nested dict in the Invocant Data parameter (_ID_) under the key 'i', and then the invocant_role + # while 'dict get $_ID_ i this' should always return a single invocant, all roles theoretically return a list of invocants fulfilling that position. + #(as specified by the @ operator during object conglomeration) + #set body [string map [::list @this@ "\[dict get \$_ID_ i this \]" @next@ $next] $body\n] + + #puts stdout "\t\t----------------------------" + #puts stdout "$body" + #puts stdout "\t\t----------------------------" + + proc ::p::${IID}::_iface::$THISNAME [concat _ID_ $arglist] $body + + #----------------------------------- + + #pointer from method-name to head of override-chain + interp alias {} ::p::${IID}::_iface::$method {} ::p::${IID}::_iface::$THISNAME + + + #point to the interface command only. The dispatcher will supply the invocant data + #interp alias {} ::p::${OID}::$method {} ::p::${IID}::_iface::$method + set argvals "" + foreach argspec $arglist { + if {[llength $argspec] == 2} { + set a [lindex $argspec 0] + } else { + set a $argspec + } + if {$a eq "args"} { + append argvals " \{*\}\$args" + } else { + append argvals " \$$a" + } + } + set argvals [string trimleft $argvals] + #this proc directly on the object is not *just* a forwarding proc + # - it provides a context in which the 'uplevel 1' from the running interface proc runs + #This (in 2018) is faster than a namespace alias forward to an interface proc which used apply to run in the dynamically calculated namespace (it seems the dynamic namespace stopped it from byte-compiling?) + + #we point to the method of the same name in the interface - which is an interp alias to the head of the implementation chain + + proc ::p::${OID}::$method [list _ID_ {*}$arglist] [subst { + ::p::${IID}::_iface::$method \$_ID_ $argvals + }] + + if 0 { + if {[llength $argvals]} { + proc ::p::${OID}::$method [list _ID_ {*}$arglist] [string map [list @ID@ [list $_ID_] @iid@ $IID @m@ $method @argl@ $arglist @argv@ $argvals] { + apply {{_ID_ @argl@} {::p::@iid@::_iface::@m@ $_ID_ @argl@}} @ID@ @argv@ + }] + } else { + + proc ::p::${OID}::$method [list _ID_ {*}$arglist] [string map [list @ID@ [list $_ID_] @iid@ $IID @m@ $method @argl@ $arglist] { + apply [list {_ID_ @argl@} {::p::@iid@::_iface::@m@ $_ID_ @argl@} [namespace current]] @ID@ + }] + + } + } + + + #proc ::p::${OID}::$method [list _ID_ {*}$arglist] [subst { + # ::p::${IID}::_iface::$method \$_ID_ $argvals + #}] + + #todo - for o_varspaces + #install ::p::${OID}::${varspace}::$method with interp alias from ::p::${OID}::$method + #- this should work correctly with the 'uplevel 1' procs in the interfaces + + + if {[string length $o_varspace]} { + if {[string match "::*" $o_varspace]} { + namespace eval $o_varspace {} + } else { + namespace eval ::p::${OID}::$o_varspace {} + } + } + + + #if the metainfo collection exists, update it. Don't worry if nonexistant as it will be created if needed. + set colMethods ::p::${OID}::_meta::>colMethods + + if {[namespace which $colMethods] ne ""} { + if {![$colMethods . hasKey $method]} { + $colMethods . add [::p::internals::predator $_ID_ . $method .] $method + } + } + + #::p::-1::update_invocant_aliases $_ID_ + return + #::>pattern .. Create [::>pattern .. Namespace]::>method_??? + #return $method_object +} + + +dict set ::p::-1::_iface::o_methods V {arglist {{glob *}}} +proc ::p::-1::V {_ID_ {glob *}} { + set invocants [dict get $_ID_ i] + #set invocant_alias [lindex [dict get $invocants this] 0] + #set invocant [lindex [interp alias {} $invocant_alias] 1] + + set OID [lindex [dict get $invocants this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + + lassign [dict get $MAP invocantdata] OID alias itemCmd cmd + set ifaces [dict get $MAP interfaces level0] ;#level 0 interfaces + + + + set vlist [list] + foreach IID $ifaces { + dict for {vname vdef} [set ::p::${IID}::_iface::o_variables] { + if {[string match $glob $vname]} { + lappend vlist $vname + } + } + } + return $vlist +} + +#experiment from http://wiki.tcl.tk/4884 +proc p::predator::pipeline {args} { + set lambda {return -level 0} + foreach arg $args { + set lambda [list apply [dict get { + toupper {{lambda input} {string toupper [{*}$lambda $input]}} + tolower {{lambda input} {string tolower [{*}$lambda $input]}} + totitle {{lambda input} {string totitle [{*}$lambda $input]}} + prefix {{lambda pre input} {string cat $pre [{*}$lambda $input]}} + suffix {{lambda suf input} {string cat [{*}$lambda $input] $suf}} + } [lindex $arg 0]] $lambda[set lambda {}] {*}[lrange $arg 1 end]] + } + return $lambda +} + +proc ::p::predator::get_apply_arg_0_oid {} { + set apply_args [lrange [info level 0] 2 end] + puts stderr ">>>>> apply_args:'$apply_args'<<<<" + set invocant [lindex $apply_args 0] + return [lindex [dict get $invocant i this] 0 0] +} +proc ::p::predator::get_oid {} { + #puts stderr "---->> [info level 1] <<-----" + set _ID_ [lindex [info level 1] 1] ;#something like ::p::17::_iface::method.1 {i {this { {16 ::p::16 item ::>thing {} } } }} arg1 arg2 + tailcall lindex [dict get $_ID_ i this] 0 0 +} + +#todo - make sure this is called for all script installations - e.g propertyread etc etc +#Add tests to check code runs in correct namespace +#review - how does 'Varspace' command affect this? +proc ::p::predator::wrap_script_in_apply_object_namespace {varspace body arglist} { + #use 'lindex $a 0' to make sure we only get the variable name. (arglist may have defaultvalues) + set arglist_apply "" + append arglist_apply "\$_ID_ " + foreach a $arglist { + if {$a eq "args"} { + append arglist_apply "{*}\$args" + } else { + append arglist_apply "\$[lindex $a 0] " + } + } + #!todo - allow fully qualified varspaces + if {[string length $varspace]} { + if {[string match ::* $varspace]} { + return "tailcall apply \[list \[list _ID_ $arglist\] \{$body\} $varspace \] $arglist_apply" + } else { + #return "uplevel 1 \[list apply \[list \[list _ID_ $arglist\] \{$body\} ::p::@OID@::$varspace \] $arglist_apply \]\n" + return "tailcall apply \[list \[list _ID_ $arglist\] \{$body\} ::p::@OID@::$varspace \] $arglist_apply" + } + } else { + #return "uplevel 1 \[list apply \[list \[list _ID_ $arglist\] \{$body\} ::p::@OID@ \] $arglist_apply \]\n" + #return "tailcall try \[list apply \[list \[list _ID_ $arglist\] \{$body\} ::p::@OID@ \] $arglist_apply \]" + + set script "tailcall apply \[list \{_ID_" + + if {[llength $arglist]} { + append script " $arglist" + } + append script "\} \{" + append script $body + append script "\} ::p::@OID@\] " + append script $arglist_apply + #puts stderr "\n88888888888888888888888888\n\t$script\n" + #puts stderr "\n77777777777777777777777777\n\ttailcall apply \[list \[list _ID_ $arglist\] \{$body\} ::p::@OID@ \] $arglist_apply" + #return $script + + + #----------------------------------------------------------------------------- + # 2018 candidates + # + #return "tailcall apply \[list \[list _ID_ $arglist\] \{$body\} ::p::@OID@ \] $arglist_apply" ;#ok - but doesn't seem to be bytecompiled + #return "tailcall apply \[list {_ID_ $arglist} {$body} ::p::@OID@ \] $arglist_apply" ;#ok - but doesn't seem to be bytecompiled + + #this has problems with @next@ arguments! (also script variables will possibly interfere with each other) + #faster though. + #return "uplevel 1 \{$body\}" + return "uplevel 1 [list $body]" + #----------------------------------------------------------------------------- + + #set script "apply \[list \[list _ID_ $arglist\] \{$body\}\] $arglist_apply" + #return "uplevel 1 \{$script\}" + + #return "puts stderr --\[info locals\]-- ;apply \[list {_ID_ $arglist} {$body} ::p::\[p::predator::get_oid\] \] $arglist_apply" ;#fail + #return "apply \[list {_ID_ $arglist} {$body} ::p::\[p::predator::get_oid\] \] $arglist_apply" ;#fail + + + + #return "tailcall apply { {_ID_ $arglist} {$body} ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\] } $arglist_apply" ;#wrong + + #return "tailcall apply \[list {_ID_ $arglist} {apply { {_ID_ $arglist} {$body}} $arglist_apply } ::p::@OID@ \] $arglist_apply" ;#wrong ns + + + #experiment with different dispatch mechanism (interp alias with 'namespace inscope') + #----------- + #return "apply { {_ID_ $arglist} {$body}} $arglist_apply" + + + #return "uplevel 1 \{$body\}" ;#do nothing + + #---------- + + #return "tailcall namespace inscope ::p::@OID@ \{apply \{\{_ID_ $arglist\} \{$body\}\}\} $arglist_apply" ;#wrong! doesn't evaluate in the correct namespace (wrong _ID_ ??) + + #return "tailcall apply \{\{_ID_ $arglist\} \{namespace inscope ::p::@OID@ \{$body\}\} \} $arglist_apply" ;#wrong - _ID_ now not available in $body + + #return "tailcall apply \{\{ns _ID_ $arglist\} \{ apply \[list {_ID_ $arglist} \{$body\} \$ns \] $arglist_apply \} \} ::p::@OID@ $arglist_apply" ;#no quicker + + #return "tailcall " + + } +} + + +#Handle 'var' and 'varspace' declarations in method/constructor/destructor/propertyread etc bodies. +#expand 'var' statements inline in method bodies +#The presence of a var statement in any code-branch will cause the processor to NOT insert the implicit default var statements. +# +#concept of 'varspace' to allow separation and/or sharing of contexts for cooperating interfaces +#WARNING: within methods etc, varspace statements affect all following var statements.. i.e varspace not affected by runtime code-branches! +# e.g if 1 {varspace x} else {varspace y} will always leave 'varspace y' in effect for following statements. +#Think of var & varspace statments as a form of compile-time 'macro' +# +#caters for 2-element lists as arguments to var statement to allow 'aliasing' +#e.g var o_thing {o_data mydata} +# this will upvar o_thing as o_thing & o_data as mydata +# +proc ::p::predator::expand_var_statements {rawbody {varspace ""}} { + set body {} + + #keep count of any explicit var statments per varspace in 'numDeclared' array + # don't initialise numDeclared. We use numDeclared keys to see which varspaces have var statements. + + #default varspace is "" + #varspace should only have leading :: if it is an absolute namespace path. + + + foreach ln [split $rawbody \n] { + set trimline [string trim $ln] + + if {$trimline eq "var"} { + #plain var statement alone indicates we don't have any explicit declarations in this branch + # and we don't want implicit declarations for the current varspace either. + #!todo - implement test + + incr numDeclared($varspace) + + #may be further var statements e.g - in other code branches + #return [list body $rawbody varspaces_with_explicit_vars 1] + } elseif {([string range $trimline 0 2] eq "var") && ([string is space [string index $trimline 3]])} { + + #append body " upvar #0 " + #append body " namespace upvar ::p::\[lindex \$_ID_ 0 0 \]${varspace} " + #append body " namespace upvar ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]${varspace} " + + if {$varspace eq ""} { + append body " namespace upvar ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\] " + } else { + if {[string match "::*" $varspace]} { + append body " namespace upvar $varspace " + } else { + append body " namespace upvar ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::${varspace} " + } + } + + #any whitespace before or betw var names doesn't matter - about to use as list. + foreach varspec [string range $trimline 4 end] { + lassign [concat $varspec $varspec] var alias ;#var == alias if varspec only 1 element. + ##append body "::p::\[lindex \$_ID_ 0 0 \]::${varspace}$var $alias " + #append body "::p::\[lindex \$_ID_ 0 0 \]${varspace}$var $alias " + + append body "$var $alias " + + } + append body \n + + incr numDeclared($varspace) + } elseif {([string range $trimline 0 7] eq "varspace") && ([string is space -strict [string index $trimline 8]])} { + # 2021 REVIEW - why do we even need 'varspace x' commands in bodies? - just use 'namespace eval x' ??? + #it is assumed there is a single word following the 'varspace' keyword. + set varspace [string trim [string range $trimline 9 end]] + + if {$varspace in [list {{}} {""}]} { + set varspace "" + } + if {[string length $varspace]} { + #set varspace ::${varspace}:: + #no need to initialize numDeclared($varspace) incr will work anyway. + #if {![info exists numDeclared($varspace)]} { + # set numDeclared($varspace) 0 + #} + + if {[string match "::*" $varspace]} { + append body "namespace eval $varspace {} \n" + } else { + append body "namespace eval ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::$varspace {} \n" + } + + #puts "!!!! here~! namespace eval ::p::\[lindex \$_ID_ 0 0\]$varspace {} " + #append body "namespace eval ::p::\[lindex \$_ID_ 0 0\]$varspace {} \n" + #append body "namespace eval ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]$varspace {} \n" + + #append body "puts \"varspace: created ns ::p::\[lindex \$_ID_ 0 0\]$varspace \"\n" + } + #!review - why? why do we need the magic 'default' name instead of just using the empty string? + #if varspace argument was empty string - leave it alone + } else { + append body $ln\n + } + } + + + + set varspaces [array names numDeclared] + return [list body $body varspaces_with_explicit_vars $varspaces] +} + + + + +#Interface Variables +dict set ::p::-1::_iface::o_methods IV {arglist {{glob *}}} +proc ::p::-1::IV {_ID_ {glob *}} { + set invocants [dict get $_ID_ i] + + set OID [lindex [dict get $invocants this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + lassign [dict get $MAP invocantdata] OID alias itemCmd cmd + set ifaces [dict get $MAP interfaces level0] ;#level 0 interfaces + + + #!todo - test + #return [dict keys ::p::${OID}::_iface::o_variables $glob] + + set members [list] + foreach vname [dict keys [set ::p::${OID}::_iface::o_variables]] { + if {[string match $glob $vname]} { + lappend members $vname + } + } + return $members +} + +dict set ::p::-1::_iface::o_methods MetaMethods {arglist {{glob *}}} +proc ::p::-1::MetaMethods {_ID_ {glob *}} { + upvar ::p::-1::_iface::o_methods metaface_methods + set metamethod_names [lsort [dict keys $metaface_methods]] + if {$glob ne "*"} { + set metamethod_names [lsearch -all -inline $metamethod_names $glob] + } + return $metamethod_names +} + + +dict set ::p::-1::_iface::o_methods Methods {arglist {{idx ""}}} +proc ::p::-1::Methods {_ID_ {idx ""}} { + set invocants [dict get $_ID_ i] + set this_invocant [lindex [dict get $invocants this] 0] + lassign $this_invocant OID _etc + #set map [dict get $this_info map] + set OID [lindex [dict get $_ID_ i this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + + + lassign [dict get $MAP invocantdata] OID alias itemCmd cmd + set ifaces [dict get $MAP interfaces level0] ;#level 0 interfaces + + set col ::p::${OID}::_meta::>colMethods + + if {[namespace which $col] eq ""} { + patternlib::>collection .. Create $col + foreach IID $ifaces { + foreach m [dict keys [set ::p::${IID}::_iface::o_methods]] { + if {![$col . hasIndex $m]} { + #todo - create some sort of lazy-evaluating method object? + #set arglist [dict get [set ::p::${IID}::iface::o_methods] $m arglist] + $col . add [::p::internals::predator $_ID_ . $m .] $m + } + } + } + } + if {[string length $idx]} { + return [$col . item $idx] + } else { + return $col + } +} + +dict set ::p::-1::_iface::o_methods M {arglist {{glob *}}} +proc ::p::-1::M {_ID_ {glob *}} { + set invocants [dict get $_ID_ i] + set this_invocant [lindex [dict get $invocants this] 0] + lassign $this_invocant OID _etc + #set map [dict get $this_info map] + set OID [lindex [dict get $_ID_ i this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + lassign [dict get $MAP invocantdata] OID alias itemCmd cmd + set ifaces [dict get $MAP interfaces level0] ;#level 0 interfaces + set members [list] + foreach IID $ifaces { + lappend members {*}[dict keys [set ::p::${IID}::_iface::o_methods] $glob] + } + return $members +} + +#PatternMethods +dict set ::p::-1::_iface::o_methods PM {arglist {{glob *}}} +proc ::p::-1::PM {_ID_ {glob *}} { + set invocants [dict get $_ID_ i] + set this_invocant [lindex [dict get $invocants this] 0] + lassign $this_invocant OID _etc + #set OID [lindex [dict get $_ID_ i this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + #lassign [dict get $MAP invocantdata] OID alias itemCmd cmd + set ifaces [dict get $MAP interfaces level1] ;#level 1 interfaces + set members [list] + foreach IID $ifaces { + lappend members {*}[dict keys [set ::p::${IID}::_iface::o_methods] $glob] + } + return [lsort $members] +} + + +#review +#Interface Methods +dict set ::p::-1::_iface::o_methods IM {arglist {{glob *}}} +proc ::p::-1::IM {_ID_ {glob *}} { + set invocants [dict get $_ID_ i] + set this_invocant [lindex [dict get $invocants this] 0] + lassign $this_invocant OID _etc + #set map [dict get $this_info map] + set OID [lindex [dict get $_ID_ i this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + + lassign [dict get $MAP invocantdata] OID alias itemCmd cmd + set ifaces [dict get $MAP interfaces level0] ;#level 0 interfaces + + return [dict keys [set ::p::${OID}::_iface::o_methods] $glob] + +} + + + +dict set ::p::-1::_iface::o_methods InterfaceStacks {arglist {}} +proc ::p::-1::InterfaceStacks {_ID_} { + upvar #0 ::p::[lindex [dict get $_ID_ i this] 0 0]::_meta::map MAP + return [dict get $MAP interfaces level0] +} + + +dict set ::p::-1::_iface::o_methods PatternStacks {arglist {}} +proc ::p::-1::PatternStacks {_ID_} { + set OID [lindex [dict get $_ID_ i this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + return [dict get $MAP interfaces level1] +} + + +#!todo fix. need to account for references which were never set to a value +dict set ::p::-1::_iface::o_methods DeletePropertyReferences {arglist {}} +proc ::p::-1::DeletePropertyReferences {_ID_} { + set OID [lindex [dict get $_ID_ i this] 0 0] + set cleared_references [list] + set refvars [info vars ::p::${OID}::_ref::*] + #unsetting vars will clear traces anyway - but we wish to avoid triggering the 'unset' traces - so we will explicitly remove all traces 1st. + foreach rv $refvars { + foreach tinfo [trace info variable $rv] { + set ops {}; set cmd {} + lassign $tinfo ops cmd + trace remove variable $rv $ops $cmd + } + unset $rv + lappend cleared_references $rv + } + + + return [list deleted_property_references $cleared_references] +} + +dict set ::p::-1::_iface::o_methods DeleteMethodReferences {arglist {}} +proc ::p::-1::DeleteMethodReferences {_ID_} { + set OID [lindex [dict get $_ID_ i this] 0 0] + set cleared_references [list] + + set iflist [dict get $MAP interfaces level0] + set iflist_reverse [lreferse $iflist] + #set iflist [dict get $MAP interfaces level0] + + + set refcommands [info commands ::p::${OID}::_ref::*] + foreach c $refcommands { + set reftail [namespace tail $c] + set field [lindex [split $c +] 0] + set field_is_a_method 0 + foreach IFID $iflist_reverse { + if {$field in [dict keys [set ::p::${IFID}::_iface::o_methods]]} { + set field_is_a_method 1 + break + } + } + if {$field_is_a_method} { + #what if it's also a property? + interp alias {} $c {} + lappend cleared_references $c + } + } + + + return [list deleted_method_references $cleared_references] +} + + +dict set ::p::-1::_iface::o_methods DeleteReferences {arglist {}} +proc ::p::-1::DeleteReferences {_ID_} { + set OID [lindex [dict get $_ID_ i this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + lassign [dict get $MAP invocantdata] OID alias default_method this + + set result [dict create] + dict set result {*}[$this .. DeletePropertyReferences] + dict set result {*}[$this .. DeleteMethodReferences] + + return $result +} + +## +#Digest +# +#!todo - review +# -> a variable containing empty string is the same as a non existant variable as far as digest is concerned.. is that bad? (probably!) +# +#!todo - write tests - check that digest changes when properties of contained objects change value +# +#!todo - include method/property/interfaces in digest calc, or provide a separate more comprehensive digest method? +# +dict set ::p::-1::_iface::o_methods Digest {arglist {args}} +proc ::p::-1::Digest {_ID_ args} { + set invocants [dict get $_ID_ i] + # md5 c-version is faster than md4 tcl version... and more likely to be required in the interp for some other purpose anyway. + #set this_invocant [lindex [dict get $invocants this] 0] + #lassign $this_invocant OID _etc + set OID [lindex [dict get $_ID_ i this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + lassign [dict get $MAP invocantdata] _OID alias default_method this + + + set interface_ids [dict get $MAP interfaces level0] + set IFID0 [lindex $interface_ids end] + + set known_flags {-recursive -algorithm -a -indent} + set defaults {-recursive 1 -algorithm md5 -indent ""} + if {[dict exists $args -a] && ![dict exists $args -algorithm]} { + dict set args -algorithm [dict get $args -a] + } + + set opts [dict merge $defaults $args] + foreach key [dict keys $opts] { + if {$key ni $known_flags} { + error "unknown option $key. Expected only: $known_flags" + } + } + + set known_algos {"" raw RAW none NONE md5 MD5 sha256 SHA256} + if {[dict get $opts -algorithm] ni $known_algos} { + error "call to Digest with unknown -algorithm [dict get $opts -algorithm]. Expected one of: $known_algos" + } + set algo [string tolower [dict get $opts -algorithm]] + + # append comma for each var so that all changes in adjacent vars detectable. + # i.e set x 34; set y 5 + # must be distinguishable from: + # set x 3; set y 45 + + if {[dict get $opts -indent] ne ""} { + set state "" + set indent "[dict get $opts -indent]" + } else { + set state "---\n" + set indent " " + } + append state "${indent}object_command: $this\n" + set indent "${indent} " + + #append state "[lindex [interp alias {} $alias] 1]\n" ;#at the very least, include the object's interface state. + append state "${indent}interfaces: [dict get $MAP interfaces]\n";#at the very least, include the object's interface state. + + + #!todo - recurse into 'varspaces' + set varspaces_found [list] + append state "${indent}interfaces:\n" + foreach IID $interface_ids { + append state "${indent} - interface: $IID\n" + namespace upvar ::p::${IID}::_iface o_varspace local_o_varspace o_varspaces local_o_varspaces + append state "${indent} varspaces:\n" + foreach vs $local_o_varspaces { + if {$vs ni $varspaces_found} { + lappend varspaces_found $vs + append state "${indent} - varspace: $vs\n" + } + } + } + + append state "${indent}vars:\n" + foreach var [info vars ::p::${OID}::*] { + append state "${indent} - [namespace tail $var] : \"" + if {[catch {append state "[set $var]"}]} { + append state "[array get $var]" + } + append state "\"\n" + } + + if {[dict get $opts -recursive]} { + append state "${indent}sub-objects:\n" + set subargs $args + dict set subargs -indent "$indent " + foreach obj [info commands ::p::${OID}::>*] { + append state "[$obj .. Digest {*}$subargs]\n" + } + + append state "${indent}sub-namespaces:\n" + set subargs $args + dict set subargs -indent "$indent " + foreach ns [namespace children ::p::${OID}] { + append state "${indent} - namespace: $ns\n" + foreach obj [info commands ${ns}::>*] { + append state "[$obj .. Digest {*}$subargs]\n" + } + } + } + + if {$algo in {"" raw none}} { + return $state + } else { + if {$algo eq "md5"} { + package require md5 + return [::md5::md5 -hex $state] + } elseif {$algo eq "sha256"} { + package require sha256 + return [::sha2::sha256 -hex $state] + } elseif {$algo eq "blowfish"} { + package require patterncipher + patterncipher::>blowfish .. Create >b1 + set [>b1 . key .] 12341234 + >b1 . encrypt $state -final 1 + set result [>b1 . ciphertext] + >b1 .. Destroy + + } elseif {$algo eq "blowfish-binary"} { + + } else { + error "can't get here" + } + + } +} + + +dict set ::p::-1::_iface::o_methods Variable {arglist {varname args}} +proc ::p::-1::Variable {_ID_ varname args} { + set invocants [dict get $_ID_ i] + + #set invocant_alias [lindex [dict get $invocants this] 0] + #set invocant [lindex [interp alias {} $invocant_alias] 1] + + set OID [lindex [dict get $invocants this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + #this interface itself is always a co-invocant + lassign [dict get $MAP invocantdata] OID alias itemCmd cmd + set interfaces [dict get $MAP interfaces level0] + + #set existing_IID [lindex $map 1 0 end] + set existing_IID [lindex $interfaces end] + + set prev_openstate [set ::p::${existing_IID}::_iface::o_open] + + if {$existing_IID != [set IID [::p::internals::expand_interface $existing_IID]]} { + #IID changed + #remove ourself from the usedby list of the previous interface + array unset ::p::${existing_IID}::_iface::o_usedby i$OID + set ::p::${IID}::_iface::o_usedby(i$OID) $cmd + + set posn [lsearch $interfaces $existing_IID] + + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level0 [concat [lreplace $interfaces $posn $posn] $IID] + dict set MAP interfaces $extracted_sub_dict + #lset map {1 0} [concat [lreplace $interfaces $posn $posn] $IID] + + + #update original object command + set ::p::${IID}::_iface::o_open 0 + } else { + set ::p::${IID}::_iface::o_open $prev_openstate + } + + set varspace [set ::p::${IID}::_iface::o_varspace] ;#varspace at the time this Variable was added (may differ from default for interface) + + if {[llength $args]} { + #!assume var not already present on interface - it is an error to define twice (?) + #lappend ::p::${IID}::_iface::o_variables [list $varname [lindex $args 0]] + dict set ::p::${IID}::_iface::o_variables $varname [list default [lindex $args 0] varspace $varspace] + + + #Implement if there is a default + #!todo - correct behaviour when overlaying on existing object with existing var of this name? + #if {[string length $varspace]} { + # set ::p::${OID}::${varspace}::$varname [lindex $args 0] + #} else { + set ::p::${OID}::$varname [lindex $args 0] + #} + } else { + #lappend ::p::${IID}::_iface::o_variables [list $varname] + dict set ::p::${IID}::_iface::o_variables $varname [list varspace $varspace] + } + + #varspace '_iface' + + return +} + + +#interp alias {} ::p::-1::variable {} ::p::-1::PatternVariable ;#for Define compatibility + +dict set ::p::-1::_iface::o_methods PatternVariable {arglist {varname args}} +proc ::p::-1::PatternVariable {_ID_ varname args} { + set invocants [dict get $_ID_ i] + + #set invocant_alias [lindex [dict get $invocants this] 0] + #set invocant [lindex [interp alias {} $invocant_alias] 1] + ##this interface itself is always a co-invocant + #lassign [lindex $invocant 0 ] OID alias itemCmd cmd + + set OID [lindex [dict get $invocants this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + + + + set patterns [dict get $MAP interfaces level1] + set iid_top [lindex $patterns end] ;#!todo - get 'open' interface. + set iface ::p::ifaces::>$iid_top + + if {(![string length $iid_top]) || ([$iface . isClosed])} { + #no existing pattern - create a new interface + set iid_top [expr {$::p::ID + 1}] ;#PREDICT the next object's id + set iface [::p::>interface .. Create ::p::ifaces::>$iid_top $OID] + + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level1 [concat $patterns $iid_top] + dict set MAP interfaces $extracted_sub_dict + #lset map {1 1} [concat $patterns $iid_top] + } + set IID $iid_top + + set varspace [set ::p::${IID}::_iface::o_varspace] ;#record varspace against each variable, because default varspace for interface can be modified. + + + if {[llength $args]} { + #lappend ::p::${IID}::_iface::o_variables [list $varname [lindex $args 0]] + dict set ::p::${IID}::_iface::o_variables $varname [list default [lindex $args 0] varspace $varspace] + } else { + dict set ::p::${IID}::_iface::o_variables $varname [list varspace $varspace] + } + + return +} + +dict set ::p::-1::_iface::o_methods Varspaces {arglist args} +proc ::p::-1::Varspaces {_ID_ args} { + set invocants [dict get $_ID_ i] + set OID [lindex [dict get $_ID_ i this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + + if {![llength $args]} { + #query + set iid_top [lindex [dict get $MAP interfaces level0] end] + set iface ::p::ifaces::>$iid_top + if {![string length $iid_top]} { + error "Cannot query Varspaces because no top level interface on object:[lindex [dict get $MAP invocantdata] 3] " + } elseif {[$iface . isClosed]} { + error "Cannot query Varspaces because top level interface (id:$iid_top) is closed on object:[lindex [dict get $MAP invocantdata] 3] " + } + return [set ::p::${iid_top}::_iface::o_varspaces] + } + set IID [::p::predator::get_possibly_new_open_interface $OID] + namespace upvar ::p::${IID}::_iface o_varspace o_varspace o_varspaces o_varspaces + + set varspaces $args + foreach vs $varspaces { + if {[string length $vs] && ($vs ni $o_varspaces)} { + if {[string match ::* $vs]} { + namespace eval $vs {} + } else { + namespace eval ::p::${OID}::$vs {} + } + lappend o_varspaces $vs + } + } + return $o_varspaces +} + +#set or query Varspace. Error to query a closed interface, but if interface closed when writing, itwill create a new open interface +dict set ::p::-1::_iface::o_methods Varspace {arglist args} +# set the default varspace for the interface, so that new methods/properties refer to it. +# varspace may be switched in between various additions of methods/properties so that different methods/properties are using different varspaces. +proc ::p::-1::Varspace {_ID_ args} { + set OID [::p::obj_get_this_oid $_ID_] + ::p::map $OID MAP + + if {![llength $args]} { + #query + set iid_top [lindex [dict get $MAP interfaces level0] end] + set iface ::p::ifaces::>$iid_top + if {![string length $iid_top]} { + error "Cannot query Varspace because no top level interface on object:[lindex [dict get $MAP invocantdata] 3] " + } elseif {[$iface . isClosed]} { + error "Cannot query Varspace because top level interface (id:$iid_top) is closed on object:[lindex [dict get $MAP invocantdata] 3] " + } + return [set ::p::${iid_top}::_iface::o_varspace] + } + set varspace [lindex $args 0] + + #set interfaces [dict get $MAP interfaces level0] + #set iid_top [lindex $interfaces end] + + set IID [::p::predator::get_possibly_new_open_interface $OID] + + + #namespace upvar ::p::${IID}::_iface o_variables o_variables o_properties o_properties o_methods o_methods o_varspace o_varspace + namespace upvar ::p::${IID}::_iface o_varspace o_varspace o_varspaces o_varspaces + + if {[string length $varspace]} { + #ensure namespace exists !? do after list test? + if {[string match ::* $varspace]} { + namespace eval $varspace {} + } else { + namespace eval ::p::${OID}::$varspace {} + } + if {$varspace ni $o_varspaces} { + lappend o_varspaces $varspace + } + } + set o_varspace $varspace +} + + +proc ::p::predator::get_possibly_new_open_interface {OID} { + #we need to re-upvar MAP rather than using a parameter - as we need to write back to it + upvar #0 ::p::${OID}::_meta::map MAP + set interfaces [dict get $MAP interfaces level0] + set iid_top [lindex $interfaces end] + + + set iface ::p::ifaces::>$iid_top + if {(![string length $iid_top]) || ([$iface . isClosed])} { + #no existing pattern - create a new interface + set iid_top [expr {$::p::ID + 1}] ;#PREDICT the next object's id + #puts stderr ">>>>creating new interface $iid_top" + set iface [::p::>interface .. Create ::p::ifaces::>$iid_top $OID] + + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level0 [concat $interfaces $iid_top] + dict set MAP interfaces $extracted_sub_dict + } + + return $iid_top +} + + + + + + + + + + +################################################################################################################################################### + +################################################################################################################################################### +dict set ::p::-1::_iface::o_methods PatternVarspace {arglist {varspace args}} +# set the default varspace for the interface, so that new methods/properties refer to it. +# varspace may be switched in between various additions of methods/properties so that different methods/properties are using different varspaces. +proc ::p::-1::PatternVarspace {_ID_ varspace args} { + set invocants [dict get $_ID_ i] + set OID [lindex [dict get $_ID_ i this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + + set patterns [dict get $MAP interfaces level1] + set iid_top [lindex $patterns end] + + set iface ::p::ifaces::>$iid_top + if {(![string length $iid_top]) || ([$iface . isClosed])} { + #no existing pattern - create a new interface + set iid_top [expr {$::p::ID + 1}] ;#PREDICT the next object's id + set iface [::p::>interface .. Create ::p::ifaces::>$iid_top $OID] + + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level1 [concat $patterns $iid_top] + dict set MAP interfaces $extracted_sub_dict + } + set IID $iid_top + + namespace upvar ::p::${IID}::_iface o_varspace o_varspace o_varspaces o_varspaces + if {[string length $varspace]} { + if {$varspace ni $o_varspaces} { + lappend o_varspaces $varspace + } + } + #o_varspace is the currently active varspace + set o_varspace $varspace +} +################################################################################################################################################### + +#get varspace and default from highest interface - return all interface ids which define it +dict set ::p::-1::_iface::o_methods GetPropertyInfo {arglist {{propnamepattern *}}} +proc ::p::-1::GetPropertyInfo {_ID_ {propnamepattern *}} { + set OID [lindex [dict get $_ID_ i this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + set interfaces [dict get $MAP interfaces level0] + + array set propinfo {} + set found_property_names [list] + #start at the lowest and work up (normal storage order of $interfaces) + foreach iid $interfaces { + set propinfodict [set ::p::${iid}::_iface::o_properties] + set matching_propnames [dict keys $propinfodict $propnamepattern] + foreach propname $matching_propnames { + if {$propname ni $found_property_names} { + lappend found_property_names $propname + } + lappend propinfo($propname,interfaces) $iid + ;#These 2 values for this $propname are overwritten for each iid in the outer loop - we are only interested in the last one + if {[dict exists $propinfodict $propname default]} { + set propinfo($propname,default) [dict get $propinfodict $propname default] + } + set propinfo($propname,varspace) [dict get $propinfodict $propname varspace] + } + } + + set resultdict [dict create] + foreach propname $found_property_names { + set fields [list varspace $propinfo($propname,varspace)] + if {[array exists propinfo($propname,default)]} { + lappend fields default [set propinfo($propname,default)] + } + lappend fields interfaces $propinfo($propname,interfaces) + dict set resultdict $propname $fields + } + return $resultdict +} + + +dict set ::p::-1::_iface::o_methods GetTopPattern {arglist args} +proc ::p::-1::GetTopPattern {_ID_ args} { + set OID [::p::obj_get_this_oid $_ID_] + ::p::map $OID MAP + + set interfaces [dict get $MAP interfaces level1] + set iid_top [lindex $interfaces end] + if {![string length $iid_top]} { + lassign [dict get $MAP invocantdata] OID _alias _default_method object_command + error "No installed level1 interfaces (patterns) for object $object_command" + } + return ::p::ifaces::>$iid_top +} + + + +dict set ::p::-1::_iface::o_methods GetTopInterface {arglist args} +proc ::p::-1::GetTopInterface {_ID_ args} { + set OID [::p::obj_get_this_oid $_ID_] + ::p::map $OID MAP + + set iid_top [lindex [dict get $MAP interfaces level0] end] + if {![string length $iid_top]} { + lassign [dict get $MAP invocantdata] OID _alias _default_method object_command + error "No installed level0 interfaces for object $object_command" + } + return ::p::ifaces::>$iid_top +} + + +dict set ::p::-1::_iface::o_methods GetExpandableInterface {arglist args} +proc ::p::-1::GetExpandableInterface {_ID_ args} { + +} + + + + + +################################################################################################################################################### + +################################################################################################################################################### +dict set ::p::-1::_iface::o_methods Property {arglist {property args}} +proc ::p::-1::Property {_ID_ property args} { + #puts stderr "::p::-1::Property called with _ID_: '$_ID_' property:$property args:$args" + #set invocants [dict get $_ID_ i] + #set invocant_roles [dict keys $invocants] + if {[llength $args] > 1} { + error ".. Property expects 1 or 2 arguments only. (>object .. Property propertyname ?default?)" + } + set OID [::p::obj_get_this_oid $_ID_] + ::p::map $OID MAP + + set interfaces [dict get $MAP interfaces level0] + set iid_top [lindex $interfaces end] + + set prev_openstate [set ::p::${iid_top}::_iface::o_open] + + set iface ::p::ifaces::>$iid_top + + + if {(![string length $iid_top]) || ([$iface . isClosed])} { + #create a new interface + set iid_top [expr {$::p::ID + 1}] ;#PREDICT the next object's id + set iface [::p::>interface .. Create ::p::ifaces::>$iid_top $OID] + + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level0 [concat $interfaces $iid_top] + dict set MAP interfaces $extracted_sub_dict + } + set IID $iid_top + + + namespace upvar ::p::${IID}::_iface o_variables o_variables o_properties o_properties o_methods o_methods o_varspace o_varspace + + + set maxversion [::p::predator::method_chainhead $IID (GET)$property] + set headid [expr {$maxversion + 1}] + set THISNAME (GET)$property.$headid ;#first version will be (GET)$property.1 + + + if {$headid == 1} { + #implementation + #interp alias {} ::p::${IID}::_iface::(GET)$property.1 {} ::p::predator::getprop $property + + #if {$o_varspace eq ""} { + # set ns ::p::${OID} + #} else { + # if {[string match "::*" $o_varspace]} { + # set ns $o_varspace + # } else { + # set ns ::p::${OID}::$o_varspace + # } + #} + #proc ::p::${IID}::_iface::(GET)$property.1 {_ID_ args} [string map [list %prop% $property %varspace% $o_varspace %ns% $ns] [info body ::p::predator::getprop_template_immediate]] + + proc ::p::${IID}::_iface::(GET)$property.1 {_ID_ args} [string map [list %prop% $property %varspace% $o_varspace ] [info body ::p::predator::getprop_template]] + + + #interp alias {} ::p::${IID}::_iface::(SET)$property.1 {} ::p::predator::setprop $property + proc ::p::${IID}::_iface::(SET)$property.1 {_ID_ args} [string map [list %prop% $property %varspace% $o_varspace] [info body ::p::predator::setprop_template]] + + + #chainhead pointers + interp alias {} ::p::${IID}::_iface::(GET)$property {} ::p::${IID}::_iface::(GET)$property.1 + interp alias {} ::p::${IID}::_iface::(SET)$property {} ::p::${IID}::_iface::(SET)$property.1 + + + } + + if {($property ni [dict keys $o_methods])} { + interp alias {} ::p::${IID}::_iface::$property {} ::p::${IID}::_iface::(GET)$property + } + + + + #installation on object + + #namespace eval ::p::${OID} [list namespace export $property] + + + + #obsolete? + #if {$property ni [P $_ID_]} { + #only link objects (GET)/(SET) for this property if property not present on any of our other interfaces + #interp alias {} ::p::${OID}::(GET)$property {} ::p::${IID}::_iface::(GET)$property $invocant + #interp alias {} ::p::${OID}::(SET)$property {} ::p::${IID}::_iface::(SET)$property $invocant + #} + + #link main (GET)/(SET) to this interface + interp alias {} ::p::${OID}::(GET)$property {} ::p::${IID}::_iface::(GET)$property + interp alias {} ::p::${OID}::(SET)$property {} ::p::${IID}::_iface::(SET)$property + + #Only install property if no method of same name already installed here. + #(Method takes precedence over property because property always accessible via 'set' reference) + #convenience pointer to chainhead pointer. + if {$property ni [M $_ID_]} { + interp alias {} ::p::${OID}::$property {} ::p::${IID}::_iface::(GET)$property + } else { + #property with same name as method - we need to make sure the refMisuse_traceHandler is fixed + + + } + + + set varspace [set ::p::${IID}::_iface::o_varspace] + + + + #Install the matching Variable + #!todo - which should take preference if Variable also given a default? + #if {[set posn [lsearch -index 0 $o_variables o_$property]] >= 0} { + # set o_variables [lreplace $o_variables $posn $posn o_$property] + #} else { + # lappend o_variables [list o_$property] + #} + dict set o_variables o_$property [list varspace $varspace] + + + + + if {[llength $args]} { + #should store default once only! + #set IFINFO(v,default,o_$property) $default + + set default [lindex $args end] + + dict set o_properties $property [list default $default varspace $varspace] + + #if {[set posn [lsearch -index 0 $o_properties $property]] >= 0} { + # set o_properties [lreplace $o_properties $posn $posn [list $property $default]] + #} else { + # lappend o_properties [list $property $default] + #} + + if {$varspace eq ""} { + set ns ::p::${OID} + } else { + if {[string match "::*" $varspace]} { + set ns $varspace + } else { + set ns ::p::${OID}::$o_varspace + } + } + + set ${ns}::o_$property $default + #set ::p::${OID}::o_$property $default + } else { + + #if {[set posn [lsearch -index 0 $o_properties $property]] >= 0} { + # set o_properties [lreplace $o_properties $posn $posn [list $property]] + #} else { + # lappend o_properties [list $property] + #} + dict set o_properties $property [list varspace $varspace] + + + #variable ::p::${OID}::o_$property + } + + + + + + #if the metainfo collection exists, update it. Don't worry if nonexistant as it will be created if needed. + #!todo - mark interface dirty (not ready?) instead? - would need all colProperties methods to respect dirty flag & synchronize as needed. (object filter?) + #catch {::p::OBJECT::${OID}::colProperties add [::p::internals::predator $invocant . $property .] $property} + + set colProperties ::p::${OID}::_meta::>colProperties + if {[namespace which $colProperties] ne ""} { + if {![$colProperties . hasKey $property]} { + $colProperties . add [::p::internals::predator $_ID_ . $property .] $property + } + } + + return +} +################################################################################################################################################### + + + +################################################################################################################################################### + +################################################################################################################################################### +interp alias {} ::p::-1::option {} ::p::-1::PatternProperty ;#for Define compatibility +dict set ::p::-1::_iface::o_methods PatternProperty {arglist {property args}} +proc ::p::-1::PatternProperty {_ID_ property args} { + set OID [::p::obj_get_this_oid $_ID_] + ::p::map $OID MAP + + set patterns [dict get $MAP interfaces level1] + set iid_top [lindex $patterns end] + + set iface ::p::ifaces::>$iid_top + + if {(![string length $iid_top]) || ([$iface . isClosed])} { + set iid_top [expr {$::p::ID + 1}] ;#PREDICT the next object's id + set iface [::p::>interface .. Create ::p::ifaces::>$iid_top $OID] + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level1 [concat $patterns $iid_top] + dict set MAP interfaces $extracted_sub_dict + #lset map {1 1} [concat $patterns $iid_top] + } + set IID $iid_top + + namespace upvar ::p::${IID}::_iface o_properties o_properties o_variables o_variables o_varspace o_varspace + + + set maxversion [::p::predator::method_chainhead $IID (GET)$property] + set headid [expr {$maxversion + 1}] + set THISNAME (GET)$property.$headid ;#first version will be (GET)$property.1 + + + + if {$headid == 1} { + #implementation + #interp alias {} ::p::${IID}::_iface::(GET)$property.1 {} ::p::predator::getprop $property + proc ::p::${IID}::_iface::(GET)$property.1 {_ID_ args} [string map [list %prop% $property %varspace% $o_varspace] [info body ::p::predator::getprop_template]] + #interp alias {} ::p::${IID}::_iface::(SET)$property.1 {} ::p::predator::setprop $property + proc ::p::${IID}::_iface::(SET)$property.1 {_ID_ args} [string map [list %prop% $property %varspace% $o_varspace] [info body ::p::predator::setprop_template]] + + + #chainhead pointers + interp alias {} ::p::${IID}::_iface::(GET)$property {} ::p::${IID}::_iface::(GET)$property.1 + interp alias {} ::p::${IID}::_iface::(SET)$property {} ::p::${IID}::_iface::(SET)$property.1 + + } + + if {($property ni [dict keys [set ::p::${IID}::_iface::o_methods]])} { + interp alias {} ::p::${IID}::_iface::$property {} ::p::${IID}::_iface::(GET)$property + } + + set varspace [set ::p::${IID}::_iface::o_varspace] + + #Install the matching Variable + #!todo - which should take preference if Variable also given a default? + #if {[set posn [lsearch -index 0 $o_variables o_$property]] >= 0} { + # set o_variables [lreplace $o_variables $posn $posn o_$property] + #} else { + # lappend o_variables [list o_$property] + #} + dict set o_variables o_$property [list varspace $varspace] + + set argc [llength $args] + + if {$argc} { + if {$argc == 1} { + set default [lindex $args 0] + dict set o_properties $property [list default $default varspace $varspace] + } else { + #if more than one arg - treat as a dict of options. + if {[dict exists $args -default]} { + set default [dict get $args -default] + dict set o_properties $property [list default $default varspace $varspace] + } else { + #no default value + dict set o_properties $property [list varspace $varspace] + } + } + #! only set default for property... not underlying variable. + #lappend ::p::${IID}::_iface::o_variables [list o_$property [lindex $args 0]] + } else { + dict set o_properties $property [list varspace $varspace] + } + return +} +################################################################################################################################################### + + + + + + + + + + + + + + + + + +################################################################################################################################################### + +################################################################################################################################################### +dict set ::p::-1::_iface::o_methods PatternPropertyRead {arglist {property args}} +proc ::p::-1::PatternPropertyRead {_ID_ property args} { + set invocants [dict get $_ID_ i] + + set this_invocant [lindex [dict get $_ID_ i this] 0] ;#assume only one 'this' + set OID [lindex $this_invocant 0] + #set OID [lindex [dict get $_ID_ i this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + lassign [dict get $MAP invocantdata] OID alias defaut_command cmd + + set patterns [dict get $MAP interfaces level1] + set existing_IID [lindex $patterns end] + + set idxlist [::list] + if {[llength $args] == 1} { + set body [lindex $args 0] + } elseif {[llength $args] == 2} { + lassign $args idxlist body + } else { + error "wrong # args: should be \"property body\" or \"property idxlist body\"" + } + + + if {$existing_IID != [set IID [::p::internals::expand_interface $existing_IID]]} { + #remove ourself from the usedby list of the previous interface + array unset ::p::${existing_IID}::_iface::o_usedby i$OID + set ::p::${IID}::_iface::o_usedby(i$OID) $cmd + + set posn [lsearch $patterns $existing_IID] + + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level1 [concat [lreplace $patterns $posn $posn] $IID] + dict set MAP interfaces $extracted_sub_dict + #lset map {1 1} [concat [lreplace $patterns $posn $posn] $IID] + + } else { + set prev_open [set ::p::${existing_IID}::_iface::o_open] + set ::p::${IID}::_iface::o_open $prev_open + } + + namespace upvar ::p::${IID}::_iface o_varspaces o_varspaces o_varspace o_varspace + + set maxversion [::p::predator::method_chainhead $IID (GET)$property] + set headid [expr {$maxversion + 1}] + if {$headid == 1} { + set headid 2 ;#reserve 1 for the getprop of the underlying property + } + + set THISNAME (GET)$property.$headid ;#first version will be (GET)$property.1 + set next [::p::predator::next_script $IID (GET)$property $THISNAME $_ID_] ;#last parameter is caller_ID_ + + + #implement + #----------------------------------- + + + set processed [dict create {*}[::p::predator::expand_var_statements $body $o_varspace]] + if {[llength [dict get $processed varspaces_with_explicit_vars]]} { + foreach vs [dict get $processed varspaces_with_explicit_vars] { + if {[string length $vs] && ($vs ni $o_varspaces)} { + lappend o_varspaces $vs + } + } + set body [dict get $processed body] + } else { + + set varDecls [::p::predator::runtime_vardecls] ;#dynamic vardecls can access vars from all interfaces of invocant object. + set body $varDecls[dict get $processed body] + } + #set body [string map [::list @this@ "\[lindex \$_ID_ 0 3 \]" @next@ $next] $body\n] + set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata \] 3\]" @next@ $next] $body\n] + + + #implementation + if {![llength $idxlist]} { + proc ::p::${IID}::_iface::(GET)$property.$headid {_ID_ args} $body + } else { + #what are we trying to achieve here? .. + proc ::p::${IID}::_iface::(GET)$property.$headid [linsert $idxlist 0 _ID_] $body + } + + + #----------------------------------- + + + #adjust chain-head pointer to point to new head. + interp alias {} ::p::${IID}::_iface::(GET)$property {} ::p::${IID}::_iface::(GET)$property.$headid + + return +} +################################################################################################################################################### + + + + + + + + + + + + +################################################################################################################################################### + +################################################################################################################################################### +dict set ::p::-1::_iface::o_methods PropertyRead {arglist {property args}} +proc ::p::-1::PropertyRead {_ID_ property args} { + set OID [::p::obj_get_this_oid $_ID_] + ::p::map $OID MAP + + #assert $OID ne "null" - dispatcher won't call PropertyRead on a non-object(?) (presumably the call would be to 'Method' instead) + lassign [dict get $MAP invocantdata] OID alias default_command cmd + + set interfaces [dict get $MAP interfaces level0] + set existing_IID [lindex $interfaces end] + + + set idxlist [::list] + if {[llength $args] == 1} { + set body [lindex $args 0] + } elseif {[llength $args] == 2} { + lassign $args idxlist body + } else { + error "wrong # args: should be \"property body\" or \"property idxlist body\"" + } + + + if {$existing_IID != [set IID [::p::internals::expand_interface $existing_IID]]} { + #remove ourself from the usedby list of the previous interface + array unset ::p::${existing_IID}::_iface::o_usedby i$OID + set ::p::${IID}::_iface::o_usedby(i$OID) $cmd + + set posn [lsearch $interfaces $existing_IID] + + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level0 [concat [lreplace $interfaces $posn $posn] $IID] + dict set MAP interfaces $extracted_sub_dict + + set ::p::${IID}::_iface::o_open 0 + } else { + set prev_open [set ::p::${existing_IID}::_iface::o_open] + set ::p::${IID}::_iface::o_open $prev_open + } + namespace upvar ::p::${IID}::_iface o_varspaces o_varspaces o_varspace o_varspace + + #array set ::p::${IID}:: [::list pr,body,$property $body pr,arg,$property $idxlist pr,name,$property $property pr,iface,$property $cmd] + + + set maxversion [::p::predator::method_chainhead $IID (GET)$property] + set headid [expr {$maxversion + 1}] + if {$headid == 1} { + set headid 2 + } + set THISNAME (GET)$property.$headid ;#first version will be (GET)$property.2 - even if corresponding property is missing (we reserve $property.1 for the property itself) + + set next [::p::predator::next_script $IID (GET)$property $THISNAME $_ID_] + + #implement + #----------------------------------- + + set processed [dict create {*}[::p::predator::expand_var_statements $body $o_varspace]] + if {[llength [dict get $processed varspaces_with_explicit_vars]]} { + foreach vs [dict get $processed varspaces_with_explicit_vars] { + if {[string length $vs] && ($vs ni $o_varspaces)} { + lappend o_varspaces $vs + } + } + set body [dict get $processed body] + } else { + set varDecls [::p::predator::runtime_vardecls] ;#dynamic vardecls can access vars from all interfaces of invocant object. + set body $varDecls[dict get $processed body] + } + #set body [string map [::list @this@ "\[lindex \$_ID_ 0 3 \]" @next@ $next] $body\n] + set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata \] 3\]" @next@ $next] $body\n] + + proc ::p::${IID}::_iface::$THISNAME [concat _ID_ $idxlist] $body + + #----------------------------------- + + + + #pointer from prop-name to head of override-chain + interp alias {} ::p::${IID}::_iface::(GET)$property {} ::p::${IID}::_iface::(GET)$property.$headid + + + interp alias {} ::p::${OID}::(GET)$property {} ::p::${IID}::_iface::(GET)$property ;#the reference traces will call this one - in case there is both a property and a method with this name. + if {$property ni [M $_ID_]} { + interp alias {} ::p::${OID}::$property {} ::p::${IID}::_iface::(GET)$property + } +} +################################################################################################################################################### + + + + + + + + + + + + + + +################################################################################################################################################### + +################################################################################################################################################### +dict set ::p::-1::_iface::o_methods PropertyWrite {arglist {property argname body}} +proc ::p::-1::PropertyWrite {_ID_ property argname body} { + set invocants [dict get $_ID_ i] + set OID [lindex [dict get $invocants this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + lassign [dict get $MAP invocantdata] OID alias default_command cmd + + set interfaces [dict get $MAP interfaces level0] + set existing_IID [lindex $interfaces end] ;#!todo - get 'open' interface. + + + + if {$existing_IID != [set IID [::p::internals::expand_interface $existing_IID]]} { + #remove ourself from the usedby list of the previous interface + array unset ::p::${existing_IID}::_iface::o_usedby i$OID + set ::p::${IID}::_iface::o_usedby(i$OID) $cmd + + set posn [lsearch $interfaces $existing_IID] + + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level0 [concat [lreplace $interfaces $posn $posn] $IID] + dict set MAP interfaces $extracted_sub_dict + #lset map {1 0} [concat [lreplace $interfaces $posn $posn] $IID] + + set ::p::${IID}::_iface::o_open 0 + } else { + set prev_open [set ::p::${existing_IID}::_iface::o_open] + set ::p::${IID}::_iface::o_open $prev_open + } + namespace upvar ::p::${IID}::_iface o_varspaces o_varspaces o_varspace o_varspace + + #pw short for propertywrite + #array set ::p::${IID}:: [::list pw,body,$property $body pw,arg,$property $argname pw,name,$property $property pw,iface,$property $cmd] + array set ::p::${IID}:: [::list pw,body,$property $body pw,arg,$property $argname pw,name,$property $property] + + + set maxversion [::p::predator::method_chainhead $IID (SET)$property] + set headid [expr {$maxversion + 1}] + + set THISNAME (SET)$property.$headid + + set next [::p::predator::next_script $IID (SET)$property $THISNAME $_ID_] + + #implement + #----------------------------------- + + set processed [dict create {*}[::p::predator::expand_var_statements $body $o_varspace]] + if {[llength [dict get $processed varspaces_with_explicit_vars]]} { + foreach vs [dict get $processed varspaces_with_explicit_vars] { + if {[string length $vs] && ($vs ni $o_varspaces)} { + lappend o_varspaces $vs + } + } + set body [dict get $processed body] + } else { + set varDecls [::p::predator::runtime_vardecls] ;#dynamic vardecls can access vars from all interfaces of invocant object. + set body $varDecls[dict get $processed body] + } + #set body [string map [::list @this@ "\[lindex \$_ID_ 0 3 \]" @next@ $next] $body\n] + set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata \] 3\]" @next@ $next] $body\n] + + + proc ::p::${IID}::_iface::$THISNAME [list _ID_ $argname] $body + + #----------------------------------- + + + + #pointer from method-name to head of override-chain + interp alias {} ::p::${IID}::_iface::(SET)$property {} ::p::${IID}::_iface::(SET)$property.$headid +} +################################################################################################################################################### + + + + + + + + + + + + + + +################################################################################################################################################### + +################################################################################################################################################### +dict set ::p::-1::_iface::o_methods PatternPropertyWrite {arglist {property argname body}} +proc ::p::-1::PatternPropertyWrite {_ID_ property argname body} { + set invocants [dict get $_ID_ i] + set OID [lindex [dict get $invocants this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + lassign [dict get $MAP invocantdata] OID alias default_command cmd + + + set patterns [dict get $MAP interfaces level1] + set existing_IID [lindex $patterns end] ;#!todo - get 'open' interface. + + + if {$existing_IID != [set IID [::p::internals::expand_interface $existing_IID]]} { + #remove ourself from the usedby list of the previous interface + array unset ::p::${existing_IID}::_iface::o_usedby i$OID + set ::p::${IID}::_iface::o_usedby(i$OID) $cmd + + set existing_ifaces [lindex $map 1 1] + set posn [lsearch $existing_ifaces $existing_IID] + + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level1 [concat [lreplace $existing_ifaces $posn $posn] $IID] + dict set MAP interfaces $extracted_sub_dict + #lset map {1 1} [concat [lreplace $existing_ifaces $posn $posn] $IID] + + #set ::p::${IID}::_iface::o_open 0 + } else { + } + + #pw short for propertywrite + array set ::p::${IID}:: [::list pw,body,$property $body pw,arg,$property $argname pw,name,$property $property pw,iface,$property $cmd] + + + return + +} +################################################################################################################################################### + + + + + + + +################################################################################################################################################### + +################################################################################################################################################### +dict set ::p::-1::_iface::o_methods PropertyUnset {arglist {property arraykeypattern body}} +proc ::p::-1::PropertyUnset {_ID_ property arraykeypattern body} { + set invocants [dict get $_ID_ i] + set OID [lindex [dict get $invocants this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + lassign [dict get $MAP invocantdata] OID alias default_command cmd + + + set interfaces [dict get $MAP interfaces level0] + set existing_IID [lindex $interfaces end] ;#!todo - choose 'open' interface to expand. + + + + if {$existing_IID != [set IID [::p::internals::expand_interface $existing_IID]]} { + #remove ourself from the usedby list of the previous interface + array unset ::p::${existing_IID}::_iface::o_usedby i$OID + set ::p::${IID}::_iface::o_usedby(i$OID) $cmd + + set posn [lsearch $interfaces $existing_IID] + + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level0 [concat [lreplace $interfaces $posn $posn] $IID] + dict set MAP interfaces $extracted_sub_dict + } else { + set prev_open [set ::p::${existing_IID}::_iface::o_open] + set ::p::${IID}::_iface::o_open $prev_open + } + namespace upvar ::p::${IID}::_iface o_varspaces o_varspaces o_varspace o_varspace o_propertyunset_handlers propertyunset_handlers + #upvar ::p::${IID}::_iface::o_propertyunset_handlers propertyunset_handlers + dict set propertyunset_handlers $property [list body $body arraykeypattern $arraykeypattern] + + set maxversion [::p::predator::method_chainhead $IID (UNSET)$property] + set headid [expr {$maxversion + 1}] + + set THISNAME (UNSET)$property.$headid + + set next [::p::predator::next_script $IID (UNSET)$property $THISNAME $_ID_] + + + set processed [dict create {*}[::p::predator::expand_var_statements $body $o_varspace]] + if {[llength [dict get $processed varspaces_with_explicit_vars]]} { + foreach vs [dict get $processed varspaces_with_explicit_vars] { + if {[string length $vs] && ($vs ni $o_varspaces)} { + lappend o_varspaces $vs + } + } + set body [dict get $processed body] + } else { + set varDecls [::p::predator::runtime_vardecls] ;#dynamic vardecls can access vars from all interfaces of invocant object. + set body $varDecls[dict get $processed body] + } + #set body [string map [::list @this@ "\[lindex \$_ID_ 0 3 \]" @next@ $next] $body\n] + set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata \] 3\]" @next@ $next] $body\n] + + #note $arraykeypattern actually contains the name of the argument + if {[string trim $arraykeypattern] eq ""} { + set arraykeypattern _dontcare_ ;# + } + proc ::p::${IID}::_iface::(UNSET)$property.$headid [list _ID_ $arraykeypattern] $body + +#----------------------------------- + + +#pointer from method-name to head of override-chain +interp alias {} ::p::${IID}::_iface::(UNSET)$property {} ::p::${IID}::_iface::(UNSET)$property.$headid + +} +################################################################################################################################################### + + + + + + + + +################################################################################################################################################### + +################################################################################################################################################### +dict set ::p::-1::_iface::o_methods PatternPropertyUnset {arglist {property arraykeypattern body}} +proc ::p::-1::PatternPropertyUnset {_ID_ property arraykeypattern body} { + set invocants [dict get $_ID_ i] + set OID [lindex [dict get $invocants this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + lassign [dict get $MAP invocantdata] OID alias itemCmd cmd + + + set patterns [dict get $MAP interfaces level1] + set existing_IID [lindex $patterns end] ;#!todo - choose 'open' interface to expand. + + + if {$existing_IID != [set IID [::p::internals::expand_interface $existing_IID]]} { + #remove ourself from the usedby list of the previous interface + array unset ::p::${existing_IID}::_iface::o_usedby i$OID + set ::p::${IID}::_iface::o_usedby(i$OID) $cmd + + set posn [lsearch $patterns $existing_IID] + + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level1 [concat [lreplace $patterns $posn $posn] $IID] + dict set MAP interfaces $extracted_sub_dict + #set ::p::${IID}::_iface::o_open 0 + } + + + upvar ::p::${IID}::_iface::o_propertyunset_handlers propertyunset_handlers + dict set propertyunset_handlers $property [list body $body arraykeypattern $arraykeypattern] + + return +} +################################################################################################################################################### + + + +#lappend ::p::-1::_iface::o_methods Implements +#!todo - some way to force overriding of any abstract (empty) methods from the source object +#e.g leave interface open and raise an error when closing it if there are unoverridden methods? + + + + + +#implementation reuse - sugar for >object .. Clone >target +dict set ::p::-1::_iface::o_methods Extends {arglist {pattern}} +proc ::p::-1::Extends {_ID_ pattern} { + if {!([string range [namespace tail $pattern] 0 0] eq ">")} { + error "'Extends' expected a pattern object" + } + set invocants [dict get $_ID_ i] + set OID [lindex [dict get $invocants this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + lassign [dict get $MAP invocantdata] OID alias itemCmd object_command + + + tailcall $pattern .. Clone $object_command +} +#implementation reuse - sugar for >pattern .. Create >target +dict set ::p::-1::_iface::o_methods PatternExtends {arglist {pattern}} +proc ::p::-1::PatternExtends {_ID_ pattern} { + if {!([string range [namespace tail $pattern] 0 0] eq ">")} { + error "'PatternExtends' expected a pattern object" + } + set invocants [dict get $_ID_ i] + set OID [lindex [dict get $invocants this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + lassign [dict get $MAP invocantdata] OID alias itemCmd object_command + + + tailcall $pattern .. Create $object_command +} + + +dict set ::p::-1::_iface::o_methods Extend {arglist {{idx ""}}} +proc ::p::-1::Extend {_ID_ {idx ""}} { + puts stderr "Extend is DEPRECATED - use Expand instead" + tailcall ::p::-1::Expand $_ID_ $idx +} + +#set the topmost interface on the iStack to be 'open' +dict set ::p::-1::_iface::o_methods Expand {arglist {{idx ""}}} +proc ::p::-1::Expand {_ID_ {idx ""}} { + set invocants [dict get $_ID_ i] + set OID [lindex [dict get $invocants this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + set interfaces [dict get $MAP interfaces level0] ;#level 0 interfaces + set iid_top [lindex $interfaces end] + set iface ::p::ifaces::>$iid_top + + if {![string length $iid_top]} { + #no existing interface - create a new one + set iid_top [expr {$::p::ID + 1}] ;#PREDICT the next object's id + set iface [::p::>interface .. Create ::p::ifaces::>$iid_top $OID] + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level0 [list $iid_top] + dict set MAP interfaces $extracted_sub_dict ;#write new interface into map + $iface . open + return $iid_top + } else { + if {[$iface . isOpen]} { + #already open.. + #assume ready to expand.. shared or not! + return $iid_top + } + lassign [dict get $MAP invocantdata] OID alias itemCmd cmd + + if {[$iface . refCount] > 1} { + if {$iid_top != [set IID [::p::internals::expand_interface $iid_top ]]} { + #!warning! not exercised by test suites! + + #remove ourself from the usedby list of the previous interface + array unset ::p::${iid_top}::_iface::o_usedby i$OID + set ::p::${IID}::_iface::o_usedby(i$OID) $cmd + + #remove existing interface & add + set posn [lsearch $interfaces $iid_top] + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level0 [concat [lreplace $interfaces $posn $posn] $IID] + dict set MAP interfaces $extracted_sub_dict + #lset map {1 0} [concat [lreplace $interfaces $posn $posn] $IID] + + + set iid_top $IID + set iface ::p::ifaces::>$iid_top + } + } + } + + $iface . open + return $iid_top +} + +dict set ::p::-1::_iface::o_methods PatternExtend {arglist {{idx ""}}} +proc ::p::-1::PatternExtend {_ID_ {idx ""}} { + puts stderr "PatternExtend is DEPRECATED - use PatternExpand instead" + tailcall ::p::-1::PatternExpand $_ID_ $idx +} + + + +#set the topmost interface on the pStack to be 'open' if it's not shared +# if shared - 'copylink' to new interface before opening for extension +dict set ::p::-1::_iface::o_methods PatternExpand {arglist {{idx ""}}} +proc ::p::-1::PatternExpand {_ID_ {idx ""}} { + set OID [::p::obj_get_this_oid $_ID_] + ::p::map $OID MAP + #puts stderr "no tests written for PatternExpand " + lassign [dict get $MAP invocantdata] OID alias itemCmd cmd + + set ifaces [dict get $MAP interfaces level1] ;#level 1 interfaces + set iid_top [lindex $ifaces end] + set iface ::p::ifaces::>$iid_top + + if {![string length $iid_top]} { + #no existing interface - create a new one + set iid_top [expr {$::p::ID + 1}] ;#PREDICT the next object's id + set iface [::p::>interface .. Create ::p::ifaces::>$iid_top $OID] + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level1 [list $iid_top] + dict set MAP interfaces $extracted_sub_dict + #lset map {1 1} [list $iid_top] + $iface . open + return $iid_top + } else { + if {[$iface . isOpen]} { + #already open.. + #assume ready to expand.. shared or not! + return $iid_top + } + + if {[$iface . refCount] > 1} { + if {$iid_top != [set IID [::p::internals::expand_interface $iid_top]]} { + #!WARNING! not exercised by test suite! + #remove ourself from the usedby list of the previous interface + array unset ::p::${iid_top}::_iface::o_usedby i$OID + set ::p::${IID}::_iface::o_usedby(i$OID) $cmd + + set posn [lsearch $ifaces $iid_top] + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level1 [concat [lreplace $ifaces $posn $posn] $IID] + dict set MAP interfaces $extracted_sub_dict + #lset map {1 1} [concat [lreplace $ifaces $posn $posn] $IID] + + set iid_top $IID + set iface ::p::ifaces::>$iid_top + } + } + } + + $iface . open + return $iid_top +} + + + + + +dict set ::p::-1::_iface::o_methods Properties {arglist {{idx ""}}} +proc ::p::-1::Properties {_ID_ {idx ""}} { + set OID [lindex [dict get $_ID_ i this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + set ifaces [dict get $MAP interfaces level0] ;#level 0 interfaces + + set col ::p::${OID}::_meta::>colProperties + + if {[namespace which $col] eq ""} { + patternlib::>collection .. Create $col + foreach IID $ifaces { + dict for {prop pdef} [set ::p::${IID}::_iface::o_properties] { + if {![$col . hasIndex $prop]} { + $col . add [::p::internals::predator $_ID_ . $prop .] $prop + } + } + } + } + + if {[string length $idx]} { + return [$col . item $idx] + } else { + return $col + } +} + +dict set ::p::-1::_iface::o_methods P {arglist {{glob *}}} +proc ::p::-1::P {_ID_ {glob *}} { + set invocants [dict get $_ID_ i] + set this_invocant [lindex [dict get $invocants this] 0] + lassign $this_invocant OID _etc + set OID [lindex [dict get $_ID_ i this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + set interfaces [dict get $MAP interfaces level0] ;#level 0 interfaces + + set members [list] + foreach IID $interfaces { + lappend members {*}[dict keys [set ::p::${IID}::_iface::o_properties] $glob] + } + return [lsort $members] +} + +#PatternProperties +dict set ::p::-1::_iface::o_methods PP {arglist {{glob *}}} +proc ::p::-1::PP {_ID_ {glob *}} { + set invocants [dict get $_ID_ i] + set this_invocant [lindex [dict get $invocants this] 0] + lassign $this_invocant OID _etc + set OID [lindex [dict get $_ID_ i this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + set interfaces [dict get $MAP interfaces level1] ;#level 1 interfaces + + set members [list] + foreach IID $interfaces { + lappend members {*}[dict keys [set ::p::${IID}::_iface::o_properties] $glob] + } + return [lsort $members] +} + + + +#Interface Properties +dict set ::p::-1::_iface::o_methods IP {arglist {{glob *}}} +proc ::p::-1::IP {_ID_ {glob *}} { + set invocants [dict get $_ID_ i] + set OID [lindex [dict get $invocants this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + set ifaces [dict get $MAP interfaces level0] ;#level 0 interfaces + set members [list] + + foreach m [dict keys [set ::p::${OID}::_iface::o_properties]] { + if {[string match $glob [lindex $m 0]]} { + lappend members [lindex $m 0] + } + } + return $members +} + + +#used by rename.test - theoretically should be on a separate interface! +dict set ::p::-1::_iface::o_methods CheckInvocants {arglist {args}} +proc ::p::-1::CheckInvocants {_ID_ args} { + #check all invocants in the _ID_ are consistent with data stored in their MAP variable + set status "ok" ;#default to optimistic assumption + set problems [list] + + set invocant_dict [dict get $_ID_ i] + set invocant_roles [dict keys $invocant_dict] + + foreach role $invocant_roles { + set invocant_list [dict get $invocant_dict $role] + foreach aliased_invocantdata $invocant_list { + set OID [lindex $aliased_invocantdata 0] + set map_invocantdata [dict get [set ::p::${OID}::_meta::map] invocantdata] + #we use lrange to make sure the lists are in canonical form + if {[lrange $map_invocantdata 0 end] ne [lrange $aliased_invocantdata 0 end]} { + set status "not-ok" + lappend problems [list type "invocant_data_mismatch" invocant_role $role oid $OID command_invocantdata $aliased_invocantdata map_invocantdata $map_invocantdata] + } + } + + } + + + set result [dict create] + dict set result status $status + dict set result problems $problems + + return $result +} + + +#get or set t +dict set ::p::-1::_iface::o_methods Namespace {arglist {args}} +proc ::p::-1::Namespace {_ID_ args} { + #set invocants [dict get $_ID_ i] + #set this_invocant [lindex [dict get $invocants this] 0] + #lassign $this_invocant OID this_info + set OID [lindex [dict get $_ID_ i this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + set IID [lindex [dict get $MAP interfaces level0] end] + + namespace upvar ::p::${IID}::_iface o_varspace active_varspace + + if {[string length $active_varspace]} { + set ns ::p::${OID}::$active_varspace + } else { + set ns ::p::${OID} + } + + #!todo - review.. 'eval' & 'code' subcommands make it too easy to violate the object? + # - should .. Namespace be usable at all from outside the object? + + + if {[llength $args]} { + #special case some of the namespace subcommands. + + #delete + if {[string match "d*" [lindex $args 0]]} { + error "Don't destroy an object's namespace like this. Use '>object .. Destroy' to remove an object." + } + #upvar,ensemble,which,code,origin,expor,import,forget + if {[string range [lindex $args 0] 0 1] in [list "up" "en" "wh" "co" "or" "ex" "im" "fo"]} { + return [namespace eval $ns [list namespace {*}$args]] + } + #current + if {[string match "cu*" [lindex $args 0]]} { + return $ns + } + + #children,eval,exists,inscope,parent,qualifiers,tail + return [namespace {*}[linsert $args 1 $ns]] + } else { + return $ns + } +} + + + + + + + + + + +dict set ::p::-1::_iface::o_methods PatternUnknown {arglist {args}} +proc ::p::-1::PatternUnknown {_ID_ args} { + set invocants [dict get $_ID_ i] + set OID [lindex [dict get $invocants this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + lassign [dict get $MAP invocantdata] OID alias itemCmd cmd + set patterns [dict get $MAP interfaces level1] + set existing_IID [lindex $patterns end] ;#!todo - choose 'open' interface to expand. + + if {$existing_IID != [set IID [::p::internals::expand_interface $existing_IID]]} { + #remove ourself from the usedby list of the previous interface + array unset ::p::${existing_IID}::_iface::o_usedby i$OID + set ::p::${IID}::_iface::o_usedby(i$OID) $cmd + + set posn [lsearch $patterns $existing_IID] + + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level1 [concat [lreplace $patterns $posn $posn] $IID] + dict set MAP interfaces $extracted_sub_dict + #lset map {1 1} [concat [lreplace $patterns $posn $posn] $IID] + #::p::predator::remap $invocant + } + + set handlermethod [lindex $args 0] + + + if {[llength $args]} { + set ::p::${IID}::_iface::o_unknown $handlermethod + return + } else { + set ::p::${IID}::_iface::o_unknown $handlermethod + } + +} + + + +dict set ::p::-1::_iface::o_methods Unknown {arglist {args}} +proc ::p::-1::Unknown {_ID_ args} { + set invocants [dict get $_ID_ i] + set OID [lindex [dict get $invocants this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + + set interfaces [dict get $MAP interfaces level0] + set existing_IID [lindex $interfaces end] ;#!todo - choose 'open' interface to expand. + + set prev_open [set ::p::${existing_IID}::_iface::o_open] + + if {$existing_IID != [set IID [::p::internals::expand_interface $existing_IID]]} { + #remove ourself from the usedby list of the previous interface + array unset ::p::${existing_IID}::_iface::o_usedby i$OID + set ::p::${IID}::_iface::o_usedby(i$OID) $cmd + + set posn [lsearch $interfaces $existing_IID] + + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level0 [concat [lreplace $interfaces $posn $posn] $IID] + dict set MAP interfaces $extracted_sub_dict + #lset map {1 0} [concat [lreplace $interfaces $posn $posn] $IID] + + set ::p::${IID}::_iface::o_open 0 + } else { + set ::p::${IID}::_iface::o_open $prev_open + } + + set handlermethod [lindex $args 0] + + if {[llength $args]} { + set ::p::${IID}::_iface::o_unknown $handlermethod + #set ::p::${IID}::(unknown) $handlermethod + + + #interp alias {} ::p::${IID}::_iface::(UNKNOWN) {} ::p::${OID}::$handlermethod + interp alias {} ::p::${IID}::_iface::(UNKNOWN) {} ::p::${IID}::_iface::$handlermethod + interp alias {} ::p::${OID}::(UNKNOWN) {} ::p::${OID}::$handlermethod + + #namespace eval ::p::${IID}::_iface [list namespace unknown $handlermethod] + #namespace eval ::p::${OID} [list namespace unknown $handlermethod] + + return + } else { + set ::p::${IID}::_iface::o_unknown $handlermethod + } + +} + + +#useful on commandline - can just uparrow and add to it to become ' .. As varname' instead of editing start and end of commandline to make it 'set varname []' +# should also work for non-object results +dict set ::p::-1::_iface::o_methods As {arglist {varname}} +proc ::p::-1::As {_ID_ varname} { + set invocants [dict get $_ID_ i] + #puts stdout "invocants: $invocants" + #!todo - handle multiple invocants with other roles, not just 'this' + + set OID [lindex [dict get $_ID_ i this] 0 0] + if {$OID ne "null"} { + upvar #0 ::p::${OID}::_meta::map MAP + lassign [dict get $MAP invocantdata] OID alias itemCmd cmd + tailcall set $varname $cmd + } else { + #puts stdout "info level 1 [info level 1]" + set role_members [dict get $_ID_ i this] + if {[llength $role_members] == 1} { + set member [lindex $role_members 0] + lassign $member _OID namespace default_method stackvalue _wrapped + tailcall set $varname $stackvalue + } else { + #multiple invocants - return all results as a list + set resultlist [list] + foreach member $role_members { + lassign $member _OID namespace default_method stackvalue _wrapped + lappend resultlist $stackvalue + } + tailcall set $varname $resultlist + } + } +} + +#!todo - AsFileStream ?? +dict set ::p::-1::_iface::o_methods AsFile {arglist {filename args}} +proc ::p::-1::AsFile {_ID_ filename args} { + dict set default -force 0 + dict set default -dumpmethod ".. Digest -algorithm raw" ;#how to serialize/persist an object + set opts [dict merge $default $args] + set force [dict get $opts -force] + set dumpmethod [dict get $opts -dumpmethod] + + + if {[file pathtype $filename] eq "relative"} { + set filename [pwd]/$filename + } + set filedir [file dirname $filename] + if {![sf::file_writable $filedir]} { + error "(method AsFile) ERROR folder $filedir is not writable" + } + if {[file exists $filename]} { + if {!$force} { + error "(method AsFile) ERROR file $filename already exists. Use -force 1 to overwrite" + } + if {![sf::file_writable $filename]} { + error "(method AsFile) ERROR file $filename is not writable - check permissions" + } + } + set fd [open $filename w] + fconfigure $fd -translation binary + + set invocants [dict get $_ID_ i] + set OID [lindex [dict get $_ID_ i this] 0 0] + if {$OID ne "null"} { + upvar #0 ::p::${OID}::_meta::map MAP + lassign [dict get $MAP invocantdata] OID alias itemCmd cmd + #tailcall set $varname $cmd + set object_data [$cmd {*}$dumpmethod] + puts -nonewline $fd $object_data + close $fd + return [list status 1 bytes [string length $object_data] filename $filename] + } else { + #puts stdout "info level 1 [info level 1]" + set role_members [dict get $_ID_ i this] + if {[llength $role_members] == 1} { + set member [lindex $role_members 0] + lassign $member _OID namespace default_method stackvalue _wrapped + puts -nonewline $fd $stackvalue + close $fd + #tailcall set $varname $stackvalue + return [list status 1 bytes [string length $stackvalue] filename $filename] + } else { + #multiple invocants - return all results as a list + set resultlist [list] + foreach member $role_members { + lassign $member _OID namespace default_method stackvalue _wrapped + lappend resultlist $stackvalue + } + puts -nonewline $fd $resultset + close $fd + return [list status 1 bytes [string length $resultset] filename $filename] + #tailcall set $varname $resultlist + } + } + +} + + + +dict set ::p::-1::_iface::o_methods Object {arglist {}} +proc ::p::-1::Object {_ID_} { + set invocants [dict get $_ID_ i] + set OID [lindex [dict get $invocants this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + lassign [dict get $MAP invocantdata] OID alias itemCmd cmd + + set result [string map [list ::> ::] $cmd] + if {![catch {info level -1} prev_level]} { + set called_by "(called by: $prev_level)" + } else { + set called_by "(called by: interp?)" + + } + + puts stdout "\n\nWARNING: '.. Object' calls are now obsolete. Please adjust your code. $called_by ( [info level 1])\n\n" + puts stdout " (returning $result)" + + return $result +} + +#todo: make equivalent to >pattern = cmdname, >pattern . x = cmdname , >pattern # apiname = cmdname +dict set ::p::-1::_iface::o_methods MakeAlias {arglist {cmdname}} +proc ::p::-1::MakeAlias {_ID_cmdname } { + set OID [::p::obj_get_this_oid $_ID_] + upvar #0 ::p::${OID}::_meta::map MAP + lassign [dict get $MAP invocantdata] OID alias itemCmd cmd + + error "concept probably won't work - try making dispatcher understand trailing '= cmdname' " +} +dict set ::p::-1::_iface::o_methods ID {arglist {}} +proc ::p::-1::ID {_ID_} { + set OID [lindex [dict get $_ID_ i this] 0 0] + return $OID +} + +dict set ::p::-1::_iface::o_methods IFINFO {arglist {}} +proc ::p::-1::IFINFO {_ID_} { + puts stderr "--_ID_: $_ID_--" + set OID [::p::obj_get_this_oid $_ID_] + upvar #0 ::p::${OID}::_meta::map MAP + + puts stderr "-- MAP: $MAP--" + + set interfaces [dict get $MAP interfaces level0] + set IFID [lindex $interfaces 0] + + if {![llength $interfaces]} { + puts stderr "No interfaces present at level 0" + } else { + foreach IFID $interfaces { + set iface ::p::ifaces::>$IFID + puts stderr "$iface : [$iface --]" + puts stderr "\tis open: [set ::p::${IFID}::_iface::o_open]" + set variables [set ::p::${IFID}::_iface::o_variables] + puts stderr "\tvariables: $variables" + } + } + +} + + + + +dict set ::p::-1::_iface::o_methods INVOCANTDATA {arglist {}} +proc ::p::-1::INVOCANTDATA {_ID_} { + #same as a call to: >object .. + return $_ID_ +} + +#obsolete? +dict set ::p::-1::_iface::o_methods UPDATEDINVOCANTDATA {arglist {}} +proc ::p::-1::UPDATEDINVOCANTDATA {_ID_} { + #package require dictutils + set updated_ID_ $_ID_ + array set updated_roles [list] + + set invocants [dict get $_ID_ i] + set invocant_roles [dict keys $invocants] + foreach role $invocant_roles { + + set role_members [dict get $invocants $role] + foreach member [dict get $invocants $role] { + #each member is a 2-element list consisting of the OID and a dictionary + #each member is a 5-element list + #set OID [lindex $member 0] + #set object_dict [lindex $member 1] + lassign $member OID alias itemcmd cmd wrapped + + set MAP [set ::p::${OID}::_meta::map] + #if {[dictutils::equal {apply {{key v1 v2} {expr {$v1 eq $v2}}}} $mapvalue [dict get $object_dict map]]} {} + + if {[dict get $MAP invocantdata] eq $member} + #same - nothing to do + + } else { + package require overtype + puts stderr "---------------------------------------------------------" + puts stderr "UPDATEDINVOCANTDATA WARNING: invocantdata in _ID_ not equal to invocantdata in _meta::map - returning updated version" + set col1 [string repeat " " [expr {[string length [dict get $MAP invocantdata]] + 2}]] + puts stderr "[overtype::left $col1 {_ID_ map value}]: $member" + puts stderr "[overtype::left $col1 ::p::${OID}::_meta::map]: [dict get $MAP invocantdata]" + puts stderr "---------------------------------------------------------" + #take _meta::map version + lappend updated_roles($role) [dict get $MAP invocantdata] + } + + } + + #overwrite changed roles only + foreach role [array names updated_roles] { + dict set updated_ID_ i $role [set updated_roles($role)] + } + + return $updated_ID_ +} + + + +dict set ::p::-1::_iface::o_methods INFO {arglist {}} +proc ::p::-1::INFO {_ID_} { + set result "" + append result "_ID_: $_ID_\n" + + set invocants [dict get $_ID_ i] + set invocant_roles [dict keys $invocants] + append result "invocant roles: $invocant_roles\n" + set total_invocants 0 + foreach key $invocant_roles { + incr total_invocants [llength [dict get $invocants $key]] + } + + append result "invocants: ($total_invocants invocant(s) in [llength $invocant_roles] role(s)) \n" + foreach key $invocant_roles { + append result "\t-------------------------------\n" + append result "\trole: $key\n" + set role_members [dict get $invocants $key] ;#usually the role 'this' will have 1 member - but roles can have any number of invocants + append result "\t Raw data for this role: $role_members\n" + append result "\t Number of invocants in this role: [llength $role_members]\n" + foreach member $role_members { + #set OID [lindex [dict get $invocants $key] 0 0] + set OID [lindex $member 0] + append result "\t\tOID: $OID\n" + if {$OID ne "null"} { + upvar #0 ::p::${OID}::_meta::map MAP + append result "\t\tmap:\n" + foreach key [dict keys $MAP] { + append result "\t\t\t$key\n" + append result "\t\t\t\t [dict get $MAP $key]\n" + append result "\t\t\t----\n" + } + lassign [dict get $MAP invocantdata] _OID namespace default_method cmd _wrapped + append result "\t\tNamespace: $namespace\n" + append result "\t\tDefault method: $default_method\n" + append result "\t\tCommand: $cmd\n" + append result "\t\tCommand Alias: [::pattern::which_alias $cmd]\n" + append result "\t\tLevel0 interfaces: [dict get $MAP interfaces level0]\n" + append result "\t\tLevel1 interfaces: [dict get $MAP interfaces level1]\n" + } else { + lassign $member _OID namespace default_method stackvalue _wrapped + append result "\t\t last item on the predator stack is a value not an object" + append result "\t\t Value is: $stackvalue" + + } + } + append result "\n" + append result "\t-------------------------------\n" + } + + + + return $result +} + + + + +dict set ::p::-1::_iface::o_methods Rename {arglist {args}} +proc ::p::-1::Rename {_ID_ args} { + set OID [::p::obj_get_this_oid $_ID_] + if {![llength $args]} { + error "Rename expected \$newname argument" + } + + #Rename operates only on the 'this' invocant? What if there is more than one 'this'? should we raise an error if there is anything other than a single invocant? + upvar #0 ::p::${OID}::_meta::map MAP + + + + #puts ">>.>> Rename. _ID_: $_ID_" + + if {[catch { + + if {([llength $args] == 3) && [lindex $args 2] eq "rename"} { + + #appears to be a 'trace command rename' firing + #puts "\t>>>> rename trace fired $MAP $args <<<" + + lassign $args oldcmd newcmd + set extracted_invocantdata [dict get $MAP invocantdata] + lset extracted_invocantdata 3 $newcmd + dict set MAP invocantdata $extracted_invocantdata + + + lassign $extracted_invocantdata _oid alias _default_method object_command _wrapped + + #Write the same info into the _ID_ value of the alias + interp alias {} $alias {} ;#first we must delete it + interp alias {} $alias {} ::p::internals::predator [list i [list this [list $extracted_invocantdata ] ] context {}] + + + + #! $object_command was initially created as the renamed alias - so we have to do it again + uplevel 1 [list rename $alias $object_command] + trace add command $object_command rename [list $object_command .. Rename] + + } elseif {[llength $args] == 1} { + #let the rename trace fire and we will be called again to do the remap! + uplevel 1 [list rename [lindex [dict get $MAP invocantdata] 3] [lindex $args 0]] + } else { + error "Rename expected \$newname argument ." + } + + } errM]} { + puts stderr "\t@@@@@@ rename error" + set ruler "\t[string repeat - 80]" + puts stderr $ruler + puts stderr $errM + puts stderr $ruler + + } + + return + + +} + +proc ::p::obj_get_invocants {_ID_} { + return [dict get $_ID_ i] +} +#The invocant role 'this' is special and should always have only one member. +# dict get $_ID_ i XXX will always return a list of invocants that are playing role XXX +proc ::p::obj_get_this_oid {_ID_} { + return [lindex [dict get $_ID_ i this] 0 0] +} +proc ::p::obj_get_this_ns {_ID_} { + return [lindex [dict get $_ID_ i this] 0 1] +} + +proc ::p::obj_get_this_cmd {_ID_} { + return [lindex [dict get $_ID_ i this] 0 3] +} +proc ::p::obj_get_this_data {_ID_} { + lassign [dict get [set ::p::[lindex [dict get $_ID_ i this] 0 0]::_meta::map] invocantdata] OID ns _unknown cmd + #set this_invocant_data {*}[dict get $_ID_ i this] + return [list oid $OID ns $ns cmd $cmd] +} +proc ::p::map {OID varname} { + tailcall upvar #0 ::p::${OID}::_meta::map $varname +} + + + diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/oolib-0.1.3.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/oolib-0.1.3.tm new file mode 100644 index 00000000..e44e2a8d --- /dev/null +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/oolib-0.1.3.tm @@ -0,0 +1,200 @@ +#JMN - api should be kept in sync with package patternlib where possible +# + +namespace eval oolib { + oo::class create collection { + variable o_data ;#dict + #variable o_alias + constructor {} { + set o_data [dict create] + } + method info {} { + return [dict info $o_data] + } + method count {} { + return [dict size $o_data] + } + method isEmpty {} { + expr {[dict size $o_data] == 0} + } + method names {{globOrIdx {}}} { + if {[llength $globOrIdx]} { + if {[string is integer -strict $globOrIdx]} { + set idx $globOrIdx + if {$idx < 0} { + set idx "end-[expr {abs($idx + 1)}]" + } + if {[catch {lindex [dict keys $o_data] $idx} result]} { + error "[self object] no such index : '$idx'" + } else { + return $result + } + } else { + #glob + return [lsearch -glob -all -inline [dict keys $o_data] $globOrIdx] + } + } else { + return [dict keys $o_data] + } + } + #like names but without globbing + method keys {} { + dict keys $o_data + } + method key {{posn 0}} { + if {$posn < 0} { + set posn "end-[expr {abs($posn + 1)}]" + } + if {[catch {lindex [dict keys $o_data] $posn} result]} { + error "[self object] no such index : '$posn'" + } else { + return $result + } + } + method hasKey {key} { + dict exists $o_data $key + } + method get {} { + return $o_data + } + method items {} { + return [dict values $o_data] + } + method item {key} { + if {[string is integer -strict $key]} { + if {$key >= 0} { + set valposn [expr {(2*$key) +1}] + return [lindex $o_data $valposn] + } else { + set key "end-[expr {abs($key + 1)}]" + return [lindex $o_data $key] + #return [lindex [dict keys $o_data] $key] + } + } + if {[dict exists $o_data $key]} { + return [dict get $o_data $key] + } + } + #inverse lookup + method itemKeys {value} { + set value_indices [lsearch -all [dict values $o_data] $value] + set keylist [list] + foreach i $value_indices { + set idx [expr {(($i + 1) *2) -2}] + lappend keylist [lindex $o_data $idx] + } + return $keylist + } + method search {value args} { + set matches [lsearch {*}$args [dict values $o_data] $value] + if {"-inline" in $args} { + return $matches + } else { + set keylist [list] + foreach i $matches { + set idx [expr {(($i + 1) *2) -2}] + lappend keylist [lindex $o_data $idx] + } + return $keylist + } + } + #review - see patternlib. Is the intention for aliases to be configurable independent of whether the target exists? + #review - what is the point of alias anyway? - why slow down other operations when a variable can hold a keyname perfectly well? + #method alias {newAlias existingKeyOrAlias} { + # if {[string is integer -strict $newAlias]} { + # error "[self object] collection key alias cannot be integer" + # } + # if {[string length $existingKeyOrAlias]} { + # set o_alias($newAlias) $existingKeyOrAlias + # } else { + # unset o_alias($newAlias) + # } + #} + #method aliases {{key ""}} { + # if {[string length $key]} { + # set result [list] + # foreach {n v} [array get o_alias] { + # if {$v eq $key} { + # lappend result $n $v + # } + # } + # return $result + # } else { + # return [array get o_alias] + # } + #} + ##if the supplied index is an alias, return the underlying key; else return the index supplied. + #method realKey {idx} { + # if {[catch {set o_alias($idx)} key]} { + # return $idx + # } else { + # return $key + # } + #} + method add {value key} { + if {[string is integer -strict $key]} { + error "[self object] collection key must not be an integer. Use another structure if integer keys required" + } + if {[dict exists $o_data $key]} { + error "[self object] col_processors object error: key '$key' already exists in collection" + } + dict set o_data $key $value + return [expr {[dict size $o_data] - 1}] ;#return index of item + } + method remove {idx {endRange ""}} { + if {[string length $endRange]} { + error "[self object] collection error: ranged removal not yet implemented.. remove one item at a time" + } + if {[string is integer -strict $idx]} { + if {$idx < 0} { + set idx "end-[expr {abs($idx+1)}]" + } + set key [lindex [dict keys $o_data] $idx] + set posn $idx + } else { + set key $idx + set posn [lsearch -exact [dict keys $o_data] $key] + if {$posn < 0} { + error "[self object] no such index: '$idx' in this collection" + } + } + dict unset o_data $key + return + } + method clear {} { + set o_data [dict create] + return + } + method reverse_the_collection {} { + #named slightly obtusely because reversing the data when there may be references held is a potential source of bugs + #the name reverse_the_collection should make it clear that the object is being modified in place as opposed to simply 'reverse' which may imply a view/copy. + #todo - consider implementing a get_reverse which provides an interface to the same collection without affecting original references, yet both allowing delete/edit operations. + set dictnew [dict create] + foreach k [lreverse [dict keys $o_data]] { + dict set dictnew $k [dict get $o_data $k] + } + set o_data $dictnew + return + } + #review - cmd as list vs cmd as script? + method map {cmd} { + set seed [list] + dict for {k v} $o_data { + lappend seed [uplevel #0 [list {*}$cmd $v]] + } + return $seed + } + method objectmap {cmd} { + set seed [list] + dict for {k v} $o_data { + lappend seed [uplevel #0 [list $v {*}$cmd]] + } + return $seed + } + } +} + +package provide oolib [namespace eval oolib { + variable version + set version 0.1.3 +}] diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/overtype-1.7.4.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/overtype-1.7.4.tm index 04d0e96b..1ca40672 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/overtype-1.7.4.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/overtype-1.7.4.tm @@ -253,7 +253,6 @@ tcl::namespace::eval overtype { coloured as this doesn't affect the display width. Default is \uFFFD - the unicode replacement char.} - -experimental -default 0 -cp437 -default 0 -type boolean -looplimit -default \uFFEF\ -type integer -help\ "internal failsafe - experimental" @@ -263,7 +262,8 @@ tcl::namespace::eval overtype { -wrap -default 0 -type boolean -info -default 0 -type boolean -help\ "When set to 1, return a dictionary (experimental)" - -binarytext -default "" -type string -choices {"" bios ice} + -format -default ansi -type string -choices {ansi binarytext-bios binarytext-ice xbin} -help\ + "Format of new data being applied as an overlay" -console -default {stdin stdout stderr} -type list @values -min 1 -max 2 @@ -328,7 +328,6 @@ tcl::namespace::eval overtype { -transparent 0 -exposed1 \uFFFD -exposed2 \uFFFD - -experimental 0 -cp437 0 -looplimit \uFFEF -crm_mode 0 @@ -336,7 +335,7 @@ tcl::namespace::eval overtype { -insert_mode 0 -wrap 0 -info 0 - -binarytext "" + -format ansi -console {stdin stdout stderr} }] #expand_right is perhaps consistent with the idea of the page_size being allowed to grow horizontally.. @@ -353,11 +352,11 @@ tcl::namespace::eval overtype { foreach {k v} $argsflags { switch -- $k { -looplimit - -width - -height - -startcolumn - -startrow - -bias - -ellipsis - -ellipsistext - -ellipsiswhitespace - - -transparent - -exposed1 - -exposed2 - -experimental + - -transparent - -exposed1 - -exposed2 - -expand_right - -appendlines - -reverse_mode - -crm_mode - -insert_mode - -cp437 - - -info - -binarytext - -console { + - -info - -format - -console { tcl::dict::set opts $k $v } -wrap - -autowrap_mode { @@ -379,6 +378,7 @@ tcl::namespace::eval overtype { set opt_height [tcl::dict::get $opts -height] set opt_startcolumn [tcl::dict::get $opts -startcolumn] set opt_startrow [tcl::dict::get $opts -startrow] + #review -appendlines - this needs thought regarding interaction with terminal height concept and scrolling set opt_appendlines [tcl::dict::get $opts -appendlines] set opt_transparent [tcl::dict::get $opts -transparent] set opt_ellipsistext [tcl::dict::get $opts -ellipsistext] @@ -397,7 +397,7 @@ tcl::namespace::eval overtype { # -- --- --- --- --- --- set opt_cp437 [tcl::dict::get $opts -cp437] set opt_info [tcl::dict::get $opts -info] - set opt_binarytext [tcl::dict::get $opts -binarytext] + set opt_format [tcl::dict::get $opts -format] set opt_console [tcl::dict::get $opts -console] @@ -416,26 +416,18 @@ tcl::namespace::eval overtype { #} #-------------------------------------------------------------------------- - # ---------------------------- - # -experimental dev flag to set flags etc - # ---------------------------- - set data_mode 0 - set edit_mode 0 - set opt_experimental [tcl::dict::get $opts -experimental] - foreach o $opt_experimental { - switch -- $o { - data_mode { - set data_mode 1 - } - edit_mode { - set edit_mode 1 - } - } - } - # ---------------------------- + #--------------------------------------------------------- + #underblock is expected to be pre-rendered - ie any ANSI codes have already been processed and rendered into the text. + #This is because the underblock is used as the basis for calculating the layout of the output + #- so it needs to be in a form where we can determine the width of each line and how many lines there are. set underblock [tcl::string::map {\r\n \n} $underblock] - set overblock [tcl::string::map {\r\n \n} $overblock] + + #do not split the overblock into lines at this stage - it may contain binary data. + #REVIEW - xbin (or binarytext?) may contain binary data which could be corrupted by mapping \r\n to \n. + #set overblock [tcl::string::map {\r\n \n} $overblock] + #--------------------------------------------------------- + if {$opt_startrow > 1} { set down [expr {$opt_startrow -1}] #when vt52? @@ -471,12 +463,17 @@ tcl::namespace::eval overtype { } insert_mode $opt_insert_mode {*}{ } autowrap_mode $opt_autowrap_mode {*}{ } cp437 $opt_cp437 {*}{ + } row 1 {*}{ + } col 1 {*}{ + } topmargin 1 {*}{ + } bottommargin $renderheight {*}{ } ] #modes #e.g insert_mode can be toggled by insert key or ansi IRM sequence CSI 4 h|l #opt_startcolumn ?? - DECSLRM ? set vtstate $initial_state + dict set vtstate col $opt_startcolumn # -- --- --- --- #REVIEW - do we need ansi resets in the underblock? @@ -484,7 +481,6 @@ tcl::namespace::eval overtype { set blankline [string repeat \u0000 $renderwidth] set underlines [lrepeat $renderheight $blankline] } else { - #---- #this splits into lines - only to rejoin - which is inefficient. #It also has code to handle joining multiple blocks - but we only have one in this case. @@ -498,16 +494,8 @@ tcl::namespace::eval overtype { } else { set underlines [split $underblock \n] } - } - #if {$underblock eq ""} { - # set blank "\x1b\[0m\x1b\[0m" - # #set underlines [list "\x1b\[0m\x1b\[0m"] - # set underlines [lrepeat $renderheight $blank] - #} else { - # #lines_as_list -ansiresets 1 will do nothing if -ansiresets 1 isn't specified - REVIEW - # set underlines [lines_as_list -ansiresets 1 $underblock] - #} + #underlines are not necessarily processed in order - depending on cursor-moves applied from overtext # -- --- --- --- #todo - reconsider the 'line' as the natural chunking mechanism for the overlay. @@ -529,95 +517,82 @@ tcl::namespace::eval overtype { #overblock height/width isn't useful in the presence of an ansi input overlay with movements. The number of lines may bear little relationship to the output height #lassign [blocksize $overblock] _w overblock_width _h overblock_height - set scheme 4 - switch -- $scheme { - 0 { - #one big chunk - set inputchunks [list mixed $overblock] - } - 1 { - #todo - set inputchunks [punk::ansi::ta::split_codes $overblock] - } - 2 { - #todo - #split into lines if possible first - then into plaintext/ansi-sequence chunks ? - set inputchunks [list ""] ;#put an empty plaintext split in for starters - set i 1 - set lines [split $overblock \n] - foreach ln $lines { - if {$i < [llength $lines]} { - append ln \n - } - set sequence_split [punk::ansi::ta::split_codes_single $ln] ;#use split_codes Not split_codes_single? - set lastpt [lindex $inputchunks end] - lset inputchunks end [tcl::string::cat $lastpt [lindex $sequence_split 0]] - lappend inputchunks {*}[lrange $sequence_split 1 end] - incr i - } - } - 3 { - #todo - #it turns out line based chunks are faster than the above.. probably because some of those end up doing the regex splitting twice - set lflines [list] - set inputchunks [split $overblock \n] - foreach ln $inputchunks { - append ln \n - lappend lflines $ln + set inputchunks [list] + switch -- $opt_format { + ansi { + #ansi is commonly but not always line-based. + #some ansi is a string of data with ansi movements and no linefeeds. + set overblock [tcl::string::map {\r\n \n} $overblock] + foreach ln [split $overblock \n] { + lappend inputchunks [list mixed $ln\n] } - if {[llength $lflines]} { - lset lflines end [tcl::string::range [lindex $lflines end] 0 end-1] + if {[llength $inputchunks]} { + #strip trailing newline from last line. + lset inputchunks end 1 [tcl::string::range [lindex $inputchunks end 1] 0 end-1] } - #set inputchunks $lflines[unset lflines] - set inputchunks [lindex [list $lflines [unset lflines]] 0] - } - 4 { - set inputchunks [list] - switch -- $opt_binarytext { - "" { - foreach ln [split $overblock \n] { - lappend inputchunks [list mixed $ln\n] - } - if {[llength $inputchunks]} { - lset inputchunks end 1 [tcl::string::range [lindex $inputchunks end 1] 0 end-1] - } + binarytext-bios { + #16 fg, 8 fg + possible blink + set input "" + set ansisplit [list ""] + set charpair 0 + foreach {ch at} [split $overblock ""] { + #review - does binarytext only apply to cp437??? we need to know the original encoding + if {[catch {punk::ansi::colour::byteAnsi $at} code]} { + puts stderr "renderspace err at charpair: $charpair [punk::ansi::ansistring VIEW ${ch}${at}]" + #append input [punk::ansi::a+ brightred White] \uFFef + set code [punk::ansi::a+ brightred White] } - bios { - #16 fg, 8 fg + possible blink - set input "" - set ansisplit [list ""] - set charpair 0 - foreach {ch at} [split $overblock ""] { - #review - does binarytext only apply to cp437??? we need to know the original encoding - set at [encoding convertto cp437 $at] - if {[catch {punk::ansi::colour::byteAnsi $at} code]} { - puts stderr "renderspace err at charpair: $charpair [punk::ansi::ansistring VIEW ${ch}${at}]" - #append input [punk::ansi::a+ brightred White] \uFFef - set code [punk::ansi::a+ brightred White] - set ch \uFFeF - } - append input $code $ch - lappend ansisplit $code $ch - incr charpair - } - #lappend inputchunks [list mixed $input] - lappend inputchunks [list ansisplit $ansisplit] + if {[catch {encoding convertfrom cp437 $ch} ch]} { + puts stderr "renderspace err at charpair: $charpair [punk::ansi::ansistring VIEW ${ch}${at}]" + set ch \uFFeF } - ice { - #16 fg, 16 bg (no blink) - set input "" - foreach {ch at} [split $overblock ""] { - set at [encoding convertto cp437 $at] - append input [punk::ansi::colour::byteAnsiIce $at]$ch - } - lappend inputchunks [list mixed $input] + append input $code $ch + lappend ansisplit $code $ch + incr charpair + } + #lappend inputchunks [list mixed $input] + lappend inputchunks [list ansisplit $ansisplit] + } + binarytext-ice { + #16 fg, 16 bg (no blink) + set input "" + foreach {ch at} [split $overblock ""] { + if {$at ne ""} { + append input [punk::ansi::colour::byteAnsiIce $at] } + set ch [encoding convertfrom cp437 $ch] + append input $ch } + lappend inputchunks [list mixed $input] } - } + xbin { + set parse_dict [punk::ansi::xbin::parse $overblock] + set ansisplit [dict get $parse_dict ansisplit] + set xbin_header_info [dict get $parse_dict header] + set flags [dict get $xbin_header_info flags] + set xbin_width [dict get $xbin_header_info width] + set xbin_height [dict get $xbin_header_info height] + puts stdout "xbin dimensions ${xbin_width}x${xbin_height} decoded [dict get $parse_dict decoded_cells] of [dict get $parse_dict expected_cells] expected cells" + puts stdout "xbin flags $flags" + set warnings [dict get $parse_dict warnings] + foreach w $warnings { + puts stderr "xbin warning: $w" + } + puts stdout "xbin decoded" + flush stdout + lappend inputchunks [list ansisplit $ansisplit] + } + } + #we have a list of 2 element input chunks {overtext_type overtext} in $inputchunks + #- each chunk is either a string of text with embedded ANSI codes (type 'mixed') + #- or a list of alternating ANSI code and text segments (type 'ansisplit') + #For ansi files each chunk may commonly correspond to a line of text - but this is not necessarily the case, as ANSI cursor movements and other codes may be present which affect the layout in ways that can't be determined until processing. + #for binary files - there may be no newlines at all - just a stream of bytes with ANSI codes interspersed to control the layout and colours. + #The chunks are processed in order, with the output of each chunk being rendered onto the current 'underlay' of the output, + #and then becoming the new 'underlay' for the next chunk to render onto. set replay_codes_underlay [tcl::dict::create 1 ""] @@ -631,13 +606,6 @@ tcl::namespace::eval overtype { set outputlines $underlines set overidx 0 - #underlines are not necessarily processed in order - depending on cursor-moves applied from overtext - set row 1 - #if {$data_mode} { - # set col [_get_row_append_column $row] - #} else { - set col $opt_startcolumn - #} set instruction_stats [tcl::dict::create] @@ -655,7 +623,10 @@ tcl::namespace::eval overtype { continue } #puts "----->[ansistring VIEW -lf 1 -vt 1 -nul 1 $overtext]<----" - set undertext [lindex $outputlines [expr {$row -1}]] + set undertext [lindex $outputlines [dict get $vtstate row]-1] + if {[tcl::dict::exists $replay_codes_underlay [dict get $vtstate row]]} { + set undertext [tcl::dict::get $replay_codes_underlay [dict get $vtstate row]]$undertext + } #renderline pads each underly line to width with spaces and should track where end of data is @@ -690,19 +661,17 @@ tcl::namespace::eval overtype { #} ###################### - set renderedrow $row + #remember the row we are just about to render. + set renderedrow [dict get $vtstate row] if {$renderedrow > $renderedrow_max} { set renderedrow_max $renderedrow } - if {[tcl::dict::exists $replay_codes_underlay $row]} { - set undertext [tcl::dict::get $replay_codes_underlay $row]$undertext - } #review insert_mode. As an 'overtype' function whose main function is not interactive keystrokes - insert is secondary - #but even if we didn't want it as an option to the function call - to process ansi adequately we need to support IRM (insertion-replacement mode) ESC [ 4 h|l - set renderopts [list -experimental $opt_experimental {*}{ + set renderopts [list {*}{ } -cp437 $opt_cp437 {*}{ } -info 1 {*}{ } -crm_mode [tcl::dict::get $vtstate crm_mode] {*}{ @@ -715,8 +684,8 @@ tcl::namespace::eval overtype { } -exposed1 $opt_exposed1 {*}{ } -exposed2 $opt_exposed2 {*}{ } -expand_right $opt_expand_right {*}{ - } -cursor_column $col {*}{ - } -cursor_row $row {*}{ + } -cursor_column [tcl::dict::get $vtstate col] {*}{ + } -cursor_row [tcl::dict::get $vtstate row] {*}{ } -overtext_type $overtext_type {*}{ } ] @@ -747,6 +716,8 @@ tcl::namespace::eval overtype { set visualwidth [tcl::dict::get $rinfo visualwidth] ;#column width of what is 'rendered' for the line set insert_lines_above [tcl::dict::get $rinfo insert_lines_above] set insert_lines_below [tcl::dict::get $rinfo insert_lines_below] + + #review - this assumes lines are rendered in order - but this isn't always true. tcl::dict::set replay_codes_underlay [expr {$renderedrow+1}] [tcl::dict::get $rinfo replay_codes_underlay] #lset replay_codes_overlay [expr $overidx+1] [tcl::dict::get $rinfo replay_codes_overlay] @@ -785,7 +756,7 @@ tcl::namespace::eval overtype { #-- todo - detect looping properly - if {$row > 1 && $overtext ne "" && $unapplied eq $overtext && $post_render_row == $row && $instruction eq ""} { + if {[dict get $vtstate row] > 1 && $overtext ne "" && $unapplied eq $overtext && $post_render_row == [dict get $vtstate row] && $instruction eq ""} { puts stderr "overtype::renderspace loop?" puts [ansistring VIEW $rinfo] break @@ -811,25 +782,23 @@ tcl::namespace::eval overtype { tcl::dict::incr instruction_stats $instruction_type switch -- $instruction_type { reset { - #reset the 'renderspace terminal' (not underlying terminal) - set row 1 - set col 1 + #reset the 'renderspace virtual terminal' (not underlying terminal) set vtstate [tcl::dict::merge $vtstate $initial_state] #todo - clear screen } {} { #end of supplied line input #lf included in data - set row $post_render_row - set col $post_render_col + dict set vtstate row $post_render_row + #dict set vtstate col $post_render_col if {![llength $unapplied_list]} { if {$overflow_right ne ""} { - incr row + dict incr vtstate row } } else { puts stderr "renderspace end of input line - has unapplied: [ansistring VIEW $unapplied] (review)" } - set col $opt_startcolumn + dict set vtstate col $opt_startcolumn } up { @@ -843,87 +812,42 @@ tcl::namespace::eval overtype { #puts stderr "up $post_render_row" #puts stderr "$rinfo" - #puts stdout "1 row:$row col $col" - set row $post_render_row - #data_mode (naming?) determines if we move to end of existing data or not. - #data_mode 0 means ignore existing line length and go to exact column - #set by -experimental flag - if {$data_mode == 0} { - set col $post_render_col - } else { - #This doesn't really work if columns are pre-filled with spaces..we can't distinguish them from data - #we need renderline to return the number of the maximum column filled (or min if we ever do r-to-l) - set existingdata [lindex $outputlines [expr {$post_render_row -1}]] - set lastdatacol [punk::ansi::printing_length $existingdata] - if {$lastdatacol < $renderwidth} { - set col [expr {$lastdatacol+1}] - } else { - set col $renderwidth - } - } - - #puts stdout "2 row:$row col $col" - #puts stdout "-----------------------" - #puts stdout $rinfo - #flush stdout + dict set vtstate row $post_render_row + dict set vtstate col $post_render_col } down { - if {$data_mode == 0} { + #cursor down. Will not force scroll if at bottom of screen. + if {$post_render_row > [llength $outputlines]} { #renderline doesn't know how far down we can go.. - if {$post_render_row > [llength $outputlines]} { - if {$opt_appendlines} { - set diff [expr {$post_render_row - [llength $outputlines]}] - set bce_line \x1b\[0m$replay_codes_overlay[string repeat \u0000 $renderwidth] - if {$diff > 0} { - lappend outputlines {*}[lrepeat $diff $bce_line] - #lappend outputlines {*}[lrepeat $diff ""] - } - lappend outputlines $bce_line - #lappend outputlines "" - } - } - set row $post_render_row - set col $post_render_col - } else { - puts stderr "renderspace down - data_mode 1 - review" - if {$post_render_row > [llength $outputlines]} { - if {$opt_appendlines} { - set diff [expr {$post_render_row - [llength $outputlines]}] - set bce_line \x1b\[0m$replay_codes_overlay[string repeat \u0000 $renderwidth] - if {$diff > 0} { - lappend outputlines {*}[lrepeat $diff $bce_line] - #lappend outputlines {*}[lrepeat $diff ""] - } - lappend outputlines $bce_line - #lappend outputlines "" + set post_render_row [llength $outputlines] + } + dict set vtstate row $post_render_row + dict set vtstate col $post_render_col + } + down_scrolling { + #todo - scrolling region. take account of decstbm. + + #renderline doesn't know how far down we can go.. + if {$post_render_row > [llength $outputlines]} { + if {$opt_appendlines} { + set diff [expr {$post_render_row - [llength $outputlines]}] + set bce_line \x1b\[0m$replay_codes_overlay[string repeat \u0000 $renderwidth] + if {$diff > 0} { + lappend outputlines {*}[lrepeat $diff $bce_line] } + lappend outputlines $bce_line } - # ---- - # review - set col $post_render_col - #just because it's out of range of the renderwidth - doesn't mean a move down should jump to within the range - 2025 - #---- - - #set existingdata [lindex $outputlines [expr {$post_render_row -1}]] - #set lastdatacol [punk::ansi::printing_length $existingdata] - - #set col [expr {$lastdatacol+1}] - - #if {$lastdatacol < $renderwidth} { - # set col [expr {$lastdatacol+1}] - #} else { - # set col $renderwidth - #} - } + dict set vtstate row $post_render_row + dict set vtstate col $post_render_col } restore_cursor { #testfile belinda.ans uses this #puts stdout "[a+ blue bold]CURSOR_RESTORE[a]" if {[tcl::dict::exists $cursor_saved_position row]} { - set row [tcl::dict::get $cursor_saved_position row] - set col [tcl::dict::get $cursor_saved_position column] + dict set vtstate row [tcl::dict::get $cursor_saved_position row] + dict set vtstate col [tcl::dict::get $cursor_saved_position column] #puts stdout "restoring: row $row col $col [ansistring VIEW $cursor_saved_attributes] [a] unapplied [ansistring VIEWCODES $unapplied]" #set nextprefix $cursor_saved_attributes #lset replay_codes_overlay [expr $overidx+1] $cursor_saved_attributes @@ -971,6 +895,47 @@ tcl::namespace::eval overtype { set overflow_handled 1 } + decstbm { + #scrolling region - CSI r + #renderline will have rendered the line based on the current vtstate row/col + #- but the scrolling region change may have caused a move to be rendered to the output which changes the row/col for the next line + #- so we need to update our vtstate cursor position. + lassign $instruction _ margin_top margin_bottom + + set margins_valid 1 ;#default assumption + #todo - validate margins. A valid scrolling region requires at least two lines. + if {$margin_top eq ""} {set margin_top 1} + if {$margin_bottom eq ""} {set margin_bottom $screen_rows} + if {![string is integer -strict $margin_top] || $margin_top < 1} { + puts stderr "DECSTBM invalid margin_top '$margin_top' [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + set margins_valid 0 + } + if {![string is integer -strict $margin_bottom] || $margin_bottom < 1} { + puts stderr "DECSTBM invalid margin_bottom '$margin_bottom' [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + set margins_valid 0 + } + if {$margin_bottom - $margin_top < 1} { + puts stderr "DECSTBM invalid margins - bottom '$margin_bottom' must be greater than top '$margin_top' [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + set margins_valid 0 + } + if {$margins_valid} { + #todo - return these for the caller to process.. + puts stderr "overtype::renderspace DECSTBM set top and bottom margin not implemented" + #Also moves the cursor to col 1 line 1 of the page + #review - examine DECOM state to determine new cursor position? + dict set vtstate row 1 + dict set vtstate col 1 + + #incr idx_over + #priv::render_to_unapplied $overlay_grapheme_control_list $gci + #set instruction [list decstbm $margin_top $margin_bottom] + dict set vtstate topmargin $margin_top + dict set vtstate bottommargin $margin_bottom + } else { + puts stderr "overtype::renderspace DECSTBM invalid margins - ignoring [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + #don't update the vtstate margins. + } + } move { ######## if {$post_render_row > [llength $outputlines]} { @@ -982,67 +947,95 @@ tcl::namespace::eval overtype { if {$diff > 0} { lappend outputlines {*}[lrepeat $diff $bce_line] } - set row $post_render_row + dict set vtstate row $post_render_row } else { - set row [llength $outputlines] + dict set vtstate row [llength $outputlines] } } else { - set row $post_render_row + dict set vtstate row $post_render_row } ####### - set col $post_render_col + dict set vtstate col $post_render_col #overflow + unapplied? } + clear_to_end_display { + #ED 0 + #review - needs to operate within top and bottom margins if set (decstbm) - but for now we assume full screen clear + #Current row already partially erased by renderline. + if {$post_render_row > [llength $outputlines]} { + dict set vtstate row [llength $outputlines] + } else { + dict set vtstate row $post_render_row + } + dict set vtstate col $post_render_col + set overflow_right "" + + set start_idx [expr {[dict get $vtstate row]}] + if {$start_idx < 0} {set start_idx 0} + for {set i $start_idx} {$i < [llength $outputlines]} {incr i} { + lset outputlines $i \x1b\[0m$replay_codes_overlay[string repeat \u0000 $renderwidth]\x1b\[0m + } + } + clear_to_start_display { + #ED 1 + #Current row already partially erased by renderline. + if {$post_render_row > [llength $outputlines]} { + dict set vtstate row [llength $outputlines] + } else { + dict set vtstate row $post_render_row + } + dict set vtstate col $post_render_col + set overflow_right "" + + set stop_idx [expr {[dict get $vtstate row] - 1}] + if {$stop_idx >= [llength $outputlines]} { + set stop_idx [expr {[llength $outputlines] - 1}] + } + for {set i 0} {$i < $stop_idx} {incr i} { + lset outputlines $i \x1b\[0m$replay_codes_overlay[string repeat \u0000 $renderwidth]\x1b\[0m + } + } clear_and_move { - #e.g 2J + #ED 2J if {$post_render_row > [llength $outputlines]} { - set row [llength $outputlines] + dict set vtstate row [llength $outputlines] } else { - set row $post_render_row + dict set vtstate row $post_render_row } - set col $post_render_col + dict set vtstate col $post_render_col set overflow_right "" ;#if we're clearing - any overflow due to insert_mode is irrelevant - set clearedlines [list] - foreach ln $outputlines { - lappend clearedlines \x1b\[0m$replay_codes_overlay[string repeat \u0000 $renderwidth]\x1b\[0m - - #set lineparts [punk::ansi::ta::split_codes $ln] - #set numcells 0 - #foreach {pt _code} $lineparts { - # if {$pt ne ""} { - # foreach grapheme [punk::char::grapheme_split $pt] { - # switch -- $grapheme { - # " " - - - _ - ! - @ - # - $ - % - ^ - & - * - = - + - : - . - , - / - | - ? - - # a - b - c - d - e - f - g - h - i - j - k - l - m - n - o - p - q - r - s - t - u - v - w - x - y - - # z - A - B - C - D - E - F - G - H - I - J - K - L - M - N - O - P - Q - R - S - T - U - V - W - X - Y - Z - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 { - # incr numcells 1 - # } - # default { - # if {$grapheme eq "\u0000"} { - # #review - # incr numcells 1 - # } elseif {$grapheme eq "\t"} { - # #set tstops [lsort -integer -unique [punk::console::get_tabstops]] - # puts stderr "tab at numcells: $numcells - REVIEW renderspace" - # set nexttabstop [expr {((int($numcells / 8) + 1) * 8)}] - # incr numcells [expr {$nexttabstop - $numcells}] - # } else { - # incr numcells [grapheme_width_cached $grapheme] - # } - # } - # } - - # } - # } - #} - ##replays/resets each line - #lappend clearedlines \x1b\[0m$replay_codes_overlay[string repeat \u0000 $numcells]\x1b\[0m + for {set i 0} {$i < [llength $outputlines]} {incr i} { + lset outputlines $i \x1b\[0m$replay_codes_overlay[string repeat \u0000 $renderwidth]\x1b\[0m } - set outputlines $clearedlines #todo - determine background/default to be in effect - DECECM ? puts stderr "replay_codes_overlay: [ansistring VIEW $replay_codes_overlay]" - #lset outputlines 0 $replay_codes_overlay[lindex $outputlines 0] - + } + delete_lines { + #DL n + set delete_count [lindex $instruction 1] + set r $renderedrow + puts stderr "delete_lines $delete_count at row $r" + if {$delete_count > 0} { + #set outputlines [lreplace $outputlines [dict get $vtstate row] [expr {[dict get $vtstate row] + $delete_count - 1}]] + set delidx_first [expr {$r - 1}] ;#convert to 0-based index + set delidx_last [expr {$delidx_first + ($delete_count - 1)}] ;#inclusive index of last line to delete + #if delete_count is 1 - we are only deleting the current line. + ledit outputlines $delidx_first $delidx_last + } + dict set vtstate row $renderedrow + if {[llength $outputlines] < [dict get $vtstate row]} { + dict set vtstate row [llength $outputlines] + } + #we need to ensure 'unapplied' data is still applied to the current line after deletion. + #Any overflow on the current line should be abandoned. + if {[llength $unapplied_ansisplit]} { + #set inputchunks [linsert $inputchunks 0 $nextprefix] + #JMN - assume backwards compat ledit available from punk::lib (for tcl <9) + ledit inputchunks -1 -1 [list ansisplit $unapplied_ansisplit] + } + incr overidx + incr loop + continue } lf_start { #raw newlines @@ -1051,9 +1044,9 @@ tcl::namespace::eval overtype { #test - treating as newline below... #append rendered $overflow_right #set overflow_right "" - set row $renderedrow - incr row - if {$row > [llength $outputlines]} { + + dict set vtstate row [expr {$renderedrow + 1}] + if {[dict get $vtstate row] > [llength $outputlines]} { #lappend outputlines "" # BCE lappend outputlines \x1b\[0m$replay_codes_overlay[string repeat \u0000 $renderwidth] @@ -1062,137 +1055,88 @@ tcl::namespace::eval overtype { # ---------------------- } lf_mid { - set edit_mode 0 - if {$edit_mode} { - #set inputchunks [linsert $inputchunks 0 $overflow_right$unapplied] - #JMN - #ledit inputchunks -1 -1 $overflow_right$unapplied - - set pt_ansi_pt [punk::ansi::ta::split_codes_single $overflow_right] - #join the trailing and leading pt parts of the 2 lists - ledit pt_ansi_pt end end "[lindex $pt_ansi_pt end][lindex $unapplied_ansisplit 0]" - lappend pt_ansi_pt [lrange $unapplied_ansisplit 1 end] - - ledit inputchunks -1 -1 [list ansisplit $pt_ansi_pt] ;#combined overflow_right and unapplied - in ansisplit form - + if {$overflow_right ne ""} { + if {$opt_expand_right} { + append rendered $overflow_right set overflow_right "" - set unapplied "" - set unapplied_list [list] - set unapplied_ansisplit [list] - - set row $post_render_row - #set col $post_render_col - set col $opt_startcolumn - if {$row > [llength $outputlines]} { - #lappend outputlines {*}[lrepeat 1 ""] - lappend outputlines \x1b\[0m$replay_codes_overlay[string repeat \u0000 $renderwidth] - } } else { - if 1 { - if {$overflow_right ne ""} { - if {$opt_expand_right} { - append rendered $overflow_right - set overflow_right "" - } else { - #review - we should really make renderline do the work...? - set overflow_width [punk::ansi::printing_length $overflow_right] - if {$visualwidth + $overflow_width <= $renderwidth} { - append rendered $overflow_right - set overflow_right "" - } else { - if {[tcl::dict::get $vtstate autowrap_mode]} { - #set outputlines [linsert $outputlines $renderedrow $overflow_right] - #ledit outputlines $renderedrow $renderedrow-1 $overflow_right - puts stderr "REVIEW wrap overflow_right to next line: $overflow_right" - #this looks wrong - ledit outputlines $renderedrow -1 $overflow_right - set overflow_right "" - set row [expr {$renderedrow + 2}] - } else { - set overflow_right "" ;#abandon - } + #review - we should really make renderline do the work...? + set overflow_width [punk::ansi::printing_length $overflow_right] + if {$visualwidth + $overflow_width <= $renderwidth} { + append rendered $overflow_right + set overflow_right "" + } else { + if {[tcl::dict::get $vtstate autowrap_mode]} { + #set outputlines [linsert $outputlines $renderedrow $overflow_right] + #ledit outputlines $renderedrow $renderedrow-1 $overflow_right + puts stderr "REVIEW wrap overflow_right to next line: $overflow_right" + #this looks wrong + ledit outputlines $renderedrow -1 $overflow_right + set overflow_right "" + #review - why are we setting this here when we override it below? + dict set vtstate row [expr {$renderedrow + 2}] + } else { + set overflow_right "" ;#abandon + } - if {0 && $visualwidth < $renderwidth} { - puts stderr "visualwidth: $visualwidth < renderwidth:$renderwidth" - error "incomplete - abandon?" - set overflowparts [punk::ansi::ta::split_codes $overflow_right] - set remaining_overflow $overflowparts - set filled 0 - foreach {pt code} $overflowparts { - lpop remaining_overflow 0 - if {$pt ne ""} { - set graphemes [punk::char::grapheme_split $pt] - set add "" - set addlen $visualwidth - foreach g $graphemes { - set w [overtype::grapheme_width_cached $g] - if {$addlen + $w <= $renderwidth} { - append add $g - incr addlen $w - } else { - set filled 1 - break - } - } - append rendered $add - } - if {!$filled} { - lpop remaining_overflow 0 ;#pop code - } + if {0 && $visualwidth < $renderwidth} { + puts stderr "visualwidth: $visualwidth < renderwidth:$renderwidth" + error "incomplete - abandon?" + set overflowparts [punk::ansi::ta::split_codes $overflow_right] + set remaining_overflow $overflowparts + set filled 0 + foreach {pt code} $overflowparts { + lpop remaining_overflow 0 + if {$pt ne ""} { + set graphemes [punk::char::grapheme_split $pt] + set add "" + set addlen $visualwidth + foreach g $graphemes { + set w [overtype::grapheme_width_cached $g] + if {$addlen + $w <= $renderwidth} { + append add $g + incr addlen $w + } else { + set filled 1 + break } - set overflow_right [join $remaining_overflow ""] } + append rendered $add + } + if {!$filled} { + lpop remaining_overflow 0 ;#pop code } } - } - set row $post_render_row - set col $opt_startcolumn - if {$row > [llength $outputlines]} { - #lappend outputlines {*}[lrepeat 1 ""] - # BCE - #puts "row: $row > outputlines: [llength $outputlines] overlay replay:[ansistring VIEW $replay_codes_overlay]" - lappend outputlines \x1b\[0m$replay_codes_overlay[string repeat \u0000 $renderwidth] - } - } else { - #old version - known to work with various ansi graphics - e.g fruit.ans - # - but fails to limit lines to renderwidth when expand_right == 0 - append rendered $overflow_right - set overflow_right "" - set row $post_render_row - set col $opt_startcolumn - if {$row > [llength $outputlines]} { - lappend outputlines {*}[lrepeat 1 ""] + set overflow_right [join $remaining_overflow ""] } } } + } + dict set vtstate row $post_render_row + dict set vtstate col $opt_startcolumn + if {[dict get $vtstate row] > [llength $outputlines]} { + #lappend outputlines {*}[lrepeat 1 ""] + # BCE + #puts "row: $row > outputlines: [llength $outputlines] overlay replay:[ansistring VIEW $replay_codes_overlay]" + lappend outputlines \x1b\[0m$replay_codes_overlay[string repeat \u0000 $renderwidth] + } } lf_overflow { - #linefeed after renderwidth e.g at column 81 for an 80 col width - #we may also have other control sequences that came after col 80 e.g cursor save - - if 0 { - set lhs [overtype::left -width 40 -wrap 1 "" [ansistring VIEWSTYLE -nul 1 -lf 1 -vt 1 $rendered]] - set lhs [textblock::frame -title "rendered $visualwidth cols" -subtitle "row-$renderedrow" $lhs] - set rhs "" - - #assertion - there should be no overflow.. - puts $lhs - } - if {![tcl::dict::get $vtstate insert_mode]} { - assert {$overflow_right eq ""} lf_overflow should not get data in overflow_right when not insert_mode - } + #linefeed after renderwidth e.g at column 81 for an 80 col width + #we may also have other control sequences that came after col 80 e.g cursor save - set row $post_render_row - #set row $renderedrow - #incr row - #only add newline if we're at the bottom - if {$row > [llength $outputlines]} { - #lappend outputlines {*}[lrepeat 1 ""] - # BCE - lappend outputlines \x1b\[0m$replay_codes_overlay[string repeat \u0000 $renderwidth] - } - set col $opt_startcolumn + if {![tcl::dict::get $vtstate insert_mode]} { + assert {$overflow_right eq ""} lf_overflow should not get data in overflow_right when not insert_mode + } + dict set vtstate row $post_render_row + #only add newline if we're at the bottom + if {[dict get $vtstate row] > [llength $outputlines]} { + #lappend outputlines {*}[lrepeat 1 ""] + # BCE + lappend outputlines \x1b\[0m$replay_codes_overlay[string repeat \u0000 $renderwidth] + } + dict set vtstate col $opt_startcolumn } newlines_above { #we get a newlines_above instruction when received at column 1 @@ -1202,76 +1146,53 @@ tcl::namespace::eval overtype { puts "--->newlines_above" puts "rinfo: $rinfo" #renderline doesn't advance the row for us - the caller has the choice to implement or not - set row $post_render_row - set col $post_render_col + set temp_row $post_render_row if {$insert_lines_above > 0} { - set row $renderedrow + set temp_row $renderedrow #set outputlines [linsert $outputlines $renderedrow-1 {*}[lrepeat $insert_lines_above ""]] #ledit outputlines $renderedrow-1 $renderedrow-2 {*}[lrepeat $insert_lines_above ""] # BCE (background color erase) set bce_line \x1b\[0m$replay_codes_overlay[string repeat \u0000 $renderwidth] ledit outputlines $renderedrow-1 -1 {*}[lrepeat $insert_lines_above $bce_line] #ledit outputlines $renderedrow-1 -1 {*}[lrepeat $insert_lines_above ""] - incr row [expr {$insert_lines_above -1}] ;#we should end up on the same line of text (at a different index), with new empties inserted above + incr temp_row [expr {$insert_lines_above -1}] ;#we should end up on the same line of text (at a different index), with new empties inserted above #? set row $post_render_row #can renderline tell us? } + dict set vtstate row $temp_row + dict set vtstate col $post_render_col } newlines_below { #obsolete? - use for ANSI insert lines sequence - if {$data_mode == 0} { - puts --->nl_below - set row $post_render_row - set col $post_render_col - if {$insert_lines_below == 1} { - #set lhs [overtype::left -width 40 -wrap 1 "" [ansistring VIEWSTYLE -lf 1 -vt 1 $rendered]] - #set lhs [textblock::frame -title rendered -subtitle "row-$renderedrow" $lhs] - #set rhs "" - #if {$overflow_right ne ""} { - # set rhs [overtype::left -width 40 -wrap 1 "" [ansistring VIEWSTYLE -lf 1 -vt 1 $overflow_right]] - # set rhs [textblock::frame -title overflow_right $rhs] - #} - #puts [textblock::join $lhs $rhs] - - #rendered - append rendered $overflow_right - # + puts --->nl_below + set temp_row $post_render_row + set temp_col $post_render_col + if {$insert_lines_below == 1} { + #set lhs [overtype::left -width 40 -wrap 1 "" [ansistring VIEWSTYLE -lf 1 -vt 1 $rendered]] + #set lhs [textblock::frame -title rendered -subtitle "row-$renderedrow" $lhs] + #set rhs "" + #if {$overflow_right ne ""} { + # set rhs [overtype::left -width 40 -wrap 1 "" [ansistring VIEWSTYLE -lf 1 -vt 1 $overflow_right]] + # set rhs [textblock::frame -title overflow_right $rhs] + #} + #puts [textblock::join $lhs $rhs] + #rendered + append rendered $overflow_right + # - set overflow_right "" - set row $renderedrow - #only add newline if we're at the bottom - if {$row > [llength $outputlines]} { - set bce_line \x1b\[0m$replay_codes_overlay[string repeat \u0000 $renderwidth] - lappend outputlines {*}[lrepeat $insert_lines_below $bce_line] - #lappend outputlines {*}[lrepeat $insert_lines_below ""] - } - incr row $insert_lines_below - set col $opt_startcolumn - } - } else { - set row $post_render_row - if {$post_render_row > [llength $outputlines]} { - if {$opt_appendlines} { - set diff [expr {$post_render_row - [llength $outputlines]}] - set bce_line \x1b\[0m$replay_codes_overlay[string repeat \u0000 $renderwidth] - - if {$diff > 0} { - lappend outputlines {*}[lrepeat $diff $bce_line] - #lappend outputlines {*}[lrepeat $diff ""] - } - lappend outputlines $bce_line - #lappend outputlines "" - } - } else { - set existingdata [lindex $outputlines [expr {$post_render_row -1}]] - set lastdatacol [punk::ansi::printing_length $existingdata] - if {$lastdatacol < $renderwidth} { - set col [expr {$lastdatacol+1}] - } else { - set col $renderwidth - } + set overflow_right "" + set temp_row $renderedrow + #only add newline if we're at the bottom + if {$temp_row > [llength $outputlines]} { + set bce_line \x1b\[0m$replay_codes_overlay[string repeat \u0000 $renderwidth] + lappend outputlines {*}[lrepeat $insert_lines_below $bce_line] + #lappend outputlines {*}[lrepeat $insert_lines_below ""] } + incr temp_row $insert_lines_below + set temp_col $opt_startcolumn } + dict set vtstate row $temp_row + dict set vtstate col $temp_col } wrapmoveforward { #doesn't seem to be used by fruit.ans testfile @@ -1305,8 +1226,8 @@ tcl::namespace::eval overtype { set c $post_render_col } #puts stderr "wrapmoveforward - moving from row $row col $col to row $r col $c" - set row $r - set col $c + dict set vtstate row $r + dict set vtstate col $c } wrapmovebackward { set c $renderwidth @@ -1334,8 +1255,8 @@ tcl::namespace::eval overtype { } else { puts stderr "Wrapmovebackward - but postrendercol >= 1???" } - set row $r - set col $c + dict set vtstate row $r + dict set vtstate col $c } overflow { #normal single-width grapheme overflow @@ -1351,13 +1272,13 @@ tcl::namespace::eval overtype { #example trigger: textblock::frame -width 80 [ansicat us-pump_up_the_jam-355.ans 355x100] - set row $post_render_row ;#renderline will not advance row when reporting overflow char + set r $post_render_row ;#renderline will not advance row when reporting overflow char #puts stderr "overflow autowrap - wrap to next line row: $row autowrap: [tcl::dict::get $vtstate autowrap_mode] renderwidth: $renderwidth visualwidth: $visualwidth [ansistring VIEW $unapplied]" if {[tcl::dict::get $vtstate autowrap_mode]} { - incr row - set col $opt_startcolumn ;#whether wrap or not - next data is at column 1 ?? + incr r + set c $opt_startcolumn ;#whether wrap or not - next data is at column 1 ?? } else { - set col $post_render_col + set c $post_render_col #The overflow can only be triggered by a grapheme (todo cluster?) - but our unapplied could contain SGR codes prior to the grapheme that triggered overflow - so we need to skip beyond any SGRs #There may be more than one, because although the stack leading up to overflow may have been merged - codes between the last column and the overflowing grapheme will remain separate #We don't expect any movement or other ANSI codes - as if they came before the grapheme, they would have triggered a different instruction to 'overflow' @@ -1410,9 +1331,12 @@ tcl::namespace::eval overtype { set overflow_handled 1 #handled by dropping overflow if any } + dict set vtstate row $r + dict set vtstate col $c } overflow_splitchar { - set row $post_render_row ;#renderline will not advance row when reporting overflow char + set r $post_render_row ;#renderline will not advance row when reporting overflow char + set c $post_render_col #2nd half of grapheme would overflow - treggering grapheme is returned in unapplied. There may also be overflow_right from earlier inserts #todo - consider various options .. re-render a single trailing space or placeholder on same output line, etc @@ -1434,8 +1358,8 @@ tcl::namespace::eval overtype { #review - inefficient to re-split (return unapplied_tagged instead of unapplied_ansisplit?) set unapplied_ansisplit [punk::ansi::ta::split_codes_single $unapplied] } else { - set col $opt_startcolumn - incr row + set c $opt_startcolumn + incr r } } else { set overflow_handled 1 @@ -1458,13 +1382,14 @@ tcl::namespace::eval overtype { set unapplied_ansisplit [punk::ansi::ta::split_codes_single $unapplied] } } - + dict set vtstate row $r + dict set vtstate col $c } vt { #can vt add a line like a linefeed can? - set row $post_render_row - set col $post_render_col + dict set vtstate row $post_render_row + dict set vtstate col $post_render_col } set_window_title { set newtitle [lindex $instruction 1] @@ -1547,19 +1472,6 @@ tcl::namespace::eval overtype { lappend nextprefix_list {*}[lrange $unapplied_ansisplit 1 end] } - if 0 { - if {$nextprefix ne ""} { - set nextoveridx [expr {$overidx+1}] - if {$nextoveridx >= [llength $inputchunks]} { - lappend inputchunks $nextprefix - } else { - #lset overlines $nextoveridx $nextprefix[lindex $overlines $nextoveridx] - #set inputchunks [linsert $inputchunks $nextoveridx $nextprefix] - ledit inputchunks $nextoveridx -1 $nextprefix - } - } - } - if {[llength $nextprefix_list]} { #set inputchunks [linsert $inputchunks 0 $nextprefix] #JMN - assume backwards compat ledit available from punk::lib (for tcl <9) @@ -1578,7 +1490,6 @@ tcl::namespace::eval overtype { set debugmsg "" append debugmsg "${Y}${sep_header}${RST}" \n append debugmsg "looplimit $looplimit reached\n" - append debugmsg "data_mode:$data_mode\n" append debugmsg "opt_appendlines:$opt_appendlines\n" append debugmsg "prev_row :[tcl::dict::get $renderopts -cursor_row]\n" append debugmsg "prev_col :[tcl::dict::get $renderopts -cursor_column]\n" @@ -2258,7 +2169,6 @@ tcl::namespace::eval overtype { Default is \uFFFD - the unicode replacement char.} -cursor_restore_attributes -default "" -cp437 -default 0 -type boolean - -experimental -default {} -overtext_type -type string -choices {mixed plain ansisplit} -default mixed @values -min 2 -max 2 undertext -type string -help\ @@ -2303,8 +2213,10 @@ tcl::namespace::eval overtype { #At the moment we return a reset at the end of the renderline result instead of the replay codes. proc renderline {args} { - #todo - fix 'unapplied' mechanism.This is particularly inefficient for long lines, or data such as binarytext which is not line-based. - #All unapplied data is re-split/reprocessed repeatedly for each line! This is very wasteful and slow. + #------------------------------------------------------------------------------------------------------------------------------------- + #todo - fix 'unapplied' mechanism.This is particularly inefficient for long lines, or data such as binarytext/xbin which is not line-based. + #All unapplied data is re-split/reprocessed repeatedly for each line! This is very wasteful and very slow. + #------------------------------------------------------------------------------------------------------------------------------------- # ## ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### # renderline written from a left-right line orientation perspective as a first-shot at getting something useful. @@ -2374,7 +2286,6 @@ tcl::namespace::eval overtype { -exposed2 \uFFFD -cursor_restore_attributes "" -cp437 0 - -experimental {} -overtext_type mixed }] #-overtext_type plain|mixed|ansisplit @@ -2390,7 +2301,7 @@ tcl::namespace::eval overtype { set argsflags [lrange $args 0 end-2] tcl::dict::for {k v} $argsflags { switch -- $k { - -experimental - -cp437 - -width - -expand_right - -transparent - -startcolumn - -cursor_column - -cursor_row + -cp437 - -width - -expand_right - -transparent - -startcolumn - -cursor_column - -cursor_row - -crm_mode - -insert_mode - -autowrap_mode - -reverse_mode - -etabs - -info - -exposed1 - -exposed2 - -cursor_restore_attributes - -overtext_type { tcl::dict::set opts $k $v @@ -3863,6 +3774,7 @@ tcl::namespace::eval overtype { } B { #CUD - Cursor Down + #CSI n B #Row move - down lassign [split $param {;}] num modifierkey set replay_codes_overlay [punk::ansi::codetype::sgr_merge [lindex $overlay_grapheme_control_stacks $gci]] @@ -4189,10 +4101,34 @@ tcl::namespace::eval overtype { if {$param eq ""} {set param 0} switch -exact -- $param { 0 { - #clear from cursor to end of screen + #ED 0 - clear from cursor to end of screen (including cursor position) + #Current-line part can be done here; remaining lines are handled by caller. + set replay_codes_overlay [punk::ansi::codetype::sgr_merge [lindex $overlay_grapheme_control_stacks $gci]] + incr idx_over + if {[llength $outcols] && $idx < [llength $outcols]} { + priv::render_erasechar $idx [expr {[llength $outcols] - $idx}] + } + priv::render_to_unapplied $overlay_grapheme_control_list $gci + set instruction clear_to_end_display + break } 1 { - #clear from cursor to beginning of screen + #ED 1 - clear from start of screen to cursor + #Current-line part can be done here; previous lines are handled by caller. + set replay_codes_overlay [punk::ansi::codetype::sgr_merge [lindex $overlay_grapheme_control_stacks $gci]] + incr idx_over + if {[llength $outcols] && $idx >= 0} { + set count [expr {$idx + 1}] + if {$count > [llength $outcols]} { + set count [llength $outcols] + } + if {$count > 0} { + priv::render_erasechar 0 $count + } + } + priv::render_to_unapplied $overlay_grapheme_control_list $gci + set instruction clear_to_start_display + break } 2 { #clear entire screen CSI 2J @@ -4210,7 +4146,8 @@ tcl::namespace::eval overtype { break } 3 { - #clear entire screen. presumably cursor doesn't move - otherwise it would be same as 2J ? + #clear entire screen. As well as scrollback buffer if supported (unimplemented) + puts stderr "overtype::renderline ED 3 - clear entire screen and scrollback buffer if supported (unimplemented) [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" } default { @@ -4271,8 +4208,79 @@ tcl::namespace::eval overtype { } M { #CSI Pn M - DL - Delete Line - puts stderr "overtype::renderline DL - Delete Line - not implemented [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + if {$param eq "" || $param eq "0"} {set param 1}; #param=number of chars to delete + if {![string is integer -strict $param] || $param < 0} { + puts stderr "overtype::renderline DCH bad param '$param' - assuming 1 [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + set param 1 + } + priv::render_to_unapplied $overlay_grapheme_control_list $gci + #The current line will be deleted by the calling function - along with more below if param > 1 + #we clear the outcols so that the result for this line is empty. + ledit outcols 0 end + ledit understacks 0 end + ledit understacks_gx 0 end + #puts stderr "overtype::renderline DL - Delete Line - not implemented [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + #todo - rename insert_lines_below to affect_lines_below or something equally generic (use for multiple instructions) + set instruction [list delete_lines $param] + break + } + P { + #DCH - Delete Character(s) + #Deletes Pn characters from cursor position, shifts line left, + #and fills vacated rightmost cells with erased cells. + if {$param eq "" || $param eq "0"} {set param 1}; #param=number of chars to delete + if {![string is integer -strict $param] || $param < 0} { + puts stderr "overtype::renderline DCH bad param '$param' - assuming 1 [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + set param 1 + } + set orig_len [llength $outcols] + for {set di 0} {$di < $param} {incr di} { + priv::render_delchar $idx + } + #Maintain line width by padding erased cells at right edge. + set removed [expr {$orig_len - [llength $outcols]}] + for {set fi 0} {$fi < $removed} {incr fi} { + lappend outcols \u0000 + lappend understacks [list $replay_codes_overlay] + lappend understacks_gx [list] + #review - should we be appending gx0state here? or just empty list? + #- presumably we should be appending gx0state from the end of the line - which may be different from current gx0state if there are codes in the line that change it - but we don't want to track those changes as we delete chars - so maybe we should be appending the gx0state from the end of the line before deletion started? + #lappend understacks_gx [list $gx0state] + } + #cursor position doesn't change. + } + @ { + #ICH - Insert Character(s) + #Inserts Pn blank characters at the cursor position, shifts line right, + #and fills vacated leftmost cells with erased cells. + #The characters shifted beyond the right margin are lost. + if {$param eq "" || $param eq "0"} {set param 1}; #param=number of chars to insert + if {![string is integer -strict $param] || $param < 1} { + puts stderr "overtype::renderline ICH bad param '$param' - assuming 1 [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + set param 1 + } + set orig_len [llength $outcols] + if {$overflow_idx != -1 && $param > [llength $outcols]} { + #since characters at rhs are lost, we can't insert more than the width. + set param $orig_len + } + set this_sgrstack [lindex $overlay_grapheme_control_stacks $gci] + set this_gxstack [lindex $overstacks_gx $idx_over] + + #use space for inserted blanks; helper handles tab reflow + priv::render_insertgraphemes $idx [lrepeat $param " "] $this_sgrstack $this_gxstack + #Keep line width fixed unless expand-right mode is active. + if {$overflow_idx != -1} { + if {[llength $outcols] > $orig_len} { + #truncate + ledit outcols $orig_len end + ledit understacks $orig_len end + ledit understacks_gx $orig_len end + } + } + + #cursor position doesn't change. } T { #CSI Pn T - SD Pan Up (empty lines introduced at top) @@ -4328,16 +4336,36 @@ tcl::namespace::eval overtype { #This control function sets the top and bottom margins for the current page. You cannot perform scrolling outside the margins lassign [split $param {;}] margin_top margin_bottom - #todo - return these for the caller to process.. - puts stderr "overtype::renderline DECSTBM set top and bottom margin not implemented" - #Also moves the cursor to col 1 line 1 of the page - set cursor_column 1 - set cursor_row 1 + set margins_valid 1 ;#default assumption + #todo - validate margins. A valid scrolling region requires at least two lines. + if {$margin_top eq ""} {set margin_top 1} + if {$margin_bottom eq ""} {set margin_bottom $screen_rows} + if {![string is integer -strict $margin_top] || $margin_top < 1} { + puts stderr "DECSTBM invalid margin_top '$margin_top' [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + set margins_valid 0 + } + if {![string is integer -strict $margin_bottom] || $margin_bottom < 1} { + puts stderr "DECSTBM invalid margin_bottom '$margin_bottom' [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + set margins_valid 0 + } + if {$margin_bottom - $margin_top < 1} { + puts stderr "DECSTBM invalid margins - bottom '$margin_bottom' must be greater than top '$margin_top' [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + set margins_valid 0 + } + if {$margins_valid} { + #todo - return these for the caller to process.. + puts stderr "overtype::renderline DECSTBM set top and bottom margin not implemented" + #Also moves the cursor to col 1 line 1 of the page + set cursor_column 1 + set cursor_row 1 - incr idx_over - priv::render_to_unapplied $overlay_grapheme_control_list $gci - set instruction move ;#own instruction? decstbm? - break + incr idx_over + priv::render_to_unapplied $overlay_grapheme_control_list $gci + set instruction [list decstbm $margin_top $margin_bottom] + break + } else { + puts stderr "overtype::renderline DECSTBM invalid margins - ignoring [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + } } s { #code conflict between ansi emulation and DECSLRM - REVIEW @@ -4833,12 +4861,12 @@ tcl::namespace::eval overtype { } D { #\x84 - #index (IND) + #index (IND) ESC D #vt102-docs: "Moves cursor down one line in same column. If cursor is at bottom margin, screen performs a scroll-up" puts stderr "renderline ESC D not fully implemented" incr cursor_row priv::render_to_unapplied $overlay_grapheme_control_list $gci - set instruction down + set instruction down_scrolling #retain cursor_column break } @@ -4872,7 +4900,7 @@ tcl::namespace::eval overtype { } #ensure rest of *overlay* is emitted to remainder priv::render_to_unapplied $overlay_grapheme_control_list $gci - set instruction up ;#need instruction for scroll-down? + set instruction up ;#need instruction for screen to scroll-down? #retain cursor_column break } @@ -5398,17 +5426,9 @@ tcl::namespace::eval overtype { set in_tab_expansion [dict create idx $i remaining [expr {$this_tab_width -1}]] set this_char \t } elseif {$ch eq "\u0000"} { - if {$cp437_glyphs} { - #map all nulls including at tail to space - set this_char " " - } else { - set this_char " " - #if {$trailing_nulls && $i < $first_tail_null_posn} { - # append outstring " " ;#map inner nulls to space - #} else { - # append outstring \u0000 - #} - } + #map all nulls including at tail to space + set this_char " " + #review } else { set this_char $ch } diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/packagetest-0.1.8.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/packagetest-0.1.8.tm new file mode 100644 index 0000000000000000000000000000000000000000..5ab00010b2b5f414f3b827e86433879339478f1c GIT binary patch literal 12718 zcmch6cRZEh|F>Ns8QG)TNGV&x&WLOxlzp7R;W&pgtdLcdnM%^2B9xJ`A{mvDk+eu9 zGl?iA4LsL34@-83_91Z) zj(|X+iI6uD?TyBx&?s5R67565644|G4c35Ht`sbejKxD>FNP!y5r~j4hNP+riy{*s zF9HQmhWy-Nq2Q4>kifj?L`Ym4M@AFz2r||ejSGM%cz7R)0Fm7hWC-m~CL)kzGzt>; zBA~npC>d`A(i7o^mhnXsNmv3N!Vqwx&t*Kb?_eck|v~1 z_M-l=#3U>RI%tnXkdf}tL8>$H1fmxLhYdtS_E2{t_tTIG+GiA@g;yq8ccIGc_GZXe1d#SR2w=DY~%hs2PmIq49121thc` zAq@>k9xNuJ$rK_UIvBj%+sn7<{MXwwA^Sy#|4m8wL^xnD6iH|=vlxC2f8ZtBkc7@Z z7wA9|K+K9uRyK9v;Dal_#t?{T1gL+1pc!-!Uc6btU+S-pTeMtf1xT1PWIilZ1evcg zSm<9XY+)A;lr(_uIY0TYXd}FIWkXheI-dtC`fP>V5MPE>aPE@;mIIU`Kz?WliNJ#_ zhC2mNmPqg>VgW$o0+uNYdlH94kkHO^!0SvxyLqAU0C4PKfWx~1WW*8te%0CUdI2^4 zm+G982Wk|6D2$;bs^gZ)BO`IDs$?&?O_0bdh+2pt4(aR#i-9DT3to=)@L8}?)Gdpw zpU?#Khh&ac!R((xtVg3{Kqz1~ z1$V-QMzZXTUjA&Rve9hQ+K`@lT_!p@xm^uUfv*K$nbMG3sx2a*eL)=MR`Rf8F>{|XsM9- zopY#36}GYv6al}94CfWJX%Ro$1QaghBJSMkK%>Nd!QW7IcR|a^cVj5*c!X zsjnBzM8G!+jY9;GAi%)=uy_=~j|6$+5M+RXfN}%+iYMS@s67e+OpsbxvwiL`YX=)a z=cRZ7{uBUO6c94!eK|Q009dy<1`9e4cn&HA0pdyaBM?2Qe0MnyT#{^5zkuF=0@N4s zL<5EGmnX>IVO2~{ZZ4JNKzh#=nizz~!UYX}%?bZoVo}oo1)3a|jE1x=4CgazQG)&| z@_AQ7elP%l`vH+m0rw&JHiRdD(0QY%K9QMkm2(00#1s6$ePl`Q!YN9ikRdWLfa*B% z%HDxBqgKxR6=lWfz>DCI_%eU};;GOt@BFKd0ocK}IJ6gR4+->U_-yig=n;?~kpN=s zMnRKE&}IaYjKzTa9t1!U0ryk5Fu|1tM1E23f}9~y(9o`x(`rs_ptv^$umZ7vsQ){r z|Mb9rBH{0j1|Ui#n*Ozq{L&W03<6hKK!33R)CLZm=)&c4xoW>c^2@ki;ad5&xuC$p zH`Qw-GJwM0cTf_ze`;!KE=t{bY=zX}uz*|e?|RULFrdwWOTGi%6{O<4NvbRDUA$>t z5Q&0BqS0W=-~g}*=39%A{CB?nE=TB>c}wrK3+62TUSgUqjO;MrQ@q`X2o#k$f@ud4 z)HN2MAAo<5c5|SQ!Gas%9QeY8{O^O7(~AWa{{Chzri(Ltc^Ki=y{u)!e)!eD!L;Ll zOtU2}m=g#sM3)*4814Vd!{-AJB1a9{Tu%Y5&wkNQ$A3F-3D{8Za~iFn&p#_5`TxEp{9Tp(2| zYAbH0BMaFAzCooiNI>*KJB58ir3GGKR0BT%jwC@cU=j(MA9y#HIDpy!k_}S@611E< z!ezO<@FeD@KfeLypCtwFU%=u&82c}){=)`9<;Ns9NbGms!jsouVt$bY;I}#R7BUum zFC;eTpdbt8>J6q22w#B3)Oq3DsP>P+-vTl%e9zAbynq^@ip2~ufNIT+c;`eep6nus zAU%JHmzj4vwT9q4o%21&R_gc|1-S+Q=7^_&;LneEy{U)`VnwaMU!@3NeQ;nbAp7^? zgSGub(|te=b#M%(%Mf5ofL6ev2dB*!47hs1BmziBEX;>t+WmX1yckFqs*gHN_6CN6 zf}9^S1A?}o>c17710f0E$`!L3w&9<30xy6+)O#ihvR|l?g)78@7SQs9{p*3Sy#FBM z|KD^P_^{tfThC*;1O_1SpC$HBg<(1W9}pcrW@S|W`5{{>!`S^b~6d6{pP9vU1x zKVkWEGClu4432*QAN>D2ziI^JGyve=Lr(zNXJpm2&sk$erOFyam+g3>lE2H%hH_laDbF7=JJF9%) zX`R^vqVFz?%{;4F4Rgm`#uInnoa!#9cpFA5Ph+Tet2~?Y1Oq0p{NQ(u1P)TGu+0=l z2%G-Md0t6I^V|2{j%;a+$^9H7Z+b<#_qDLw{nVRP?cM!7J%~@$x6d6`nMevfrQ+sx zRyoL}(68y?{?tPC3Ayolh8|w2tvkbPy-S+gQz~D+%y&|YQH%{&yD%VMm*KyeNxZs; zmyad%8#XD5_8|>1B{!vhCS+PeC)n@H@qzn0dZn3zFK9JwRCh!Rxx8g0$Lw_CkgeS; zT{5C6{Vej!9<8t+*gGvOBIYh9$J#@U+s?+y1tfnAwKL3CnW&7EQSRGY#>{)1PtxRP z_HJB{U`c%KeWl5dJetvKl-sYE;5+Lk2$kG!{M{J=`!hOu>VFPzof^xYz4(#0JGjwF z{m@6}dnX80=rMm<^*7h#!@3DO1gjt4y|ov~@#W#B(ASQ>w1MH0WR&M!S{a3v1e2^!{i<+Xg}Yp`M3vrvqe3X6G6v z_ieuLll4I$@24NkzFX2(yKbxP$a2WWcW1g-?9g+fC}pw9tlr9Uu`s+$XwfI{# zJ~l>&-ADAZmakAqZ&|L003hd0|z>aveY`zPMt6!fV2crjwH72V^Es4~_QeVS*8 zp?W^%rDqQ9aXTH_(@2XAu_MS2KhF7}cK(x^oa^J99ES>8JF!Kr@L6r*von|Z+4Xa6v$z(8 zsa@O(>pQmHA%Zhy_an=pHb1QXj&m|ik>vyZ>87TfEo;4)rxZu1lB-$y*9qkW$y? zeT(*Fmlge>HJcvmGI`7*lYk%HlS{Wb;Vu zw>X)tHp#?3mQsi^4ydUj+zr(fp2}@}LO!-vc>IpXaQ%~K+WPYLR)e_#MYs4_uITdkf=(XblZc_1(K4^S@i*5BMf$VFUz0$FxM-2vP z-JK#*3UA6ExRSKiEuB&C%*HPt44D%q6t`#@M^n)Hy=w{^WNut{jcwH9^mccmw{}CF ze}mX)!oirJLUPrb@|+qM>3IHqyXBgD_Kd^4Qrt(|!gH^XAKTg2O`+~*#NyE>5Tuj0 zQ2CUiLydlh{BkbgsePsbeU&G;hW6gsDCpSW(z;EUX^at-sKZ$<#47nNif2~M$WJlE z1|jR*l2h*>sMCvMR!Er{n8Kb+=0_Pr4Q7R}LPcpKnrm(-yRfRC`(#}4I-C=|aa9=m z`MuJY)i$?rAAr>h?+jX7ym%zUIbQ0~;BIb5)w^PvDl{Aeey-6Y!|u43d@_Jk1n zBatJbn?-;fI<{xE9$!pz$GMJD924AlItNr@llx|7{#_vXQw7sj>flBdq`ZDI1!Y0NyL!7DI%?)8Vm z&JC7nQcabY4Vt}KRiefrdq#E){|x;-_M(F(q7s1@%nEv*(MVD92TZkxcv;Ii%0i_g zpso_y%`zICq3y$}=_S2ndXLh)yNcG=SfuvVrE->^>J#uX@;}3?ZKuQISw|Xs{c~b? zIw4)6dwQZJfzVlB`h0^FD;+{;tCN8AnRwHgHj_u|t#8mI-8p;aqv$>3TSo>`x#V=1 z!uTHE5O6(}WxIc${B~ETleF}u#6;$(${7qK=6c}OX|a2k!s6Hr59T^O{29NF{P>Mj zBdgL6;~vrv=NR0p*U;7zClx2ZACzmVc83P7=}Wpwhb&Kcwvz968p&E`$DC577b};c zu}YNV#q4rx_tjDI+BLf)+gSPVdXn^Di+131oDE(qq+WcSUrjt)o?XjOu=M-K?hfyc zlZro9pZ!s-VZ;|^wAy}H`*q~B(NoP?O|2-SLIakw2o{#a>htSsrpa3d(q9$2f?n1t z)89ecB0qUIC0Zw$Xa94H;{rbnvj@etowMr3*j?J*ai%!RmZ^6P@hDSoSU>>giiY?J{=v@z(ux4?A((nJfmUEn~aIOqhi@ zuQAJUBr=X0iZ@(*uYCL+Q<$Mmx^N%!?Ix#6*N10EG;-xX=Ut$%|7g(PEVgMR?*X>? zc83^KN^ARWi{p-;%=U&i8tCC2$8uFOHcC7we4^Eumlc;59dTDZkCjJ2!2qjgJ)>NB z>3d~$frjs$qdL}s`kw|TQyiO%L-9Kz4C^f;yFA#M2QF0YC{H0_d*~3zq9Yc{=13>@ zw9Df>bX77YCrK&+3g60&Ayd@h>4q3qT9gxA&-;$hS)rJxtpk}&clgojW@E}~Ojk1m zuViYq*WA_2j#gmiO%%IFso36hU zXYyy8iV6D>UY3l8_7^x8HfhF$M#zTJ*Gg83hZiYI>n$O+S>8)glDCfrC+Dj2W@K?s?dIQmj6+@T1~s*H>(VV z%Vv^S)$=8#3cfRWSbKcAaYg#V4c-&87k)m?F?xhC-9GEIY40={``vMGVD|GYEf-#F zs}y3D)s-lkx8sO|se3XbSJL&Q>>$EL$F_m$VUsY~T z-)1(gcz{9D7RKk9PrCcLKbpKY7%_d^V%yHvufiiDg7;e`w)K!EV(q(Xb}}o09uayEY7d|IYv5<@40!qp4o?Ycp?HxH3L-+iQ3D8@-Qq z)m{ZRq;$*sd=bCcdq&F5XeT|5FP8Pu1;bU1eNJ{4Dz9r)G&Jc|D)>x%e|{~2P|%6r zL@(1&?)AynWmMZ_<6ik|d5y*eFqkd!y6>%s zLKZ$8$$TXcn_3es5gJH|ef$jBC9aZ#G=AsRy`TSGXD70|N4M}k*@&|PZ`aj>+)+Hr z-loQwkC=oMXY%^lue;i?N!j|>#}y&lcgTG4Vh*gJV-w#f85VTM&*8-ei$Ole2*w6a zd$sR8HF8}DIx)lD?@c-GBE~vgc@^+4I9U$mKmwMP@t2-G^x5yCRI{U1*Mx#if>)k^4J*&m4JHvEj*PqVYm{IaHjgM=aFw*3Gy2Y~8u7 zt~^nqyj}B+xWxt*_4soV1Em>O8*D>INZazquL)tgh1Re4nshF8R*zJ=hyMYh^7x zqh{Uk&Bq6ID>nIH?tgra9qRioIv`j!U=?(+^fRG+YTZ{Bq7O)!uHB;&G3EuLsv6aa(Im+U+v8w8yX8QI3BokxN;}wi-F3FS*zRC+*bYH z(`s2>d_zk$h>VBt>6g4ZDYh-&Qz`PpA<;WVc?WKg3cc)tVp}&suIpSL5=JKuM_7n; z6w?$4G@i?@;)o~tOF5%z!f!kJtqs4;?=ES6k1apbcxzs2`s%(L5Rxo$hr8xB)R`L*`q4>qB~l16)~xXf2yr zi0P~JwR_W__a&Q@zspP$>pvi(>$Zw%yL8lDE@m~OS{t17h{aBB%;1*im(ri#*tyPz0)RYf4uQ`!* z-n(k3@jQnx@zHgqr>tKdX7}HW)Ns0Swtu(e*(WUWn-cT;LNB-QD|&KdhE!=>CRO65 z=nuTG5Fw@-i7SqbGGk|h`O+17*PYF6=RUQG!~N?u-XD044HvyQwfYASn@ah%_r6%; zb$1U`Zz1m~UF+iYnp?S9-A{Qass@wl_&A4^=H_S3odddz$Mi>5iJa0uUE~|DaOGH< zU2l7=;59;olX%AGwT@>Mrp6OFENgAlbu89uq{b-(v!1wg`VP%cN-{pp=F@C?|J%C- zV+l>c=?Fr|$BQPP8&73gii%fp;kB@`fjC_e{bp{Oo4f91 z&d6}7wXfYhvc`MQ>o1@AlQkK9QH&O6Y?U$5-)5?W}9=)-1edS$x^%!tPo|;ToDs#G@Csc6)K+ zu0g^==HETiug)awvCy)b=ImJ8+qJ*oOz!UE5%}%2#yi|?dXVMQ468lmT8o@^@=!i} zEGl4kyW~`oo2DYf5uzgS=%7zot@7;At64uZu3Z*ONTjfte^c7>gX_ventU($FPaX= znlqIx9}ExQ+MW@2l*4ef^<)Z* zu8@IX-*xNcWWjCM6+|TJtSV3`_pu!^9jnzx^c^p}qu-aPhLVc3@IT0v=zt&B&tln- zz#KD%vXv6Qc*jOF=OQuZvgWIfNPz&Bz9Uz|f10GQ1*IFb8Tx4s8Ab^vr&qYoWY=li*iY8;E+eE&f0K@D=Sp~I_<;j&?Y z=Z~sODJCA}zApJZUN9)IsMz2O@0;wJ;sIg=CCOV@=gl$bb#mg(3BCS2^t7zOHE}Lx z@szjLA);fZbPUY1#uaigmjd+eALRc%ZyeiFNC(A+0#aGegi!S={~Ekcpn@ zr$07i5%Ua`_RCy7smJJW+~}>I1p|+R$f*sQcGbln^hg(jDYWk{tRHG~*|Nn##W?7*`zt@5aF?PU`h&E7GVg{C!^|4i;| z3ut*QJw6#NmTAHzcg#Da?EAaXqPi0?A8%9`2}p)u>Pijy4@JuD!;O~uwC5O>Y-4)a z*BasXZ8%-~{pGRIsCByzRjcl36R%#oVeNZKQI1N(eih~yd_Ii&kDn5bZ1Vg_n`I!my>AwmU_)1hDx7VYU|}tdio<@YITEW zQKPB*qhyb4m)){0#a8Y19>4n^%x{-}dQu@(VE9$Nf%c$+MI)ndjq>|Dx9)po|LRN!X=`TkCy&!J@!9NZ>&|}l z?!g!Tu=4FW+r{@|#~WJ~_qM&7sXN)YLZmw$&6* zwz*qNC!wszhc&qCj=Eo>8DVnl;`q!C0P{wl{`MEXZ}RTAq^xUB8GE-j+~VRMyTjc9 z=B1W=w_CZAWLNKv-y7h=U2!g=e)tkiyTzWvQKo{0H0@6sYI20Qc=Zp~__lp!y>j$| zaIhM|`hAsSG5-2fxfY$$fU(nM6T<$Gu+LY$;og$ISw;(ETDtW#e;=8HsrjPM|89V8 UVa&(`Z>9zR9Kg2%FZ}EO06j*}rvLx| literal 0 HcmV?d00001 diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk-0.1.1.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk-0.1.1.tm new file mode 100644 index 00000000..e3ba36b4 --- /dev/null +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk-0.1.1.tm @@ -0,0 +1,9302 @@ +#Punk - where radical modification is a craft and anti-patterns are another exploratory tool for the Pattern Punk. +#Built on Tcl of course - because it's the most powerful piece of under-appreciated and alternate-thinking engineering you can plug into. + + +namespace eval punk { + proc lazyload {pkg} { + #experimental - for binary packages that have significant load time. + package require zzzload + if {[package provide $pkg] eq ""} { + zzzload::pkg_require $pkg + } + } + #lazyload twapi ? + + catch {package require vfs} ;#attempt load now so we can use faster 'package provide' to test existence later + + variable can_exec_windowsapp + set can_exec_windowsapp unknown ;#don't spend a potential X00ms testing until needed + variable windowsappdir + set windowsappdir "" + variable cmdexedir + set cmdexedir "" + + proc sync_package_paths_script {} { + #the tcl::tm namespace doesn't exist until one of the tcl::tm commands + #is run. (they are loaded via ::auto_index triggering load of tm.tcl) + #we call tcl::tm::list to trigger the initial set of tm paths before + #we can override it, otherwise our changes will be lost + #REVIEW - won't work on safebase interp where paths are mapped to {$p(:x:)} etc + list apply {{ap tmlist} { + set ::auto_path $ap + tcl::tm::list + set ::tcl::tm::paths $tmlist + }} $::auto_path [tcl::tm::list] + } + + + + proc ::punk::auto_execok_original name [info body ::auto_execok] + variable better_autoexec + + + #use this var via better_autoexec only + set better_autoexec 1 + proc ::punk::auto_execok_windows name { + ::punk::auto_execok_better $name + } + + set has_commandstack [expr {![catch {package require commandstack}]}] + if {$has_commandstack} { + if {[catch { + package require punk::packagepreference + } errM]} { + catch {puts stderr "Failed to load punk::packagepreference"} + } + catch punk::packagepreference::install + } else { + # + } + + if {![interp issafe] && $::tcl_platform(platform) eq "windows"} { + + #return the raw command string from the registry for the association of the given extension, without processing the placeholders such as %1 %SystemRoot% etc. + #This is because we want to process these ourselves to be able to return a proper list of command and arguments. + #Note that the resulting string can't be directly treated as a tcl list because it has double quoted segments with characters that are literals (not escaped) + #Accessing it directly as a list will cause tcl to interpret the backslashes as escapes and lose the literal meaning values such as the path. + proc extension_open_association {ext} { + #look up assoc and ftype to find associated file type and application. + #Note that the windows 'ftype' and 'assoc' commands only examine the system's data - not the user-specific data which may override the system data. + #to get the user-specific associations we need to read the registry keys. + + #extensions in the registry seem to be stored lower case wnd with a leading dot. + set lext [string tolower $ext] + package require registry + set user_assoc_path [join [list HKEY_CURRENT_USER Software Microsoft Windows CurrentVersion Explorer FileExts $lext UserChoice] "\\"] + + #The UserChoice subkey under this key is where the user-specific association is stored when the user has made a choice. It contains a Progid value which points to the associated file type. + #It can return something like "Python.File" or "Applications\python.exe" or even tcl_auto_file (for .tcl files associated with tclsh by a tcl installer) + + #The UserChoice key may not exist if the user hasn't made an explicit choice, in which case we fall back to the system association which is stored under HKEY_CLASSES_ROOT\$ext (which also contains user-specific overrides but is more cumbersome to query for them) + if {![catch {registry get $user_assoc_path Progid} user_choice]} { + if {$user_choice ne ""} { + #examples such as Applications\python.exe and tcl_auto_file are found under HKEY_CURRENT_USER\Software\Classes + #they then have a sub-path shell\open\command which contains the command to open files of that type, which is what we need to extract the associated application. + #it is faster to query for the key directly within a catch than to retrieve keys as lists and iterate through them to find the one we want. + if {![catch {registry get [join [list HKEY_CURRENT_USER Software Classes $user_choice shell open command] "\\"] ""} raw_assoc]} { + #The command string can contain placeholders like "%1" for the file name, so we need to extract just the executable path. + #e.g .py -> "c:\Program Files\Python\python.exe" "%1" + #e.g .rb -> "C:\tools\ruby31\bin\ruby.exe" "%1" %* + # e.g .vbs -> "%SystemRoot%\System32\WScript.exe" "%1" %* + #we need to process this without Tcl interpreting the backslashes as escapes. + #we will use double quotes to determine which entries belong together as a list item for the resulting list of command and arguments. + #set assoc [string map [list \\ \\\\] $raw_assoc] + set assoc $raw_assoc + } else { + #e.g Python.File + if {![catch {registry get [join [list HKEY_LOCAL_MACHINE SOFTWARE Classes $user_choice shell open command] "\\"] ""} raw_assoc]} { + #set assoc [string map [list \\ \\\\] $raw_assoc] + set assoc $raw_assoc + } else { + set assoc "" + } + } + + } else { + #review - is it possible for Progid to be empty string? If so we should probably fall back to system association instead of returning no association. + #alternatively it could mean the user has explicitly chosen to have no association for this file type - in which case returning an empty association may be the correct behaviour. + set assoc "" + } + } else { + #fall back to system association and ftype + if {![catch {registry get [join [list HKEY_LOCAL_MACHINE SOFTWARE Classes $lext] "\\"] ""} ftype]} { + #ftype is the file type associated with the extension, e.g "Python.File" + #we then need to look up the command associated with this file type under the same path but with the file type instead of the extension and with the additional sub-path shell\open\command + if {![catch {registry get [join [list HKEY_LOCAL_MACHINE SOFTWARE Classes $ftype shell open command] "\\"] ""} raw_assoc]} { + #set assoc [string map [list \\ \\\\] $raw_assoc] + set assoc $raw_assoc + } else { + set assoc "" + } + } else { + set assoc "" + } + } + return $assoc + } + + + } + + if {![interp issafe] && $has_commandstack && $::tcl_platform(platform) eq "windows"} { + + #still a caching version of auto_execok - but with proper(fixed) search order + + #set b [info body ::auto_execok] + #proc ::auto_execok_original name $b + + proc better_autoexec {{onoff ""}} { + variable better_autoexec + if {$onoff eq ""} { + return $better_autoexec + } + if {![string is boolean -strict $onoff]} { + error "better_autoexec argument 'onoff' must be a boolean, received: $onoff" + } + if {$onoff && ($onoff != $better_autoexec)} { + puts "Turning on better_autoexec - search PATH first then extension" + set better_autoexec 1 + proc ::punk::auto_execok_windows name { + ::punk::auto_execok_better $name + } + punk::auto_exec::rehash + } elseif {!$onoff && ($onoff != $better_autoexec)} { + puts "Turning off better_autoexec - search extension then PATH" + set better_autoexec 0 + proc ::punk::auto_execok_windows name { + ::punk::auto_execok_original $name + } + punk::auto_exec::rehash + } else { + puts "no change" + } + } + #better_autoexec $better_autoexec ;#init to default + + + proc auto_execok_better name { + #review - we have a gneral problem of auto_exec caching negative results for relative paths. + #A failed resolution of a relative path should not generate an entry in ::auto_execs. + #This happens in plain tclsh - so we need to determine where in Tcl this happens and fix it there. + #Simply returning an empty string here will still result in a negative cache entry. + #we want to cache negative results for absolute paths or plain filenames with no file-separator. + #e.g ./doesntexist.exe should not be cached as not found, but should be re-resolved every time. (cwd dependent) + #e.g doesntexist.exe should be cached as not found, because it will always be not found until it appears in the PATH. + #i.e it is required to prefix with ./ to exec a file in the current directory. (similar to unix shells) + + + global auto_execs env tcl_platform + #for now at least, auto_execok_better is windows-specific. + package require punk::auto_exec + + if {[info exists auto_execs($name)]} { + return $auto_execs($name) + } + #puts stdout "[a+ red]...[a]" + set auto_execs($name) "" + + set shellBuiltins [list {*}{ + assoc cls copy date del dir echo erase exit ftype + md mkdir mklink move rd ren rename rmdir start time type ver vol + }] + if {[info exists env(PATHEXT)]} { + # Add an initial ; to have the {} extension check first. + set execExtensions [split ";$env(PATHEXT)" ";"] + } else { + set execExtensions [list {} .com .exe .bat .cmd] + } + + if {[string tolower $name] in $shellBuiltins} { + # When this is command.com for some reason on Win2K, Tcl won't + # exec it unless the case is right, which this corrects. COMSPEC + # may not point to a real file, so do the check. + set cmd $env(COMSPEC) + if {[file exists $cmd]} { + set cmd [file attributes $cmd -shortname] + } + return [set auto_execs($name) [list $cmd /c $name]] + } + + if {[llength [file split $name]] != 1} { + #----------------------------------------------------- + #has a path component - could be relative or absolute. + #----------------------------------------------------- + if {[file pathtype $name] eq "relative"} { + #don't cache negative result for any relative paths - as they may become valid if the file appears in the relative location, or if the user changes directory and the same relative path points to a different file. + #our only way to do this is by cooperating with the unknown handler. + set auto_execs($name) "for_unknown_handler by punk::auto_exec relative_path - file existence should be re-checked at call time" + return $auto_execs($name) + } + + if {[string tolower [file extension $name]] eq ".lnk"} { + #special case .lnk + #todo - consider working directory or other properties of link before launching? + package require punk::winlnk + if {![catch {punk::winlnk::target $name} linktarget]} { + if {$linktarget ne ""} { + set target $linktarget + } else { + return "" + } + } else { + set target $name + } + } else { + set target $name + } + #always store $name as the key when setting auto_execs. + foreach ext $execExtensions { + set file ${target}${ext} + #first execExtension is empty string - ensure we test actual file as given before we try appending extensions. + if {$ext eq ""} { + set test_ext [file extension $file] + } else { + set test_ext $ext + } + if {[file exists $file] && ![file isdirectory $file]} { + #look up assoc and ftype to find associated file type and application. + #Note that the windows 'ftype' and 'assoc' commands only examine the system's data - not the user-specific data which may override the system data. + #set assoc [extension_open_association $ext] + set associnfo [punk::auto_exec::shell_open_command $test_ext] + set valuetype [dict get $associnfo type] + set assoc [dict get $associnfo value] + set windows_file_type [dict get $associnfo filetype] + if {$assoc eq ""} { + return [set auto_execs($name) [list $file]] + } else { + if {[file pathtype $target] eq "relative" && $windows_file_type eq "InternetShortcut"} { + #special case InternetShortcut - cannot accept relative path - so we can't cache it in auto_execs if we used a relative path to launch + #if we return an empty string - the auto_exec will fail to launch this every time. + #The best we can do is return a token for the 'unknown' process to detect and re-resolve the path every time. + #This requires cooperation from 'unknown' which may not be configured to handle this token if the default 'punk' version isn't installed. + + #we can't resolve using absolute path here - because we don't want to lock in a specific file for a relative path. + #e.g ::auto_execs(./link.url) = some.exe c:/desktop/link.url + #this would be wrong if the user changed directory and tried to run ./link.url again on a different file with the same name + # - as the cached path would no longer be correct. + return [set auto_execs($name) "for_unknown_handler by punk::auto_exec absolute_path required"] + } + puts stderr "auto_execok_better: (review required) assoc $assoc for file $file ext $test_ext" + set run [punk::auto_exec::shell_command_as_tcl_list -type $valuetype $assoc $file] ;# -workingdir [pwd] vs path of script? + return [set auto_execs($name) $run] + #return [set auto_execs($name) [list $file]] + } + } + } + #cache negative result for absolute paths - as they will always point to the same location, so if they don't exist now, they won't exist later. + set auto_execs($name) "" + return "" + } + + #change1 + #set path "[file dirname [info nameofexecutable]];.;" + set path "[file dirname [info nameofexecutable]];" + + + # ------------------------ + #Note that unlike an ordinary Tcl array - the linked ::env behaves differently. + #e.g parray ::env Path will not find ::env(PATH) and yet 'info exists env(Path)' returns true. + #similarly 'set ::env(Path) ?newval?' or any case variation can set/get the value of ::env(PATH) + #Windows environment variables are case-insensitive. + + #No evidence has been seen that any version of windows; current or historic since NT; can allow differently cased versions + # of an environment variable to exist concurrently in the same environment. + #for this reason we should be able to just use PATH. + # + if {[info exists env(PATH)]} { + append path ";$env(PATH)" + } + # ------------------------ + + if {[info exists env(SystemRoot)]} { + set windir $env(SystemRoot) + } elseif {[info exists env(WINDIR)]} { + set windir $env(WINDIR) + } + if {[info exists windir]} { + append path "$windir/system32;$windir/system;$windir;" + } + + #change2 + if {[file extension $name] ne "" && [string tolower [file extension $name]] in [string tolower $execExtensions]} { + set lookfor [list $name] + } else { + set lookfor [lmap ext $execExtensions {string cat ${name} ${ext}}] + } + #puts "-->$lookfor" + + + foreach dir [split $path {;}] { + set dir [string trim $dir {\\}] ;#trailing slash will result in a tail such as "/python.exe" + #set dir [file normalize $dir] + # Skip already checked directories + if {[info exists checked($dir)] || ($dir eq "")} { + continue + } + set checked($dir) {} + + #surprisingly fast + #set matches [glob -nocomplain -dir $dir -types f -tails {*}$lookfor] + ##puts "--dir $dir matches:$matches" + #if {[llength $matches]} { + # set file [file join $dir [lindex $matches 0]] + # #puts "--match0:[lindex $matches 0] file:$file" + # return [set auto_execs($name) [list $file]] + #} + + #what if it's a link? + #foreach match [glob -nocomplain -dir $dir -types f -tail {*}$lookfor] { + # set file [file join $dir $match] + # if {[file exists $file]} { + # return [set auto_execs($name) [list $file]] + # } + #} + + #safest? could be a link? + foreach match [glob -nocomplain -dir $dir -tail -- {*}$lookfor] { + set file [file join $dir $match] + if {[file exists $file] && ![file isdirectory $file]} { + #set assoc [extension_open_association [file extension $file]] + #todo - cache this lookup for each extension we encounter? maybe not, as the user might like changes reflected between runs. review. + if {"windows" ne $::tcl_platform(platform)} { + return [set auto_execs($name) [list $file]] + } + + set associnfo [punk::auto_exec::shell_open_command [file extension $file]] + set assoc [dict get $associnfo value] + set type [dict get $associnfo type] + if {$assoc eq ""} { + return [set auto_execs($name) [list $file]] + } else { + puts stderr "auto_execok_better: assoc $assoc for file $file with type $type" + #return [set auto_execs($name) [list $file]] + #review - our stored auto_execs doesn't have any way to capture the full assoc info such as how subsequent arguments should be processed. + #This may need handling in our Tcl shell 'unknown' function when calls are actually made to these commands + #- we may need to re-process the assoc info at that point to determine how to combine all arguments with the calling specification in the assoc string. + #The workingdir for the command may also need to be determined at that point - should it be the dir of the script being called, or the current dir of the shell? + + #The main point of Tcl's auto_execs is to avoid scanning the PATH entries every time a command is called, + #but we may want to keep some of the assoc info available for processing at call time. + set run [punk::auto_exec::shell_command_as_tcl_list -type $type $assoc $file] ;# -workingdir [pwd] vs path of script? + return [set auto_execs($name) $run] + } + } + } + } + + #foreach ext $execExtensions { + #unset -nocomplain checked + #foreach dir [split $path {;}] { + # # Skip already checked directories + # if {[info exists checked($dir)] || ($dir eq "")} { + # continue + # } + # set checked($dir) {} + # set file [file join $dir ${name}${ext}] + # if {[file exists $file] && ![file isdirectory $file]} { + # return [set auto_execs($name) [list $file]] + # } + #} + #} + return "" + } + + + + #review - what if punk package reloaded - but ::auto_execs has updated path for winget.exe? + #what if we create another interp and use the same ::auto_execs? The appdir won't be detected. + #TODO - see if there is a proper windows way to determine where the 'reparse point' apps are installed + + + + #winget is installed on all modern windows (but not on windows sandbox!) and is an example of the problem this addresses + #we target apps with same location + + #the main purpose of this override is to support windows app executables (installed as 'reparse points') + #for Tcl versions prior to the 2025-01 fix by APN https://core.tcl-lang.org/tcl/tktview/4f0b5767ac + #versions prior to this will use cmd.exe to resolve the links + set stackrecord [commandstack::rename_command -renamer ::punk auto_execok name { + #set windowsappdir "%appdir%" + upvar ::punk::can_exec_windowsapp can_exec_windowsapp + upvar ::punk::windowsappdir windowsappdir + upvar ::punk::cmdexedir cmdexedir + + if {$windowsappdir eq ""} { + #we are targeting the winget location under the presumption this is where microsoft store apps are stored as 'reparse points' + #Tcl (2025) can't exec when given a path to these 0KB files + #This path is probably something like C:/Users/username/AppData/Local/Microsoft/WindowsApps + if {!([info exists ::env(LOCALAPPDATA)] && + [file exists [set testapp [file join $::env(LOCALAPPDATA) "Microsoft" "WindowsApps" "winget.exe"]]])} { + #should be unlikely to get here - unless LOCALAPPDATA missing (or winget.exe missing e.g windows sandbox) + set windowsappdir [file dirname [lindex [::punk::auto_execok_windows winget.exe] 0]] + catch {puts stderr "(resolved winget by search)"} + } else { + set windowsappdir [file dirname $testapp] + } + } + + #set default_auto [$COMMANDSTACKNEXT $name] + set default_auto [::punk::auto_execok_windows $name] + #if {$name ni {cmd cmd.exe}} { + # unset -nocomplain ::auto_execs + #} + + if {$default_auto eq ""} { + return + } + set namedir [file dirname [lindex $default_auto 0]] + + if {$namedir eq $windowsappdir} { + if {$can_exec_windowsapp eq "unknown"} { + if {[catch {exec [file join $windowsappdir winget.exe] --version}]} { + set can_exec_windowsapp 0 + } else { + set can_exec_windowsapp 1 + } + } + if {$can_exec_windowsapp} { + return [file join $windowsappdir $name] + } + if {$cmdexedir eq ""} { + #cmd.exe very unlikely to move + set cmdexedir [file dirname [lindex [::punk::auto_execok_windows cmd.exe] 0]] + #auto_reset never seems to exist as a command - because auto_reset deletes all commands in the ::auto_index + #anyway.. it has other side effects (affects auto_load) + } + return "[file join $cmdexedir cmd.exe] /c $name" + } + return $default_auto + }] + + + } + +} + + + +#repltelemetry cooperation with other packages such as shellrun +#Maintenance warning: shellrun expects repltelemetry_emmitters to exist if punk namespace exists +namespace eval punk { + variable repltelemetry_emmitters + #don't stomp.. even if something created this namespace in advance and is 'cooperating' a bit early + if {![info exists repltelemetry_emitters]} { + set repltelemetry_emmitters [list] + } +} + +namespace eval punk::pipecmds { + #where to install proc/compilation artifacts for pieplines + namespace export * +} +namespace eval punk::pipecmds::split_patterns {} +namespace eval punk::pipecmds::split_rhs {} +namespace eval punk::pipecmds::var_classify {} +namespace eval punk::pipecmds::destructure {} +namespace eval punk::pipecmds::insertion {} + + +#globals... some minimal global var pollution +#punk's official silly test dictionary +set punk_testd [dict create \ + a0 a0val \ + b0 [dict create \ + a1 b0a1val \ + b1 b0b1val \ + c1 b0c1val \ + d1 b0d1val \ + ] \ + c0 [dict create] \ + d0 [dict create \ + a1 [dict create \ + a2 d0a1a2val \ + b2 d0a1b2val \ + c2 d0a1c2val \ + ] \ + b1 [dict create \ + a2 [dict create \ + a3 d0b1a2a3val \ + b3 d0b1a2b3val \ + ] \ + b2 [dict create \ + a3 d0b1b2a3val \ + bananas "in pyjamas" \ + c3 [dict create \ + po "in { }" \ + b4 ""\ + c4 "can go boom" \ + ] \ + d3 [dict create \ + a4 "-paper -cuts" \ + ] \ + e3 [dict create] \ + ] \ + ] \ + ] \ + e0 "multi\nline"\ + ] +#test dict 2 - uniform structure and some keys with common prefixes for glob matching +set punk_testd2 [dict create {*}{ + } a0 [dict create {*}{ + b1 {a b c} + b2 {a b c d} + x1 {x y z 1 2} + y2 {X Y Z 1 2} + z1 {k1 v1 k2 v2 k3 v3} + }] {*}{ + } a1 [dict create {*}{ + b1 {a b c} + b2 {a b c d} + x1 {x y z 1 2} + y2 {X Y Z 1 2} + z1 {k1 v1 k2 v2 k3 v3} + }] {*}{ + } b1 [dict create {*}{ + b1 {a b c} + b2 {a b c d} + x1 {x y z 1 2} + y2 {X Y Z 1 2} + z1 {k1 v1 k2 v2 k3 v3} + }] {*}{ + } +] + +#impolitely cooperative with punk repl - todo - tone it down. +#namespace eval ::punk::repl::codethread { +# variable running 0 +#} +package require punk::lib ;# subdependency punk::args +package require punk::ansi +if {![llength [info commands ::ansistring]]} { + namespace import punk::ansi::ansistring +} +#require aliascore after punk::lib & punk::ansi are loaded +#package require punk::aliascore ;#mostly punk::lib aliases +#punk::aliascore::init -force 1 + +package require punk::repl::codethread +package require punk::config +#package require textblock +catch {package require punk::console} ;#requires Thread - will not work in safe interps. +package require punk::ns +package require punk::winpath ;# for windows paths - but has functions that can be called on unix systems +package require punk::repo +package require punk::du +package require punk::mix::base +package require base64 + +package require punk::pipe + +namespace eval punk { + # -- --- --- + #namespace import ::control::assert ;#according to tcllib doc - assert can be enabled/disabled per namespace + # using control::control assert enabled within a namespace for which ::control::assert wasn't imported can produce surprising results. + #e.g setting to zero may keep asserts enabled - (e.g if the assert command is still available due to namespace path etc) - but.. querying the enabled status may show zero even in the parent namespace where asserts also still work. + #package require control + #control::control assert enabled 1 + + #We will use punk::assertion instead + + package require punk::assertion + if {[catch {namespace import ::punk::assertion::assert} errM]} { + catch { + puts stderr "punk error importing punk::assertion::assert\n$errM" + puts stderr "punk::a* commands:[info commands ::punk::a*]" + } + } + punk::assertion::active on + # -- --- --- + + interp alias {} purelist {} lreplace x 0 0 ;#required by pipe system + if {[catch { + package require pattern + } errpkg]} { + catch {puts stderr "Failed to load package pattern error: $errpkg"} + } + package require shellfilter + package require punkapp + + package require struct::list + package require fileutil + #package require punk::lib + + #NOTE - always call debug.xxx with braced message instead of double-quoted (unless specifically intending to do double-subtition) + #(or $ within values will be substituted, causing an extra error message if the var doesn't exist - which it quite possibly doesn't) + package require debug + + debug define punk.unknown + debug define punk.pipe + debug define punk.pipe.var + debug define punk.pipe.args + debug define punk.pipe.rep ;#string/list representation with tcl::unsupported::representation + debug define punk.pipe.compile ;#info about when we compile pipeline components into procs etc + + + #----------------------------------- + # todo - load initial debug state from config + debug off punk.unknown + debug level punk.unknown 1 + debug off punk.pipe + debug level punk.pipe 4 + debug off punk.pipe.var + debug level punk.pipe.var 4 + debug off punk.pipe.args + debug level punk.pipe.args 3 + debug off punk.pipe.rep 2 + debug off punk.pipe.compile + debug level punk.pipe.compile 2 + + + debug header "dbg> " + + + variable last_run_display [list] + + + #variable re_headvar1 {([a-zA-Z:@.(),]+?)(?![^(]*\))(,.*)*$} + + + + #----------------------------------------------------------------------------------- + #strlen is important for testing issues with string representationa and shimmering. + #This specific implementation with append (as at 2023-09) is designed to ensure the original str representation isn't changed + #It may need to be reviewed with different Tcl versions in case the append empty string is 'optimised/tuned' in some way that affects the behaviour + proc strlen {str} { + append str2 $str {} + string length $str2 + } + #----------------------------------------------------------------------------------- + + #get a copy of the item without affecting internal rep + proc valcopy {obj} { + append obj2 $obj {} + } + + + proc set_valcopy {varname obj} { + #maintenance: also punk::lib::set_valcopy + #e.g used by repl's codeinterp. Maintains internal rep, easier to call e.g interp eval code [list punk::set_valcopy varnmame $val] + append obj2 $obj {} + uplevel 1 [list set $varname $obj2] + } + + interp alias "" strlen "" ::punk::strlen + interp alias "" str_len "" ::punk::strlen + interp alias "" valcopy "" ::punk::valcopy + #proc ::strlen {str} { + # string length [append str2 $str {}] + #} + #proc ::valcopy {obj} { + # append obj2 $obj {} + #} + + #----------------------------------------------------------------------------------- + #order of arguments designed for pipelining + #review - 'piper_' prefix is a naming convention for functions that are ordered for tail-argument pipelining + #piper_ function names should read intuitively when used in a pipeline with tail argument supplied by the pipeline - but may seem reversed when using standalone. + proc piper_append {new base} { + append base $new + } + interp alias "" piper_append "" ::punk::piper_append + proc piper_prepend {new base} { + append new $base + } + interp alias "" piper_prepend "" ::punk::piper_prepend + + proc ::punk::K {x y} { return $x} + + #---------------------- + #todo - fix overtype + #create test + #overtype::renderline -insert_mode 0 -transparent 1 [a+ green]-----[a] " [a+ underline]x[a]" + #---------------------- + + + proc stacktrace {} { + set stack "Stack trace:\n" + for {set i 1} {$i < [info level]} {incr i} { + set lvl [info level -$i] + set pname [lindex $lvl 0] + append stack [string repeat " " $i]$pname + + if {![catch {info args $pname} pargs]} { + foreach value [lrange $lvl 1 end] arg $pargs { + + if {$value eq ""} { + if {$arg != 0} { + info default $pname $arg value + } + } + append stack " $arg='$value'" + } + } else { + append stack " !unknown vars for $pname" + } + + append stack \n + } + return $stack + } + + namespace eval argdoc { + punk::args::define { + @id -id ::punk::get_runchunk + @cmd -name "punk::get_runchunk" -help\ + "experimental" + @opts + -1 -optional 1 -type none + -2 -optional 1 -type none + @values -min 0 -max 0 + } + } + #get last command result that was run through the repl + proc ::punk::get_runchunk {args} { + #set argd [punk::args::parse $args withdef { + # @id -id ::punk::get_runchunk + # @cmd -name "punk::get_runchunk" -help\ + # "experimental" + # @opts + # -1 -optional 1 -type none + # -2 -optional 1 -type none + # @values -min 0 -max 0 + #}] + #todo - make this command run without truncating previous runchunks + set runchunks [tsv::array names repl runchunks-*] + + set sortlist [list] + foreach cname $runchunks { + set num [lindex [split $cname -] 1] + lappend sortlist [list $num $cname] + } + set sorted [lsort -index 0 -integer $sortlist] + set chunkname [lindex $sorted end-1 1] + set runlist [tsv::get repl $chunkname] + #puts stderr "--$runlist" + if {![llength $runlist]} { + return "" + } else { + return [lindex [lsearch -inline -index 0 $runlist result] 1] + } + } + interp alias {} _ {} ::punk::get_runchunk + + + proc ::punk::var {varname {= _=.=_} args} { + upvar $varname the_var + switch -exact -- ${=} { + = { + if {[llength $args] > 1} { + set the_var $args + } else { + set the_var [lindex $args 0] + } + } + .= { + if {[llength $args] > 1} { + set the_var [uplevel 1 $args] + } else { + set the_var [uplevel 1 [lindex $args 0]] + } + } + _=.=_ { + set the_var + } + default { + set the_var [list ${=} {*}$args] + } + } + } + proc src {args} { + #based on wiki.. https://wiki.tcl-lang.org/page/source+with+args + #added support for ?-encoding name? and other options of Tcl source command under assumption they come pairs before the filename + # review? seems unlikely source command will ever accept solo options. It would make complete disambiguation impossible when passing additional args as we are doing here. + set cmdargs [list] + set scriptargs [list] + set inopts 0 + set i 0 + foreach a $args { + if {$i eq [llength $args]-1} { + #reached end without finding end of opts + #must be file - even if it does match -* ? + break + } + if {!$inopts} { + if {[string match -* $a]} { + set inopts 1 + } else { + #leave loop at first nonoption - i should be index of file + break + } + } else { + #leave for next iteration to check + set inopts 0 + } + incr i + } + set cmdargs [lrange $args 0 $i] + set scriptargs [lrange $args $i+1 end] + set argv $::argv + set argc $::argc + set ::argv $scriptargs + set ::argc [llength $scriptargs] + set code [catch {uplevel [list source {*}$cmdargs]} return] + set ::argv $argv + set ::argc $argc + return -code $code $return + } + + + + + proc varinfo {vname {flag ""}} { + upvar $vname v + if {[array exists $vname]} { + error "can't read \"$vname\": variable is array" + } + if {[catch {set v} err]} { + error "can't read \"$vname\": no such variable" + } + set inf [shellfilter::list_element_info [list $v]] + set inf [dict get $inf 0] + if {$flag eq "-v"} { + return $inf + } + + set output [dict create] + dict set output wouldbrace [dict get $inf wouldbrace] + dict set output wouldescape [dict get $inf wouldescape] + dict set output head_tail_names [dict get $inf head_tail_names] + dict set output len [dict get $inf len] + return $output + } + + #review - extending core commands could be a bit intrusive...although it can make sense in a pipeline. + #e.g contrived pipeline example to only allow setting existing keys + ## .= @head.= list {a aaa b bbb c ccc} |d,dkeys@keys> |> &true.= {is_list_all_in_list $nkeys $dkeys} |> {dict modify d {*}$new} |> &true.= {is_list_all_ni_list $nkeys $dkeys} |> {dict modify d {*}$new} -1} { + #lassign [punk::lib::string_splitbefore $token $first_term] v k + set v [string range $token 0 $first_term-1] + set k [string range $token $first_term end] ;#key section includes the terminal char + lappend varlist [list $v $k] + } else { + lappend varlist [list $token ""] + } + set token "" + set token_index -1 ;#reduce by 1 because , not included in next token + set first_term -1 + } else { + if {$first_term == -1} { + if {$c in $var_terminals} { + set first_term $token_index + } + } + append token $c + if {$c eq "("} { + set in_brackets 1 + } + } + } + incr token_index + } + if {[string length $token]} { + if {$first_term > -1} { + set v [string range $token 0 $first_term-1] + set k [string range $token $first_term end] ;#key section includes the terminal char + lappend varlist [list $v $k] + } else { + lappend varlist [list $token ""] + } + } + return $varlist + } + + proc fp_restructure {selector data} { + if {$selector eq ""} { + fun=.= {val $input} and always break + set lhs "" + set rhs "" + #todo - check performance impact of catches around list and dict operations - consider single catch around destructure and less specific match error info? + foreach index $subindices { + set subpath [join [lrange $subindices 0 $i_keyindex] /] + set lhs $subpath + set assigned "" + set get_not 0 + set already_assigned 0 + set do_bounds_check 0 ;#modified by leading single @ for list operations - doesn't apply to certain items like 'head','tail' which have specifically defined bounds-checks implicit in their normal meaning. + #thse have anyhead and anytail for explicit allowance to be used on lists with insufficient items to produce values. + #todo - see if 'string is list' improved in tcl9 vs catch {llength $list} + switch -exact -- $index { + # { + set active_key_type "list" + if {![catch {llength $leveldata} assigned]} { + set already_assigned 1 + } else { + set action ?mismatch-not-a-list + break + } + } + ## { + set active_key_type "dict" + if {![catch {dict size $leveldata} assigned]} { + set already_assigned 1 + } else { + set action ?mismatch-not-a-dict + break + } + } + #? { + #review - compare to %# ????? + #seems to be unimplemented ? + set assigned [string length $leveldata] + set already_assigned 1 + } + @ { + upvar v_list_idx v_list_idx ;#positional tracker for /@ - list position + set active_key_type "list" + #e.g @1/1/@/1 the lone @ is a positional spec for this specific subkey + #no normalization done - ie @2/@ will not be considered same subkey as @end/@ or @end-0/@ even if llength = 3 + #while x@,y@.= is reasonably handy - especially for args e.g $len} { + set action ?mismatch-list-index-out-of-range + break + } + set assigned [lindex $leveldata $index] + set already_assigned 1 + } + @@ - @?@ - @??@ { + set active_key_type "dict" + + #NOTE: it may at first seem pointless to use @@/key, since we have to know the key - but this can be used to match 'key' only at the first position in .= list key {x y} key2 etc + #x@@ = a {x y} + #x@@/@0 = a + #x@@/@1 = x y + #x@@/a = a {x y} + # but.. as the @@ is stateful - it generally isn't very useful for multiple operations on the same pair within the pattern group. + # (note that ?@ forms a different subpath - so can be used to test match prior to @@ without affecting the index) + # It is analogous to v1@,v2@ for lists. + # @pairs is more useful for repeated operations + + # + #set subpath [join [lrange $subindices 0 $i_keyindex] /] + if {[catch {dict size $leveldata} dsize]} { + set action ?mismatch-not-a-dict + break + } + set next_this_level [incr v_dict_idx($subpath)] + set keyindex [expr {$next_this_level -1}] + if {($keyindex + 1) <= $dsize} { + set k [lindex [dict keys $leveldata] $keyindex] + if {$index eq "@?@"} { + set assigned [dict get $leveldata $k] + } else { + set assigned [list $k [dict get $leveldata $k]] + } + } else { + if {$index eq "@@"} { + set action ?mismatch-dict-index-out-of-range + break + } else { + set assigned [list] + } + } + set already_assigned 1 + } + default { + switch -glob -- $index { + @@* { + set active_key_type "dict" + set key [string range $index 2 end] + #dict exists test is safe - no need for catch + if {[dict exists $leveldata $key]} { + set assigned [dict get $leveldata $key] + } else { + set action ?mismatch-dict-key-not-found + break + } + set already_assigned 1 + } + {@\?@*} { + set active_key_type "dict" + set key [string range $index 3 end] + #dict exists test is safe - no need for catch + if {[dict exists $leveldata $key]} { + set assigned [dict get $leveldata $key] + } else { + set assigned [list] + } + set already_assigned 1 + } + {@\?\?@*} { + set active_key_type "dict" + set key [string range $index 4 end] + #dict exists test is safe - no need for catch + if {[dict exists $leveldata $key]} { + set assigned [list $key [dict get $leveldata $key]] + } else { + set assigned [list] + } + set already_assigned 1 + } + @* { + set active_key_type "list" + set do_bounds_check 1 + set index [string trimleft $index @] + } + default { + # + } + } + + if {!$already_assigned} { + if {[string match "not-*" $index] && $active_key_type in [list "" "list"]} { + #e.g not-0-end-1 not-end-4-end-2 + set get_not 1 + #cherry-pick some easy cases, and either assign, or re-map to corresponding index + switch -- $index { + not-tail { + set active_key_type "list" + set assigned [lindex $leveldata 0]; set already_assigned 1 + } + not-head { + set active_key_type "list" + #set selector "tail"; set get_not 0 + set assigned [lrange $leveldata 1 end]; set already_assigned 1 + } + not-end { + set active_key_type "list" + set assigned [lrange $leveldata 0 end-1]; set already_assigned 1 + } + default { + #trim off the not- and let the remaining index handle based on get_not being 1 + set index [string range $index 4 end] + } + } + } + } + } + } + + if {!$already_assigned} { + + #keyword 'pipesyntax' at beginning of error message + set listmsg "pipesyntax Unable to interpret subindex $index\n" + append listmsg "selector: '$selector'\n" + append listmsg "@ must be followed by a selector (possibly compound separated by forward slashes) suitable for lindex or lrange commands, or a not-x expression\n" + append listmsg "Additional accepted keywords include: head tail\n" + append listmsg "Use var@@key to treat value as a dict and retrieve element at key" + + + #we can't just set 'assigned' for a position spec for in/ni (not-in) because we don't have the value here to test against + #need to set a corresponding action + if {$active_key_type in [list "" "list"]} { + set active_key_type "list" + #for pattern matching purposes - head/tail not valid on empty lists (similar to elixir) + if {$index eq "0"} { + if {[catch {llength $leveldata} len]} { + set action ?mismatch-not-a-list + break + } + set assigned [lindex $leveldata 0] + } elseif {$index eq "head"} { + #NOTE: /@head and /head both do bounds check. This is intentional + if {[catch {llength $leveldata} len]} { + set action ?mismatch-not-a-list + break + } + if {$len == 0} { + set action ?mismatch-list-index-out-of-range-empty + break + } + #alias for 0 - for h@head,t@tail= similar to erlang/elixir hd() tl() or [head | tail] = list syntax + set assigned [lindex $leveldata 0] + } elseif {$index eq "end"} { + # @end /end + if {[catch {llength $leveldata} len]} { + set action ?mismatch-not-a-list + break + } + if {$do_bounds_check && $len < 1} { + set action ?mismatch-list-index-out-of-range + } + set assigned [lindex $leveldata end] + } elseif {$index eq "tail"} { + #NOTE: /@tail and /tail both do bounds check. This is intentional. + if {[catch {llength $leveldata} len]} { + set action ?mismatch-not-a-list + break + } + #tail is a little different in that we allow tail on a single element list - returning an empty result - but it can't be called on an empty list + #arguably tail could be considered as an index-out-of-range for less than 2 elements - but this would be less useful, and surprising to those coming from other pattern-matching systems. + #In this way tail is different to @1-end + if {$len == 0} { + set action ?mismatch-list-index-out-of-range + break + } + set assigned [lrange $leveldata 1 end] ;#return zero or more elements - but only if there is something (a head) at position zero. + } elseif {$index eq "anyhead"} { + # @anyhead + #allow returning of head or nothing if empty list + if {[catch {llength $leveldata} len]} { + set action ?mismatch-not-a-list + break + } + set assigned [lindex $leveldata 0] + } elseif {$index eq "anytail"} { + # @anytail + #allow returning of tail or nothing if empty list + #anytail will return empty both for empty list, or single element list - but potentially useful in combination with anyhead. + if {[catch {llength $leveldata} len]} { + set action ?mismatch-not-a-list + break + } + set assigned [lrange $leveldata 1 end] + } elseif {$index eq "init"} { + # @init + #all but last element - same as haskell 'init' + if {[catch {llength $leveldata} len]} { + set action ?mismatch-not-a-list + break + } + set assigned [lrange $leveldata 0 end-1] + } elseif {$index eq "list"} { + # @list + #allow returning of entire list even if empty + if {[catch {llength $leveldata} len]} { + set action ?mismatch-not-a-list + break + } + set assigned $leveldata + } elseif {$index eq "raw"} { + #no list checking.. + set assigned $leveldata + } elseif {$index eq "keys"} { + #need active_key_type of 'list' for 'keys' and 'values' keywords which act on either dict or a list with even number of elements + if {[catch {dict size $leveldata} dsize]} { + set action ?mismatch-not-a-dict + break + } + set assigned [dict keys $leveldata] + } elseif {$index eq "values"} { + #need active_key_type of 'list' for 'keys' and 'values' keywords which act on either dict or a list with even number of elements + if {[catch {dict size $leveldata} dsize]} { + set action ?mismatch-not-a-dict + break + } + set assigned [dict values $leveldata] + } elseif {$index eq "pairs"} { + if {[catch {dict size $leveldata} dsize]} { + set action ?mismatch-not-a-dict + break + } + #set assigned [dict values $leveldata] + set pairs [list] + tcl::dict::for {k v} $leveldata {lappend pairs [list $k $v]} + set assigned [lindex [list $pairs [unset pairs]] 0] + } elseif {[string is integer -strict $index]} { + if {[catch {llength $leveldata} len]} { + set action ?mismatch-not-a-list + break + } + # only check if @ was directly in original index section + if {$do_bounds_check && ($index+1 > $len || $index < 0)} { + set action ?mismatch-list-index-out-of-range + break + } + if {$get_not} { + #already handled not-0 + set assigned [lreplace $leveldata $index $index] + } else { + set assigned [lindex $leveldata $index] + } + } elseif {[string first "end" $index] >=0} { + if {[regexp {^end([-+]{1,2}[0-9]+)$} $index _match endspec]} { + if {[catch {llength $leveldata} len]} { + set action ?mismatch-not-a-list + break + } + #leave the - from the end- as part of the offset + set offset [expr $endspec] ;#don't brace! (consider: set x --34;puts expr $j;puts expr {$j} ) + if {$do_bounds_check && ($offset > 0 || abs($offset) >= $len)} { + set action ?mismatch-list-index-out-of-range + break + } + if {$get_not} { + set assigned [lreplace $leveldata $index $index] + } else { + set assigned [lindex $leveldata $index] + } + } elseif {[regexp {^([0-9]+|end|end[-+]{1,2}[0-9]+)-([0-9]+|end|end[-+]{1,2}([0-9]+))$} $index _ start end]} { + if {[catch {llength $leveldata} len]} { + set action ?mismatch-not-a-list + break + } + if {$do_bounds_check && [string is integer -strict $start]} { + if {$start+1 > $len || $start < 0} { + set action ?mismatch-list-index-out-of-range + break + } + } elseif {$start eq "end"} { + #ok + } elseif {$do_bounds_check} { + set startoffset [string range $start 3 end] ;#include the - from end- + set startoffset [expr $startoffset] ;#don't brace! + if {$startoffset > 0 || abs($startoffset) >= $len} { + set action ?mismatch-list-index-out-of-range + break + } + } + if {$do_bounds_check && [string is integer -strict $end]} { + if {$end+1 > $len || $end < 0} { + set action ?mismatch-list-index-out-of-range + break + } + } elseif {$end eq "end"} { + #ok + } elseif {$do_bounds_check} { + set endoffset [string range $end 3 end] ;#include the - from end- + set endoffset [expr $endoffset] ;#don't brace! + if {$endoffset > 0 || abs($endoffset) >= $len} { + set action ?mismatch-list-index-out-of-range + break + } + } + if {$get_not} { + set assigned [lreplace $leveldata $start $end] + } else { + set assigned [lrange $leveldata $start $end] + } + } else { + error $listmsg "destructure $selector" [list pipesyntax destructure selector $selector] + } + } elseif {[string first - $index] > 0} { + puts "====> index:$index leveldata:$leveldata" + if {[catch {llength $leveldata} len]} { + set action ?mismatch-not-a-list + break + } + #handle pure int-int ranges separately + set testindex [string map [list - "" + ""] $index] + if {[string is digit -strict $testindex]} { + #don't worry about leading - negative value for indices not valid anyway + set parts [split $index -] + if {[llength $parts] != 2} { + error $listmsg "destructure $selector" [list pipesyntax destructure selector $selector] + } + lassign $parts start end + if {$start+1 > $len || $end+1 > $len} { + set action ?mismatch-not-a-list + break + } + if {$get_not} { + set assigned [lreplace $leveldata $start $end] + } else { + set assigned [lrange $leveldata $start $end] + } + } else { + error $listmsg "destructure $selector" [list pipesyntax destructure selector $selector] + } + + } else { + #keyword 'pipesyntax' at beginning of error message + error $listmsg "destructure $selector" [list pipesyntax destructure selector $selector] + } + } else { + #treat as dict key + set active_key_type "dict" + if {[dict exists $leveldata $index]} { + set assigned [dict get $leveldata $index] + } else { + set action ?mismatch-dict-key-not-found + break + } + + } + } + set leveldata $assigned + set rhs $leveldata + #don't break on empty data - operations such as # and ## can return 0 + #if {![llength $leveldata]} { + # break + #} + incr i_keyindex + } + #puts stdout "----> destructure rep leveldata: [rep $leveldata]" + #puts stdout ">> destructure returning: [dict create -assigned $leveldata -action $action -lhs $lhs -rhs $rhs]" + + #maintain key order - caller unpacks using lassign + return [dict create -assigned $leveldata -action $action -lhs $lhs -rhs $rhs] + + } + #todo - fp_destructure - return a function-pipeline that can then be transformed to a funcl and finally a more efficient tcl script + proc destructure_func {selector data} { + #puts stderr ".d." + set selector [string trim $selector /] + #upvar v_list_idx v_list_idx ;#positional tracker for /@ - list position + #upvar v_dict_idx v_dict_idx ;#positional tracker for /@@ - dict position + + #map some problematic things out of the way in a manner that maintains some transparency + #e.g glob chars ? * in a command name can make testing using {[info commands $cmd] ne ""} produce spurious results - requiring a stricter (and slower) test such as {$cmd in [info commands $cmd]} + #The selector forms part of the proc name + #review - compare with pipecmd_namemapping + set selector_safe [string map [list {*}{ + ? + * + \\ + {"} + {$} + "\x1b\[" + "\x1b\]" + {[} + {]} + :: + {;} + " " + \t + \n + \r + }] $selector] + + set cmdname ::punk::pipecmds::destructure::_$selector_safe + if {[info commands $cmdname] ne ""} { + return [$cmdname $data] ;# note upvar 2 for stateful v_list_idx to be resolved in _multi_bind_result context + } + + set leveldata $data + set body [destructure_func_build_procbody $cmdname $selector $data] + + puts stdout ---- + puts stderr "proc $cmdname {leveldata} {" + puts stderr $body + puts stderr "}" + puts stdout --- + proc $cmdname {leveldata} $body + #eval $script ;#create the proc + debug.punk.pipe.compile {proc $cmdname} 4 + #return [dict create -assigned $leveldata -action $action -lhs $lhs -rhs $rhs] + #use return - script has upvar 2 for v_list_idx to be resolved in _multi_bind_result context + return [$cmdname $data] + } + + #Builds a *basic* function to do the destructuring. + #This is simply a set of steps to destructure each level of the data based on the hierarchical selector. + #It just uses intermediate variables and adds some comments to the code to show the indices used at each point. + #This may be useful in the long run as a debug/fallback mechanism - but ideally we should be building a more efficient script. + proc destructure_func_build_procbody {cmdname selector data} { + set script "" + #place selector in comment in script only - if there is an error in selector we pick it up when building the script. + #The script itself should only be returning errors in its action key of the result dictionary + append script \n [string map [list $selector] {# set selector {}}] + set subindices [split $selector /] + append script \n [string map [list [list $subindices]] {# set subindices }] + set action ?match ;#default assumption. Alternatively set to ?mismatch or ?mismatch- and always break + append script \n {set action ?match} + #append script \n {set assigned ""} ;#review + set active_key_type "" + append script \n {# set active_key_type ""} + set lhs "" + #append script \n [tstr {set lhs ${{$lhs}}}] + append script \n {set lhs ""} + set rhs "" + append script \n {set rhs ""} + + set INDEX_OPERATIONS {} ;#caps to make clear in templates that this is substituted from script building scope + + #maintain key order - caller unpacks using lassign + set returnline {dict create -assigned $leveldata -action $action -lhs $lhs -rhs $rhs} + set return_template {return [tcl::dict::create -assigned $leveldata -action $action -lhs $lhs -rhs xxx -index_operations {${$INDEX_OPERATIONS}}]} + #set tpl_return_mismatch {return [dict create -assigned $leveldata -action ${$MISMATCH} -lhs $lhs -rhs $rhs -index_operations {${$INDEX_OPERATIONS}}]} + set tpl_return_mismatch {return [dict create -assigned $leveldata -action ${$MISMATCH} -lhs $lhs -rhs xxx -index_operations {${$INDEX_OPERATIONS}}]} + set tpl_return_mismatch_not_a_list {return [dict create -assigned $leveldata -action ?mismatch-not-a-list -lhs $lhs -rhs xxx -index_operations {${$INDEX_OPERATIONS}}]} + set tpl_return_mismatch_list_index_out_of_range {return [dict create -assigned $leveldata -action ?mismatch-list-index-out-of-range -lhs $lhs -rhs xxx -index_operations {${$INDEX_OPERATIONS}}]} + set tpl_return_mismatch_list_index_out_of_range_empty {return [dict create -assigned $leveldata -action ?mismatch-list-index-out-of-range-empty -lhs $lhs -rhs xxx -index_operations {${$INDEX_OPERATIONS}}]} + set tpl_return_mismatch_not_a_dict {return [dict create -assigned $leveldata -action ?mismatch-not-a-dict -lhs $lhs -rhs xxx -index_operations {${$INDEX_OPERATIONS}}]} + #dict 'index' when using stateful @@ etc to iterate over dict instead of by key + set tpl_return_mismatch_dict_index_out_of_range {return [dict create -assigned $leveldata -action ?mismatch-dict-index-out-of-range -lhs $lhs -rhs xxx -index_operations {${$INDEX_OPERATIONS}}]} + set tpl_return_mismatch_dict_key_not_found {return [dict create -assigned $leveldata -action ?mismatch-dict-key-not-found -lhs $lhs -rhs xxx -index_operations {${$INDEX_OPERATIONS}}]} + + + if {![string length $selector]} { + #just return $leveldata + set script { + dict create -assigned $leveldata -action ?match -lhs "" -rhs $leveldata + } + return $script + } + + if {[string is digit -strict [join $subindices ""]]} { + #review tip 551 (underscores in numerical literals) (tcl9+) + #puts stderr ">>>>>>>>>>>>>>>> data: $leveldata selector: $selector subindices: $subindices" + #pure numeric keylist - put straight to lindex + # + #NOTE: this direct access e.g v/0/1/2 doesn't check out of bounds which is at odds with list access containing @ + #We will leave this as a syntax for different (more performant) behaviour + #- it's potentially a little confusing - but it would be a shame not to have the possibility to take advantage of the lindex deep indexing capability in pattern matching. + #TODO - review and/or document + # + #Todo - add a handler for v/n/n/n/n/# to allow unchecked counting at depth too. + #(or more generally - loop until we hit another type of subindex) + + #set assigned [lindex $leveldata {*}$subindices] + if {[llength $subindices] == 1} { + append script \n "# index_operation listindex" \n + lappend INDEX_OPERATIONS listindex + } else { + append script \n "# index_operation listindex-nested" \n + lappend INDEX_OPERATIONS listindex-nested + } + append script \n [tstr -return string -allowcommands { + if {[catch {lindex $leveldata ${$subindices}} leveldata]} { + ${[tstr -ret string $tpl_return_mismatch_not_a_list]} + } + }] + # -- --- --- + #append script \n $returnline \n + append script [tstr -return string $return_template] + return $script + # -- --- --- + } + if {[string match @@* $selector]} { + #part following a double @ is dict key possibly with forward-slash separators for subpath access e.g @@key/subkey/etc + set rawkeylist [split $selector /] ;#first key retains @@ - may be just '@@' + set keypath [string range $selector 2 end] + set keylist [split $keypath /] + lappend INDEX_OPERATIONS dict_path + if {([lindex $rawkeylist 0] ne "@@") && ([lsearch $keylist @*] == -1) && ([lsearch $keylist #*] == -1) && ([lsearch $keylist %*] == -1)} { + #pure keylist for dict - process in one go + #dict exists will return 0 if not a valid dict. + # is equivalent to {*}keylist when substituted + append script \n [tstr -return string -allowcommands { + if {[dict exists $leveldata ${$keylist}]} { + set leveldata [dict get $leveldata ${$keylist}] + } else { + #set action ?mismatch-dict-key-not-found + ${[tstr -ret string $tpl_return_mismatch_dict_key_not_found]} + } + }] + append script [tstr -return string $return_template] + return $script + # -- --- --- + } + #else + #compound keylist e.g x@@data/@0/1 or x@@/a (combined dict/list access) + #process level by level + } + + + + set i_keyindex 0 + append script \n {set i_keyindex 0} + #todo - check performance impact of catches around list and dict operations - consider single catch around destructure and less specific match error info? + foreach index $subindices { + #set index_operation "unspecified" + set level_script_complete 0 ;#instead of break - as we can't use data to determine break when building script + set SUBPATH [join [lrange $subindices 0 $i_keyindex] /] + append script \n "# ------- START index:$index subpath:$SUBPATH ------" + set lhs $index + append script \n "set lhs {$index}" + + set assigned "" + append script \n {set assigned ""} + + #got_not shouldn't need to be in script + set get_not 0 + if {[tcl::string::index $index 0] eq "!"} { + append script \n {#get_not is true e.g !0-end-1 !end-4-end-2 !0 !@0 !@@key} + set index [tcl::string::range $index 1 end] + set get_not 1 + } + + # do_bounds_check shouldn't need to be in script + set do_bounds_check 0 ;#modified by leading single @ for list operations - doesn't apply to certain items like 'head','tail' which have specifically defined bounds-checks implicit in their normal meaning. + #thse have anyhead and anytail for explicit allowance to be used on lists with insufficient items to produce values. + #append script \n {set do_boundscheck 0} + switch -exact -- $index { + # - @# { + #list length + set active_key_type "list" + if {$get_not} { + lappend INDEX_OPERATIONS not-list + append script \n {# set active_key_type "list" index_operation: not-list} + append script \n { + if {[catch {llength $leveldata}]} { + #not a list - not-length is true + set assigned 1 + } else { + #is a list - not-length is false + set assigned 0 + } + } + } else { + lappend INDEX_OPERATIONS list-length + append script \n {# set active_key_type "list" index_operation: list-length} + append script \n [tstr -return string -allowcommands { + if {[catch {llength $leveldata} assigned]} { + ${[tstr -ret string $tpl_return_mismatch_not_a_list]} + } + }] + } + set level_script_complete 1 + } + ## { + #dict size + set active_key_type "dict" + if {$get_not} { + lappend INDEX_OPERATIONS not-dict + append script \n {# set active_key_type "dict" index_operation: not-dict} + append script \n { + if {[catch {dict size $leveldata}]} { + set assigned 1 ;#not a dict - not-size is true + } else { + set assigned 0 ;#is a dict - not-size is false + } + } + } else { + lappend INDEX_OPERATIONS dict-size + append script \n {# set active_key_type "dict" index_operation: dict-size} + append script \n [tstr -return string -allowcommands { + if {[catch {dict size $leveldata} assigned]} { + #set action ?mismatch-not-a-dict + ${[tstr -ret string $tpl_return_mismatch_not_a_dict]} + } + }] + } + set level_script_complete 1 + } + %# { + set active_key_type "string" + if {$get_not} { + error "!%# not string length is not supported" + } + #string length - REVIEW - + lappend INDEX_OPERATIONS string-length + append script \n {# set active_key_type "" index_operation: string-length} + append script \n {set assigned [string length $leveldata]} + set level_script_complete 1 + } + %%# { + #experimental + set active_key_type "string" + if {$get_not} { + error "!%%# not string length is not supported" + } + #string length - REVIEW - + lappend INDEX_OPERATIONS ansistring-length + append script \n {# set active_key_type "" index_operation: ansistring-length} + append script \n {set assigned [ansistring length $leveldata]} + set level_script_complete 1 + } + %str - %string { + set active_key_type "string" + if {$get_not} { + error "!%str - not string-get is not supported" + } + lappend INDEX_OPERATIONS string-get + append script \n {# set active_key_type "" index_operation: string-get} + append script \n {set assigned $leveldata} + set level_script_complete 1 + + #todo - %lpad- %lpadstr- %join- etc as in punk::lib::showdict + #review - merge code shared with showdict for these operations + } + %sp { + #experimental + set active_key_type "string" + if {$get_not} { + error "!%sp - not string-space is not supported" + } + lappend INDEX_OPERATIONS string-space + append script \n {# set active_key_type "" index_operation: string-space} + append script \n {set assigned " "} + set level_script_complete 1 + } + %empty { + #experimental + set active_key_type "string" + if {$get_not} { + error "!%empty - not string-empty is not supported" + } + lappend INDEX_OPERATIONS string-empty + append script \n {# set active_key_type "" index_operation: string-empty} + append script \n {set assigned ""} + set level_script_complete 1 + } + @words { + set active_key_type "string" + if {$get_not} { + error "!%words - not list-words-from-string is not supported" + } + lappend INDEX_OPERATIONS list-words-from-string + append script \n {# set active_key_type "" index_operation: list-words-from-string} + append script \n {set assigned [regexp -inline -all {\S+} $leveldata]} + set level_script_complete 1 + } + @chars { + #experimental - leading character based on result not input(?) + #input type is string - but output is list + set active_key_type "list" + if {$get_not} { + error "!%chars - not list-chars-from-string is not supported" + } + lappend INDEX_OPERATIONS list-from_chars + append script \n {# set active_key_type "" index_operation: list-chars-from-string} + append script \n {set assigned [split $leveldata ""]} + set level_script_complete 1 + } + @join { + #experimental - flatten one level of list + #join without arg - output is list + set active_key_type "string" + if {$get_not} { + error "!@join - not list-join-list is not supported" + } + lappend INDEX_OPERATIONS list-join-list + append script \n {# set active_key_type "" index_operation: list-join-list} + append script \n {set assigned [join $leveldata]} + set level_script_complete 1 + } + %join { + #experimental + #input type is list - but output is string + set active_key_type "string" + if {$get_not} { + error "!%join - not string-join-list is not supported" + } + lappend INDEX_OPERATIONS string-join-list + append script \n {# set active_key_type "" index_operation: string-join-list} + append script \n {set assigned [join $leveldata ""]} + set level_script_complete 1 + } + %ansiview { + #review - implemented differently in showdict. + #(showdict uses ansistring VIEW -lf 1 ) + set active_key_type "string" + if {$get_not} { + error "!%# not string-ansiview is not supported" + } + lappend INDEX_OPERATIONS string-ansiview + append script \n {# set active_key_type "" index_operation: string-ansiview} + append script \n {set assigned [ansistring VIEW $leveldata]} + set level_script_complete 1 + } + %ansiviewstyle { + set active_key_type "string" + if {$get_not} { + error "!%# not string-ansiviewstyle is not supported" + } + lappend INDEX_OPERATIONS string-ansiviewstyle + append script \n {# set active_key_type "" index_operation: string-ansiviewstyle} + append script \n {set assigned [ansistring VIEWSTYLE $leveldata]} + set level_script_complete 1 + } + @ { + #as this is a stateful list next index operation - we use not (!@) to mean there is no element at the next index (instead of returning the complement ie all elements except next) + #This is in contrast to other not operations on indices e.g /!2 which returns all elements except that at index 2 + + + #append script \n {puts stderr [uplevel 1 [list info vars]]} + + #NOTE: + #v_list_idx in context of _multi_bind_result + #we call destructure_func from _mult_bind_result which in turn calls the proc (or the script on first run) + append script \n {upvar 2 v_list_idx v_list_idx} + + set active_key_type "list" + append script \n {# set active_key_type "list" index_operation: list-get-next} + #e.g @1/1/@/1 the lone @ is a positional spec for this specific subkey + #no normalization done - ie @2/@ will not be considered same subkey as @end/@ or @end-0/@ even if llength = 3 + #while x@,y@.= is reasonably handy - especially for args e.g $len} { + set assigned 1 + } else { + set assigned 0 + } + }] + + } else { + lappend INDEX_OPERATIONS get-next + append script \n [tstr -return string -allowcommands { + set index [expr {[incr v_list_idx(@)]-1}] + + if {[catch {llength $leveldata} len]} { + #set action ?mismatch-not-a-list + ${[tstr -ret string $tpl_return_mismatch_not_a_list]} + } elseif {$index+1 > $len} { + #set action ?mismatch-list-index-out-of-range + ${[tstr -ret string $tpl_return_mismatch_list_index_out_of_range]} + } else { + set assigned [lindex $leveldata $index] + } + }] + } + set level_script_complete 1 + } + @* { + set active_key_type "list" + if {$get_not} { + lappend INDEX_OPERATIONS list-is-empty + append script \n [tstr -return string -allowcommands { + if {[catch {llength $leveldata} len]} { + ${[tstr -ret string $tpl_return_mismatch_not_a_list]} + } elseif {$len == 0} { + set assigned 1 ;#list is empty + } else { + set assigned 0 + } + }] + } else { + lappend INDEX_OPERATIONS list-get-all + append script \n [tstr -return string -allowcommands { + if {[catch {llength $leveldata} len]} { + ${[tstr -ret string $tpl_return_mismatch_not_a_list]} + } else { + set assigned [lrange $leveldata 0 end] + } + }] + } + set level_script_complete 1 + } + @@ { + #stateful: tracking of index using v_dict_idx + set active_key_type "dict" + lappend INDEX_OPERATIONS get-next-value + append script \n {# set active_key_type "dict" index_operation: get-next-value} + append script \n {upvar v_dict_idx v_dict_idx} ;#review! + + #NOTE: it may at first seem pointless to use @@/key, since we have to know the key - but this can be used to match 'key' only at the first position in .= list key {x y} key2 etc + #x@@ = a {x y} + #x@@/@0 = a + #x@@/@1 = x y + #x@@/a = a {x y} + # but.. as the @@ is stateful - it generally isn't very useful for multiple operations on the same pair within the pattern group. + # (note that @@ @?@ @??@ form different subpaths - so the ? & ?? versions can be used to test match prior to @@ without affecting the index) + #review - might be more useful if they shared an index ? + # It is analogous to v1@,v2@ for lists. + # @pairs is more useful for repeated operations + + + set indent " " + set assignment_script [string map [list \r\n "\r\n$indent" \n "\n$indent" ] { + if {($keyindex + 1) <= $dsize} { + set k [lindex [dict keys $leveldata] $keyindex] + set assigned [list $k [dict get $leveldata $k]] + } else { + ${[tstr -ret string $tpl_return_mismatch_dict_index_out_of_range]} + } + }] + + set assignment_script [tstr -ret string -allowcommands $assignment_script] + + append script [tstr -return string -allowcommands { + if {[catch {dict size $leveldata} dsize]} { + ${[tstr -ret string $tpl_return_mismatch_not_a_dict]} + } else { + set next_this_level [incr v_dict_idx(${$SUBPATH})] + set keyindex [expr {$next_this_level -1}] + ${$assignment_script} + } + }] + set level_script_complete 1 + } + @?@ { + #stateful: tracking of index using v_dict_idx + set active_key_type "dict" + lappend INDEX_OPERATIONS get?-next-value + append script \n {# set active_key_type "dict" index_operation: get?-next-value} + append script \n {upvar v_dict_idx v_dict_idx} ;#review! + set indent " " + set assignment_script [string map [list \r\n "\r\n$indent" \n "\n$indent" ] { + if {($keyindex + 1) <= $dsize} { + set k [lindex [dict keys $leveldata] $keyindex] + set assigned [dict get $leveldata $k] + } else { + set assigned [list] + } + }] + append script [tstr -return string -allowcommands { + if {[catch {dict size $leveldata} dsize]} { + ${[tstr -ret string $tpl_return_mismatch_not_a_dict]} + } else { + set next_this_level [incr v_dict_idx(${$SUBPATH})] + set keyindex [expr {$next_this_level -1}] + ${$assignment_script} + } + }] + set level_script_complete 1 + } + @??@ { + set active_key_type "dict" + lappend INDEX_OPERATIONS get?-next-pair + append script \n {# set active_key_type "dict" index_operation: get?-next-pair} + append script \n {upvar v_dict_idx v_dict_idx} ;#review! + set indent " " + set assignment_script [string map [list \r\n "\r\n$indent" \n "\n$indent" ] { + if {($keyindex + 1) <= $dsize} { + set k [lindex [dict keys $leveldata] $keyindex] + set assigned [list $k [dict get $leveldata $k]] + } else { + set assigned [list] + } + }] + append script [tstr -return string -allowcommands { + if {[catch {dict size $leveldata} dsize]} { + ${[tstr -ret string $tpl_return_mismatch_not_a_dict]} + } else { + set next_this_level [incr v_dict_idx(${$SUBPATH})] + set keyindex [expr {$next_this_level -1}] + ${$assignment_script} + } + }] + set level_script_complete 1 + } + @vv@ - @VV@ - @kk@ - @KK@ { + error "unsupported index $index" + } + default { + + #assert rules for values within @@ + #glob search is done only if there is at least one * within @@ + #if there is at least one ? within @@ - then a non match will not raise an error (quiet) + + #single or no char between @@: + #lookup/search is based on key - return is values + + #double char within @@: + #anything with a dot returns k v pairs e.g @k.@ @v.@ @..@ + #anything that is a duplicate returns k v pairs e.g @kk@ @vv@ @**@ + #anything with a letter and a star returns the type of the letter, and the search is based on the position of the star where posn 1 is for key, posn 2 is for value + #e.g @k*@ returns keys - search on values + #e.g @*k@ returns keys - search on keys + #e.g @v*@ returns values - search on values + #e.g @*v@ returns values - search on keys + + switch -glob -- $index { + @@* { + #exact key match - return value + #noisy get value - complain if key non-existent + #doesn't complain if not a dict - because we use 'tcl::dict::exists' which will return false without error even if the value isn't dict-shaped + set active_key_type "dict" + set key [string range $index 2 end] + if {$get_not} { + lappend INDEX_OPERATIONS exactkey-get-value-not + #review - dict remove allows silent call if key doesn't exist - but we are enforcing existence here + #this seems reasonable given we have an explicit @?@ syntax (nocomplain equivalent) and there could be a legitimate case for wanting a non-match if trying to return the complement of a non-existent key + append script \n [tstr -return string -allowcommands { + # set active_key_type "dict" index_operation: exactkey-get-value-not + if {[dict exists $leveldata ${$key}]} { + set assigned [dict values [dict remove $leveldata ${$key}]] + } else { + #set action ?mismatch-dict-key-not-found + ${[tstr -ret string $tpl_return_mismatch_dict_key_not_found]} + } + }] + + } else { + lappend INDEX_OPERATIONS exactkey-get-value + append script \n [tstr -return string -allowcommands { + # set active_key_type "dict index_operation: exactkey-get-value" + if {[dict exists $leveldata ${$key}]} { + set assigned [dict get $leveldata ${$key}] + } else { + #set action ?mismatch-dict-key-not-found + ${[tstr -ret string $tpl_return_mismatch_dict_key_not_found]} + } + }] + } + set level_script_complete 1 + } + {@\?@*} { + #exact key match - quiet get value + #silent empty result if non-existent key - silence when non-existent key also if using not-@?@badkey which will just return whole dict + #note - dict remove will raise error on non-dict-shaped value whilst dict exists will not + set active_key_type "dict" + set key [string range $index 3 end] + if {$get_not} { + lappend INDEX_OPERATIONS exactkey?-get-value-not + append script \n [tstr -return string -allowcommands { + # set active_key_type "dict" index_operation: exactkey?-get-value-not + if {[catch {dict size $leveldata}]} { + ${[tstr -ret string $tpl_return_mismatch_not_a_dict]} + } + set assigned [dict values [dict remove $leveldata ${$key}]] + }] + + } else { + lappend INDEX_OPERATIONS exactkey?-get-value + #dict exists test is safe - no need for catch + append script \n [string map [list $key] { + # set active_key_type "dict" index_operation: exactkey?-get-value + if {[dict exists $leveldata ]} { + set assigned [dict get $leveldata ] + } else { + set assigned [dict create] + } + }] + } + set level_script_complete 1 + } + {@\?\?@*} { + #quiet get pairs + #this is silent too.. so how do we do a checked return of dict key+val? + set active_key_type "dict" + set key [string range $index 4 end] + if {$get_not} { + lappend INDEX_OPERATIONS exactkey?-get-pair-not + append script \n [tstr -return string -allowcommands { + # set active_key_type "dict" index_operation: exactkey?-get-pair-not + if {[catch {dict size $leveldata}]} { + ${[tstr -ret string $tpl_return_mismatch_not_a_dict]} + } + set assigned [dict remove $leveldata ${$key}] + }] + } else { + lappend INDEX_OPERATIONS exactkey?-get-pair + append script \n [string map [list $key] { + # set active_key_type "dict" index_operation: exactkey?-get-pair + if {[dict exists $leveldata ]} { + set assigned [dict create [dict get $leveldata ]] + } else { + set assigned [dict create] + } + }] + } + set level_script_complete 1 + } + @..@* - @kk@* - @KK@* { + #noisy get pairs by key + set active_key_type "dict" + set key [string range $index 4 end] + if {$get_not} { + lappend INDEX_OPERATIONS exactkey-get-pairs-not + #review - dict remove allows silent call if key doesn't exist - but we are enforcing existence here + #this seems reasonable given we have an explicit @?@ syntax (nocomplain equivalent) and there could be a legitimate case for wanting a non-match if trying to return the complement of a non-existent key + append script \n [tstr -return string -allowcommands { + # set active_key_type "dict" index_operation: exactkey-get-pairs-not + if {[dict exists $leveldata ${$key}]} { + set assigned [tcl::dict::remove $leveldata ${$key}] + } else { + ${[tstr -ret string $tpl_return_mismatch_dict_key_not_found]} + } + }] + + } else { + lappend INDEX_OPERATIONS exactkey-get-pairs + append script \n [tstr -return string -allowcommands { + # set active_key_type "dict index_operation: exactkey-get-pairs" + if {[dict exists $leveldata ${$key}]} { + tcl::dict::set assigned ${$key} [tcl::dict::get $leveldata ${$key}] + } else { + ${[tstr -ret string $tpl_return_mismatch_dict_key_not_found]} + } + }] + } + set level_script_complete 1 + + } + @vv@* - @VV@* { + #noisy(?) get pairs by exact value + #return mismatch on non-match even when not- specified + set active_key_type "dict" + set keyglob [string range $index 4 end] + set active_key_type "dict" + set key [string range $index 4 end] + if {$get_not} { + #review - for consistency we are reporting a mismatch when the antikey being looked up doesn't exist + #The utility of this is debatable + lappend INDEX_OPERATIONS exactvalue-get-pairs-not + append script \n [tstr -return string -allowcommands { + # set active_key_type "dict" index_operation: exactvalue-get-pairs-not + if {[catch {dict size $leveldata}]} { + ${[tstr -ret string $tpl_return_mismatch_not_a_dict]} + } + set nonmatches [dict create] + tcl::dict::for {k v} $leveldata { + if {![string equal ${$key} $v]} { + dict set nonmatches $k $v + } + } + + if {[dict size $nonmatches] < [dict size $leveldata]} { + #our key matched something + set assigned $nonmatches + } else { + #our key didn't match anything - don't return the nonmatches + #set action ?mismatch-dict-key-not-found + ${[tstr -ret string $tpl_return_mismatch_dict_key_not_found]} + } + }] + + } else { + lappend INDEX_OPERATIONS exactvalue-get-pairs + append script \n [tstr -return string -allowcommands { + # set active_key_type "dict index_operation: exactvalue-get-pairs-not" + if {[catch {dict size $leveldata}]} { + ${[tstr -ret string $tpl_return_mismatch_not_a_dict]} + } + set matches [list] + tcl::dict::for {k v} $leveldata { + if {[string equal ${$key} $v]} { + lappend matches $k $v + } + } + if {[llength $matches]} { + set assigned $matches + } else { + #set action ?mismatch-dict-key-not-found + ${[tstr -ret string $tpl_return_mismatch_dict_key_not_found]} + } + }] + } + set level_script_complete 1 + + } + {@\*@*} - {@\*v@*} - {@\*V@*} { + #dict key glob - return values only + set active_key_type "dict" + if {[string match {@\*@*} $index]} { + set keyglob [string range $index 3 end] + } else { + #vV + set keyglob [string range $index 4 end] + } + #if $keyglob eq "" - needs to query for dict key that is empty string. + if {$get_not} { + lappend INDEX_OPERATIONS globkey-get-values-not + append script \n [tstr -return string -allowcommands { + if {[catch {dict size $leveldata}]} { + ${[tstr -ret string $tpl_return_mismatch_not_a_dict]} + } + # set active_key_type "dict" index_operation: globkey-get-values-not + set matched [dict keys $leveldata {${$keyglob}}] + set assigned [dict values [dict remove $leveldata {*}$matched]] + }] + + } else { + lappend INDEX_OPERATIONS globkey-get-values + append script \n [tstr -return string -allowcommands { + # set active_key_type "dict" index_operation: globkey-get-values + if {[catch {dict size $leveldata}]} { + ${[tstr -ret string $tpl_return_mismatch_not_a_dict]} + } + set matched [dict keys $leveldata {${$keyglob}}] + set assigned [list] + foreach m $matched { + lappend assigned [dict get $leveldata $m] + } + }] + } + set level_script_complete 1 + + } + {@\*.@*} { + #dict key glob - return pairs + set active_key_type "dict" + set keyglob [string range $index 4 end] + append script [tstr -return string -allowcommands { + if {[catch {dict size $leveldata}]} { + ${[tstr -ret string $tpl_return_mismatch_not_a_dict]} + } + }] + if {$get_not} { + lappend INDEX_OPERATIONS globkey-get-pairs-not + append script \n [string map [list $keyglob] { + # set active_key_type "dict" index_operation: globkey-get-pairs-not + set matched [dict keys $leveldata {}] + set assigned [dict remove $leveldata {*}$matched] + }] + + } else { + lappend INDEX_OPERATIONS globkey-get-pairs + append script \n [string map [list $keyglob] { + # set active_key_type "dict" index_operations: globkey-get-pairs + set matched [dict keys $leveldata {}] + set assigned [dict create] + foreach m $matched { + dict set assigned $m [dict get $leveldata $m] + } + }] + } + set level_script_complete 1 + } + {@\*k@*} - {@\*K@*} { + #dict key glob - return keys + set active_key_type "dict" + set keyglob [string range $index 4 end] + append script [tstr -return string -allowcommands { + if {[catch {dict size $leveldata}]} { + ${[tstr -ret string $tpl_return_mismatch_not_a_dict]} + } + }] + if {$get_not} { + lappend INDEX_OPERATIONS globkey-get-keys-not + append script \n [string map [list $keyglob] { + # set active_key_type "dict" index_operation: globkey-get-keys-not + set matched [dict keys $leveldata {}] + set assigned [dict keys [dict remove $leveldata {*}$matched]] + }] + + } else { + lappend INDEX_OPERATIONS globkey-get-keys + append script \n [string map [list $keyglob] { + # set active_key_type "dict" index_operation: globkey-get-keys + set assigned [dict keys $leveldata {}] + }] + } + set level_script_complete 1 + } + {@k\*@*} - {@K\*@*} { + #dict value glob - return keys + set active_key_type "dict" + set valglob [string range $index 4 end] + append script [tstr -return string -allowcommands { + if {[catch {dict size $leveldata}]} { + ${[tstr -ret string $tpl_return_mismatch_not_a_dict]} + } + }] + if {$get_not} { + lappend INDEX_OPERATIONS globvalue-get-keys-not + append script \n [string map [list $valglob] { + # set active_key_type "dict" index_operation: globvalue-get-keys-not + set assigned [list] + tcl::dict::for {k v} $leveldata { + if {![string match {} $v]} { + lappend assigned $k + } + } + }] + } else { + lappend INDEX_OPERATIONS globvalue-get-keys + append script \n [string map [list $valglob] { + # set active_key_type "dict" index_operation: globvalue-get-keys + set assigned [list] + tcl::dict::for {k v} $leveldata { + if {[string match {} $v]} { + lappend assigned $k + } + } + }] + } + set level_script_complete 1 + } + {@.\*@*} { + #dict value glob - return pairs + set active_key_type "dict" + set valglob [string range $index 4 end] + append script [tstr -return string -allowcommands { + if {[catch {dict size $leveldata}]} { + ${[tstr -ret string $tpl_return_mismatch_not_a_dict]} + } + }] + if {$get_not} { + lappend INDEX_OPERATIONS globvalue-get-pairs-not + append script \n [string map [list $valglob] { + # set active_key_type "dict" index_operation: globvalue-get-pairs-not + set assigned [dict create] + tcl::dict::for {k v} $leveldata { + if {![string match {} $v]} { + dict set assigned $k $v + } + } + }] + } else { + lappend INDEX_OPERATIONS globvalue-get-pairs + append script \n [string map [list $valglob] { + # set active_key_type "dict" index_operation: globvalue-get-pairs + set assigned [dict create] + tcl::dict::for {k v} $leveldata { + if {[string match {} $v]} { + dict set assigned $k $v + } + } + }] + } + set level_script_complete 1 + } + {@V\*@*} - {@v\*@*} { + #dict value glob - return values + set active_key_type dict + set valglob [string range $index 4 end] + append script [tstr -return string -allowcommands { + if {[catch {dict size $leveldata}]} { + ${[tstr -ret string $tpl_return_mismatch_not_a_dict]} + } + }] + if {$get_not} { + lappend INDEX_OPERATIONS globvalue-get-values-not + append script \n [string map [list $valglob] { + # set active_key_type "dict" ;# index_operation: globvalue-get-values-not + set assigned [list] + tcl::dict::for {k v} $leveldata { + if {![string match {} $v]} { + lappend assigned $v + } + } + }] + + } else { + lappend INDEX_OPERATIONS globvalue-get-values + append script \n [string map [list $valglob] { + # set active_key_type "dict" ;#index_operation: globvalue-get-value + set assigned [dict values $leveldata ] + }] + } + set level_script_complete 1 + + } + {@\*\*@*} { + #dict val/key glob return pairs) + set active_key_type "dict" + set keyvalglob [string range $index 4 end] + append script [tstr -return string -allowcommands { + if {[catch {dict size $leveldata}]} { + ${[tstr -ret string $tpl_return_mismatch_not_a_dict]} + } + }] + if {$get_not} { + lappend INDEX_OPERATIONS globkeyvalue-get-pairs-not + error "globkeyvalue-get-pairs-not todo" + } 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 assigned [dict create] + tcl::dict::for {k v} $leveldata { + if {[string match {} $k] || [string match {} $v]} { + dict set assigned $k $v + } + } + }] + } + set level_script_complete 1 + puts stderr "globkeyvalue-get-pairs review" + } + @* { + set active_key_type "list" + set do_bounds_check 1 + + set index [string trimleft $index @] + append script \n [string map [list $index] { + # set active_key_type "list" index_operation: ? + set index + }] + } + %split-* { + #split on one or more chars - review + #set hidekey 1 + #lassign [split $key -] _ splitchars + #set thisval [split $dval $splitchars] + set active_key_type "string" + set splitchars [string range $index 7 end] + append script \n [string map [list $splitchars] { + # set active_key_type "string" index_operation: split-string + #e.g supports %split-"\\n"= "l1\n\nl3" -> {l1 "" l3} + set splitchars "" + set assigned [split $leveldata $splitchars] + }] + puts "---split script: $script" + set level_script_complete 1 + + #todo %splitat- %splitn- ?? + } + %lpad-* { + #moved from punk::lib::showdict patterns. + #set hidekey 1 + #lassign [split $key -] _ extra + #set width [expr {[textblock::width $dval] + $extra}] + #set thisval [textblock::pad $dval -which left -width $width] + set active_key_type "string" + set extra [string range $index 6 end] + append script \n [string map [list $extra] { + # set active_key_type "string" index_operation: lpad-string + set extra "" + set width [expr {[textblock::width $leveldata] + $extra}] + set assigned [textblock::pad $leveldata -which left -width $width] + }] + set level_script_complete 1 + } + %* { + #see above re %lpad- etc and synchronizing with showdict + set active_key_type "string" + set do_bounds_check 0 + set index [string range $index 1 end] + append script \n [string map [list $index] { + # set active_key_type "string" index_operation: ? + set index + }] + } + default { + puts "destructure_func_build_body unmatched index $index" + } + } + } + } + + if {!$level_script_complete} { + + + #keyword 'pipesyntax' at beginning of error message + set listmsg "pipesyntax Unable to interpret subindex $index\n" + append listmsg "selector: '$selector'\n" + append listmsg "@ must be followed by a selector (possibly compound separated by forward slashes) suitable for lindex or lrange commands, or a not-x expression\n" + append listmsg "Additional accepted keywords include: head tail\n" + append listmsg "Use var@@key to treat value as a dict and retrieve element at key" + + #append script \n [string map [list $listmsg] {set listmsg ""}] + + + + #we can't just set 'assigned' for a position spec for in/ni (not-in) because we don't have the value here to test against + #need to set a corresponding action + if {$active_key_type in [list "" "list"]} { + set active_key_type "list" + append script \n {# set active_key_type "list"} + #for pattern matching purposes - head/tail not valid on empty lists (similar to elixir) + switch -exact -- $index { + 0 { + if {$get_not} { + append script \n "# index_operation listindex-int-not" \n + lappend INDEX_OPERATIONS listindex-zero-not + set assignment_script {set assigned [lrange $leveldata 1 end]} + } else { + lappend INDEX_OPERATIONS listindex-zero + set assignment_script {set assigned [lindex $leveldata 0]} + if {$do_bounds_check} { + append script \n "# index_operation listindex-int (bounds checked)" \n + append script \n [tstr -return string -allowcommands { + if {[catch {llength $leveldata} len]} { + ${[tstr -ret string $tpl_return_mismatch_not_a_list]} + } elseif {[llength $leveldata] == 0} { + ${[tstr -ret string $tpl_return_mismatch_list_index_out_of_range_empty]} + } else { + ${$assignment_script} + } + }] + } else { + append script \n "# index_operation listindex-int" \n + append script \n [tstr -return string -allowcommands { + if {[catch {llength $leveldata} len]} { + ${[tstr -ret string $tpl_return_mismatch_not_a_list]} + } else { + ${$assignment_script} + } + }] + } + } + } + head { + #NOTE: /@head and /head both do bounds check. This is intentional + if {$get_not} { + append script \n "# index_operation listindex-head-not" \n + lappend INDEX_OPERATIONS listindex-head-not + set assignment_script {set assigned [lrange $leveldata 1 end]} + } else { + append script \n "# index_operation listindex-head" \n + lappend INDEX_OPERATIONS listindex-head + set assignment_script {set assigned [lindex $leveldata 0]} + } + append script \n [tstr -return string -allowcommands { + if {[catch {llength $leveldata} len]} { + #set action ?mismatch-not-a-list + ${[tstr -ret string $tpl_return_mismatch_not_a_list]} + } elseif {$len == 0} { + #set action ?mismatch-list-index-out-of-range-empty + ${[tstr -ret string $tpl_return_mismatch_list_index_out_of_range_empty]} + } else { + #alias for 0 - for h@head,t@tail= similar to erlang/elixir hd() tl() or [head | tail] = list syntax + ${$assignment_script} + } + }] + } + end { + if {$get_not} { + append script \n "# index_operation listindex-end-not" \n + lappend INDEX_OPERATIONS listindex-end-not + #on single element list Tcl's lrange will do what we want here and return nothing + set assignment_script {set assigned [lrange $leveldata 0 end-1]} + } else { + append script \n "# index_operation listindex-end" \n + lappend INDEX_OPERATIONS listindex-end + set assignment_script {set assigned [lindex $leveldata end]} + } + if {$do_bounds_check} { + append script \n [tstr -return string -allowcommands { + if {[catch {llength $leveldata} len]} { + #set action ?mismatch-not-a-list + ${[tstr -ret string $tpl_return_mismatch_not_a_list]} + } elseif {$len == 0} { + #set action ?mismatch-list-index-out-of-range + ${[tstr -ret string $tpl_return_mismatch_list_index_out_of_range_empty]} + } else { + ${$assignment_script} + } + }] + } else { + append script \n [tstr -return string -allowcommands { + if {[catch {llength $leveldata} len]} { + #set action ?mismatch-not-a-list + ${[tstr -ret string $tpl_return_mismatch_not_a_list]} + } else { + ${$assignment_script} + } + }] + } + } + tail { + #NOTE: /@tail and /tail both do bounds check. This is intentional. + # + #tail is a little different in that we allow tail on a single element list - returning an empty result - but it can't be called on an empty list + #arguably tail could be considered as an index-out-of-range for less than 2 elements - but this would be less useful, and surprising to those coming from other pattern-matching systems. + #In this way tail is different to @1-end + if {$get_not} { + append script \n "# index_operation listindex-tail-not" \n + lappend INDEX_OPERATIONS listindex-tail-not + set assignment_script {set assigned [lindex $leveldata 0]} + } else { + append script \n "# index_operation listindex-tail" \n + lappend INDEX_OPERATIONS listindex-tail + set assignment_script {set assigned [lrange $leveldata 1 end] ;#return zero or more elements - but only if there is something (a head) at position zero} + } + append script \n [tstr -return string -allowcommands { + if {[catch {llength $leveldata} len]} { + #set action ?mismatch-not-a-list + ${[tstr -ret string $tpl_return_mismatch_not_a_list]} + } elseif {$len == 0} { + #set action ?mismatch-list-index-out-of-range + ${[tstr -ret string $tpl_return_mismatch_list_index_out_of_range_empty]} + } else { + ${$assignment_script} + } + }] + } + anyhead { + #allow returning of head or nothing if empty list + if {$get_not} { + append script \n "# index_operation listindex-anyhead-not" \n + lappend INDEX_OPERATIONS listindex-anyhead-not + set assignment_script {set assigned [lrange $leveldata 1 end]} + } else { + append script \n "# index_operation listindex-anyhead" \n + lappend INDEX_OPERATIONS listindex-anyhead + set assignment_script {set assigned [lindex $leveldata 0]} + } + append script \n [tstr -return string -allowcommands { + if {[catch {llength $leveldata} len]} { + #set action ?mismatch-not-a-list + ${[tstr -ret string $tpl_return_mismatch_not_a_list]} + } else { + ${$assignment_script} + } + }] + } + anytail { + #allow returning of tail or nothing if empty list + #anytail will return empty both for empty list, or single element list - but potentially useful in combination with anyhead. + if {$get_not} { + append script \n "# index_operation listindex-anytail-not" \n + lappend INDEX_OPERATIONS listindex-anytail-not + set assignment_script {set assigned [lindex $leveldata 0]} + } else { + append script \n "# index_operation listindex-anytail" \n + lappend INDEX_OPERATIONS listindex-anytail + set assignment_script {set assigned [lrange $leveldata 1 end]} + } + append script \n [tstr -return string -allowcommands { + if {[catch {llength $leveldata} len]} { + #set action ?mismatch-not-a-list + ${[tstr -ret string $tpl_return_mismatch_not_a_list]} + } else { + ${$assignment_script} + } + }] + } + init { + #all but last element - same as haskell 'init' + #counterintuitively, get-notinit can therefore return first element if it is a single element list + #does bounds_check for get-not@init make sense here? maybe - review + if {$get_not} { + append script \n "# index_operation listindex-init-not" \n + lappend INDEX_OPERATIONS listindex-init-not + set assignment_script {set assigned [lindex $leveldata end]} + } else { + append script \n "# index_operation listindex-init" \n + lappend INDEX_OPERATIONS listindex-init + set assignment_script {set assigned [lrange $leveldata 0 end-1]} + } + append script \n [tstr -return string -allowcommands { + if {[catch {llength $leveldata} len]} { + #set action ?mismatch-not-a-list + ${[tstr -ret string $tpl_return_mismatch_not_a_list]} + } else { + ${$assignment_script} + } + }] + } + list { + #get_not? + #allow returning of entire list even if empty + if {$get_not} { + lappend INDEX_OPERATIONS list-getall-not + set assignment_script {set assigned {}} + } else { + lappend INDEX_OPERATIONS list-getall + set assignment_script {set assigned $leveldata} + } + append script \n [tstr -return string -allowcommands { + if {[catch {llength $leveldata} len]} { + #set action ?mismatch-not-a-list + ${[tstr -ret string $tpl_return_mismatch_not_a_list]} + } else { + ${$assignment_script} + } + }] + } + raw { + #get_not - return nothing?? + #no list checking.. + if {$get_not} { + lappend INDEX_OPERATIONS getraw-not + append script \n {set assigned {}} + } else { + lappend INDEX_OPERATIONS getraw + append script \n {set assigned $leveldata} + } + } + keys { + #@get_not?? + #need active_key_type of 'list' for 'keys' and 'values' keywords which act on either dict or a list with even number of elements + if {$get_not} { + lappend INDEX_OPERATIONS list-getkeys-not + set assignment_script {set assigned [dict values $leveldata]} ;#not-keys is equivalent to values + } else { + lappend INDEX_OPERATIONS list-getkeys + set assignment_script {set assigned [dict keys $leveldata]} + } + append script \n [tstr -return string -allowcommands { + if {[catch {dict size $leveldata} dsize]} { + #set action ?mismatch-not-a-dict + ${[tstr -ret string $tpl_return_mismatch_not_a_dict]} + } else { + ${$assignment_script} + } + }] + } + values { + #get_not ?? + #need active_key_type of 'list' for 'keys' and 'values' keywords which act on either dict or a list with even number of elements + if {$get_not} { + lappend INDEX_OPERATIONS list-getvalues-not + set assignment_script {set assigned [dict keys $leveldata]} ;#not-values is equivalent to keys + } else { + lappend INDEX_OPERATIONS list-getvalues + set assignment_script {set assigned [dict values $leveldata]} + } + append script \n [tstr -return string -allowcommands { + if {[catch {dict size $leveldata} dsize]} { + #set action ?mismatch-not-a-dict + ${[tstr -ret string $tpl_return_mismatch_not_a_dict]} + } else { + ${$assignment_script} + } + }] + } + pairs { + #get_not ?? + if {$get_not} { + #review - return empty list instead like not-list and not-raw? + error $listmsg "destructure $selector" [list pipesyntax destructure selector $selector not-pairs_not_supported] + } else { + lappend INDEX_OPERATIONS list-getpairs + } + append script \n [tstr -return string -allowcommands { + if {[catch {dict size $leveldata} dsize]} { + #set action ?mismatch-not-a-dict + ${[tstr -ret string $tpl_return_mismatch_not_a_dict]} + } else { + set pairs [list] + tcl::dict::for {k v} $leveldata {lappend pairs [list $k $v]} + set assigned [lindex [list $pairs [unset pairs]] 0] + } + }] + } + default { + if {[regexp {[?*]} $index]} { + if {$get_not} { + lappend INDEX_OPERATIONS listsearch-not + set assign_script [string map [list $index] { + set assigned [lsearch -all -inline -not $leveldata ] + }] + } else { + lappend INDEX_OPERATIONS listsearch + set assign_script [string map [list $index] { + set assigned [lsearch -all -inline $leveldata ] + }] + } + append script \n [tstr -return string -allowcommands { + if {[catch {llength $leveldata} len]} { + ${[tstr -ret string $tpl_return_mismatch_not_a_list]} + } else { + ${$assign_script} + } + }] + } elseif {[string is integer -strict $index]} { + if {$get_not} { + lappend INDEX_OPERATIONS listindex-not + set assign_script [string map [list $index] { + #not- was specified (already handled not-0) + set assigned [lreplace $leveldata ] + }] + } else { + lappend INDEX_OPERATIONS listindex + set assign_script [string map [list $index] {set assigned [lindex $leveldata ]}] + } + + if {$do_bounds_check} { + if {$index < 0} { + error $listmsg "destructure $selector" [list pipesyntax destructure selector $selector index_lessthanzero_out_of_bounds_for_all_data_while_bounds_check_on] + } + set max [expr {$index + 1}] + append script \n [tstr -return string -allowcommands { + if {[catch {llength $leveldata} len]} { + #set action ?mismatch-not-a-list + ${[tstr -ret string $tpl_return_mismatch_not_a_list]} + } else { + # bounds_check due to @ directly specified in original index section + if {${$max} > $len} { + #set action ?mismatch-list-index-out-of-range + ${[tstr -ret string $tpl_return_mismatch_list_index_out_of_range]} + } else { + ${$assign_script} + } + } + }] + } else { + append script \n [tstr -return string -allowcommands { + if {[catch {llength $leveldata} len]} { + #set action ?mismatch-not-a-list + ${[tstr -ret string $tpl_return_mismatch_not_a_list]} + } else { + ${$assign_script} + } + }] + } + } elseif {[punk::lib::is_indexset $index]} { + #review - a basic math statement such as 5-1 is also a valid member of an indexset + #see punk::lib::is_indexset and punk::lib::indexset_resolve + #single element of an indexset - e.g @..3 or @1..5 or @..end or @.. or @end..0 or @end-5..8 etc + set is_range [expr {[string first ".." $index] >= 0}] + if {$get_not} { + if {$is_range} { + lappend INDEX_OPERATIONS list-range-not + } else { + lappend INDEX_OPERATIONS listindex-not + } + set assign_script { + set assigned [lremove $assigned {*}[punk::lib::indexset_resolve [llength $leveldata] ]] + } + } else { + if {$is_range} { + lappend INDEX_OPERATIONS list-range + #todo - if we know it's a contiguous range, we could use lrange here instead of lindex + #we would also need to detect if it's a reverse range such as @5..1 and handle that correctly + #- lrange doesn't support reverse ranges, but we could resolve the indexset to a list of indices + #and then use lindex with that list of indices to get the correct result. + #we don't always know at this point if the range is in reverse or not because we don't know the size of the list until + #runtime - so we will handle both cases in the same way for now. + #e.g for index 5..end-6 - this could be forward or reverse depending on the length of the list. + set assign_script { + set assigned [lmap i [punk::lib::indexset_resolve [llength $leveldata] ] {lindex $leveldata $i}] + } + } else { + lappend INDEX_OPERATIONS listindex + set assign_script { + set assigned [lindex $leveldata [punk::lib::indexset_resolve [llength $leveldata] ]] + } + } + } + + if {$do_bounds_check} { + #bounds check each element of the resolved indexset - if any are out of bounds, return mismatch-list-index-out-of-range + if {$is_range} { + append script \n [tstr -return string -allowcommands { + if {[catch {llength $leveldata} len]} { + #set action ?mismatch-not-a-list + ${[tstr -ret string $tpl_return_mismatch_not_a_list]} + } else { + lassign [split ..] idx1 _ idx2 + set v2 [punk::lib::lindex_resolve_basic $len $idx2] + if {isinf($v2)} { + ${[tstr -ret string $tpl_return_mismatch_list_index_out_of_range]} + } + set v1 [punk::lib::lindex_resolve_basic $len $idx1] + if {isinf($v1)} { + ${[tstr -ret string $tpl_return_mismatch_list_index_out_of_range]} + } + ${$assign_script} + } + }] + } else { + append script \n [tstr -return string -allowcommands { + if {[catch {llength $leveldata} len]} { + #set action ?mismatch-not-a-list + ${[tstr -ret string $tpl_return_mismatch_not_a_list]} + } else { + set v1 [punk::lib::lindex_resolve_basic $len ] + if {isinf($v1)} { + ${[tstr -ret string $tpl_return_mismatch_list_index_out_of_range]} + } + ${$assign_script} + } + }] + } + } else { + append script \n [tstr -return string -allowcommands { + if {[catch {llength $leveldata} len]} { + #set action ?mismatch-not-a-list + ${[tstr -ret string $tpl_return_mismatch_not_a_list]} + } else { + ${$assign_script} + } + }] + } + set script [string map [list $index] $script] + } elseif {[string first "end" $index] >=0} { + #review - obsoleted by indexset syntax. prune branch? + puts stderr "index with end detected - review if this branch still reachable - prune? $index" + if {[regexp {^end([-+]{1,2}[0-9]+)$} $index _match endspec]} { + + if {$get_not} { + lappend INDEX_OPERATIONS listindex-endoffset-not + set assign_script [string map [list $index] { + #not- was specified (already handled not-0) + set assigned [lreplace $leveldata ] + }] + } else { + lappend INDEX_OPERATIONS listindex-endoffset + set assign_script [string map [list $index ] {set assigned [lindex $leveldata ]}] + } + + if {$do_bounds_check} { + #tstr won't add braces - so the ${$endspec} value inserted in the expr will remain unbraced as required in this case. + append script \n [tstr -return string -allowcommands { + if {[catch {llength $leveldata} len]} { + set action ?mismatch-not-a-list + } else { + #bounds-check is true + #leave the - from the end- as part of the offset + set offset [expr ${$endspec}] ;#don't brace! + if {($offset > 0 || abs($offset) >= $len)} { + #set action ?mismatch-list-index-out-of-range + ${[tstr -ret string $tpl_return_mismatch_list_index_out_of_range]} + } else { + ${$assign_script} + } + } + }] + } else { + append script \n [tstr -ret string -allowcommands { + if {[catch {llength $leveldata} len]} { + #set action ?mismatch-not-a-list + ${[tstr -ret string $tpl_return_mismatch_not_a_list]} + } else { + ${$assign_script} + } + }] + } + + } elseif {[regexp {^([0-9]+|end|end[-+]{1,2}[0-9]+)-([0-9]+|end|end[-+]{1,2}([0-9]+))$} $index _ start end]} { + #review - obsoleted by indexset syntax. prune branch? + puts stderr "index with range and end detected - review if this branch still reachable - prune? $index" + if {$get_not} { + lappend INDEX_OPERATIONS list-range-not + set assign_script [string map [list $start $end ] { + #not- was specified (already handled not-0) + set assigned [lreplace $leveldata ] + }] + } else { + lappend INDEX_OPERATIONS list-range + set assign_script [string map [list $start $end] {set assigned [lrange $leveldata ]}] + } + + append script \n [tstr -ret string -allowcommands { + if {[catch {llength $leveldata} len]} { + #set action ?mismatch-not-a-list + ${[tstr -ret string $tpl_return_mismatch_not_a_list]} + } + }] + + if {$do_bounds_check} { + if {[string is integer -strict $start]} { + if {$start < 0} { + error $listmsg "destructure $selector" [list pipesyntax destructure selector $selector start_lessthanzero_out_of_bounds_for_all_data_while_bounds_check_on] + } + append script \n [tstr -return string -allowcommands { + set start ${$start} + if {$start+1 > $len} { + #set action ?mismatch-list-index-out-of-range + ${[tstr -ret string $tpl_return_mismatch_list_index_out_of_range]} + } + }] + } elseif {$start eq "end"} { + #noop + } else { + set startoffset [string range $start 3 end] ;#include the - from end- + set startoffset [expr $startoffset] ;#don't brace! + if {$startoffset > 0} { + #e.g end+1 + error $listmsg "destructure $selector" [list pipesyntax destructure selector $selector end+x_out_of_bounds_for_all_data_while_bounds_check_on] + + } + append script \n [tstr -return string -allowcommands { + set startoffset ${$startoffset} + if {abs($startoffset) >= $len} { + #set action ?mismatch-list-index-out-of-range + ${[tstr -ret string $tpl_return_mismatch_list_index_out_of_range]} + } + }] + } + if {[string is integer -strict $end]} { + if {$end < 0} { + error $listmsg "destructure $selector" [list pipesyntax destructure selector $selector end_lessthanzero_out_of_bounds_for_all_data_while_bounds_check_on] + } + append script \n [tstr -return string -allowcommands { + set end ${$end} + if {$end+1 > $len} { + #set action ?mismatch-list-index-out-of-range + ${[tstr -ret string $tpl_return_mismatch_list_index_out_of_range]} + } + }] + } elseif {$end eq "end"} { + #noop + } else { + set endoffset [string range $end 3 end] ;#include the - from end- + + set endoffset [expr $endoffset] ;#don't brace! + if {$endoffset > 0} { + error $listmsg "destructure $selector" [list pipesyntax destructure selector $selector end+x_out_of_bounds_for_all_data_while_bounds_check_on] + } + append script \n [tstr -return string -allowcommands { + set endoffset ${$endoffset} + if {abs($endoffset) >= $len} { + #set action ?mismatch-list-index-out-of-range + ${[tstr -ret string $tpl_return_mismatch_list_index_out_of_range]} + } + }] + } + } + + append script \n [string map [list $assign_script] { + if {![string match ?mismatch-* $action]} { + + } + }] + + } else { + #fail now - no need for script + error $listmsg "destructure $selector" [list pipesyntax destructure selector $selector] + } + } elseif {[string first - $index] > 0} { + puts stderr "index with - detected - review if this branch still reachable - prune? $index" + #review - we changed to detect indexset above. + #syntax @m-n should be deprecated in favour of @m..n + #todo - check if this branch still reachable - prune? + #e.g @1-3 gets here + #JMN + if {$get_not} { + lappend INDEX_OPERATIONS list-range-not + } else { + lappend INDEX_OPERATIONS list-range + } + + append script \n [tstr -return string -allowcommands { + if {[catch {llength $leveldata} len]} { + #set action ?mismatch-not-a-list + ${[tstr -ret string $tpl_return_mismatch_not_a_list]} + } + }] + + #handle pure int-int ranges separately + set testindex [string map [list - "" + ""] $index] + if {[string is digit -strict $testindex]} { + #don't worry about leading - negative value for indices not valid anyway + set parts [split $index -] + if {[llength $parts] != 2} { + error $listmsg "destructure $selector" [list pipesyntax destructure selector $selector] + } + lassign $parts start end + + #review - Tcl lrange just returns nothing silently. + #if we don't intend to implement reverse indexing - we should probably not emit an error + if {$start > $end} { + puts stderr "pipesyntax for selector $selector error - reverse index unimplemented" + error $listmsg "destructure $selector" [list pipesyntax destructure selector $selector] + } + if {$do_bounds_check} { + #append script [string map [list $start $end] { + # set start + # set end + # if {$start+1 > $len || $end+1 > $len} { + # set action ?mismatch-list-index-out-of-range + # } + #}] + #set eplusone [expr {$end+1}] + append script [tstr -return string -allowcommands { + if {$len < ${[expr {$end+1}]}} { + set action ?mismatch-list-index-out-of-range + ${[tstr -ret string $tpl_return_mismatch_list_index_out_of_range]} + } + }] + } + + + if {$get_not} { + set assign_script [string map [list $start $end] { + #not- was specified (already handled not-0) + set assigned [lreplace $leveldata ] + }] + } else { + set assign_script [string map [list $start $end] {set assigned [lrange $leveldata ]}] + } + + + } else { + error $listmsg "destructure $selector" [list pipesyntax destructure selector $selector] + } + + append script \n [string map [list $assign_script] { + if {![string match ?mismatch-* $action]} { + + } + }] + + } else { + #keyword 'pipesyntax' at beginning of error message + #pipesyntax error - no need to even build script - can fail now + error $listmsg "destructure $selector" [list pipesyntax destructure selector $selector] + } + } + } + } elseif {$active_key_type eq "string"} { + #changed to indexset notation m..n allowing eg 2..end-1 etc. + #if {[string match *-* $index]} {} + + if {[punk::lib::is_indexset $index]} { + #review - we are assuming a single element indexset here - ie no comma separated sets. + + #todo - support $get_not + #todo - consider bounds_check for string indices. + # - Tcl doesn't do bounds checking for string index, but we need to consider in the context of pattern-matching + # whether we want to support syntaxes for with and without bounds checking on string indices. + + set is_range [expr {[string first ".." $index] >= 0}] + if {$is_range} { + lappend INDEX_OPERATIONS string-range + #review - not efficient for contiguous monotonically increasing ranges + #because we are retrievinng each character individually and concatenating + #- but it is more flexible because it also supports reverse ranges and could support non-contiguous ranges such as @0,2,4..6 + set assign_script { + set assigned [join [lmap i [punk::lib::indexset_resolve [string length $leveldata] ] {string index $leveldata $i}] ""] + } + } else { + lappend INDEX_OPERATIONS string-index + set assign_script { + set assigned [string index $leveldata [punk::lib::indexset_resolve [string length $leveldata] ]] + } + } + + #set assign_script { + # set assigned [lmap i [punk::lib::indexset_resolve [llength $leveldata] ] {lindex $leveldata $i}] + #} + + #todo - consider where/if we can support 'ansistring INDEX' for ANSI strings. + #if so - it shouldn't overload the % operator we currently use for string access. + append script \n [tstr -return string -allowcommands { + if {$leveldata eq ""} { + set assigned "" + } else { + ${$assign_script} + } + }] + set script [string map [list $index] $script] + + + #set re_idxdashidx {^([-+]{0,1}\d+|end[-+]{1}\d+|end)-([-+]{0,1}\d+|end[-+]{1}\d+|end)$} + ##todo - support more complex indices: 0-end-1 etc + + #lassign [split $index -] a b + #append script \n [tstr -return string -allowcommands { + # # set active_key_type "string" + # set assigned [string range $leveldata ${$a} ${$b}] + #}] + + } else { + if {$index eq "*"} { + #equivalent to indexset ".." + lappend INDEX_OPERATIONS string-all + append script \n [tstr -return string -allowcommands { + # set active_key_type "string" + set assigned $leveldata + }] + } elseif {[regexp {[?*]} $index]} { + lappend INDEX_OPERATIONS string-globmatch + append script \n [tstr -return string -allowcommands { + # set active_key_type "string" + if {[string match $index $leveldata]} { + set assigned $leveldata + } else { + set assigned "" + } + }] + } else { + lappend INDEX_OPERATIONS string-index + append script \n [tstr -return string -allowcommands { + # set active_key_type "string" + set assigned [string index $leveldata ${$index}] + }] + } + } + + } else { + #treat as dict key + if {$get_not} { + #dict remove can accept non-existent keys.. review do we require not-@?@key to get silence? + append script \n [tstr -return string { + set assigned [dict remove $leveldata ${$index}] + }] + } else { + append script \n [tstr -return string -allowcommands { + # set active_key_type "dict" + if {[dict exists $leveldata {${$index}}]} { + set assigned [dict get $leveldata {${$index}}] + } else { + set action ?mismatch-dict-key-not-found + ${[tstr -ret string $tpl_return_mismatch_dict_key_not_found]} + } + }] + } + + } + + + } ;# end if $level_script_complete + + + append script \n { + set leveldata $assigned + } + incr i_keyindex + append script \n "# ------- END index $index ------" + } ;# end foreach + + + + #puts stdout "----> destructure rep leveldata: [rep $leveldata]" + #puts stdout ">> destructure returning: [dict create -assigned $leveldata -action $action -lhs $lhs -rhs $rhs]" + + #maintain key order - caller unpacks using lassign + #append script \n {dict create -assigned $leveldata -action $action -lhs $lhs -rhs $rhs} + append script \n [tstr -return string $return_template] \n + return $script + } + + + + + #called from match_assign/know_dot_assign for lhs of assignment - uplevel 2 to caller's level + #called from match_assign/know_dot_assign for rhs pipelined vars - uplevel 1 to write vars only in 'apply' scope + #return a dict with keys result, setvars, unsetvars + #TODO - implement cross-binding (as opposed to overwrite/reassignment) when a var appears multiple times in a pattern/multivar + #e.g x@0,x@1 will only match if value at positions 0 & 1 is the same (a form of auto-pinning?) + #e.g x,x@0 will only match a single element list + #todo blocking or - p1|p2 if p1 matches - return p1 and continue pipeline - immediately return p2 if p1 didn't match. (ie p2 not forwarded in pipeline) + # non-blocking or - p1||p2 if p1 matches - return p1 and continue pipeline - else match p2 and continue pipeline + proc _multi_bind_result {multivar data args} { + #puts stdout "---- _multi_bind_result multivar:'$multivar' data:'$data' options:'$args'" + #'ismatch' must always be first element of dict - as we dispatch on ismatch 0 or ismatch 1 + if {![string length $multivar]} { + #treat the absence of a pattern as a match to anything + #JMN2 - changed to list based destructuring + return [dict create ismatch 1 result $data setvars {} script {}] + #return [dict create ismatch 1 result [list $data] setvars {} script {}] + } + set returndict [dict create ismatch 0 result "" setvars {}] + set script "" + + set defaults [list -unset 0 -levelup 2 -mismatchinfo 1 -script 0] + set opts [dict merge $defaults $args] + set unset [dict get $opts -unset] + set lvlup [dict get $opts -levelup] + set get_mismatchinfo [dict get $opts -mismatchinfo] + + + + #first classify into var_returntype of either "pipeline" or "segment" + #segment returntype is indicated by leading % + + set varinfo [punk::pipe::lib::_var_classify $multivar] + set var_names [dict get $varinfo var_names] + set var_class [dict get $varinfo var_class] + set varspecs_trimmed [dict get $varinfo varspecs_trimmed] + + set var_actions [list] + set expected_values [list] + #e.g {a = abc} {b set ""} + foreach classinfo $var_class vname $var_names { + lassign [lindex $classinfo 0] v + lappend var_actions [list $v "" ""] ;#varactions keeps original lhs - not trimmed version + lappend expected_values [list var $vname spec $v info - lhs - rhs -] ;#code looks for 'info -' to see if changed from default + } + + #puts stdout "var_actions: $var_actions" + #puts stdout "expected_values: $expected_values" + + + #puts stdout "\n var_class: $var_class\n" + # e.g {{x {}} 0} {{y @0} 0} {{'ok @0} 1} {{^v @@key} 2} + + #set varspecs_trimmed [lmap varinfo $var_class {expr {([lindex $varinfo 1] > 0) ? [list [string range [lindex $varinfo 0 0] 1 end] [lindex $varinfo 0 1]] : [lindex $varinfo 0]}}] + #puts stdout "\n varspecs_trimmed: $varspecs_trimmed\n" + + + #var names (possibly empty portion to the left of ) + #debug.punk.pipe.var "varnames: $var_names" 4 + + set v_list_idx(@) 0 ;#for spec with single @ only + set v_dict_idx(@@) 0 ;#for spec with @@ only + + #jn + + #member lists of returndict which will be appended to in the initial value-retrieving loop + set returndict_setvars [dict get $returndict setvars] + + set assigned_values [list] + + + #varname action value - where value is value to be set if action is set + #actions: + # "" unconfigured - assert none remain unconfigured at end + # noop no-change + # matchvar-set name is a var to be matched + # matchatom-set names is an atom to be matched + # matchglob-set + # set + # question mark versions are temporary - awaiting a check of action vs var_class + # e.g ?set may be changed to matchvar or matchatom or set + + + debug.punk.pipe.var {initial map expected_values: $expected_values} 5 + + set returnval "" + set i 0 + #assertion i incremented at each continue and at each end of loop - at end i == list length + 1 + #always use 'assigned' var in each loop + # (for consistency and to assist with returnval) + # ^var means a pinned variable - compare value of $var to rhs - don't assign + # + # In this loop we don't set variables - but assign an action entry in var_actions - all with leading question mark. + # as well as adding the data values to the var_actions list + # + # TODO! we may (commonly) encounter same vkey in the pattern - no need to reparse and re-fetch from data! + set vkeys_seen [list] + foreach v_and_key $varspecs_trimmed { + set vspec [join $v_and_key ""] + lassign $v_and_key v vkey + + set assigned "" + #The binding spec begins at first @ or # or / + + #set firstq [string first "'" $vspec] + #set v [lindex $var_names $i] + #if v contains any * and/or ? - then it is a glob match - not a varname + + lassign [destructure_func $vkey $data] _assigned assigned _action matchaction _lhs lhs _rhs rhs + if {$matchaction eq "?match"} { + set matchaction "?set" + } + lset var_actions $i 1 $matchaction + lset var_actions $i 2 $assigned + + #update the setvars/unsetvars elements + if {[string length $v]} { + dict set returndict_setvars $v $assigned + } + + #JMN2 + #special case expansion for empty varspec (e.g , or ,,) + #if {$vspec eq ""} { + # lappend assigned_values {*}$assigned + #} else { + lappend assigned_values $assigned + #} + incr i + } + + #todo - fix! this isn't the actual tclvars that were set! + dict set returndict setvars $returndict_setvars + + #assigned_values is the ordered list of source elements in the data (rhs) as extracted by each position-spec + #For booleans the final val may later be normalised to 0 or 1 + + + #assertion all var_actions were set with leading question mark + #perform assignments only if matched ok + + + #0 - novar + #1 - atom ' + #2 - pin ^ + #3 - boolean & + #4 - integer + #5 - double + #6 - var + #7 - glob (no classifier and contains * or ?) + if 0 { + debug.punk.pipe.var {VAR_CLASS: $var_class} 5 + debug.punk.pipe.var {VARACTIONS: $var_actions} 5 + debug.punk.pipe.var {VARSPECS_TRIMMED: $varspecs_trimmed} 5 + + debug.punk.pipe.var {atoms: [lsearch -all -inline -index 1 $var_class 1]} 5 + debug.punk.pipe.var {pins: [lsearch -all -inline -index 1 $var_class 2]} 5 + debug.punk.pipe.var {bools: [lsearch -all -inline -index 1 $var_class 3]} 5 + debug.punk.pipe.var {ints: [lsearch -all -inline -index 1 $var_class 4]} 5 + debug.punk.pipe.var {doubles: [lsearch -all -inline -index 1 $var_class 5]} 5 + debug.punk.pipe.var {vars: [lsearch -all -inline -index 1 $var_class 6]} 5 + debug.punk.pipe.var {globs: [lsearch -all -inline -index 1 $var_class 7]} 5 + } + + set match_state [lrepeat [llength $var_names] ?] + unset -nocomplain v + unset -nocomplain nm + set mismatched [list] + set i 0 + #todo - stop at first mismatch - for pattern matching (especially pipecase - we don't want to waste time reading vars if we already have a mismatch earlier in the pattern) + foreach va $var_actions { + #val comes from -assigned + lassign $va lhsspec act val ;#lhsspec is the full value source for LHS ie the full atom/number/varspec e.g for pattern ^var@@key/@0 it is "^var" + set varname [lindex $var_names $i] + + if {[string match "?mismatch*" $act]} { + #already determined a mismatch - e.g list or dict key not present + lset match_state $i 0 + lset expected_values $i [list var $varname spec $lhsspec info mismatch lhs ? rhs $val] + break + } + + + set class_key [lindex $var_class $i 1] + lassign {0 0 0 0 0 0 0 0 0 0} isatom ispin isbool isint isdouble isvar isglob isnumeric isgreaterthan islessthan + foreach ck $class_key { + switch -- $ck { + 1 {set isatom 1} + 2 {set ispin 1} + 3 {set isbool 1} + 4 {set isint 1} + 5 {set isdouble 1} + 6 {set isvar 1} + 7 {set isglob 1} + 8 {set isnumeric 1} + 9 {set isgreaterthan 1} + 10 {set islessthan 1} + } + } + + + #set isatom [expr {$class_key == 1}] + #set ispin [expr {2 in $class_key}] + #set isbool [expr {3 in $class_key}] + #set isint [expr {4 in $class_key}] + #set isdouble [expr {5 in $class_key}] + #set isvar [expr {$class_key == 6}] + #set isglob [expr {7 in $class_key}] + #set isnumeric [expr {8 in $class_key}] ;#force numeric comparison (only if # classifier present) + ##marking numbers with pin ^ has undetermined meaning. Perhaps force expr matching only? + #set isgreaterthan [expr {9 in $class_key}] + #set islessthan [expr {10 in $class_key}] + + + + if {$isatom} { + #puts stdout "==>isatom $lhsspec" + set lhs [string range $lhsspec 1 end] + if {[string index $lhs end] eq "'"} { + set lhs [string range $lhs 0 end-1] + } + lset var_actions $i 1 matchatom-set + if {$lhs eq $val} { + lset match_state $i 1 + lset expected_values $i [list var $varname spec $lhsspec info match lhs $lhs rhs $val] + incr i + continue + } else { + lset match_state $i 0 + lset expected_values $i [list var $varname spec $lhsspec info strings-not-equal lhs $lhs rhs $val] + break + } + } + + + + + # - should set expected_values in each branch where match_state is not set to 1 + # - setting expected_values when match_state is set to 0 is ok except for performance + + + #todo - pinned booleans? we would need to disambiguate from a direct value match.. ie double tag as something like: ^&var or + #ispin may reclassify as isint,isdouble based on contained value (as they don't have their own classifier char and are unambiguous and require special handling) + if {$ispin} { + #puts stdout "==>ispin $lhsspec" + if {$act in [list "?set" "?matchvar-set"]} { + lset var_actions $i 1 matchvar-set + #attempt to read + upvar $lvlup $varname the_var + #if {![catch {uplevel $lvlup [list ::set $varname]} existingval]} {} + if {![catch {set the_var} existingval]} { + + if {$isbool} { + #isbool due to 2nd classifier i.e ^& + lset expected_values $i [list var $varname spec $lhsspec info test-lhs-bool lhs $existingval rhs $val] + #normalise to LHS! + lset assigned_values $i $existingval + } elseif {$isglob} { + #isglob due to 2nd classifier ^* + lset expected_values $i [list var $varname spec $lhsspec info test-lhs-glob lhs $existingval rhs $val] + } elseif {$isnumeric} { + #flagged as numeric by user using ^# classifiers + set testexistingval [join [scan $existingval %lld%s] ""] ;# handles octals (leading zeros), ok for use with bignums, internal decimal points and sci notation (but not leading .) + if {[string is integer -strict $testexistingval]} { + set isint 1 + lset assigned_values $i $existingval + lset expected_values $i [list var $varname spec $lhsspec info test-lhs-int lhs $existingval rhs $val] + } elseif {[string is double $existingval] || [string is double -strict $testexistingval]} { + #test existingval in case something like .5 (which scan will have missed - producing empty testexistingval) + set isdouble 1 + #doubles comparisons use float_almost_equal - so lhs can differ from rhs - for pins we always want to return the normalised lhs ie exactly what is in the var + lset assigned_values $i $existingval + + lset expected_values $i [list var $varname spec $lhsspec info test-lhs-double lhs $existingval rhs $val] + } else { + #user's variable doesn't seem to have a numeric value + lset match_state $i 0 + lset expected_values $i [list var $varname spec $lhsspec info mismatch-lhs-not-numeric lhs $existingval rhs $val] + break + } + + } else { + #standard pin - single classifier ^var + lset match_state $i [expr {$existingval eq $val}] + if {![lindex $match_state $i]} { + lset match_state $i 0 + lset expected_values $i [list var $varname spec $lhsspec info "string-compare-not-equal" lhs $existingval rhs $val] + break + } else { + lset expected_values $i [list var $varname spec $lhsspec info "string-compare-equal" lhs $existingval rhs $val] + } + } + + } else { + #puts stdout "pinned var $varname result:$result vs val:$val" + #failure is *probably* because var is unset - but could be a read-only var due to read-trace or it could be nonexistant namespace + lset match_state $i 0 + lset expected_values $i [list var $varname spec $lhsspec info failread-$varname lhs ? rhs $val] + break + } + } + } + + + + if {$isint} { + #note - we can have classified (above) a value such as 08 on lhs as integer - even though expr and string is integer don't do so. + #expected_values $i [list var $varname spec $lhsspec info match-lhs-int lhs $existingval rhs $val] + + if {$ispin} { + set existing_expected [lindex $expected_values $i] + set lhs [dict get $existing_expected lhs] + } else { + set lhs $lhsspec ;#literal integer in the pattern + } + if {$isgreaterthan || $islessthan} { + set lhs [string range $lhsspec 0 end-1] + set testlhs $lhs + } + if {[string index $lhs 0] eq "."} { + set testlhs $lhs + } else { + set testlhs [join [scan $lhs %lld%s] ""] + } + if {[string index $val 0] eq "."} { + set testval $val + } else { + set testval [join [scan $val %lld%s] ""] ;# handles octals (leading zeros) and bignums (not leading .) + } + if {[string is integer -strict $testval]} { + if {$isgreaterthan} { + #puts "lhsspec: $lhsspec testlhs: $testlhs testval: $testval" + if {$testlhs <= $testval} { + lset match_state $i 1 + } else { + lset match_state $i 0 + lset expected_values $i [list var $varname spec $lhsspec info "expr-not-greater-than-int-int" lhs $lhs rhs $val] + break + } + } elseif {$islessthan} { + if {$testlhs >= $testval} { + lset match_state $i 1 + } else { + lset match_state $i 0 + lset expected_values $i [list var $varname spec $lhsspec info "expr-not-less-than-int-int" lhs $lhs rhs $val] + break + } + } else { + if {$testlhs == $testval} { + lset match_state $i 1 + } else { + lset match_state $i 0 + lset expected_values $i [list var $varname spec $lhsspec info "expr-mismatch-int-int" lhs $lhs rhs $val] + break + } + } + } elseif {[string is double -strict $testval]} { + #dragons. (and shimmering) + if {[string first "e" $val] != -1} { + #scientific notation - let expr compare + if {$isgreaterhthan} { + if {$testlhs <= $testval} { + lset match_state $i 1 + } else { + lset match_state $i 0 + lset expected_values $i [list var $varname spec $lhsspec info "expr-not-greater-than-int-sci" lhs $lhs rhs $val] + break + } + } elseif {$islessthan} { + if {$testlhs >= $testval} { + lset match_state $i 1 + } else { + lset match_state $i 0 + lset expected_values $i [list var $varname spec $lhsspec info "expr-not-less-than-int-sci" lhs $lhs rhs $val] + break + } + } else { + if {$testlhs == $testval} { + lset match_state $i 1 + } else { + lset match_state $i 0 + lset expected_values $i [list var $varname spec $lhsspec info "expr-mismatch-int-sci" lhs $lhs rhs $val] + break + } + } + } elseif {[string is digit -strict [string trim $val -]] } { + #probably a wideint or bignum with no decimal point + #It seems odd that bignums which just look like large integers should ever compare equal if you do a +1 to one side . + #if we use float_almost_equal they may compare equal. on the other hand expr also does apparently inconsistent thins with comparing integer-like bignums vs similar sized nums with .x at the end. + #2 values further apart can compare equal while int-like ones closer together can compare different. + #The rule seems to be for bignums that if it *looks* like a whole int the comparison is exact - but otherwise the float behaviours kick in. + #This is basically what we're doing here but with an arguably better (for some purposes!) float comparison. + #string comparison can presumably always be used as an alternative. + # + #let expr compare + if {$isgreaterthan} { + if {$testlhs <= $testval} { + lset match_state $i 1 + } else { + lset match_state $i 0 + lset expected_values $i [list var $varname spec $lhsspec info "expr-not-greater-than-int-puredigits" lhs $lhs rhs $val] + break + } + } elseif {$islessthan} { + if {$testlhs >= $testval} { + lset match_state $i 1 + } else { + lset match_state $i 0 + lset expected_values $i [list var $varname spec $lhsspec info "expr-not-less-than-int-puredigits" lhs $lhs rhs $val] + break + } + } else { + if {$testlhs == $testval} { + lset match_state $i 1 + } else { + lset match_state $i 0 + lset expected_values $i [list var $varname spec $lhsspec info "expr-mismatch-int-puredigits" lhs $lhs rhs $val] + break + } + } + } else { + if {[punk::pipe::float_almost_equal $testlhs $testval]} { + lset match_state $i 1 + } else { + if {$isgreaterthan} { + if {$testlhs <= $testval} { + lset match_state $i 1 + } else { + lset match_state $i 0 + lset expected_values $i [list var $varname spec $lhsspec info "expr-not-greater-than-int-float" lhs $lhs rhs $val] + break + } + } elseif {$islessthan} { + if {$testlhs >= $testval} { + lset match_state $i 1 + } else { + lset match_state $i 0 + lset expected_values $i [list var $varname spec $lhsspec info "expr-not-less-than-int-float" lhs $lhs rhs $val] + break + } + } else { + lset match_state $i 0 + lset expected_values $i [list var $varname spec $lhsspec info "float_almost_equal-mismatch-int-float" lhs $lhs rhs $val] + break + } + } + } + } else { + #e.g rhs not a number.. + if {$testlhs == $testval} { + lset match_state $i 1 + } else { + lset match_state $i 0 + lset expected_values $i [list var $varname spec $lhsspec info "expr-mismatch-unknown-rhstestval-$testval" lhs $lhs rhs $val] + break + } + } + } elseif {$isdouble} { + #dragons (and shimmering) + # + # + if {$ispin} { + set existing_expected [lindex $expected_values $i] + set lhs [dict get $existing_expected lhs] + } else { + set lhs $lhsspec ;#literal integer in the pattern + } + if {$isgreaterthan || $islessthan} { + error "+/- not yet supported for lhs float" + set lhs [string range $lhsspec 0 end-1] + set testlhs $lhs + } + if {[string index $val 0] eq "."} { + set testval $val ;#not something with some number of leading zeros + } else { + set testval [join [scan $val %lld%s] ""] ;# handles octals (leading zeros), ok for use with bignums, internal decimal points and sci notation (but not leading .) + } + #expr handles leading 08.1 0009.1 etc without triggering octal + #so we don't need to scan lhs + if {[string first "e" $lhs] >= 0 || [string first "e" $testval] >= 0} { + if {$lhs == $testval} { + lset match_state $i 1 + lset expected_values $i [list var $varname spec $lhsspec info match-expr-sci lhs $lhs rhs $val] + } else { + lset match_state $i 0 + lset expected_values $i [list var $varname spec $lhsspec info mismatch-expr-sci lhs $lhs rhs $val] + break + } + } elseif {[string is digit -strict [string trim $lhs -]] && [string is digit -strict [string trim $val -]]} { + #both look like big whole numbers.. let expr compare using it's bignum capability + if {$lhs == $testval} { + lset match_state $i 1 + lset expected_values $i [list var $varname spec $lhsspec info match-expr-pure-digits lhs $lhs rhs $val] + } else { + lset match_state $i 0 + lset expected_values $i [list var $varname spec $lhsspec info mismatch-expr-pure-digits lhs $lhs rhs $val] + break + } + } else { + #float_almost_equal will disagree with expr based on scale.. just enough to allow for example [expr 0.2 + 0.1] to equal 0.3 - whereas expr will declare a mismatch + if {[punk::pipe::float_almost_equal $lhs $testval]} { + lset match_state $i 1 + lset expected_values $i [list var $varname spec $lhsspec info match-float-almost-equal lhs $lhs rhs $val] + } else { + lset match_state $i 0 + lset expected_values $i [list var $varname spec $lhsspec info mismatch-float-almost-equal lhs $lhs rhs $val] + break + } + } + } elseif {$isbool} { + #Note - cross binding of booleans deliberately doesn't compare actual underlying values - only that truthiness or falsiness matches. + #e.g &x/0,&x/1,&x/2= {1 2 yes} + # all resolve to true so the cross-binding is ok. + # Also - the setting of the variable x is normalized to 1 or 0 only. (true & false would perhaps be nicer - but 1 & 0 are theoretically more efficient for later comparisons as they can have a pure int rep?.) + # todo - consider the booleanString rep. Can/should we return true & false instead and maintain efficiency w.r.t shimmering? + # + #punk::pipe::boolean_equal $a $b + set extra_match_info "" ;# possible crossbind indication + set is_literal_boolean 0 + if {$ispin} { + #for a pinned boolean - the most useful return is the value in the pinned var rather than the rhs. This is not entirely consistent .. e.g pinned numbers will return rhs !review! + #As an additional pattern can always retrieve the raw value - pinned vars returning themselves (normalisation use-case ) seems the most consistent overall, and the most useful + set existing_expected [lindex $expected_values $i] + set lhs [dict get $existing_expected lhs] + } else { + set lhs [string range $lhsspec 1 end] ;# - strip off & classifier prefix + + if {![string length $lhs]} { + #empty varname - ok + if {[string is boolean -strict $val] || [string is double -strict $val]} { + lset match_state $i 1 + lset var_actions $i 1 "return-normalised-value" + lset assigned_values $i [expr {bool($val)}] + lset expected_values $i [list var $varname spec $lhsspec info "return-boolean-rhs-normalised" lhs - rhs $val] + } else { + lset match_state $i 0 + lset expected_values $i [list var $varname spec $lhsspec info "mismatch-boolean-rhs" lhs - rhs $val] + break + } + } elseif {$lhs in [list 0 1]} { + #0 & 1 are the only literal numbers that satisfy Tcl's 'string is boolean' test. + set is_literal_boolean 1 + } elseif {[string index $lhs 0] eq "'" && [string index $lhs end] eq "'"} { + #literal boolean (&'yes',&'false',&'1',&'0' etc) in the pattern + #we won't waste any cycles doing an extra validity test here - it will fail in the comparison below if not a string understood by Tcl to represent a boolean. + set is_literal_boolean 1 + set lhs [string range $lhs 1 end-1] ;#strip off squotes + } else { + #todo - a standard variable name checking function for consistency.. for now we'll rule out numbers here to help avoid mistakes. + set tclvar $lhs + if {[string is double $tclvar]} { + error "pipesyntax invalid variable name '$tclvar' for boolean in pattern. (subset of legal tcl vars allowed in pattern context)" "_multi_bind_result $multivar $data $args" [list pipesyntax patternvariable invalid_boolean $tclvar] + #proc _multi_bind_result {multivar data args} + } + #treat as variable - need to check cross-binding within this pattern group + set first_bound [lsearch -index 0 $var_actions $lhsspec] + if {$first_bound == $i} { + #test only rhs (val) for boolean-ness - but boolean-ness as boolean_almost_equal understands it. (e.g floats allowed) + if {[string is boolean -strict $val] || [string is double -strict $val]} { + lset match_state $i 1 + lset var_actions $i 1 [string range $act 1 end] ;# should now be the value "set". We only need this on the first_bound + #review - consider what happens if boolean is leftmost pattern - underlying value vs normalised value to continue in pipeline + #Passing underlying value is inconsistent with what goes in the tclvar - so we need to update the returnval + #puts stderr "==========[lindex $assigned_values $i]" + lset var_actions $i 2 [expr {bool($val)}] ;#normalise to 1 or 0 + lset assigned_values $i [lindex $var_actions $i 2] + #puts stderr "==========[lindex $assigned_values $i]" + lset expected_values $i [list var $varname spec $lhsspec info "match-boolean-rhs-any-lhs" lhs - rhs $val] ;#retain underlying val in expected_values for diagnostics. + } else { + lset match_state $i 0 + lset expected_values $i [list var $varname spec $lhsspec info "mismatch-boolean-rhs-any-lhs" lhs - rhs $val] + break + } + } else { + set expectedinfo [lindex $expected_values $first_bound] + set expected_earlier [dict get $expectedinfo rhs] + set extra_match_info "-crossbind-first" + set lhs $expected_earlier + } + } + } + + + #may have already matched above..(for variable) + if {[lindex $match_state $i] != 1} { + if {![catch {punk::pipe::boolean_almost_equal $lhs $val} ismatch]} { + if {$ismatch} { + lset match_state $i 1 + lset expected_values $i [list var $varname spec $lhsspec info match-boolean-almost-equal$extra_match_info lhs $lhs rhs $val] + } else { + lset match_state $i 0 + lset expected_values $i [list var $varname spec $lhsspec info mismatch-boolean-almost-equal$extra_match_info lhs $lhs rhs $val] + break + } + } else { + #we should only error from boolean_equal if passed something Tcl doesn't recognise as a boolean + lset match_state $i 0 + lset expected_values $i [list var $varname spec $lhsspec info badvalue-boolean$extra_match_info lhs $lhs rhs $val] + break + } + } + + } elseif {$isglob} { + if {$ispin} { + set existing_expected [lindex $expected_values $i] + set lhs [dict get $existing_expected lhs] + } else { + set lhs $lhsspec ;#literal glob in the pattern - no classifier prefix + } + if {[string match $lhs $val]} { + lset match_state $i 1 + lset expected_values $i [list var $varname spec $lhsspec info "match-glob" lhs $lhs rhs $val] + } else { + lset match_state $i 0 + lset expected_values $i [list var $varname spec $lhsspec info "mismatch-glob" lhs $lhs rhs $val] + break + } + + } elseif {$ispin} { + #handled above.. leave case in place so we don't run else for pins + + } else { + #puts stdout "==> $lhsspec" + #NOTE - pinned var of same name is independent! + #ie ^x shouldn't look at earlier x bindings in same pattern + #unpinned non-atoms + #cross-binding. Within this multivar pattern group only (use pin ^ for binding to result from a previous pattern) + # + switch -- $varname { + "" { + #don't attempt cross-bind on empty-varname + lset match_state $i 1 + #don't change var_action $i 1 to set + lset expected_values $i [list var $varname spec $lhsspec info "match-no-lhs-var" lhs - rhs $val] + } + "_" { + #don't cross-bind on the special 'don't-care' varname + lset match_state $i 1 + lset var_actions $i 1 [string range $act 1 end] ;# ?set -> set + lset expected_values $i [list var $varname spec $lhsspec info "match-any-lhs-dontcare-var" lhs - rhs $val] + } + default { + set first_bound [lsearch -index 0 $var_actions $varname] + #assertion first_bound >=0, we will always find something - usually self + if {$first_bound == $i} { + lset match_state $i 1 + lset var_actions $i 1 [string range $act 1 end] ;# ?set -> set + lset expected_values $i [list var $varname spec $lhsspec info "match-any-lhs" lhs - rhs $val] + } else { + assert {$first_bound < $i} assertion_fail: _multi_bind_result condition: [list $first_bound < $i] + set expectedinfo [lindex $expected_values $first_bound] + set expected_earlier [dict get $expectedinfo rhs] + if {$expected_earlier ne $val} { + lset match_state $i 0 + lset expected_values $i [list var $varname spec $lhsspec info "mismatch-crossbind-first" lhs $expected_earlier rhs $val] + break + } else { + lset match_state $i 1 + #don't convert ?set to set - or var setter will write for each crossbound instance. Possibly no big deal for performance - but could trigger unnecessary write traces for example + #lset var_actions $i 1 [string range $act 1 end] + lset expected_values $i [list var $varname spec $lhsspec info "match-crossbind-first" lhs $expected_earlier rhs $val] + } + } + } + } + } + + incr i + } + + #JMN2 - review + #set returnval [lindex $assigned_values 0] + if {[llength $assigned_values] == 1} { + set returnval [join $assigned_values] + } else { + set returnval $assigned_values + } + #puts stdout "----> > rep returnval: [rep $returnval]" + + + + + + #-------------------------------------------------------------------------- + #Variable assignments (set) should only occur down here, and only if we have a match + #-------------------------------------------------------------------------- + set match_count_needed [llength $var_actions] + #set match_count [expr [join $match_state +]] ;#expr must be unbraced here + set matches [lsearch -all -inline $match_state 1] ;#default value for each match_state entry is "?" + set match_count [llength $matches] + + + debug.punk.pipe.var {MATCH_STATE: $match_state count_needed: $match_count_needed vs match_count: $match_count} 4 + debug.punk.pipe.var {VARACTIONS2: $var_actions} 5 + debug.punk.pipe.var {EXPECTED : $expected_values} 4 + + #set match_count [>f . foldl 0 [>f . sum .] $match_state] ;#ok method.. but slow compared to expr with join + if {$match_count == $match_count_needed} { + #do assignments + for {set i 0} {$i < [llength $var_actions]} {incr i} { + if {([lindex $var_class $i 1] == 6 || [lindex $var_class $i] == 3 ) && ([string length [set varname [lindex $var_names $i]]])} { + #isvar + if {[lindex $var_actions $i 1] eq "set"} { + upvar $lvlup $varname the_var + set the_var [lindex $var_actions $i 2] + } + } + } + dict set returndict ismatch 1 + #set i 0 + #foreach va $var_actions { + # #set isvar [expr {[lindex $var_class $i 1] == 6}] + # if {([lindex $var_class $i 1] == 6 || [lindex $var_class $i] == 3 ) && ([string length [set varname [lindex $var_names $i]]])} { + # #isvar + # lassign $va lhsspec act val + # upvar $lvlup $varname the_var + # if {$act eq "set"} { + # set the_var $val + # } + # #if {[lindex $var_actions $i 1] eq "set"} { + # # set the_var $val + # #} + # } + # incr i + #} + } else { + #todo - some way to restrict mismatch info to simple "mismatch" and avoid overhead of verbose message + #e.g for within pipeswitch block where mismatches are expected and the reasons are less important than moving on quickly + set vidx 0 + #set mismatches [lmap m $match_state v $var_names {expr {$m == 0} ? {[list mismatch $v]} : {[list match $v]}}] + set mismatches [lmap m $match_state v $var_names {expr {$m == 0 ? [list mismatch $v] : [list match $v]}}] + set var_display_names [list] + foreach v $var_names { + if {$v eq ""} { + lappend var_display_names {{}} + } else { + lappend var_display_names $v + } + } + #REVIEW 2025 + #set mismatches_display [lmap m $match_state v $var_display_names {expr {$m == 0} ? {$v} : {[expr {$m eq "?"} ? {"?[string repeat { } [expr [string length $v] -1]]"} : {[string repeat " " [string length $v]]} ]}}] + set mismatches_display [lmap m $match_state v $var_display_names {expr {$m == 0 ? $v : [expr {$m eq "?" ? "?[string repeat { } [expr {[string length $v] -1}]]" : [string repeat " " [string length $v]] }]}}] + set msg "\n" + append msg "Unmatched\n" + append msg "Cannot match right hand side to pattern $multivar\n" + append msg "vars/atoms/etc: $var_names\n" + append msg "mismatches: [join $mismatches_display { } ]\n" + set i 0 + #0 - novar + #1 - atom ' + #2 - pin ^ + #3 - boolean & + #4 - integer + #5 - double + #6 - var + #7 - glob (no classifier and contains * or ?) + foreach mismatchinfo $mismatches { + lassign $mismatchinfo status varname + if {$status eq "mismatch"} { + # varname can be empty string + set varclass [lindex $var_class $i 1] + set val [lindex $var_actions $i 2] + set e [dict get [lindex $expected_values $i] lhs] + set type "" + if {2 in $varclass} { + append type "pinned " + } + + if {$varclass == 1} { + set type "atom" + } elseif {$varclass == 2} { + set type "pinned var" + } elseif {3 in $varclass} { + append type "boolean" + } elseif {4 in $varclass} { + append type "int" + } elseif {5 in $varclass} { + append type "double" + } elseif {$varclass == 6} { + set type "var" + } elseif {7 in $varclass} { + append type "glob" + } elseif {8 in $varclass} { + append type "numeric" + } + if {$type eq ""} { + set type "" + } + + set lhs_tag "- [dict get [lindex $expected_values $i] info]" + set mmaction [lindex $var_actions $i 1] ;#e.g ?mismatch-dict-index-out-of-range + set tag "?mismatch-" + if {[string match $tag* $mmaction]} { + set mismatch_reason [string range $mmaction [string length $tag] end] + } else { + set mismatch_reason $mmaction + } + append msg " $type: '$varname' $mismatch_reason $lhs_tag LHS: '$e' vs RHS: '$val'\n" + } + incr i + } + #error $msg + dict unset returndict result + #structured error return - used by pipeswitch/pipecase - matching on "binding mismatch*" + dict set returndict mismatch [dict create binding mismatch varnames $var_names matchinfo $mismatches display $msg data $data] + return $returndict + } + + if {![llength $var_names]} { + #var_name entries can be blank - but it will still be a list + #JMN2 + #dict set returndict result [list $data] + dict set returndict result $data + } else { + assert {$i == [llength $var_names]} assertion_fail _multi_bind_result condition {$i == [llength $var_names]} + dict set returndict result $returnval + } + return $returndict + } + + ######################################################## + # dragons. + # using an error as out-of-band way to signal mismatch is the easiest. + # It comes at some cost (2us 2023?) to trigger catches. (which is small relative to uncompiled pipeline costs in initial version - but per pattern mismatch will add up) + # The alternative of attempting to tailcall return the mismatch as data - is *hard* if not impossible to get right. + # We need to be able to match on things like {error {mismatch etc}} - without it then itself being interpreted as a mismatch! + # A proper solution may involve a callback? tailcall some_mismatch_func? + # There may be a monad-like boxing we could do.. to keep it in data e.g {internalresult match } {internalresult mismatch } and be careful to not let boxed data escape ?? + # make sure there is good test coverage before experimenting with this + proc _handle_bind_result {d} { + #set match_caller [info level 2] + #debug.punk.pipe {_handle_bind_result match_caller: $match_caller} 9 + if {![dict exists $d result]} { + #uplevel 1 [list error [dict get $d mismatch]] + #error [dict get $d mismatch] + return -code error -errorcode [list binding mismatch varnames [dict get $d mismatch varnames]] [dict get $d mismatch] + } else { + return [dict get $d result] + } + } + # initially promising - but the approach runs into impossible disambiguation of mismatch as data vs an actual mismatch + proc _handle_bind_result_experimental1 {d} { + #set match_caller [info level 2] + #debug.punk.pipe {_handle_bind_result match_caller: $match_caller} 9 + if {![dict exists $d result]} { + tailcall return [dict get $d mismatch] + } else { + return [dict get $d result] + } + } + ######################################################## + + #timings very similar. listset3 closest in performance to pipeset. review - test on different tcl versions. + #Unfortunately all these variations seem around 10x slower than 'set list {a b c}' or 'set list [list a b c]' + #there seems to be no builtin for list setting with args syntax. lappend is close but we would need to catch unset the var first. + #proc listset1 {listvarname args} { + # tailcall set $listvarname $args + #} + #interp alias {} listset2 {} apply {{vname args} {tailcall set $vname $args}} + #interp alias {} listset3 {} apply {{vname args} {upvar $vname v; set v $args}} + proc pipeset {pipevarname args} { + upvar $pipevarname the_pipe + set the_pipe $args + } + + #pipealias should capture the namespace context of the pipeline so that commands are resolved in the namespace in which the pipealias is created + proc pipealias {targetcmd args} { + set cmdcopy [punk::valcopy $args] + set nscaller [uplevel 1 [list ::tcl::namespace::current]] + tailcall interp alias {} $targetcmd {} apply [list args [append cmdcopy " {*}\$args"] $nscaller] + } + proc pipealias_extract {targetcmd} { + set applybody [lindex [interp alias "" $targetcmd] 1 1] + #strip off trailing " {*}$args" + return [lrange [string range $applybody 0 end-9] 0 end] + } + #although the pipealias2 'concat' alias is cleaner in that the original pipeline can be extracted using list commands - it runs much slower + proc pipealias2 {targetcmd args} { + set cmdcopy [punk::valcopy $args] + set nscaller [uplevel 1 [list ::tcl::namespace::current]] + tailcall interp alias {} $targetcmd {} apply [list args [concat "\[concat" [list $cmdcopy] "\$args]"] $nscaller] + } + + + #same as used in unknown func for initial launch + #variable re_assign {^([^\r\n=\{]*)=(.*)} + #variable re_assign {^[\{]{0,1}([^ \t\r\n=]*)=(.*)} + variable re_assign {^([^ \t\r\n=\{]*)=(.*)} + variable re_dot_assign {^([^ \t\r\n=\{]*)\.=(.*)} + #match_assign is tailcalled from unknown - uplevel 1 gets to caller level + proc match_assign {scopepattern equalsrhs args} { + #review - :: is legal in atoms! + if {[string match "*::*" $scopepattern]} { + error "match_assign scopepattern '$scopepattern' contains namespace separator '::' - invalid." + } + #puts stderr ">> match_assign '$scopepattern=$equalsrhs' $args" + set fulltail $args + set cmdns ::punk::pipecmds + set namemapping [punk::pipe::lib::pipecmd_namemapping $equalsrhs] + + #we deliberately don't call pipecmd_namemapping on the scopepattern even though it may contain globs. REVIEW + #(we need for example x*= to be available as is via namespace path mechanism (from punk::pipecmds namespace)) + + set pipecmd ${cmdns}::$scopepattern=$namemapping + + #pipecmd could have glob chars - test $pipecmd in the list - not just that info commands returns results. + if {$pipecmd in [info commands $pipecmd]} { + #puts "==nscaller: '[uplevel 1 [list namespace current]]'" + #uplevel 1 [list ::namespace import $pipecmd] + set existing_path [uplevel 1 [list ::tcl::namespace::path]] + if {$cmdns ni $existing_path} { + uplevel 1 [list ::tcl::namespace::path [concat $existing_path $cmdns]] + } + tailcall $pipecmd {*}$args + } + + + #NOTE: + #we need to ensure for case: + #= x=y + #that the second arg is treated as a raw value - never a pipeline command + + #equalsrhs is set if there is a segment-insertion-pattern *directly* after the = + #debug.punk.pipe {match_assign '$multivar' '$equalsrhs' '$fulltail'} 4 + #can match pattern on lhs with a value where pattern is a minilang that can refer to atoms (simple non-whitespace strings), numbers, or varnames (possibly pinned) as well as a trailing spec for position within the data. + + # allow x=insertionpattern to begin a pipeline e.g x= |> string tolower ? or x=1 a b c <| X to produce a X b c + # + #to assign an entire pipeline to a var - use pipeset varname instead. + + # in our script's handling of args: + #avoid use of regexp match on each element - or we will unnecessarily force string reps on lists + #same with lsearch with a string pattern - + #wouldn't matter for small lists - but we need to be able to handle large ones efficiently without unneccessary string reps + set script [string map [list [list $scopepattern] $equalsrhs] { + #script built by punk::match_assign + if {[llength $args]} { + #scan for existence of any pipe operator (|*> or <*|) only - we don't need position + #all pipe operators must be a single element + #we don't first check llength args == 1 because for example: + # x= <| + # x= |> + #both leave x empty. To assign a pipelike value to x we would have to do: x= <| |> (equiv: set x |>) + set scopep + foreach a $args { + if {![catch {llength $a} sublen]} { + #don't enforce sublen == 1. Legal to have whitespace including newlines {| x >} + if {[string match |*> $a] || [string match <*| $a]} { + tailcall punk::pipeline = $scopep "" {*}$args + } + } + } + if {[llength $args] == 1} { + set segmenttail [lindex $args 0] + } else { + error "pipedata = must take a single argument. Got [llength $args] args: '$args'" "match_assign $args" [list pipedata segment too_many_elements segment_type =] + } + } else { + #set segmenttail [purelist] + set segmenttail [lreplace x 0 0] + } + }] + + + + + if {[string length $equalsrhs]} { + # as we aren't in a pipleine - there is no data to insert - we proably still need to run _split_equalsrhs to verify the syntax. + # review - consider way to turn it off as optimisation for non-pipelined assignment - but generally standard Tcl set could be used for that purpose. + # We are probably only here if testing in the repl - in which case the error messages are important. + set var_index_position_list [punk::pipe::lib::_split_equalsrhs $equalsrhs] + #we may have an insertion-spec that inserts a literal atom e.g to wrap in "ok" + # x='ok'>0/0 data + # => {ok data} + # we won't examine for vars as there is no pipeline - ignore + # also ignore trailing * (indicator for variable data to be expanded or not - ie {*}) + # we will differentiate between / and @ in the same way that general pattern matching works. + # /x will simply call linsert without reference to length of list + # @x will check for out of bounds + # + # !TODO - sort by position lowest to highest? or just require user to order the pattern correctly? + + + + foreach v_pos $var_index_position_list { + lassign $v_pos v indexspec positionspec + #e.g =v1/1>0 A pattern predator system) + # + #todo - review + # + # + #for now - the script only needs to handle the case of a single segment pipeline (no |> <|) + + + #temp - needs_insertion + #we can safely output no script for variable insertions for now - because if there was data available, + #we would have to be in a pipeline - in which case the script above would have delegated all our operations anyway. + #tag: positionspechandler + if {([string index $v 0] eq "'" && [string index $v end] eq "'") || [string is integer -strict $v]} { + #(for now)don't allow indexspec on a literal value baked into the pipeline - it doesn't really make sense + #- unless the pipeline construction has been parameterised somehow e.g "=${something}/0" + #review + if {[string length $indexspec]} { + error "pipesyntax literal value $v - index specification not allowed (match_assign)1" "match_assign $scopepattern $equalsrhs $args" [list pipesyntax index_on_literal] + } + if {[string index $v 0] eq "'" && [string index $v end] eq "'"} { + set datasource [string range $v 1 end-1] + } elseif {[string is integer -strict $v]} { + set datasource $v + } + append script [string map [list $datasource] { + set insertion_data "" ;#atom could have whitespace + }] + + set needs_insertion 1 + } elseif {$v eq ""} { + #default variable is 'data' + set needs_insertion 0 + } else { + append script [string map [list $v] { + #uplevel? + #set insertion_data [set ] + }] + set needs_insertion 0 + } + if {$needs_insertion} { + set script2 [punk::list_insertion_script $positionspec segmenttail ] + set script2 [string map [list "\$insertion_data" ] $script2] + append script $script2 + } + + + } + + + } + + if {![string length $scopepattern]} { + append script { + return $segmenttail + } + } else { + append script [string map [list $scopepattern] { + #we still need to bind whether list is empty or not to allow any patternmatch to succeed/fail + set d [punk::_multi_bind_result {} $segmenttail] + #return [punk::_handle_bind_result $d] + #maintenance: inlined + if {![dict exists $d result]} { + #uplevel 1 [list error [dict get $d mismatch]] + #error [dict get $d mismatch] + return -code error -level 1 -errorcode [list binding mismatch] [dict get $d mismatch] + } else { + return [dict get $d result] + } + }] + } + + debug.punk.pipe.compile {match_assign creating proc $pipecmd} 2 + uplevel 1 [list ::proc $pipecmd args $script] + set existing_path [uplevel 1 [list ::tcl::namespace::path]] + if {$cmdns ni $existing_path} { + uplevel 1 [list ::tcl::namespace::path [concat $existing_path $cmdns]] + } + tailcall $pipecmd {*}$args + } + + #return a script for inserting data into listvar + #review - needs updating for list-return semantics of patterns? + proc list_insertion_script {keyspec listvar {data }} { + set positionspec [string trimright $keyspec "*"] + set do_expand [expr {[string index $keyspec end] eq "*"}] + if {$do_expand} { + set exp {{*}} + } else { + set exp "" + } + #NOTE: linsert and lreplace can take multiple values at tail ie expanded data + + set ptype [string index $positionspec 0] + if {$ptype in [list @ /]} { + set index [string range $positionspec 1 end] + } else { + #the / is optional (default) at first position - and we have already discarded the ">" + set ptype "/" + set index $positionspec + } + #puts stderr ">> >> $index" + set script "" + set isint [string is integer -strict $index] + if {$index eq "."} { + #do nothing - this char signifies no insertion + } elseif {$isint || [regexp {^(end|end[-+]{1,2}[0-9]+)$} $index]} { + if {$ptype eq "@"} { + #compare position to *possibly updated* list - note use of $index > $datalen rather than $index+1 > $datalen - (we allow 'insertion' at end of list by numeric index) + if {$isint} { + append script [string map [list $listvar $index] { + if {( > [llength $])} { + #not a pipesyntax error + error "pipedata insertionpattern index out of bounds. index: vs len: [llength $] use /x instead of @x to avoid check (list_insertion_script)" "list_insertion_script $keyspec" [list pipedata insertionpattern index_out_f_bounds] + } + }] + } + #todo check end-x bounds? + } + #todo - change to ledit + #consider also $[set {}] instead of using unset + #see https://wiki.tcl-lang.org/page/K regarding Unsharing Objects + if {$isint} { + append script [string map [list $listvar $index $exp $data] { + set [linsert [lindex [list $ [unset ]] 0] ] + }] + } else { + append script [string map [list $listvar $index $exp $data] { + #use inline K to make sure the list is unshared (optimize for larger lists) + set [linsert [lindex [list $ [unset ]] 0] ] + }] + + } + } elseif {[string first / $index] < 0 && [string first - $index] > 0} { + if {[regexp {^([0-9]+|end|end[-+]{1,2}[0-9]+)-([0-9]+|end|end[-+]{1,2}([0-9]+))$} $index _ start end]} { + #also - range checks for @ which must go into script !!! + append script [string map [list $listvar $start $end $exp $data] { + set [lreplace [lindex [list $ [unset ]] 0] ] + }] + } else { + error "pipesyntax error in segment insertionpattern - positionspec:'$keyspec' unable to interpret position spec (list_insertion_script)2" "list_insertion_script $keyspec" [list pipedata insertionpattern_invalid] + } + } elseif {[string first / $index] >= 0} { + #nested insertion e.g /0/1/2 /0/1-1 + set parts [split $index /] + set last [lindex $parts end] + if {[string first - $last] >=0} { + lassign [split $last -] a b + if {![regexp {^([0-9]+|end|end[-+]{1,2}[0-9]+)-([0-9]+|end|end[-+]{1,2}([0-9]+))$} $last _ a b]} { + error "pipesyntax error in segment insertionpattern - positionspec:'$keyspec' unable to interpret position spec (list_insertion_script)3" "list_insertion_script $keyspec" [list pipesyntax insertionpattern_invalid] + } + if {$a eq $b} { + if {!$do_expand} { + #we can do an lset + set lsetkeys [list {*}[lrange $parts 0 end-1] $a] + append script [string map [list $listvar $lsetkeys $data] { + lset + }] + } else { + #we need to lreplace the containing item + append script [string map [list $listvar [lrange $parts 0 end-1] $a $data] { + set target [lindex $ ] + lset target {*} + lset $target + }] + } + } else { + #we need to lreplace a range at the target level + append script [string map [list $listvar [lrange $parts 0 end-1] $a $b $exp $data] { + set target [lindex $ ] + set target [lreplace $target ] + lset $target + }] + } + } else { + #last element has no -, so we are inserting at the final position - not replacing + append script [string map [list $listvar [lrange $parts 0 end-1] $last $exp $data] { + set target [lindex $ ] + #set target [linsert $target ] + ledit target -1 + lset $target + }] + } + + + } else { + error "pipesyntax error in segment - positionspec:'$keyspec' unable to interpret position spec (list_insertion_script)4" "list_insertion_script $keyspec" [list pipesyntax insertionpattern_invalid] + } + return $script + } + + + + + proc _is_math_func_prefix {e1} { + #also catch starting brackets.. e.g "(min(4,$x) " + if {[regexp {^[^[:alnum:]]*([[:alnum:]]*).*} $e1 _ word]} { + #possible math func + if {$word in [info functions]} { + return true + } + } + return false + } + + #todo - option to disable these traces which provide clarifying errors (performance hit?) + proc pipeline_args_read_trace_error {args} { + error "The pipelined data doesn't appear to be a valid Tcl list\nModify input, or use \$data or another variable name instead of \$args." "pipeline_args_read_trace_error $args" [list pipedata args_unavailable_data_not_a_list] + } + + + #NOTE: the whole idea of scanning for %x% is a lot of work(performance penalty) + #consider single placeholder e.g "_" as only positional indicator - for $data only - and require braced script with $var for more complex requirements + #possibly also *_ for expanded _ ? + #This would simplify code a lot - but also quite possible to collide with user data. + #Perhaps not a big deal as unbraced segments between |> are mainly(?) a convenience for readability/repl etc. + # (but importantly (at pipeline start anyway) unbraced segments are a mechanism to inject data from calling scope or from pipeline args <|) + # + #detect and retrieve %xxx% elements from item without affecting list/string rep + #commas, @, ', ^ and whitespace not part of a valid tag (allows some substitution within varspecs) + #%% is not a valid tag + #(as opposed to using regexp matching which causes string reps) + proc get_tags {item} { + set chars [split $item {}] + set terminal_chars [list , @ ' ^ " " \t \n \r] + #note % is both terminal and initiating - so for the algorithm we don't include it in the list of terminal_chars + set nonterminal [lmap v $chars {expr {$v ni $terminal_chars}}] + set percents [lmap v $chars {expr {$v eq "%"}}] + #useful for test/debug + #puts "CHARS : $chars" + #puts "NONTERMINAL: $nonterminal" + #puts "PERCENTS : $percents" + set sequences [list] + set in_sequence 0 + set start -1 + set end -1 + set i 0 + #todo - some more functional way of zipping/comparing these lists? + set s_length 0 ;#sequence length including % symbols - minimum for tag therefore 2 + foreach n $nonterminal p $percents { + if {!$in_sequence} { + if {$n & $p} { + set s_length 1 + set in_sequence 1 + set start $i + set end $i + } else { + set s_length 0 + } + } else { + if {$n ^ $p} { + incr s_length + incr end + } else { + if {$n & $p} { + if {$s_length == 1} { + # % followed dirctly by % - false start + #start again from second % + set s_length 1 + set in_sequence 1 + set start $i + set end $i + } else { + incr end + lappend sequences [list $start $end] + set in_sequence 0 + set s_length 0 + set start -1; set end -1 + } + } else { + #terminated - not a tag + set in_sequence 0 + set s_length 0 + set start -1; set end -1 + } + } + } + incr i + } + + set tags [list] + foreach s $sequences { + lassign $s start end + set parts [lrange $chars $start $end] + lappend tags [join $parts ""] + } + return $tags + } + + #show underlying rep of list and first level + proc rep_listname {lname} { + upvar $lname l + set output "$lname list rep: [rep $l]\n" + foreach item $l { + append output "-rep $item\n" + append output " [rep $item]\n" + } + return $output + } + + + # -- + #consider possible tilde templating version ~= vs .= + #support ~ and ~* placeholders only. + #e.g x~= list aa b c |> lmap v ~ {string length $v} |> tcl::mathfunc::max ~* + #The ~ being mapped to $data in the pipeline. + #This is more readable and simpler for beginners - although it doesn't handle more advanced insertion requirements. + #possibility to mix as we can already with .= and = + #e.g + #x.= list aa b c |> ~= lmap v ~ {string length $v} |> .=>* tcl::mathfunc::max + # -- + proc pipeline {segment_op initial_returnvarspec equalsrhs args} { + set fulltail $args + #unset args ;#leave args in place for error diagnostics + debug.punk.pipe {call pipeline: op:'$segment_op' '$initial_returnvarspec' '$equalsrhs' '$fulltail'} 4 + #debug.punk.pipe.rep {[rep_listname fulltail]} 6 + + + #review + set equalsrhs [string map [list {;} {\;}] $equalsrhs] + + + #--------------------------------------------------------------------- + # test if we have an initial x.=y.= or x.= y.= + + #nextail is tail for possible recursion based on first argument in the segment + #set nexttail [lassign $fulltail next1] ;#tail head + + set next1 [lindex $args 0] + switch -- $next1 { + pipematch { + set nexttail [lrange $args 1 end] + set results [uplevel 1 [list pipematch {*}$nexttail]] + debug.punk.pipe {>>> pipematch results: $results} 1 + + set d [_multi_bind_result $initial_returnvarspec $results] + return [_handle_bind_result $d] + } + pipecase { + set msg "pipesyntax\n" + append msg "pipecase does not return a value directly in the normal way\n" + append msg "It will return a casemismatch dict on mismatch\n" + append msg "But on a successful match - it will use an 'error' mechanism to return {ok result {something}} in the caller's scope -\n" + append msg "This will appear as an error in the repl, or disrupt pipeline result propagation if not in an appropriate wrapper\n" + append msg "Call pipecase from within a pipeline script block or wrapper such as pipeswitch or apply." + error $msg + } + } + + #temp - this is related to a script for the entire pipeline (functional composition) - not the script for the segment-based x=y or x.=y proc. + set ::_pipescript "" + + + + #NOTE: + #important that for assignment: + #= x=y .. + #The second element is always treated as a raw value - not a pipeline instruction. + #whereas... for execution: + #.= x=y the second element is a pipeline-significant symbol based on the '=' even if it was passed in as an argument. + #Usually an execution segment (.= cmd etc..) will have args inserted at the tail anyway - + #- but if the pipeline is designed to put an argument in the zero position - then presumably it is intended as a pipeline-significant element anyway + #This gives a *slight* incompatibility with external commands containing '=' - in that they may not work properly in pipelines + # + if {$segment_op ne "="} { + #handle for example: + #var1.= var2= "etc" |> string toupper + # + #var1 will contain ETC (from entire pipeline), var2 will contain etc (from associated segment) + # + + + if {([set nexteposn [string last = $next1]] >= 0)} { + set next1 [string map [list {;} {\;}] $next1] ;#review + #do we really need to test for script_shaped if last char is = ? + if {![punk::pipe::lib::arg_is_script_shaped $next1]} { + set nexttail [lrange $args 1 end] + #*SUB* pipeline recursion. + #puts "======> recurse based on next1:$next1 " + if {[string index $next1 $nexteposn-1] eq {.}} { + #var1.= var2.= ... + #non pipelined call to self - return result + set results [uplevel 1 [list $next1 {*}$nexttail]] + #debug.punk.pipe.rep {==> rep recursive results: [rep $results]} 5 + #debug.punk.pipe {>>> results: $results} 1 + return [_handle_bind_result [_multi_bind_result $initial_returnvarspec $results]] + } + #puts "======> recurse assign based on next1:$next1 " + #if {[regexp {^([^ \t\r\n=\{]*)=(.*)} $next1 _ nextreturnvarspec nextrhs]} { + #} + #non pipelined call to plain = assignment - return result + set results [uplevel 1 [list $next1 {*}$nexttail]] + #debug.punk.pipe {>>> results: $results} 1 + set d [_multi_bind_result $initial_returnvarspec $results] + return [_handle_bind_result $d] + } + } + } + + set procname $initial_returnvarspec.=$equalsrhs + + #--------------------------------------------------------------------- + + #todo add 'op' argument and handle both .= and = + # + #|> data piper symbol + #<| args piper symbol (arguments supplied at end of pipeline e.g from commandline or from calling and/or currying the command) + # + + set more_pipe_segments 1 ;#first loop + + #this contains the main %data% and %datalist% values going forward in the pipeline + #as well as any extra pipeline vars defined in each |> + #It also contains any 'args' with names supplied in <| + set dict_tagval [dict create] ;#cumulative %x% tag dict which operates on the whole length of the pipeline + + #determine if there are input args at the end of the pipeline indicated by reverse <| symbol possibly with argspecs e.g transform x y z =0} { + set tailremaining [lrange $fulltail 0 $firstargpipe_posn-1] + set argslist [lrange $fulltail $firstargpipe_posn+1 end] ;#Note that this could be a whole other pipeline with |> and/or <| elements. + set argpipe [lindex $fulltail $firstargpipe_posn] + set argpipespec [string range $argpipe 1 end-1] ;# strip off < & | from " b1 b2 b3 |outpipespec> c1 c2 c3 + # for a1 a2 a3 - the pipe to the right is actually an outpipespec and for c1 c2 c3 the pipe to the left is an inpipespec + + + #our initial command list always has *something* before we see any pipespec |> + #Therefore we initially have a blank inpipespec (although in effect, it comes from the argpipespec <|) + set inpipespec $argpipespec + set outpipespec "" + + #avoiding regexp on each arg to maintain list reps + #set tailmap [lmap v $tailremaining {lreplace [split $v {}] 1 end-1}] + ## set tailmap [lmap v $tailremaining {if {[regexp {^\|(.*)>$} $v _ outpipespec] && !$pipeseen} {set pipeseen 1;set outpipespec} {if {$pipeseen} {set v} 0}}] + #e.g for: a b c |> e f g |> h + #set firstpipe_posn [lsearch $tailmap {| >}] + + set firstpipe_posn [lsearch $tailremaining "|*>"] + + if {$firstpipe_posn >=0} { + set outpipespec [string range [lindex $tailremaining $firstpipe_posn] 1 end-1] + set segment_members [lrange $tailremaining 0 $firstpipe_posn-1] + #set tailremaining [lrange $tailremaining $firstpipe_posn+1 end] + set tailremaining [lreplace $tailremaining 0 $firstpipe_posn] ;#generally too short for any K combinator benefit? what about lists with scripts? is it dependent on list length or also element content size? + } else { + set segment_members $tailremaining + set tailremaining [list] + } + + + + set script_like_first_word 0 + set rhs $equalsrhs + + set segment_first_is_script 0 ;#default assumption until tested + + set segment_first_word [lindex $segment_members 0] + if {$segment_op ne "="} { + if {[punk::pipe::lib::arg_is_script_shaped $segment_first_word]} { + set segment_first_is_script 1 + } + } else { + if {[llength $segment_members] > 1} { + error "pipedata = can only accept a single argument (got: '$segment_members')" "pipeline $segment_op $initial_returnvarspec $equalsrhs $fulltail" [list pipedata too_many_elements] + #proc pipeline {segment_op initial_returnvarspec equalsrhs args} + } + set segment_members $segment_first_word + } + + + + #tailremaining includes x=y during the loop. + set returnvarspec $initial_returnvarspec + if {![llength $argslist]} { + unset -nocomplain previous_result ;# we want it unset for first iteration - differentiate from empty string + } else { + set previous_result $argslist + } + + set segment_result_list [list] + set i 0 ;#segment id + set j 1 ;#next segment id + set pipespec(args) $argpipespec ;# from trailing <| + set pipespec(0,in) $inpipespec + set pipespec(0,out) $outpipespec + + set max_iterations 100 ;# configurable? -1 for no limit ? This is primarily here to aid debugging of runaway loops in initial development .. should probably set to no-limit in final version. + while {$more_pipe_segments == 1} { + #--------------------------------- + debug.punk.pipe {[a yellow bold]i$i SEGMENT MEMBERS([llength $segment_members]): $segment_members[a]} 4 + debug.punk.pipe {[a yellow bold]i$i TAIL REMAINING([llength $tailremaining]): $tailremaining[a]} 4 + debug.punk.pipe {[a] inpipespec(prev [a yellow bold]|$pipespec($i,in)[a]>) outpipespec(next [a+ yellow bold]|$pipespec($i,out)>[a])} 4 + debug.punk.pipe {[a cyan bold] segment_first_is_script:$segment_first_is_script} 4 + if {$segment_first_is_script} { + debug.punk.pipe {[a cyan bold] script segment: [lindex $segment_members 0][a]} 4 + } + + + + #examine inpipespec early to give faster chance for mismatch. ie before scanning segment for argument position + set segment_result "" + if {[info exists previous_result]} { + set prevr $previous_result + } else { + set prevr "" + } + set pipedvars [dict create] + if {[string length $pipespec($i,in)]} { + #check the varspecs within the input piper + # - data and/or args may have been manipulated + set d [apply {{mv res} { + punk::_multi_bind_result $mv $res -levelup 1 + }} $pipespec($i,in) $prevr] + #temp debug + #if {[dict exists $d result]} { + #set jjj [dict get $d result] + #puts "!!!!! [rep $jjj]" + #} + set inpipespec_result [_handle_bind_result $d] + set pipedvars [dict get $d setvars] + set prevr $inpipespec_result ;# leftmost spec in |> needs to affect pipeline flow of 'data' + #puts stdout "inpipespec:|$pipespec($i,in)> prevr:$prevr setvars: $pipedvars" + } + debug.punk.pipe {[a] previous_iteration_result: $prevr[a]} 6 + debug.punk.pipe.rep {rep previous_iteration_result [rep $prevr]} + + + if {$i == $max_iterations} { + puts stderr "ABORTING. Reached max_iterations $max_iterations (todo: make configurable)" + set more_pipe_segments 0 + } + + set insertion_patterns [punk::pipe::lib::_split_equalsrhs $rhs] ;#raises error if rhs of positionspec not like /* or @* + set segment_has_insertions [expr {[llength $insertion_patterns] > 0}] + #if {$segment_has_insertions} { + # puts stdout ">>> $segment_members insertion_patterns $insertion_patterns" + #} + + debug.punk.pipe.var {segment_has_insertions: $insertion_patterns} 5 + debug.punk.pipe.rep {[rep_listname segment_members]} 4 + + + + + #whether the segment has insertion_patterns or not - apply any modification from the piper argspecs (script will use modified args/data) + #pipedvars comes from either previous segment |>, or <| args + if {[dict exists $pipedvars "data"]} { + #dict set dict_tagval %data% [list [dict get $pipedvars "data"]] + dict set dict_tagval data [dict get $pipedvars "data"] + } else { + if {[info exists previous_result]} { + dict set dict_tagval data $prevr + } + } + foreach {vname val} $pipedvars { + #add additionally specified vars and allow overriding of %args% and %data% by not setting them here + if {$vname eq "data"} { + #already potentially overridden + continue + } + dict set dict_tagval $vname $val + } + + #todo! + #segment_script - not in use yet. + #will require non-iterative pipeline processor to use ... recursive.. or coroutine based + set script "" + + if {!$segment_has_insertions} { + #debug.punk.pipe.var {[a cyan]SEGMENT has no tags[a]} 7 + #add previous_result as data in end position by default, only if *no* insertions specified (data is just list-wrapped previous_result) + #set segment_members_filled [concat $segment_members [dict get $dict_tagval %data%]] ;# data flows through by default as single element - not args - because some strings are not valid lists + #insertion-specs with a trailing * can be used to insert data in args format + set segment_members_filled $segment_members + if {[dict exists $dict_tagval data]} { + lappend segment_members_filled [dict get $dict_tagval data] + } + + } else { + debug.punk.pipe.var {processing insertion_pattern dict_tagval: $dict_tagval} 4 + set segment_members_filled [list] + set segmenttail $segment_members ;# todo - change to segment_members here to match punk::match_assign + + set rhsmapped [punk::pipe::lib::pipecmd_namemapping $rhs] + set cmdname "::punk::pipecmds::insertion::_$rhsmapped" + #glob chars have been mapped - so we can test by comparing info commands result to empty string + if {[info commands $cmdname] eq ""} { + + set insertion_script "proc $cmdname {dict_tagval segmenttail} {\n" + foreach v_pos $insertion_patterns { + #puts stdout "v_pos '$v_pos'" + lassign $v_pos v indexspec positionspec ;#v may be atom, or varname (in pipeline scope) + #puts stdout "v:'$v' indexspec:'$indexspec' positionspec:'$positionspec'" + #julz + + append insertion_script \n [string map [list $v_pos] { + lassign [list ] v indexspec positionspec + }] + + if {([string index $v 0] eq "'") && ([string index $v end] eq "'")} { + set v [string range $v 1 end-1] ;#assume trailing ' is present! + if {[string length $indexspec]} { + error "pipesyntax - index not supported on atom" "pipeline $segment_op $initial_returnvarspec $equalsrhs $args" [list pipesyntax index_on_literal] + } + append insertion_script \n "set insertion_data [list $v]" ;#sub in shortened $v now -i.e use atom value itself (string within single quotes) + } elseif {[string is double -strict $v]} { + #don't treat numbers as variables + if {[string length $indexspec]} { + error "pipesyntax - index not supported on number" "pipeline $segment_op $initial_returnvarspec $equalsrhs $args" [list pipesyntax index_on_literal] + } + append insertion_script \n {set insertion_data $v} + } else { + #todo - we should potentially group by the variable name and pass as a single call to _multi_bind_result - because stateful @ and @@ won't work in independent calls + append insertion_script \n [string map [list $cmdname] { + #puts ">>> v: $v dict_tagval:'$dict_tagval'" + if {$v eq ""} { + set v "data" + } + if {[dict exists $dict_tagval $v]} { + set insertion_data [dict get $dict_tagval $v] + #todo - use destructure_func + set d [punk::_multi_bind_result $indexspec $insertion_data] + set insertion_data [punk::_handle_bind_result $d] + } else { + #review - skip error if varname is 'data' ? + #e.g we shouldn't really fail for: + #.=>* list a b c <| + #??? Technically + #we need to be careful not to insert empty-list as an argument by default + error "pipevariable - varname $v not present in pipeline context. pipecontext_vars: [dict keys $dict_tagval] (2)" " pipecontext_vars: [dict keys $dict_tagval]" [list pipevariable variable_not_in_pipeline_scope] + } + + }] + } + + + + + #append script [string map [list $getv]{ + # + #}] + #maintenance - index logic should be similar identical? to to match_assign - which only needs to process atoms because it (for now?) delegates all pipeline ops here, so no vars available (single segment assign) + #tag: positionspechandler + + + #puts stdout "=== list_insertion_script '$positionspec' segmenttail " + set script2 [punk::list_insertion_script $positionspec segmenttail ] + set script2 [string map [list "\$insertion_data" ] $script2] + append insertion_script \n $script2 + + } + append insertion_script \n {set segmenttail} + append insertion_script \n "}" + #puts stderr "$insertion_script" + debug.punk.pipe.compile {creating proc ::punk::pipecmds::insertion::_$rhsmapped } 4 + eval $insertion_script + } + + set segment_members_filled [::punk::pipecmds::insertion::_$rhsmapped $dict_tagval [lindex [list $segmenttail [unset segmenttail]] 0] ] + + #set segment_members_filled $segmenttail + #note - length of segment_members_filled may now differ from length of original segment_members! (if do_expand i.e trailing * in any insertion_patterns) + + } + set rhs [string map $dict_tagval $rhs] ;#obsolete? + + debug.punk.pipe.rep {segment_members_filled rep: [rep $segment_members_filled]} 4 + + + # script index could have changed!!! todo fix! + + #we require re_dot_assign before re_assign (or fix regexes so order doesn't matter!) + if {(!$segment_first_is_script ) && $segment_op eq ".="} { + #no scriptiness detected + + #debug.punk.pipe.rep {[a yellow bold][rep_listname segment_members_filled][a]} 4 + + set cmdlist_result [uplevel 1 $segment_members_filled] + #debug.punk.pipe {[a green bold]forward_result: $forward_result[a]} 4 + #debug.punk.pipe.rep {[a yellow bold]forward_result REP: [rep $forward_result][a]} 4 + + #set d [_multi_bind_result $returnvarspec [punk::K $cmdlist_result [unset cmdlist_result]]] + set d [_multi_bind_result $returnvarspec [lindex [list $cmdlist_result [unset cmdlist_result ]] 0]] + + set segment_result [_handle_bind_result $d] + #puts stderr ">>forward_result: $forward_result segment_result $segment_result" + + + } elseif {$segment_op eq "="} { + #slightly different semantics for assigment! + #We index into the DATA - not the position within the segment! + #(an = segment must take a single argument, as opposed to a .= segment) + #(This was a deliberate design choice for consistency with set, and to reduce errors.) + #(we could have allowed multiple args to = e.g to form a list, but it was tried, and the edge-cases were unintuitive and prone to user error) + #(The choice to restrict to single argument, but allow insertion and appending via insertion-specs is more explicit and reliable even though the insertion-specs operate differently to those of .=) + # + #we have to ensure that for an empty segment - we don't append to the empty list, thus listifying the data + #v= {a b c} |> = + # must return: {a b c} not a b c + # + if {!$segment_has_insertions} { + set segment_members_filled $segment_members + if {[dict exists $dict_tagval data]} { + if {![llength $segment_members_filled]} { + set segment_members_filled [dict get $dict_tagval data] + } else { + lappend segment_members_filled [dict get $dict_tagval data] + } + } + } + + set d [_multi_bind_result $returnvarspec [lindex [list $segment_members_filled [unset segment_members_filled ]] 0]] + set segment_result [_handle_bind_result $d] + + + } elseif {$segment_first_is_script || $segment_op eq "script"} { + #script + debug.punk.pipe {[a+ cyan bold].. evaluating as script[a]} 2 + + set script [lindex $segment_members 0] + + #build argument lists for 'apply' + set segmentargnames [list] + set segmentargvals [list] + foreach {k val} $dict_tagval { + if {$k eq "args"} { + #skip args - it is manually added at the end of the apply list if it's a valid tcl list + continue + } + lappend segmentargnames $k + lappend segmentargvals $val + } + + set argsdatalist $prevr ;#default is raw result as a list. May be overridden by an argspec within |> e.g |args@@key> or stripped if not a tcl list + #puts "------> rep prevr argsdatalist: [rep $argsdatalist]" + set add_argsdata 0 + if {[dict exists $dict_tagval "args"]} { + set argsdatalist [dict get $dict_tagval "args"] + #see if the raw result can be treated as a list + if {[catch {lindex $argsdatalist 0}]} { + #we cannot supply 'args' + set pre_script "" + #todo - only add trace if verbose warnings enabled? + append pre_script "trace add variable args read punk::pipeline_args_read_trace_error\n" + set script $pre_script + append script $segment_first_word + set add_argsdata 0 + } else { + set add_argsdata 1 + } + } + + debug.punk.pipe.rep {>> [rep_listname segmentargvals]} 4 + set ns [uplevel 1 {::tcl::namespace::current}] + if {!$add_argsdata} { + debug.punk.pipe {APPLY1: (args not set; not a list) segment vars:$segmentargnames} 4 + #puts stderr " script: $script" + #puts stderr " vals: $segmentargvals" + set evaluation [uplevel 1 [list ::apply [::list $segmentargnames $script $ns] {*}$segmentargvals]] + } else { + debug.punk.pipe {APPLY2: (args is set)segment vars:$segmentargnames} 4 + #puts stderr " script: $script" + #puts stderr " vals: $segmentargvals $argsdatalist" + #pipeline script context should be one below calling context - so upvar v v will work + #ns with leading colon will fail with apply + set evaluation [uplevel 1 [list ::apply [::list [::concat $segmentargnames args] $script $ns] {*}$segmentargvals {*}$argsdatalist]] + } + + debug.punk.pipe.rep {script result, evaluation: [rep_listname evaluation]} 4 + #puts "---> rep script evaluation result: [rep $evaluation]" + #set d [_multi_bind_result $returnvarspec [punk::K $evaluation [unset evaluation]]] + + #trailing segment_members are *pipedata* scripts - as opposed to ordinary pipeline scripts! + set tail_scripts [lrange $segment_members 1 end] + if {[llength $tail_scripts]} { + set r [pipedata $evaluation {*}$tail_scripts] + } else { + set r $evaluation + } + set d [_multi_bind_result $returnvarspec [lindex [list $r [unset r]] 0]] + set segment_result [_handle_bind_result $d] + } else { + #tags ? + #debug.punk.pipe {>>raw commandline: [concat $rhs $segment_members_filled]} 5 + if {false} { + #experimental. + package require funcl + #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] + } 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 " + #append snew "set pipe_[expr $i -1]" + #append pscript $snew + set pscript [funcl::o_of_n 1 $segment_members $pscript] + + } + } + + 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 ]] + + #multi_bind_result needs to return a funcl for rhs of: + #lindex [list [set syncvar [main pipeline.. ]] [rhs binding funcl...] 1 ] + #which uses syncvar + # + #The lhs of 'list' runs first so now syncvar can be the root level of the rhs function list and bind the necessary vars. + #NOTE: unintuitively, we are returning the value of rhs to the main pipleline! (leftmost binding) this is because the leftmost binding determines what goes back to the pipeline result + + set segment_result [_handle_bind_result $d] + } + #the subresult doesn't need to go backwards - as the final assignment can emit the result into a variable + #It makes more sense and is ultimately more useful (and more easy to reason about) for the result of each assignment to be related only to the pre-pipe section + #It may however make a good debug point + #puts stderr "segment $i segment_result:$segment_result" + + debug.punk.pipe.rep {[rep_listname segment_result]} 3 + + + + + + #examine tailremaining. + # either x x x |?> y y y ... + # or just y y y + #we want the x side for next loop + + #set up the conditions for the next loop + #|> x=y args + # inpipespec - contents of previous piper |xxx> + # outpipespec - empty or content of subsequent piper |xxx> + # previous_result + # assignment (x=y) + + + set pipespec($j,in) $pipespec($i,out) + set outpipespec "" + set tailmap "" + set next_pipe_posn -1 + if {[llength $tailremaining]} { + + #set tailmap [lmap v $tailremaining {lreplace [split $v {}] 1 end-1}] + ##e.g for: a b c |> e f g |> h + #set next_pipe_posn [lsearch $tailmap {| >}] + set next_pipe_posn [lsearch $tailremaining "|*>"] + + set outpipespec [string range [lindex $tailremaining $next_pipe_posn] 1 end-1] + } + set pipespec($j,out) $outpipespec + + + set script_like_first_word 0 + if {[llength $tailremaining] || $next_pipe_posn >= 0} { + + if {$next_pipe_posn >=0} { + set next_all_members [lrange $tailremaining 0 $next_pipe_posn-1] ;#exclude only piper |xxx> for + set tailremaining [lrange $tailremaining $next_pipe_posn+1 end] + + } else { + set next_all_members $tailremaining + set tailremaining [list] + } + + + #assignment is the arg immediately following |> operator e.g x.=blah or x=etc (or a normal commandlist or script!) + set segment_first_word "" + set returnvarspec "" ;# the lhs of x=y + set segment_op "" + set rhs "" + set segment_first_is_script 0 + if {[llength $next_all_members]} { + if {[punk::pipe::lib::arg_is_script_shaped [lindex $next_all_members 0]]} { + set segment_first_word [lindex $next_all_members 0] + set segment_first_is_script 1 + set segment_op "" + set segment_members $next_all_members + } else { + set possible_assignment [lindex $next_all_members 0] + #set re_dot_assign {^([^ \t\r\n=\{]*)\.=(.*)} + if {[regexp {^([^ \t\r\n=\{]*)\.=(.*)} $possible_assignment _ returnvarspec rhs]} { + set segment_op ".=" + set segment_first_word [lindex $next_all_members 1] + set script_like_first_word [punk::pipe::lib::arg_is_script_shaped $segment_first_word] + if {$script_like_first_word} { + set segment_first_is_script 1 ;#relative to segment_members which no longer includes the .= + } + set segment_members [lrange $next_all_members 1 end] + } elseif {[regexp {^([^ \t\r\n=]*)=(.*)} $possible_assignment _ returnvarspec rhs]} { + set segment_op "=" + #never scripts + #must be at most a single element after the = ! + if {[llength $next_all_members] > 2} { + #raise this as pipesyntax as opposed to pipedata? + error "pipesyntax - at most one element can follow = (got [lrange $next_all_members 1 end])" "pipeline $segment_op $returnvarspec $rhs [lrange $next_all_members 1 end]" [list pipesyntax too_many_elements] + } + set segment_first_word [lindex $next_all_members 1] + if {[catch {llength $segment_first_word}]} { + set segment_is_list 0 ;#only used for segment_op = + } else { + set segment_is_list 1 ;#only used for segment_op = + } + + set segment_members $segment_first_word + } else { + #no assignment operator and not script shaped + set segment_op "" + set returnvarspec "" + set segment_first_word [lindex $next_all_members 0] + set segment_first_word [lindex $next_all_members 1] + set segment_members $next_all_members + #puts stderr ">>3 no-operator segment_first_word: '$segment_first_word'" + } + } + + + } else { + #?? two pipes in a row ? + debug.punk.pipe {[a+ yellow bold]WARNING: no segment members found[a]} 0 + set segment_members return + set segment_first_word return + } + + #set forward_result $segment_result + #JMN2 + set previous_result $segment_result + #set previous_result [join $segment_result] + } else { + debug.punk.pipe {[a+ cyan bold]End of pipe segments ($i)[a]} 4 + #output pipe spec at tail of pipeline + + set pipedvars [dict create] + if {[string length $pipespec($i,out)]} { + set d [apply {{mv res} { + punk::_multi_bind_result $mv $res -levelup 1 + }} $pipespec($i,out) $segment_result] + set segment_result [_handle_bind_result $d] + set pipedvars [dict get $d setvars] + } + + set more_pipe_segments 0 + } + + #the segment_result is based on the leftmost var on the lhs of the .= + #whereas forward_result is always the entire output of the segment + #JMN2 + #lappend segment_result_list [join $segment_result] + lappend segment_result_list $segment_result + incr i + incr j + } ;# end while + + return [lindex $segment_result_list end] + #JMN2 + #return $segment_result_list + #return $forward_result + } + + + #just an experiment + #what advantage/difference versus [llength [lrange $data $start $end]] ??? + proc data_range_length {data start end} { + set datalen [llength $data] + + #normalize to s and e + if {$start eq "end"} { + set s [expr {$datalen - 1}] + } elseif {[string match end-* $start]} { + set stail [string range $start 4 end] + set posn [expr {$datalen - $stail -1}] + if {$posn < 0} { + return 0 + } + set s $posn + } else { + #int + if {($start < 0) || ($start > ($datalen -1))} { + return 0 + } + set s $start + } + if {$end eq "end"} { + set e [expr {$datalen - 1}] + } elseif {[string match end-* $end]} { + set etail [string range $end 4 end] + set posn [expr {$datalen - $etail -1}] + if {$posn < 0} { + return 0 + } + set e $posn + } else { + #int + if {($end < 0)} { + return 0 + } + set e $end + } + if {$s > ($datalen -1)} { + return 0 + } + if {$e > ($datalen -1)} { + set e [expr {$datalen -1}] + } + + + + if {$e < $s} { + return 0 + } + + return [expr {$e - $s + 1}] + } + + # unknown -- + # This procedure is called when a Tcl command is invoked that doesn't + # exist in the interpreter. It takes the following steps to make the + # command available: + # + # 1. See if the autoload facility can locate the command in a + # Tcl script file. If so, load it and execute it. + # 2. If the command was invoked interactively at top-level: + # (a) see if the command exists as an executable UNIX program. + # If so, "exec" the command. + # (b) see if the command requests csh-like history substitution + # in one of the common forms !!, !, or ^old^new. If + # so, emulate csh's history substitution. + # (c) see if the command is a unique abbreviation for another + # command. If so, invoke the command. + # + # Arguments: + # args - A list whose elements are the words of the original + # command, including the command name. + + #review - we shouldn't really be doing this + #We need to work out if we can live with the real default unknown and just inject some special cases at the beginning before falling-back to the normal one + + proc ::unknown args { + #puts stderr "unk>$args" + variable ::tcl::UnknownPending + global auto_noexec auto_noload env tcl_interactive errorInfo errorCode + + if {[info exists errorInfo]} { + set savedErrorInfo $errorInfo + } + if {[info exists errorCode]} { + set savedErrorCode $errorCode + } + + set name [lindex $args 0] + if {![info exists auto_noload]} { + # + # Make sure we're not trying to load the same proc twice. + # + if {[info exists UnknownPending($name)]} { + return -code error "self-referential recursion\ + in \"unknown\" for command \"$name\"" + } + set UnknownPending($name) pending + set ret [catch { + auto_load $name [uplevel 1 {::tcl::namespace::current}] + } msg opts] + unset UnknownPending($name) + if {$ret != 0} { + dict append opts -errorinfo "\n (autoloading \"$name\")" + return -options $opts $msg + } + if {![array size UnknownPending]} { + unset UnknownPending + } + if {$msg} { + if {[info exists savedErrorCode]} { + set ::errorCode $savedErrorCode + } else { + unset -nocomplain ::errorCode + } + if {[info exists savedErrorInfo]} { + set errorInfo $savedErrorInfo + } else { + unset -nocomplain errorInfo + } + set code [catch {uplevel 1 $args} msg opts] + if {$code == 1} { + # + # Compute stack trace contribution from the [uplevel]. + # Note the dependence on how Tcl_AddErrorInfo, etc. + # construct the stack trace. + # + set errInfo [dict get $opts -errorinfo] + set errCode [dict get $opts -errorcode] + set cinfo $args + if {[string length [encoding convertto utf-8 $cinfo]] > 150} { + set cinfo [string range $cinfo 0 150] + while {[string length [encoding convertto utf-8 $cinfo]] > 150} { + set cinfo [string range $cinfo 0 end-1] + } + append cinfo ... + } + set tail "\n (\"uplevel\" body line 1)\n invoked\ + from within\n\"uplevel 1 \$args\"" + set expect "$msg\n while executing\n\"$cinfo\"$tail" + if {$errInfo eq $expect} { + # + # The stack has only the eval from the expanded command + # Do not generate any stack trace here. + # + dict unset opts -errorinfo + dict incr opts -level + return -options $opts $msg + } + # + # Stack trace is nested, trim off just the contribution + # from the extra "eval" of $args due to the "catch" above. + # + set last [string last $tail $errInfo] + if {$last + [string length $tail] != [string length $errInfo]} { + # Very likely cannot happen + return -options $opts $msg + } + set errInfo [string range $errInfo 0 $last-1] + set tail "\"$cinfo\"" + set last [string last $tail $errInfo] + if {$last < 0 || $last + [string length $tail] != [string length $errInfo]} { + return -code error -errorcode $errCode \ + -errorinfo $errInfo $msg + } + set errInfo [string range $errInfo 0 $last-1] + set tail "\n invoked from within\n" + set last [string last $tail $errInfo] + if {$last + [string length $tail] == [string length $errInfo]} { + return -code error -errorcode $errCode \ + -errorinfo [string range $errInfo 0 $last-1] $msg + } + set tail "\n while executing\n" + set last [string last $tail $errInfo] + if {$last + [string length $tail] == [string length $errInfo]} { + return -code error -errorcode $errCode \ + -errorinfo [string range $errInfo 0 $last-1] $msg + } + return -options $opts $msg + } else { + dict incr opts -level + return -options $opts $msg + } + } + } + #set isrepl [expr {[file tail [file rootname [info script]]] eq "repl"}] + set isrepl [punk::repl::codethread::is_running] ;#may not be reading though + if {$isrepl} { + #set ::tcl_interactive 1 + } + if {$isrepl || (([info level] == 1) && (([info script] eq "" ) ) + && ([info exists tcl_interactive] && $tcl_interactive))} { + + if {![info exists auto_noexec]} { + set new [auto_execok $name] + if {$new ne ""} { + set redir "" + if {[namespace which -command console] eq ""} { + set redir ">&@stdout <@stdin" + } + + + #windows experiment todo - use twapi and named pipes + #twapi::namedpipe_server {\\.\pipe\something} + #Then override tcl 'exec' and replace all stdout/stderr/stdin with our fake ones + #These can be stacked with shellfilter and operate as OS handles - which we can't do with fifo2 etc + # + + #if {[string first " " $new] > 0} { + # set c1 $name + #} else { + # set c1 $new + #} + + # -- --- --- --- --- + set idlist_stdout [list] + set idlist_stderr [list] + #set shellrun::runout "" + #when using exec with >&@stdout (to ensure process is connected to console) - the output unfortunately doesn't go via the shellfilter stacks + #lappend idlist_stderr [shellfilter::stack::add stderr ansiwrap -settings {-colour {red bold}}] + #lappend idlist_stdout [shellfilter::stack::add stdout tee_to_var -action float -settings {-varname ::shellrun::runout}] + + if {[punk::config::configure running auto_exec_mechanism] eq "experimental"} { + #TODO - something cross-platform that allows us to maintain a separate console(s) with an additional set of IO channels to drive it + #not a trivial task + + #This runs external executables in a context in which they are not attached to a terminal + #VIM for example won't run, and various programs can't detect terminal dimensions etc and/or will default to ansi-free output + #ctrl-c propagation also needs to be considered + + set teehandle punksh + uplevel 1 [list ::catch {*}{ + } [list ::shellfilter::run [concat [list $new] [lrange $args 1 end]] -teehandle $teehandle -inbuffering line -outbuffering none ] {*}{ + } ::tcl::UnknownResult ::tcl::UnknownOptions + ] + + if {[string trim $::tcl::UnknownResult] ne "exitcode 0"} { + dict set ::tcl::UnknownOptions -code error + set ::tcl::UnknownResult "Non-zero exit code from command '$args' $::tcl::UnknownResult" + } else { + #no point returning "exitcode 0" if that's the only non-error return. + #It is misleading. Better to return empty string. + set ::tcl::UnknownResult "" + } + } else { + set repl_runid [punk::get_repl_runid] + #set ::punk::last_run_display [list] + set resolved $new + if {[string match "for_unknown_handler *" $new]} { + set ext [file extension $name] + if {[string tolower $ext] eq ".lnk"} { + #for .lnk files we can often resolve the target path without needing to execute the shell open command + #- which is desirable because it allows us to avoid the absolute path requirement for unknown-handler auto_execok commands, + #which is desirable because it allows us to support relative paths and paths with environment variables in them + #(e.g for .lnk files that point to executables with environment variables in the path) + set targetinfo [punk::winlnk::resolve $name] + if {[dict exists $targetinfo link_roottarget]} { + set resolved [dict get $targetinfo link_roottarget] + #arguments? + } else { + puts "(unknown-handler): failed to resolve .lnk target for $name. Falling back to shell open command resolution, which may fail if absolute path is required." + } + } else { + #re-resolve. + set associnfo [punk::auto_exec::shell_open_command $ext] + set registry_valuetype [dict get $associnfo type] ;#sz vs expand_sz + set command_spec [dict get $associnfo value] + set windows_file_type [dict get $associnfo filetype] + if {[string match "*absolute_path required" $new]} { + puts "(unknown-handler): auto_execok for $name requires absolute path. Re-resolving $name with absolute path." + set fullpath [file normalize $name] + #at least for .url files - long paths (paths with multiple spaces?) can fail to run. Using the short path seems to fix this. + #This seems hacky but anyway.. + set attributes [file attributes $fullpath] + if {[dict exists $attributes -shortname]} { + set fullpath [dict get $attributes -shortname] + } + set resolved [punk::auto_exec::shell_command_as_tcl_list -type $registry_valuetype $command_spec $fullpath] + } else { + #todo + set newnorm [file normalize $name] + puts stderr "(unknown-handler): re-resolving $name with auto_execok $newnorm" + set resolved [auto_execok $newnorm] + } + } + } + + if {$resolved eq ""} { + #resolved may be emptyif auto_execok returns an empty string. + dict set ::tcl::UnknownOptions -code error + set ::tcl::UnknownResult "unresolved path '$name'" + return -options $::tcl::UnknownOptions $::tcl::UnknownResult + } + set redir ">&@stdout <@stdin" + uplevel 1 [list ::catch [concat exec $redir $resolved [lrange $args 1 end]] ::tcl::UnknownResult ::tcl::UnknownOptions] + #we can't detect stdout/stderr output from the exec + #for now emit an extra \n on stderr + #todo - there is probably no way around this but to somehow exec in the context of a completely separate console + #This is probably a tricky problem - especially to do cross-platform + # + # - use [dict get $::tcl::UnknownOptions -code] (0|1) exit + if {[dict get $::tcl::UnknownOptions -code] == 0} { + set c green + set m "ok" + } else { + set c yellow + set m "errorCode $::errorCode" + } + set chunklist [list] + lappend chunklist [list "info" "[a $c]$m[a] " ] + if {$repl_runid != 0} { + tsv::lappend repl runchunks-$repl_runid {*}$chunklist + } + + } + + foreach id $idlist_stdout { + shellfilter::stack::remove stdout $id + } + foreach id $idlist_stderr { + shellfilter::stack::remove stderr $id + } + # -- --- --- --- --- + + + #uplevel 1 [list ::catch \ + # [concat exec $redir $new [lrange $args 1 end]] \ + # ::tcl::UnknownResult ::tcl::UnknownOptions] + + #puts "===exec with redir:$redir $::tcl::UnknownResult ==" + dict incr ::tcl::UnknownOptions -level + return -options $::tcl::UnknownOptions $::tcl::UnknownResult + } + } + + if {$name eq "!!"} { + set newcmd [history event] + } elseif {[regexp {^!(.+)$} $name -> event]} { + set newcmd [history event $event] + } elseif {[regexp {^\^([^^]*)\^([^^]*)\^?$} $name -> old new]} { + set newcmd [history event -1] + catch {regsub -all -- $old $newcmd $new newcmd} + } + if {[info exists newcmd]} { + tclLog $newcmd + history change $newcmd 0 + uplevel 1 [list ::catch $newcmd \ + ::tcl::UnknownResult ::tcl::UnknownOptions] + dict incr ::tcl::UnknownOptions -level + return -options $::tcl::UnknownOptions $::tcl::UnknownResult + } + + set ret [catch {set candidates [info commands $name*]} msg] + if {$name eq "::"} { + set name "" + } + if {$ret != 0} { + dict append opts -errorinfo \ + "\n (expanding command prefix \"$name\" in unknown)" + return -options $opts $msg + } + # Filter out bogus matches when $name contained + # a glob-special char [Bug 946952] + if {$name eq ""} { + # Handle empty $name separately due to strangeness + # in [string first] (See RFE 1243354) + set cmds $candidates + } else { + set cmds [list] + foreach x $candidates { + if {[string first $name $x] == 0} { + lappend cmds $x + } + } + } + + #punk - disable prefix match search + set default_cmd_search 0 + if {$default_cmd_search} { + if {[llength $cmds] == 1} { + uplevel 1 [list ::catch [lreplace $args 0 0 [lindex $cmds 0]] ::tcl::UnknownResult ::tcl::UnknownOptions] + dict incr ::tcl::UnknownOptions -level + return -options $::tcl::UnknownOptions $::tcl::UnknownResult + } + if {[llength $cmds]} { + return -code error "ambiguous command name \"$name\": [lsort $cmds]" + } + } else { + #punk hacked version - report matches but don't run + if {[llength $cmds]} { + return -code error "unknown command name \"$name\": possible match(es) [lsort $cmds]" + } + + } + + + } + return -code error -errorcode [list TCL LOOKUP COMMAND $name] "invalid command name $name" + } + + proc know {cond body} { + set existing [info body ::unknown] + #assuming we can't test on cond being present in existing unknown script - because it may be fairly simple and prone to false positives (?) + ##This means we can't have 2 different conds with same body if we test for body in unknown. + ##if {$body ni $existing} { + set scr [base64::encode -maxlen 0 $cond] ;#will only be decoded if the debug is triggered + #tcllib has some double-substitution going on.. base64 seems easiest and will not impact the speed of normal execution when debug off. + + #tclint-disable-next-line + proc ::unknown {args} [string map [list @c@ $cond @b@ $body @scr@ $scr] { + #--------------------------------------- + if {![catch {expr {@c@}} res] && $res} { + debug.punk.unknown {HANDLED BY: punk unknown_handler ([llength $args]) args:'$args' "cond_script:'[punk::decodescript @scr@]'" } 4 + return [eval {@b@}] + } else { + debug.punk.unknown {skipped: punk unknown_handler ([llength $args]) args:'$args' "cond_script:'[punk::decodescript @scr@]'" } 4 + } + #--------------------------------------- + }]$existing + #} + } + + proc know? {{len 2000}} { + puts [string range [info body ::unknown] 0 $len] + } + proc decodescript {b64} { + if {[ catch { + base64::decode $b64 + } scr]} { + return "" + } else { + return "($scr)" + } + } + + # --------------------------- + # commands that should be aliased in safe interps that need to use punk repl + # + proc get_repl_runid {} { + if {[interp issafe]} { + if {[info commands ::tsv::exists] eq ""} { + puts stderr "punk::get_repl_runid cannot operate directly in safe interp - install the appropriate punk aliases" + error "punk::get_repl_runid punk repl aliases not installed" + } + #if safe interp got here - there must presumably be a direct set of aliases on tsv::* commands + } + if {[tsv::exists repl runid]} { + return [tsv::get repl runid] + } else { + return 0 + } + } + #ensure we don't get into loop in unknown when in safe interp - which won't have tsv + proc set_repl_last_unknown {args} { + if {[interp issafe]} { + if {[info commands ::tsv::set] eq ""} { + puts stderr "punk::set_repl_last_unknown cannot operate directly in safe interp - install an alias to tsv::set repl last_unknown" + return + } + #tsv::* somehow working - possibly custom aliases for tsv functionality ? review + } + if {[info commands ::tsv::set] eq ""} { + puts stderr "set_repl_last_unknown - tsv unavailable!" + return + } + tsv::set repl last_unknown {*}$args + } + # --------------------------- + + #---------------- + #for var="val {a b c}" + #proc ::punk::val {{v {}}} {tailcall lindex $v} + #proc ::punk::val {{v {}}} {return $v} ;#2023 - approx 2x faster than the tailcall lindex version + + proc ::punk::val [list [list v [purelist]]] {return $v} + #---------------- + + proc configure_unknown {} { + #----------------------------- + #these are critical e.g core behaviour or important for repl displaying output correctly + + + #can't use know - because we don't want to return before original unknown body is called. + proc ::unknown {args} [string cat { + #set ::punk::last_run_display [list] + #set ::repl::last_unknown [lindex $args 0] ;#jn + #tsv::set repl last_unknown [lindex $args 0] ;#REVIEW + punk::set_repl_last_unknown [lindex $args 0] + }][info body ::unknown] + + + #handle process return dict of form {exitcode num etc blah} + #ie when the return result as a whole is treated as a command + #exitcode must be the first key + know {[lindex $args 0 0] eq "exitcode"} { + uplevel 1 [list exitcode {*}[lrange [lindex $args 0] 1 end]] + } + + + #----------------------------- + # + # potentially can be disabled by config(?) - but then scripts not able to use all repl features.. + + + #------------------------ + #todo 2026 - remove - use new : expr syntax instead + #todo - repl output info that it was evaluated as an expression + #know {[expr $args] || 1} {expr $args} + #know {[expr $args] || 1} {tailcall expr $args} + #--------------------------- + + #it is significantly faster to call a proc such as punk::lib::range like this than to inline it in the unknown proc + #punk::lib::range is defined as a wrapper to lseq if it is available (8.7+) + know {[regexp {^([+-]*[0-9_]+)\.\.([+-]*[0-9_]+)$} [lindex $args 0 0] -> from to]} {punk::lib::range $from $to} + + + #NOTE: + #we don't allow setting namespace qualified vars in the lhs assignment pattern. + #The principle is that we shouldn't be setting vars outside of the immediate calling scope. + #(It would also be difficult and error-prone and generally make the pipelines less re-usable and reliable) + #Therefore ::nswhatever::blah= x is the pipeline: blah= x - where the corresponding command, if any is first resolved in ::nswhatever + #We will require that the namespace already exists - which is consistent with if the command were to be run without unknown + proc ::punk::_unknown_assign_dispatch {matchedon pattern equalsrhs args} { + set tail [lassign $args hd] + #puts "-> _unknown_assign_dispatch '$partzerozero' pattern:'$pattern' equalsrhs:'$equalsrhs' args:'$args' argshd:'$hd' argstail:'$tail'" + if {$hd ne $matchedon} { + if {[llength $tail]} { + error "unknown_assign_dispatch: pipeline with args unexpanded. Try {*}\$pipeline $tail" + } + #regexp $punk::re_assign $hd _ pattern equalsrhs + #we assume the whole pipeline has been provided as the head + #regexp {^([^\t\r\n=]*)\=([^ \t\r\n]*)(.*)} $hd _ pattern equalsrhs tail + regexp {^([^\t\r\n=]*)\=([^\r\n]*)} $hd _ pattern fullrhs + lassign [punk::pipe::lib::_rhs_tail_split $fullrhs] equalsrhs tail + } + #NOTE: - it doesn't make sense to call 'namespace' qualifiers or 'namespace tail' on a compound hd such as v,::etc= blah + # we only look at leftmost namespace-like thing and need to take account of the pattern syntax + # e.g for ::etc,'::x'= + # the ns is :: and the tail is etc,'::x'= + # (Tcl's namespace qualifiers/tail won't help here) + if {[string match ::* $hd]} { + set patterns [punk::pipe::lib::_split_patterns_memoized $hd] + #get a pair-list something like: {::x /0} {etc {}} + set ns [namespace qualifiers [lindex $patterns 0 0]] + set nslen [string length $ns] + set patterntail [string range $ns $nslen end] + } else { + set ns "" + set patterntail $pattern + } + if {[string length $ns] && ![namespace exists $ns]} { + error "unknown_assign_dispatch: namespace '$ns' not found. (Note that pipeline lhs variables cannot be namespaced)" + } else { + set nscaller [uplevel 1 [list ::tcl::namespace::current]] + #jmn + set rhsmapped [punk::pipe::lib::pipecmd_namemapping $equalsrhs] + set commands [uplevel 1 [list ::tcl::info::commands $pattern=$rhsmapped]] ;#uplevel - or else we are checking from perspective of this namespace ::punk + #we must check for exact match of the command in the list - because command could have glob chars. + if {"$pattern=$rhsmapped" in $commands} { + puts stderr "unknown_assign_dispatch>> '$pattern=$equalsrhs' $commands nscaller: '$nscaller'" + #we call the namespaced function - we don't evaluate it *in* the namespace. + #REVIEW + #warn for now...? + #tailcall $pattern=$equalsrhs {*}$args + tailcall $pattern=$rhsmapped {*}$tail + } + } + #puts "--->nscurrent [uplevel 1 [list ::namespace current]]" + #ignore the namespace.. + #We could interpret the fact that the nonexistant pipe was called with a namespace to indicate that's where the pipecommand should be created.. + #But.. we would need to ensure 1st (compiling) invocation runs the same way as subsequent invocations. + #namespace evaling match_assign here probably wouldn't accomplish that and may create surprises with regards to where lhs vars(if any) are created + tailcall ::punk::match_assign $patterntail $equalsrhs {*}$tail + #return [uplevel 1 [list ::punk::match_assign $varspecs $rhs $tail]] + } + #variable re_assign {^([^\r\n=\{]*)=(.*)} + #characters directly following = need to be assigned to the var even if they are escaped whitespace (e.g \t \r \n) + #unescaped whitespace causes the remaining elements to be part of the tail -ie are appended to the var as a list + #e.g x=a\nb c + #x will be assigned the list {a\nb c} ie the spaces between b & c are not maintained + # + #know {[regexp {^([^\t\r\n=]*)\=([^ \t\r\n]*)} [lindex $args 0] matchedon pattern equalsrhs]} {tailcall ::punk::_unknown_assign_dispatch $matchedon $pattern $equalsrhs {*}$args} + #know {[regexp {^{([^\t\r\n=]*)\=([^ \t\r\n]*)}} [lindex $args 0] matchedon pattern equalsrhs]} {tailcall ::punk::_unknown_assign_dispatch $matchedon $pattern $equalsrhs {*}$args} + + + + proc ::punk::_unknown_compare {val1 val2 args} { + if {![string length [string trim $val2]]} { + if {[llength $args] > 1} { + #error "Extra args after comparison operator ==. usage e.g : \$var1==\$var2 or \$var1==\$var2 + 2" + set val2 [string cat {*}[lrange $args 1 end]] + return [expr {$val1 eq $val2}] + } + return $val1 + } elseif {[llength $args] == 1} { + #simple comparison + if {[string is digit -strict $val1$val2]} { + return [expr {$val1 == $val2}] + } else { + return [string equal $val1 $val2] + } + } elseif {![catch {expr $val2 {*}[lrange $args 1 end]} evaluated]} { + if {[string is digit -strict $val1$evaluated]} { + return [expr {$val1 == $evaluated}] + } else { + return [expr {$val1 eq $evaluated}] + } + } else { + set evaluated [uplevel 1 [list {*}$val2 {*}[lrange $args 1 end]]] + if {[string is digit -strict $val1$evaluated]} { + return [expr {$val1 == $evaluated}] + } else { + return [expr {$val1 eq $evaluated}] + } + } + } + #ensure == is after = in know sequence + #.* on left is pretty broad - todo: make it a little more specific to avoid unexpected interactions + know {[regexp {(.*)==(.*)} [lindex $args 0] _ val1 val2]} {tailcall ::punk::_unknown_compare $val1 $val2 {*}$args} + #.= must come after = here to ensure it comes before = in the 'unknown' proc + #set punk::re_dot_assign {([^=]*)\.=(.*)} + #know {[regexp $punk::re_dot_assign [lindex $args 0 0] _ varspecs rhs]} { + # set tail [expr {([lindex $args 0] eq [lindex $args 0 0]) ? [lrange $args 1 end] : [concat [lrange [lindex $args 0] 1 end] [lrange $args 1 end] ] }] + # tailcall ::punk::match_exec $varspecs $rhs {*}$tail + # #return [uplevel 1 [list ::punk::match_exec $varspecs $rhs {*}$tail]] + # } + # + + + + proc ::punk::_unknown_dot_assign_dispatch {partzerozero pattern equalsrhs args} { + #puts stderr ". unknown dispatch $partzerozero" + set argstail [lassign $args hd] + + #this equates to auto-flattening the head.. which seems like a bad idea, the structure was there for a reason. + #we should require explicit {*} expansion if the intention is for the args to be joined in at that level. + #expr {($hd eq $partzerozero) ? [set tail $argstail] : [set tail [concat [lrange $hd 1 end] $argstail ]] } + + if {$hd ne $partzerozero} { + if {[llength $argstail]} { + error "unknown_dot_assign_dispatch: pipeline with args unexpanded. Try {*}\$pipeline $argstail" + } + #regexp $punk::re_assign $hd _ pattern equalsrhs + #we assume the whole pipeline has been provided as the head + #regexp {^([^ \t\r\n=\{]*)\.=([^ \t\r\n]*)(.*)} $hd _ pattern equalsrhs argstail + #regexp {^([^ \t\r\n=\{]*)\.=([^ \t\r\n]*)(.*)} $hd _ pattern equalsrhs argstail + + regexp {^([^ \t\r\n=\{]*)\.=([^\r\n]*)} $hd _ pattern fullrhs + lassign [punk::pipe::lib::_rhs_tail_split $fullrhs] equalsrhs argstail + } + #tailcall ::punk::match_assign $pattern $equalsrhs {*}$argstail + + + return [uplevel 1 [list ::punk::pipeline .= $pattern $equalsrhs {*}$argstail]] + + } + + # + know {[regexp {^([^\t\r\n=]*)\=([^\r\n]*)} [lindex $args 0] matchedon pattern equalsrhs]} {tailcall ::punk::_unknown_assign_dispatch $matchedon $pattern $equalsrhs {*}$args} + know {[regexp {^{([^\t\r\n=]*)\=([^\r\n]*)}} [lindex $args 0] matchedon pattern equalsrhs]} {tailcall ::punk::_unknown_assign_dispatch $matchedon $pattern $equalsrhs {*}$args} + + #variable re_dot_assign {^([^ \t\r\n=\{]*)\.=(.*)} + #know {[regexp {^([^ \t\r\n=\{]*)\.=(.*)} [lindex $args 0 0] partzerozero varspecs rhs]} {tailcall punk::_unknown_dot_assign_dispatch $partzerozero $varspecs $rhs {*}$args} + #know {[regexp {^([^ \t\r\n=\{]*)\.=(.*)} [lindex $args 0] partzerozero varspecs rhs]} {tailcall punk::_unknown_dot_assign_dispatch $partzerozero $varspecs $rhs {*}$args} + #know {[regexp {^([^\t\r\n=\{]*)\.=(.*)} [lindex $args 0] partzerozero varspecs rhs]} {tailcall punk::_unknown_dot_assign_dispatch $partzerozero $varspecs $rhs {*}$args} + #know {[regexp {^([^\t\r\n=]*)\.=(.*)} [lindex $args 0] partzerozero varspecs rhs]} {tailcall punk::_unknown_dot_assign_dispatch $partzerozero $varspecs $rhs {*}$args} + know {[regexp {^([^=]*)\.=(.*)} [lindex $args 0] partzerozero varspecs rhs]} {tailcall punk::_unknown_dot_assign_dispatch $partzerozero $varspecs $rhs {*}$args} + + #add escaping backslashes to a value + #matching odd keys in dicts using pipeline syntax can be tricky - as + #e.g + #set ktest {a"b} + #@@[escv $ktest].= list a"b val + #without escv: + #@@"a\\"b".= list a"b val + #with more backslashes in keys the escv use becomes more apparent: + #set ktest {\\x} + #@@[escv $ktest].= list $ktest val + #without escv we would need: + #@@\\\\\\\\x.= list $ktest val + proc escv {v} { + #https://stackoverflow.com/questions/11135090/is-there-any-tcl-function-to-add-escape-character-automatically + #thanks to DKF + regsub -all {\W} $v {\\&} + } + interp alias {} escv {} punk::escv + #review + #set v "\u2767" + # + #escv $v + #\ + #the + + + #know {[regexp $punk::re_dot_assign [lindex $args 0 0] partzerozero varspecs rhs]} { + # set argstail [lassign $args hd] + # #set tail [expr {($hd eq $partzerozero) ? $argstail : [concat [lrange $hd 1 end] $argstail ] }] ;#!WRONG. expr will convert some numbers to scientific notation - this is premature/undesirable! + # #avoid using the return from expr and it works: + # expr {($hd eq $partzerozero) ? [set tail $argstail] : [set tail [concat [lrange $hd 1 end] $argstail ]] } + # + # tailcall ::punk::match_exec $varspecs $rhs {*}$tail + # #return [uplevel 1 [list ::punk::match_exec $varspecs $rhs {*}$tail]] + #} + + } + configure_unknown + #if client redefines 'unknown' after package require punk, they must call punk::configure_unknown afterwards. + # + + #main Pipe initiator function - needed especially if 'unknown' not configured to interpret x.= x= etc + #Should theoretically be slightly faster.. but pipelines are relatively slow until we can get pipeline compiling and optimisation. + proc % {args} { + set arglist [lassign $args assign] ;#tail, head + if {$assign eq ".="} { + tailcall {*}[list ::punk::pipeline .= "" "" {*}$arglist] + } elseif {$assign eq "="} { + tailcall {*}[list ::punk::pipeline = "" "" {*}$arglist] + } + + #review + set assign [string map {; \\;} $assign] + + set is_script [punk::pipe::lib::arg_is_script_shaped $assign] + + if {!$is_script && [string index $assign end] eq "="} { + #set re_dotequals {^([^ \t\r\n=\{]*)\.=$} + #set dumbeditor {\}} + #set re_equals {^([^ \t\r\n=\{]*)=$} + #set dumbeditor {\}} + if {[regexp {^([^ \t\r\n=\{]*)\.=$} $assign _ returnvarspecs]} { + set cmdlist [list ::punk::pipeline .= $returnvarspecs "" {*}$arglist] + } elseif {[regexp {^([^ \t\r\n=\{]*)=$} $assign _ returnvarspecs]} { + set cmdlist [list ::punk::pipeline = $returnvarspecs "" {*}$arglist] + } else { + error "pipesyntax punk::% unable to interpret pipeline '$args'" "% $args" [list pipesyntax unable_to_interpret] + } + } else { + if {$is_script} { + set cmdlist [list ::punk::pipeline "script" "" "" {*}$args] + } else { + set cmdlist [list ::punk::pipeline ".=" "" "" $assign {*}$arglist] + } + } + tailcall {*}$cmdlist + + + #result-based mismatch detection can probably never work nicely.. + #we need out-of-band method to detect mismatch. Otherwise we can't match on mismatch results! + # + set result [uplevel 1 $cmdlist] + #pipeline result not guaranteed to be a proper list so we can't use list methods to directly look for 'binding mismatch' + #.. but if we use certain string methods - we shimmer the case where the main result is a list + #string match doesn't seem to change the rep.. though it does generate a string rep. + #puts >>1>[rep $result] + if {[catch {lrange $result 0 1} first2wordsorless]} { + #if we can't get as a list then it definitely isn't the semi-structured 'binding mismatch' + return $result + } else { + if {$first2wordsorless eq {binding mismatch}} { + error $result + } else { + #puts >>2>[rep $result] + return $result + } + } + } + + proc ispipematch {args} { + expr {[lindex [uplevel 1 [list ::punk::pipematch {*}$args]] 0] eq "ok"} + } + + #pipe initiator which will never raise an error *except for pipesyntax* , but always returns {ok {result something}} or {error {mismatch something}} or, for tcl errors {error {reason something}} + proc pipematch {args} { + #debug.punk.pipe {pipematch level [info level] levelinfo [info level 0]} 2 + variable re_dot_assign + variable re_assign + + set arglist [lassign $args assign] + if {$assign eq ".="} { + set cmdlist [list ::punk::pipeline .= "" "" {*}$arglist] + } elseif {$assign eq "="} { + set cmdlist [list ::punk::pipeline = "" "" {*}$arglist] + } elseif {![punk::pipe::lib::arg_is_script_shaped $assign] && [string index $assign end] eq "="} { + #set re_dotequals {^([^ \t\r\n=\{]*)\.=$} + # set dumbeditor {\}} + #set re_equals {^([^ \t\r\n=\{]*)=$} + # set dumbeditor {\}} + if {[regexp {^([^ \t\r\n=]*)\.=.*} $assign _ returnvarspecs]} { + set cmdlist [list ::punk::pipeline .= $returnvarspecs "" {*}$arglist] + } elseif {[regexp {^([^ \t\r\n=]*)=.*} $assign _ returnvarspecs]} { + set cmdlist [list $assign {*}$arglist] + #set cmdlist [list ::punk::pipeline = $returnvarspecs "" {*}$arglist] + } else { + error "pipesyntax punk::pipematch unable to interpret pipeline '$args'" "pipematch $args" [pipesyntax unable_to_interpret] + } + } else { + set cmdlist $args + #script? + #set cmdlist [list ::punk::pipeline .= "" "" {*}$args] + } + + if {[catch {uplevel 1 $cmdlist} result erroptions]} { + #puts stderr "pipematch erroptions:$erroptions" + #debug.punk.pipe {pipematch error $result} 4 + set ecode [dict get $erroptions -errorcode] + switch -- [lindex $ecode 0] { + binding { + if {[lindex $ecode 1] eq "mismatch"} { + #error {reason xxx} should only be returned for underlying tcl errors. error {someotherkey xxx} for structured errors such as a binding mismatch + #return [dict create error [dict create mismatch $result]] + #puts stderr "pipematch converting error to {error {mismatch }}" + return [list error [list mismatch $result]] + } + } + pipesyntax { + #error $result + return -options $erroptions $result + } + casematch { + return $result + } + } + #return [dict create error [dict create reason $result]] + return [list error [list reason $result]] + } else { + return [list ok [list result $result]] + #debug.punk.pipe {pipematch result $result } 4 + #return [dict create ok [dict create result $result]] + } + } + + proc pipenomatchvar {varname args} { + if {[string first = $varname] >=0} { + #first word "pipesyntax" is looked for by pipecase + error "pipesyntax pipenomatch expects a simple varname as first argument" "pipenomatchvar $varname $args" [list pipesyntax expected_simple_varname] + } + #debug.punk.pipe {pipematch level [info level] levelinfo [info level 0]} 2 + + set assign [lindex $args 0] + set arglist [lrange $args 1 end] + if {[string first = $assign] >= 0} { + variable re_dot_assign + variable re_assign + #what if we get passed a script block containing = ?? e.g {error x=a} + if {$assign eq ".="} { + set cmdlist [list ::punk::pipeline .= "" "" {*}$arglist] + } elseif {$assign eq "="} { + set cmdlist [list ::punk::pipeline = "" "" {*}$arglist] + } elseif {[regexp $re_dot_assign $assign _ returnvarspecs rhs]} { + set cmdlist [list ::punk::pipeline .= $returnvarspecs $rhs {*}$arglist] + } elseif {[regexp $re_assign $assign _ returnvarspecs rhs]} { + set cmdlist [list ::punk::pipeline = $returnvarspecs $rhs {*}$arglist] + } else { + debug.punk.pipe {[a+ yellow bold] Unexpected arg following pipenomatchvar variable [a]} 0 + set cmdlist $args + #return [dict create error [dict create reason [dict create pipematch bad_first_word value $assign pipeline [list pipematch $assign {*}$args]]]] + } + } else { + set cmdlist $args + } + + upvar 1 $varname nomatchvar + if {[catch {uplevel 1 $cmdlist} result erroptions]} { + set ecode [dict get $erroptions -errorcode] + debug.punk.pipe {[a+ yellow bold]pipematchnomatch error $result[a]} 3 + if {[lindex $ecode 0] eq "pipesyntax"} { + set errordict [dict create error [dict create pipesyntax $result]] + set nomatchvar $errordict + return -options $erroptions $result + } + if {[lrange $ecode 0 1] eq "binding mismatch"} { + #error {reason xxx} should only be returned for underlying tcl errors. error {someotherkey xxx} for structured errors such as a binding mismatch + set errordict [dict create error [dict create mismatch $result]] + set nomatchvar $errordict + return -options $erroptions $result + } + set errordict [dict create error [dict create reason $result]] + set nomatchvar $errordict + #re-raise the error for pipeswitch to deal with + return -options $erroptions $result + } else { + debug.punk.pipe {pipematchnomatch result $result } 4 + set nomatchvar "" + #uplevel 1 [list set $varname ""] + #return raw result only - to pass through to pipeswitch + return $result + #return [dict create ok [dict create result $result]] + } + } + + #should only raise an error for pipe syntax errors - all other errors should be wrapped + proc pipecase {args} { + #debug.punk.pipe {pipecase level [info level] levelinfo [info level 0]} 9 + set arglist [lassign $args assign] + if {$assign eq ".="} { + set cmdlist [list ::punk::pipeline .= "" "" {*}$arglist] + } elseif {$assign eq "="} { + #set cmdlist [list ::punk::pipeline = "" "" {*}$arglist] + set cmdlist [list ::= {*}$arglist] + } elseif {![punk::pipe::lib::arg_is_script_shaped $assign] && [string first "=" $assign] >= 0} { + #set re_dotequals {^([^ \t\r\n=\{]*)\.=$} + #set dumbeditor {\}} + #set re_equals {^([^ \t\r\n=\{]*)=$} + #set dumbeditor {\}} + + if {[regexp {^([^ \t\r\n=]*)\.=.*} $assign _ returnvarspecs]} { + set cmdlist [list ::punk::pipeline .= $returnvarspecs "" {*}$arglist] + } elseif {[regexp {^([^ \t\r\n=]*)=.*} $assign _ returnvarspecs]} { + set cmdlist [list $assign {*}$arglist] + #set cmdlist [list ::punk::pipeline = $returnvarspecs "" {*}$arglist] + } else { + error "pipesyntax pipecase unable to interpret pipeline '$args'" + } + #todo - account for insertion-specs e.g x=* x.=/0* + } else { + #script? + set cmdlist [list ::punk::pipeline .= "" "" {*}$args] + } + + + if {[catch {uplevel 1 [list ::if 1 $cmdlist]} result erroptions]} { + #puts stderr "====>>> result: $result erroptions" + set ecode [dict get $erroptions -errorcode] + switch -- [lindex $ecode 0] { + pipesyntax { + #error $result + return -options $erroptions $result + } + casenomatch { + return -options $erroptions $result + } + binding { + if {[lindex $ecode 1] eq "mismatch"} { + #error {reason xxx} should only be returned for underlying tcl errors. error {someotherkey xxx} for structured errors such as a binding mismatch + #return [dict create error [dict create mismatch $result]] + # + #NOTE: casemismatch is part of the api for pipecase. It is a casemismatch rather than an error - because for a pipecase - a casemismatch is an expected event (many casemismatches - one match) + return [dict create casemismatch $result] + } + } + } + + #we can't always treat $result as a list - may be an error string which can't be represented as a list, and there may be no useful errorCode + #todo - use errorCode instead + if {[catch {lindex $result 0} word1]} { + #tailcall error $result + return -options $erroptions $result + } else { + switch -- $word1 { + switcherror - funerror { + error $result "pipecase [lsearch -all -inline $args "*="]" + } + resultswitcherror - resultfunerror { + #recast the error as a result without @@ok wrapping + #use the tailcall return to stop processing other cases in the switch! + tailcall return [dict create error $result] + } + ignore { + #suppress error, but use normal return + return [dict create error [dict create suppressed $result]] + } + default { + #normal tcl error + #return [dict create error [dict create reason $result]] + tailcall error $result "pipecase $args" [list caseerror] + } + } + } + } else { + tailcall return -errorcode [list casematch] [dict create ok [dict create result $result]] + } + + } + + #note that pipeswitch deliberately runs in callers scope to have direct access to variables - it is akin to a control structure. + #It also - somewhat unusually accepts args - which we provide as 'switchargs' + #This is unorthodox/risky in that it will clobber any existing var of that name in callers scope. + #Solve using documentation.. consider raising error if 'switchargs' already exists, which would require user to unset switchargs in some circumstances. + proc pipeswitch {pipescript args} { + #set nextargs $args + #unset args + #upvar args upargs + #set upargs $nextargs + upvar switchargs switchargs + set switchargs $args + uplevel 1 [::list ::if 1 $pipescript] + } + #static-closure version - because we shouldn't be writing back to calling context vars directly + #Tcl doesn't (2023) have mutable closures - but for functional pipeline composition - we probably don't want that anyway! + #pipeswitchc is preferable to pipeswitch in that we can access context without risk of affecting it, but is less performant. (particularly in global scope.. but that probably isn't an important usecase) + proc pipeswitchc {pipescript args} { + set binding {} + if {[info level] == 1} { + #up 1 is global + set get_vars [list info vars] + } else { + set get_vars [list info locals] + } + set vars [uplevel 1 {*}$get_vars] + set posn [lsearch $vars switchargs] + #set vars [lreplace $vars $posn $posn] + set vars [lreplace $vars[set vars {}] $posn $posn] + foreach v $vars { + upvar 1 $v var + if {(![array exists var]) && [info exists var]} { + lappend binding [list $v $var] ;#values captured as defaults for apply args. + } + } + lappend binding [list switchargs $args] + apply [list $binding $pipescript [uplevel 1 {::tcl::namespace::current}]] + } + + proc pipedata {data args} { + #puts stderr "'$args'" + set r $data + for {set i 0} {$i < [llength $args]} {incr i} { + set e [lindex $args $i] + #review: string is list is as slow as catch {llength $e} - and also affects ::errorInfo unlike other string is commands. bug/enhancement report? + if {![string is list $e]} { + #not a list - assume script and run anyway + set r [apply [list {data} $e] $r] + } else { + if {[llength $e] == 1} { + switch -- $e { + > { + #output to calling context. only pipedata return value and '> varname' should affect caller. + incr i + uplevel 1 [list set [lindex $args $i] $r] + } + % - pipematch - ispipematch { + incr i + set e2 [lindex $args $i] + #set body [list $e {*}$e2] + #append body { $data} + + set body [list $e {*}$e2] + append body { {*}$data} + + + set applylist [list {data} $body] + #puts stderr $applylist + set r [apply $applylist $r] + } + pipeswitch - pipeswitchc { + #pipeswitch takes a script not a list. + incr i + set e2 [lindex $args $i] + set body [list $e $e2] + #pipeswitch takes 'args' - so expand $data when in pipedata context + append body { {*}$data} + #use applylist instead of uplevel when in pipedata context! + #can use either switchdata/data but not vars in calling context of 'pipedata' command. + #this is consistent with pipeswitch running in a % / .= pipeline which can only access vars in immediate calling context. + set applylist [list {data} $body] + #puts stderr $applylist + set r [apply $applylist $r] + } + default { + #puts "other single arg: [list $e $r]" + append e { $data} + set r [apply [list {data} $e] $r] + } + } + } elseif {[llength $e] == 0} { + #do nothing - pass data through + #leave r as is. + } else { + set r [apply [list {data} $e] $r] + } + } + } + return $r + } + + + proc scriptlibpath {{shortname {}} args} { + set scriptlib [punk::config::configure running scriptlib] + if {[string match "lib::*" $shortname]} { + set relpath [string map [list "lib::" "" "::" "/"] $shortname] + set relpath [string trimleft $relpath "/"] + set fullpath $scriptlib/$relpath + } else { + set shortname [string trimleft $shortname "/"] + set fullpath $scriptlib/$shortname + } + return $fullpath + } + + + #useful for aliases e.g treemore -> xmore tree + proc xmore {args} { + if {[llength $args]} { + #more is older and not as featureful as less + #more importantly - at least some implementations (msys on windows) can skip output lines - unknown as to why + #uplevel #0 [list {*}$args | more] + uplevel #0 [list {*}$args | less -X] ;#-X to avoid use of alternate-screen + } else { + error "usage: punk::xmore args where args are run as {*}\$args | more" + } + } + + + #environment path as list + # + #return *appendable* pipeline - i.e no args via <| + proc path_list_pipe {{glob *}} { + if {$::tcl_platform(platform) eq "windows"} { + set sep ";" + } else { + # : ok for linux/bsd ... mac? + set sep ":" + } + set cond [string map [list $glob] {expr {[string length $item] && [string match $item]}}] + #env members such as ''path' not case sensitive on windows - but are on some other platforms (at least FreeBSD) + return [list .= set ::env(PATH) |> .=>2 string trimright $sep |> .=>1 split $sep |> list_filter_cond $cond ] + } + proc path_list {{glob *}} { + set pipe [punk::path_list_pipe $glob] + {*}$pipe + } + proc path_basic {{glob *}} { + set pipe [punk::path_list_pipe $glob] + {*}$pipe |> list_as_lines + } + namespace eval argdoc { + punk::args::define { + @id -id ::punk::path + @cmd -name "punk::path"\ + -summary\ + "Display PATH executable shadowing and conflicts with TCL commands"\ + -help\ + {Introspection of the PATH environment variable. + This tool will examine executables within each PATH entry and show which binaries + are overshadowed by earlier PATH entries. + It can also be used to examine the contents of each PATH entry, and to filter results using glob patterns. + + ${[punk::args::helpers::example { + + #show all executables in all PATH entries + punk::path + #show all executables in all PATH entries that contain 'Windows' in the path + punk::path -pathglob *Windows* + #show all executables in all PATH entries that contain 'scoop' in the path, + #and filter the executables to show only those that are named dir, ls or start with 'ca' + punk::path -pathglob *scoop* dir ls ca* + #show all executables that conflict with TCL commands starting with 'a' in the current namespace. + punk::path {*}[nscommandlist a*] + #show all executables that conflict with TCL commands resolvable from the current namespace. + punk::path {*}[info commands] + + }]} + + see also the punk::auto_exec package. + } + @opts + -pathglob -type string -default {*} -multiple true -help "Case insensitive glob pattern to filter path entries. Default '*' to include all PATH directories." + @values -min 0 -max -1 + binglob -type list -default {*} -multiple true -optional 1 -help "glob pattern to filter results. Default '*' to include all entries." + } + } + + variable d_path_info + variable d_bin_info + variable d_index_executables + #there is still a potential conflict regarding auto_execok on windows - which has some cmd.exe builtins as auto-executable + #- but these are not actually executable files on the filesystem - so they won't be found by our path search + #- but they will be found when not masked by a tcl command. + proc path {args} { + variable d_path_info + variable d_bin_info + variable d_index_executables + set is_windows [expr {$::tcl_platform(platform) eq "windows"}] + set argd [punk::args::parse $args withid ::punk::path] + lassign [dict values $argd] leaders opts values received + set pathglobs [dict get $opts -pathglob] + set binglobs [dict get $values binglob] + if {$is_windows} { + set sep ";" + } else { + # : ok for linux/bsd ... mac? + set sep ":" + } + set all_paths [split [string trimright $::env(PATH) $sep] $sep] + if {[llength $pathglobs]} { + if {[lsearch -exact $pathglobs "*"] >= 0} { + #if we have a wildcard glob then the others are irrelevant - we want to match all paths + set matched_paths $all_paths + } else { + set matched_paths [list] + foreach p $all_paths { + foreach pg $pathglobs { + if {[string match -nocase $pg $p]} { + lappend matched_paths $p + break + } + } + } + } + } + + #This should be designed to be useful on all platforms. + #Case sensitivity represents a difficulty because even on a particular platform + #- different filesystems or folders may have different case sensitivity configurations. + + #as a first step - we can detect windows and mac platforms and treat paths as case-insensitive, vs case-sensitive on other unix-like platforms. + #as a second step - we will consider running a test on each path to determine if the folder at the leaf level is case-sensitive or not. + #- and then use that information to determine how to treat the executables in that path. + #This may be a bit of a performance hit - so we may want to cache the results of this test for each path - and provide a way to clear the cache if needed. + #Alternatively we could just provide an option to treat all paths as case-sensitive or case-insensitive. + + #Windows executable search location order: + #1. The current directory. + #2. The directories that are listed in the PATH environment variable. + # within each directory windows uses the PATHEXT environment variable to determine + #which files are considered executable and in which order they are considered. + #So for example if PATHEXT is set to .COM;.EXE;.BAT;.CMD then if there are files + #with the same name but different extensions in the same directory, then the one + #with the extension that appears first in PATHEXT will be executed when that name is called. + + #On windows platform, PATH entries can be case-insensitively duplicated - we want to treat these as the same path for the purposes of overshadowing - but we want to show the actual paths in the output. + #Duplicate PATH entries are also a fairly likely possibility on all platforms. + #This is likely a misconfiguration, but we want to be able to show it in the output - as it can affect which executables are overshadowed by which PATH entries. + + #By default we don't want to display all executables in all PATH entries - as this can be very verbose + #- but we want to be able to show which executables are overshadowed by which PATH entries, + #and to be able to filter the PATH entries and the executables using glob patterns. + #To achieve this we will build two dicts - one keyed by normalized path, and one keyed by normalized executable name. + #The path dict will contain the original paths that correspond to each normalized path, and the indices of those paths + #in the original PATH list. The executable dict will contain the paths and path indices where each executable is found, + #and the actual executable names (with case and extensions as they appear on the filesystem). We will also build a + #dict keyed by path index which contains the list of executables in that path - to make it easy to show which + #executables are overshadowed by which paths. + if {$is_windows} { + #Sometimes PATHEXT includes an entry of just a dot - which means files with no extension are considered executable. + #We need to account for this in our glob pattern. + set pathexts [list] + #review - we assume this is only relevant on windows for now. + if {[info exists ::env(PATHEXT)]} { + set env_pathexts [split $::env(PATHEXT) ";"] + #set pathexts [lmap e $env_pathexts {string tolower $e}] + foreach pe $env_pathexts { + if {$pe eq "."} { + continue + } + lappend pathexts [string tolower $pe] + } + } else { + set env_pathexts [list] + #default PATHEXT if not set - according to Microsoft docs + set pathexts [list .com .exe .bat .cmd] + } + foreach bg $binglobs { + set has_pathext 0 + foreach pe $pathexts { + if {[string match -nocase "*$pe" $bg]} { + set has_pathext 1 + break + } + } + if {!$has_pathext} { + foreach pe $pathexts { + set globext "$bg$pe" + if {$globext ni $binglobs} { + lappend binglobs "$bg$pe" + } + } + } + } + set lc_binglobs [lmap e $binglobs {string tolower $e}] + if {"." in $pathexts} { + foreach bg $binglobs { + set has_pathext 0 + foreach pe $pathexts { + if {[string match -nocase "*$pe" $bg]} { + set base [string range $bg 0 [expr {[string length $bg] - [string length $pe] - 1}]] + set has_pathext 1 + break + } + } + if {$has_pathext} { + if {[string tolower $base] ni $lc_binglobs} { + lappend binglobs "$base" + } + } + } + } + } + + set d_path_info [dict create] ;#key is normalized path (e.g case-insensitive on windows). + set d_bin_info [dict create] ;#key is normalized executable name (e.g case-insensitive on windows, or callable with extensions stripped off). + set d_index_executables [dict create] ;#key is path index, value is list of executables in that path + set path_idx 0 + foreach p $all_paths { + if {$is_windows} { + set pnorm [string tolower $p] + } else { + set pnorm $p + } + if {[string length $pnorm] > 1} { + set lastchar [string index $pnorm end] + if {$lastchar eq "/" || $lastchar eq "\\"} { + set pnorm [string range $pnorm 0 end-1] + } + } + if {![dict exists $d_path_info $pnorm]} { + dict set d_path_info $pnorm [dict create original_paths [list $p] indices [list $path_idx]] + set executables [list] + if {[file isdirectory $p]} { + #get all files that are executable in this path. + #If we don't normalize the path here - then trailing backslashes on windows can cause a problem with the -tail glob returning a leading slash on the executable names. + #also as we don't necessarily normalize the resulting final path with executable - we want the case to be correct. + set pnormglob [file normalize $p] + if {$is_windows} { + + #TCL's glob on windows is case-insensitive, but in some cases return the result with the case as globbed for regardless of the actual case on the filesystem. + #(This seems to occur when the pattern does *not* contain a wildcard and is probably a bug) + #We would rather report results with the actual case as they appear on the filesystem - so we try to normalize the results. + #The normalization doesn't work as expected - but can be worked around by using 'string range $e 0 end' instead of just $e - which seems to force Tcl to give us the actual case from the filesystem rather than the case as globbed for. + #(another workaround is to use a degenerate case glob e.g when looking for 'SDX.exe' to glob for '[S]DX.exe' + # but tcl's glob does not respect the case of even the character-class pattern - so this is not a reliable workaround). + #see punk::fglob for a work-in-progress glob implementation which gives us more control over case sensitivity and the case of results on windows. + + #----------------------- + #JJJ + #set globresults [lsort -unique [glob -nocomplain -directory $pnormglob -types {f x} {*}$binglobs]] + #set executables [list] + #foreach e $globresults { + # puts stderr "glob result: $e" + # puts stderr "normalized executable name: [file tail [file normalize [string range $e 0 end]]]]" + # lappend executables [file tail [file normalize $e]] + #} + #----------------------- + + #track all executables in the path - even those that don't match the binglobs + #use fglob to get the actual case of the executables on windows - as glob seems to return the case as globbed for rather than the actual case on the filesystem in some cases. + #this doesn't run a full 'file normalize' on the results which affects whether a more efficient internal representation is stored + + #fglob with single glob argument should already return a unique list. + set folder_exes [fglob -nocomplain -directory $pnormglob -types {f x} *] + set executables [list] + foreach e $folder_exes { + lappend executables [file tail $e] + } + + } else { + #set executables [lsort -unique [glob -nocomplain -directory $p -types {f x} -tail {*}$binglobs]] + set executables [lsort -unique [glob -nocomplain -directory $p -types {f x} -tail *]] + } + } + dict set d_index_executables $path_idx $executables + foreach exe $executables { + #todo - other case-insensitive platforms/filesystems. + if {$is_windows} { + set exe_key [string tolower $exe] + } else { + #on case + set exe_key $exe + } + if {![dict exists $d_bin_info $exe_key]} { + dict set d_bin_info $exe_key [dict create path_indices [list $path_idx] paths [list $p] executable_names [list $exe]] + } else { + #dict lappend d_bin_info $exe_key path_indices $path_idx paths $p executable_names $exe + set bindata [dict get $d_bin_info $exe_key] + dict lappend bindata path_indices $path_idx + dict lappend bindata paths $p + dict lappend bindata executable_names $exe + dict set d_bin_info $exe_key $bindata + } + } + } else { + #duplicate path entry - add to list of original paths for this normalized path + + # Tcl's dict lappend takes the arguments dictionaryVariable key value ?value ...? + # we need to extract the inner dictionary containig lists to append to, and then set it back after appending to the lists within it. + set pathdata [dict get $d_path_info $pnorm] + dict lappend pathdata original_paths $p + dict lappend pathdata indices $path_idx + dict set d_path_info $pnorm $pathdata + + #consider this alternative approach which reduces number of references to the extracted inner dictionary. + #Will it help avoid copy on write performance issues with dicts? + #see voo package. + # --------------- + #set pathdata [dict get $d_path_info $pnorm] + #dict set d_path_info $pnorm {} + #try { + # dict lappend pathdata original_paths $p + # dict lappend pathdata indices $path_idx + #} finally { + # dict set d_path_info $pnorm $pathdata + #} + # --------------- + + #we don't need to add executables for this path - as they will be the same as the original path that we have already processed. + #However we do need to add the path index to the path_indices for each executable that is found in this path - as this will affect which paths are shown as overshadowing which executables. + set executables [dict get $d_index_executables [lindex [dict get $d_path_info $pnorm indices] 0]] ;#get executables for this path + foreach exe $executables { + if {$is_windows} { + set exe_key [string tolower $exe] + } else { + set exe_key $exe + } + #dict lappend d_bin_info $exe_key path_indices $path_idx paths $p executable_names $exe + set bindata [dict get $d_bin_info $exe_key] + dict lappend bindata path_indices $path_idx + dict lappend bindata paths $p + dict lappend bindata executable_names $exe + dict set d_bin_info $exe_key $bindata + } + } + + incr path_idx + } + + #temporary debug output to check dicts are being built correctly + #set debug "" + #append debug "Path info dict:" \n + #append debug [showdict $d_path_info] \n + #append debug "Binary info dict:" \n + #append debug [showdict $d_bin_info {*}$binglobs] \n + ##append debug "Index executables dict:" \n + ##append debug [showdict $d_index_executables] \n + ##return $debug + #puts stdout $debug + + + #dict for {p pinfo} $d_path_info { + # set original_paths [dict get $pinfo original_paths] + # set indices [dict get $pinfo indices] + # puts stdout "Path: $p" + # puts stdout " Original paths: $original_paths" + # puts stdout " Indices in PATH: $indices" + # if {[dict exists $d_index_executables [lindex $indices 0]]} { + # set executables [dict get $d_index_executables [lindex $indices 0]] + # puts stdout " Executables: [llength $executables]" + # } else { + # puts stdout " Executables: (not a directory or no executables found)" + # } + #} + + set nscaller [uplevel 1 {::tcl::namespace::current}] + set context_commands [namespace eval $nscaller {info commands}] + + #process paths in order they appear in the original PATH. + set pidx 0 + #use a punk::textblock::table for formatting. + set rows [list] + set headers [list "idx" "Path" "exe\nCount" "Shadow\nCount" "Executables" "TCL context\nConflicts"] + set ERR [punk::ansi::a+ red bold] + set RST [punk::ansi::a] + set STR [punk::ansi::a+ strike] + set SDW [punk::ansi::a+ red strike] + set WRN [punk::ansi::a+ yellow bold] + set subcols 2 + foreach p $all_paths { + #if {$p ni $matched_paths} { + # incr pidx + # continue + #} + set thisrow [list $pidx] + if {$is_windows} { + set pnorm [string tolower $p] + } else { + set pnorm $p + } + if {[string length $pnorm] > 1} { + set lastchar [string index $pnorm end] + if {$lastchar eq "/" || $lastchar eq "\\"} { + set pnorm [string range $pnorm 0 end-1] + } + } + set pinfo [dict get $d_path_info $pnorm] + set original_paths [dict get $pinfo original_paths] + set indices [dict get $pinfo indices] + if {[lindex $indices 0] == $pidx} { + #this is the first occurrence of this path in the original PATH. + set overshadowed [list] + set conflicts [list] + lappend thisrow $p + if {[dict exists $d_index_executables $pidx]} { + set executables [dict get $d_index_executables $pidx] + lappend thisrow [llength $executables] + set display_executables [list] + foreach exe $executables { + set matched_binglob 0 + if {$is_windows} { + foreach bg $binglobs { + #review - -nocase only on case-insensitive platforms/filesystems? + #todo - mac has case-insensitive filesystem by default. + if {[string match -nocase $bg $exe]} { + set matched_binglob 1 + continue + } + } + } else { + foreach bg $binglobs { + if {[string match $bg $exe]} { + set matched_binglob 1 + continue + } + } + } + if {$is_windows} { + set exe_key [string tolower $exe] + } else { + set exe_key $exe + } + if {[dict exists $d_bin_info $exe_key]} { + set bindata [dict get $d_bin_info $exe_key] + set path_indices [dict get $bindata path_indices] + set is_overshadowed 0 + foreach pi $path_indices { + if {$pi < $pidx} { + lappend overshadowed $exe + set is_overshadowed 1 + break + } + } + if {$matched_binglob} { + if {$is_windows} { + #check for matches in context_commands - which are case-insensitive on windows + #the context_commands are however case sensitive. + #we want to mark conflicts in one of two ways in the conflicts column. + #- if there is a case-insensitive match but not a case-sensitive match + #- then we have a conflict but not an exact match - so we will mark this with orange style. + #If there is an exact match in context_commands - then we will mark this with the red style + #to indicate that this executable is overshadowed by a command in the current context. + + #we may have multiple tcl commands that conflict with the same executable. + #e.g DIG and dig. + if {[llength [set ncmatches [lsearch -all -inline -nocase $context_commands [file rootname $exe]]]]} { + if {[set exactmatch [lsearch -exact $context_commands [file rootname $exe]]] ne ""} { + foreach nc $ncmatches { + set nc [namespace eval $nscaller [list namespace origin $nc]] + if {$nc eq $exactmatch} { + lappend conflicts $ERR$nc$RST + } else { + lappend conflicts "$WRN$nc$RST" + } + } + } else { + foreach nc $ncmatches { + set nc [namespace eval $nscaller [namespace origin $nc]] + lappend conflicts "$WRN$nc$RST" + } + } + } else { + if {[llength [set ncmatches [lsearch -all -inline -nocase $context_commands $exe]]]} { + if {[set exactmatch [lsearch -exact $context_commands $exe]] ne ""} { + foreach nc $ncmatches { + set nc [namespace eval $nscaller [namespace origin $nc]] + if {$nc eq $exactmatch} { + lappend conflicts $ERR$nc$RST + } else { + lappend conflicts "$WRN$nc$RST" + } + } + } else { + foreach nc $ncmatches { + set nc [namespace eval $nscaller [namespace origin $nc]] + lappend conflicts "$WRN$nc$RST" + } + } + } + } + + } else { + #check for any exact matches in context_commands + if {$exe in $context_commands} { + lappend conflicts $ERR$exe$RST + } + } + if {$is_overshadowed} { + lappend display_executables "$SDW$exe$RST" + } else { + lappend display_executables $exe + } + } + } else { + #executable not found in bin_info dict - this shouldn't happen - but if it does we will just treat it as not overshadowed and include it in the display. + lappend display_executables $WRN$exe$RST + } + } + if {[llength $overshadowed]} { + lappend thisrow "$ERR[llength $overshadowed]$RST" + } else { + lappend thisrow "0" + } + if {[llength $display_executables]} { + lappend thisrow [textblock::list_as_table -columns $subcols -show_edge 0 $display_executables] + } else { + lappend thisrow "" + } + if {[llength $conflicts]} { + #lappend thisrow [textblock::list_as_table -columns $subcols -show_edge 0 $conflicts] + lappend thisrow [join $conflicts \n] + } else { + lappend thisrow "" + } + } else { + lappend thisrow "" + lappend thisrow "" + lappend thisrow "" + lappend thisrow "(not a directory or no executables found)" + lappend thisrow "" + } + } else { + #this is a duplicate path entry - we want to show it as a duplicate of the original path entry. + set original_path_idx [lindex $indices 0] + set original_path [lindex [dict get $d_path_info $pnorm original_paths] 0] + #duplicate paths might be cased differently. + lappend thisrow "$ERR$p (repeated pathentry)\n original at index $original_path_idx as\n$original_path$RST" + set overshadowed [list] + set conflicts [list] + set display_executables [list] + if {[dict exists $d_index_executables $original_path_idx]} { + set executables [dict get $d_index_executables $original_path_idx] + lappend thisrow [llength $executables] + foreach exe $executables { + if {$is_windows} { + set exe_key [string tolower $exe] + } else { + set exe_key $exe + } + if {[dict exists $d_bin_info $exe_key]} { + set bindata [dict get $d_bin_info $exe_key] + set path_indices [dict get $bindata path_indices] + set is_overshadowed 0 + foreach pi $path_indices { + if {$pi < $pidx} { + lappend overshadowed $exe + set is_overshadowed 1 + break + } + } + + + + #dupe will always have all exes as overshadowed by the original. + #don't need to waste time and screen space to display duplicate info - the user should tidy up the PATH. + #if {$is_overshadowed} { + # lappend display_executables "$SDW$exe$RST" + #} else { + # lappend display_executables $exe + #} + } + } + } else { + #this shouldn't happen - but if it does we will just treat it as not overshadowed and include it in the display. + lappend thisrow "(not a directory or no executables found)" + } + if {[llength $overshadowed]} { + lappend thisrow "$ERR[llength $overshadowed]$RST" + } else { + lappend thisrow "0" + } + if {[llength $display_executables]} { + lappend thisrow [textblock::list_as_table -columns $subcols -show_edge 0 $display_executables] + } else { + lappend thisrow "" + } + lappend thisrow "" ;#don't show conflict info for duplicate paths - as the user should tidy up the PATH to remove duplicates, and the conflict info will be the same as the original path entry. + } + if {[llength $matched_paths] < [llength $all_paths]} { + #if there is any filtering of paths - then we want to show all these paths whether or not there are any matches for binglobs + if {$p in $matched_paths} { + lappend rows $thisrow + } + } else { + #no specific filtering of paths - so only show rows where there are matches for binglobs + if {[lsearch -exact $binglobs "*"] >= 0} { + lappend rows $thisrow + } else { + #end-1 is the executables column. + #if there are no matches for binglobs then we'll hide the row. + if {[string length [lindex $thisrow end-1]] > 0} { + lappend rows $thisrow + } + } + } + incr pidx + } + set t [textblock::table -return tableobject -rows $rows -headers $headers] + return [$t print] + + } + + #------------------------------------------------------------------- + #sh 'test' equivalent - to be used with exitcode of process + # + + #single evaluation to get exitcode + proc sh_test {args} { + set a1 [lindex $args 0] + if {$a1 in [list -b -c -d -e -f -h -L -s -S -x -w]} { + set a2 [lindex $args 1] + if {![catch { + set attrinfo [file attributes $a2] + } errM]} { + if {[dict exists $attrinfo -vfs] && [dict get $attrinfo -vfs] == 1} { + puts stderr "WARNING: external 'test' being called on vfs path. External command will probably not have access to the vfs. Use 'TEST' for Tcl view of vfs mounted filesystems." + } + } + } + tailcall run test {*}$args + } + + #whether v is an integer from perspective of unix test command. + #can be be bigger than a tcl int or wide ie bignum - but must be whole number + #test doesn't handle 1.0 - so we shouldn't auto-convert + proc is_sh_test_integer {v} { + if {[string first . $v] >=0 || [string first e $v] >= 0} { + return false + } + #if it is double but not sci notation and has no dots - then we can treat as a large integer for 'test' + if {[string is double -strict $v]} { + return true + } else { + return false + } + } + #can use double-evaluation to get true/false + #faster tcl equivalents where possible to accuratley provide, and fallthrough to sh for compatibility of unimplemented + #The problem with fallthrough is that sh/bash etc have a different view of existant files + #e.g unix files such as /dev/null vs windows devices such as CON,PRN + #e.g COM1 is mapped as /dev/ttyS1 in wsl (?) + #Note also - tcl can have vfs mounted file which will appear as a directory to Tcl - but a file to external commands! + #We will stick with the Tcl view of the file system. + #User can use their own direct calls to external utils if + #Note we can't support $? directly in Tcl - script would have to test ${?} or use [set ?] + proc sh_TEST {args} { + upvar ? lasterr + set lasterr 0 + set a1 [lindex $args 0] + set a2 [lindex $args 1] + set a3 [lindex $args 2] + set fileops [list -b -c -d -e -f -h -L -s -S -x -w] + if {[llength $args] == 1} { + #equivalent of -n STRING + set boolresult [expr {[string length $a1] != 0}] + } elseif {[llength $args] == 2} { + if {$a1 in $fileops} { + if {$::tcl_platform(platform) eq "windows"} { + #e.g trailing dot or trailing space + if {[punk::winpath::illegalname_test $a2]} { + #protect with \\?\ to stop windows api from parsing + #will do nothing if already prefixed with \\?\ + + set a2 [punk::winpath::illegalname_fix $a2] + } + } + } + switch -- $a1 { + -b { + #dubious utility on FreeBSD, windows? + #FreeBSD has dropped support for block devices - stating 'No serious applications rely on block devices' + #Linux apparently uses them though + if{[file exists $a2]} { + set boolresult [expr {[file type $a2] eq "blockSpecial"}] + } else { + set boolresult false + } + } + -c { + #e.g on windows CON,NUL + if {[file exists $a2]} { + set boolresult [expr {[file type $a2] eq "characterSpecial"}] + } else { + set boolresult false + } + } + -d { + set boolresult [file isdirectory $a2] + } + -e { + set boolresult [file exists $a2] + } + -f { + #e.g on windows CON,NUL + if {[file exists $a2]} { + set boolresult [expr {[file type $a2] eq "file"}] + } else { + set boolresult false + } + } + -h - + -L { + set boolresult [expr {[file type $a2] eq "link"}] + } + -s { + set boolresult [expr {[file exists $a2] && ([file size $a2] > 0 )}] + } + -S { + if {[file exists $a2]} { + set boolresult [expr {[file type $a2] eq "socket"}] + } else { + set boolresult false + } + } + -x { + set boolresult [expr {[file exists $a2] && [file executable $a2]}] + } + -w { + set boolresult [expr {[file exists $a2] && [file writable $a2]}] + } + -z { + set boolresult [expr {[string length $a2] == 0}] + } + -n { + set boolresult [expr {[string length $a2] != 0}] + } + default { + puts stderr "sh_TEST: delegating 'test $args' to external 'test' command" + #set boolresult [apply {arglist {uplevel #0 [runx test {*}$arglist]} ::} $args] + set callinfo [runx test {*}$args] + set errinfo [dict get $callinfo stderr] + set exitcode [dict get $callinfo exitcode] + if {[string length $errinfo]} { + puts stderr "sh_TEST error in external call to 'test $args': $errinfo" + set lasterr $exitcode + } + if {$exitcode == 0} { + set boolresult true + } else { + set boolresult false + } + } + } + } elseif {[llength $args] == 3} { + switch -- $a2 { + "=" { + #test does string comparisons + set boolresult [string equal $a1 $a3] + } + "!=" { + #string comparison + set boolresult [expr {$a1 ne $a3}] + } + "-eq" { + #test expects a possibly-large integer-like thing + #shell scripts will + if {![is_sh_test_integer $a1]} { + puts stderr "sh_TEST: invalid integer '$a1'" + set lasterr 2 + return false + } + if {![is_sh_test_integer $a3]} { + puts stderr "sh_TEST: invalid integer '$a3'" + set lasterr 2 + return false + } + set boolresult [expr {$a1 == $a3}] + } + "-ge" { + if {![is_sh_test_integer $a1]} { + puts stderr "sh_TEST: invalid integer '$a1'" + set lasterr 2 + return false + } + if {![is_sh_test_integer $a3]} { + puts stderr "sh_TEST: invalid integer '$a3'" + set lasterr 2 + return false + } + set boolresult [expr {$a1 >= $a3}] + } + "-gt" { + if {![is_sh_test_integer $a1]} { + puts stderr "sh_TEST: invalid integer '$a1'" + set lasterr 2 + return false + } + if {![is_sh_test_integer $a3]} { + puts stderr "sh_TEST: invalid integer '$a3'" + set lasterr 2 + return false + } + set boolresult [expr {$a1 > $a3}] + } + "-le" { + if {![is_sh_test_integer $a1]} { + puts stderr "sh_TEST: invalid integer '$a1'" + set lasterr 2 + return false + } + if {![is_sh_test_integer $a3]} { + puts stderr "sh_TEST: invalid integer '$a3'" + set lasterr 2 + return false + } + set boolresult [expr {$a1 <= $a3}] + } + "-lt" { + if {![is_sh_test_integer $a1]} { + puts stderr "sh_TEST: invalid integer '$a1'" + set lasterr 2 + return false + } + if {![is_sh_test_integer $a3]} { + puts stderr "sh_TEST: invalid integer '$a3'" + set lasterr 2 + return false + } + set boolresult [expr {$a1 < $a3}] + } + "-ne" { + if {![is_sh_test_integer $a1]} { + puts stderr "sh_TEST: invalid integer '$a1'" + set lasterr 2 + return false + } + if {![is_sh_test_integer $a3]} { + puts stderr "sh_TEST: invalid integer '$a3'" + set lasterr 2 + return false + } + set boolresult [expr {$a1 != $a3}] + } + default { + puts stderr "sh_TEST: delegating 'test $args' to external 'test' command" + #set boolresult [apply {arglist {uplevel #0 [runx test {*}$arglist]} ::} $args] + set callinfo [runx test {*}$args] + set errinfo [dict get $callinfo stderr] + set exitcode [dict get $callinfo exitcode] + if {[string length $errinfo]} { + puts stderr "sh_TEST error in external call to 'test $args': $errinfo" + set lasterr $exitcode + } + if {$exitcode == 0} { + set boolresult true + } else { + set boolresult false + } + + } + } + } else { + puts stderr "sh_TEST: delegating 'test $args' to external 'test' command" + #set boolresult [apply {arglist {uplevel #0 [runx test {*}$arglist]} ::} $args] + set callinfo [runx test {*}$args] + set errinfo [dict get $callinfo stderr] + set exitcode [dict get $callinfo exitcode] + if {[string length $errinfo]} { + puts stderr "sh_TEST error in external call to 'test $args': $errinfo" + set lasterr $exitcode + } + if {$exitcode == 0} { + set boolresult true + } else { + set boolresult false + } + } + + #normalize 1,0 etc to true,false + #we want to make it obvious we are not just reporting exitcode 0 for example - which represents true in tcl. + if {$boolresult} { + return true + } else { + if {$lasterr == 0} { + set lasterr 1 + } + return false + } + + + } + proc sh_echo {args} { + tailcall run echo {*}$args + } + proc sh_ECHO {args} { + #execute the result of the run command - which is something like: 'exitcode n' - to get true/false + tailcall apply {arglist {uplevel #0 [run echo {*}$arglist]} ::} $args + } + + + #sh style true/false for process exitcode. 0 is true - everything else false + proc exitcode {args} { + set c [lindex $args 0] + if {[string is integer -strict $c]} { + #return [expr {$c == 0}] + #return true/false to make it clearer we are outputting tcl-boolean inverse mapping from the shell style 0=true + if {$c == 0} { + return true + } else { + return false + } + } else { + return false + } + } + #------------------------------------------------------------------- + + namespace export help aliases alias exitcode % pipedata pipecase pipeline pipematch pipeswitch pipeswitchc pipecase linelist linesort inspect list_as_lines val treemore + + #namespace ensemble create + + + + + + + #maint - punk::args has similar + #this is largely obsolete - uses dict for argspecs (defaults) instead of textblock as in punk::args + #textblock has more flexibility in some ways - but not as easy to manipulate especially with regards to substitutions + #todo - consider a simple wrapper for punk::args to allow calling with dict of just name and default? + #JMN + #generally we expect values to contain leading dashes only if -- specified. Otherwise no reliable way determine difference between bad flags and values + #If no eopts (--) specified we stop looking for opts at the first nondash encountered in a position we'd expect a dash - so without eopt, values could contain dashes - but not in first position after flags. + #only supports -flag val pairs, not solo options + #If an option is supplied multiple times - only the last value is used. + #TODO - remove + proc get_leading_opts_and_values {defaults rawargs args} { + if {[llength $defaults] %2 != 0} { + error "get_leading_opts_and_values expected first argument 'defaults' to be a dictionary" + } + dict for {k v} $defaults { + if {![string match -* $k]} { + error "get_leading_opts_and_values problem with supplied defaults. Expect each key to begin with a dash. Got key '$k'" + } + } + #puts "--> [info frame -2] <--" + set cmdinfo [dict get [info frame -2] cmd] + #we can't treat cmdinfo as a list - it may be something like {command {*}$args} in which case lindex $cmdinfo 0 won't work + #hopefully first word is a plain proc name if this function was called in the normal manner - directly from a proc + #we will break at first space and assume the lhs of that will give enough info to be reasonable - (alternatively we could use entire cmdinfo - but it might be big and ugly) + set caller [regexp -inline {\S+} $cmdinfo] + + #if called from commandline or some other contexts such as outside of a proc in a namespace - caller may just be "namespace" + if {$caller eq "namespace"} { + set caller "get_leading_opts_and_values called from namespace" + } + + # ------------------------------ + if {$caller ne "get_leading_opts_and_values"} { + #check our own args + lassign [get_leading_opts_and_values {-anyopts 0 -minvalues 0 -maxvalues -1} $args] _o ownopts _v ownvalues + if {[llength $ownvalues] > 0} { + error "get_leading_opts_and_values expected: a dictionary of defaults, a list of args and at most two option pairs -minvalues and -maxvalues - got extra arguments: '$ownvalues'" + } + set opt_minvalues [dict get $ownopts -minvalues] + set opt_maxvalues [dict get $ownopts -maxvalues] + set opt_anyopts [dict get $ownopts -anyopts] + } else { + #don't check our own args if we called ourself + set opt_minvalues 0 + set opt_maxvalues 0 + set opt_anyopts 0 + } + # ------------------------------ + + if {[set eopts [lsearch $rawargs "--"]] >= 0} { + set values [lrange $rawargs $eopts+1 end] + set arglist [lrange $rawargs 0 $eopts-1] + } else { + if {[lsearch $rawargs -*] >= 0} { + #to support option values with leading dash e.g -offset -1 , we can't just take the last flagindex + set i 0 + foreach {k v} $rawargs { + if {![string match -* $k]} { + break + } + if {$i+1 >= [llength $rawargs]} { + #no value for last flag + error "bad options for $caller. No value supplied for last option $k" + } + incr i 2 + } + set arglist [lrange $rawargs 0 $i-1] + set values [lrange $rawargs $i end] + } else { + set values $rawargs ;#no -flags detected + set arglist [list] + } + } + if {$opt_maxvalues == -1} { + #only check min + if {[llength $values] < $opt_minvalues} { + error "bad number of trailing values for $caller. Got [llength $values] values. Expected at least $opt_minvalues" + } + } else { + if {[llength $values] < $opt_minvalues || [llength $values] > $opt_maxvalues} { + if {$opt_minvalues == $opt_maxvalues} { + error "bad number of trailing values for $caller. Got [llength $values] values. Expected exactly $opt_minvalues" + } else { + error "bad number of trailing values for $caller. Got [llength $values] values. Expected between $opt_minvalues and $opt_maxvalues inclusive" + } + } + } + + if {!$opt_anyopts} { + set checked_args [dict create] + for {set i 0} {$i < [llength $arglist]} {incr i} { + #allow this to error out with message indicating expected flags + dict set checked_args [tcl::prefix match -message "options for $caller. Unexpected option" [dict keys $defaults] [lindex $arglist $i]] [lindex $arglist $i+1] + incr i ;#skip val + } + } else { + set checked_args $arglist + } + set opts [dict merge $defaults $checked_args] + + #maintain order of opts $opts values $values as caller may use lassign. + return [dict create opts $opts values $values] + } + + + + + + + + + + #-------------------------------------------------- + #some haskell-like operations + #group equivalent + #http://zvon.org/other/haskell/Outputlist/group_f.html + #as we can't really distinguish a single element list from a string we will use 2 functions + proc group_list1 {lst} { + set out [list] + set prev [lindex $lst 0] + set g [list] + foreach i $lst { + if {$i eq $prev} { + lappend g $i + } else { + lappend out $g + set g [list $i] + } + set prev $i + } + lappend out $g + return $out + } + proc group_list {lst} { + set out [list] + set next [lindex $lst 1] + set tail [lassign $lst x] + set g [list $x] + set y [lindex $tail 0] + set last_condresult [expr {$x}] + set n 1 ;#start at one instead of zero for lookahead + foreach x $tail { + set y [lindex $tail $n] + set condresult [expr {$x}] + if {$condresult eq $last_condresult} { + lappend g $x + } else { + lappend out $g + set g [list $x] + set last_condresult $condresult + } + incr n + } + lappend out $g + return $out + } + + #NOT attempting to match haskell other than in overall concept. + # + #magic var-names are a bit of a code-smell. But submitting only an expr argument is more Tcl-like than requiring an 'apply' specification. + #Haskell seems to take an entire lambda so varnames can be user-specified - but the 'magic' there is in it's choice of submitting 2 elements at a time + #We could do similar .. but we'll focus on comprehensibility for the basic cases - especially as begginning and end of list issues could be confusing. + # + #vars: index prev, prev0, prev1, item, next, next0, next1,nextr, cond + #(nextr is a bit obscure - but basically means next-repeat ie if no next - use same value. just once though.) + #group by cond result or first 3 wordlike parts of error + #e.g group_list_by {[lindex $item 0]} {{a 1} {a 2} {b 1}} + proc group_list_by {cond lst} { + set out [list] + set prev [list] + set next [lindex $lst 1] + set tail [lassign $lst item] + set g [list $item] + set next [lindex $tail 0] + if {$prev eq ""} { + set prev0 0 + set prev1 1 + set prevr $item + } else { + set prev0 $prev + set prev1 $prev + set prevr $prev + } + if {$next eq ""} { + set next0 0 + set next1 1 + set nextr $item + } else { + set next0 $next + set next1 $next + set nextr $next + } + set last_condresult [apply {{index cond prev prev0 prev1 prevr item next next0 next1 nextr} { + if {[catch {expr $cond} r]} { + puts stderr "index: 0 ERROR $r" + set wordlike_parts [regexp -inline -all {\S+} $r] + set r [list ERROR {*}[lrange $wordlike_parts 0 2]] + } + set r + } + } 0 $cond $prev $prev0 $prev1 $prevr $item $next $next0 $next1 $nextr] + set n 1 ;#start at one instead of zero for lookahead + #note - n also happens to matchi zero-based index of original list + set prev $item + foreach item $tail { + set next [lindex $tail $n] + if {$prev eq ""} { + set prev0 0 + set prev1 1 + set prevr $item + } else { + set prev0 $prev + set prev1 $prev + set prevr $prev + } + if {$next eq ""} { + set next0 0 + set next1 1 + set nextr $item + } else { + set next0 $next + set next1 $next + set nextr $next + } + set condresult [apply {{index cond prev prev0 prev1 prevr item next next0 next1 nextr} { + if {[catch {expr $cond} r]} { + puts stderr "index: $index ERROR $r" + set wordlike_parts [regexp -inline -all {\S+} $r] + set r [list ERROR {*}[lrange $wordlike_parts 0 2]] + } + set r + } + } $n $cond $prev $prev0 $prev1 $prevr $item $next $next0 $next1 $nextr] + if {$condresult eq $last_condresult} { + lappend g $item + } else { + lappend out $g + set g [list $item] + set last_condresult $condresult + } + incr n + set prev $item + } + lappend out $g + return $out + } + + #group_numlist ? preserve representation of numbers rather than use string comparison? + + + # - group_string + #.= punk::group_string "aabcccdefff" + # aa b ccc d e fff + proc group_string {str} { + lmap v [group_list [split $str ""]] {string cat {*}$v} + } + + #lists may be of unequal lengths + proc transpose_lists {list_rows} { + set res {} + #set widest [pipedata $list_rows {lmap v $data {llength $v}} {tcl::mathfunc::max {*}$data}] + set widest [tcl::mathfunc::max {*}[lmap v $list_rows {llength $v}]] + for {set j 0} {$j < $widest} {incr j} { + set newrow {} + foreach oldrow $list_rows { + if {$j >= [llength $oldrow]} { + #continue + lappend newrow "" + } else { + lappend newrow [lindex $oldrow $j] + } + } + lappend res $newrow + } + return $res + } + proc transpose_equal_lists {list_rows} { + set columns [list] + set rowidx -1 + foreach l $list_rows { + set colidx -1 + incr rowidx + foreach val $l { + incr colidx + lset columns $colidx $rowidx $val + } + } + return $columns + } + proc transpose_strings {list_of_strings} { + set charlists [lmap v $list_of_strings {split $v ""}] + set tchars [transpose_lists $charlists] + lmap v $tchars {string cat {*}$v} + } + + package require struct::matrix + #transpose a serialized matrix using the matrix command + #Note that we can have missing row values below and to right + #e.g + #a + #a b + #a + proc transpose_matrix {matrix_rows} { + set mcmd [struct::matrix] + #serialization format: numcols numrows rowlist + set widest [tcl::mathfunc::max {*}[lmap v $matrix_rows {llength $v}]] + $mcmd deserialize [list [llength $matrix_rows] $widest $matrix_rows] + $mcmd transpose + set result [lindex [$mcmd serialize] 2] ;#strip off dimensions + $mcmd destroy + return $result + } + + set objname [namespace current]::matrixchain + if {$objname ni [info commands $objname]} { + oo::class create matrixchain { + variable mcmd + constructor {matrixcommand} { + puts "wrapping $matrixcommand with [self]" + set mcmd $matrixcommand + } + destructor { + puts "matrixchain destructor called for [self] (wrapping $mcmd)" + $mcmd destroy + } + method unknown {args} { + if {[llength $args]} { + switch -- [lindex $args 0] { + add - delete - insert - transpose - sort - set - swap { + $mcmd {*}$args + return [self] ;#result is the wrapper object for further chaining in pipelines + } + default { + tailcall $mcmd {*}$args + } + } + } else { + #will error.. but we should pass that on + tailcall $mcmd + } + } + } + } + + #review + #how do we stop matrix pipelines from leaving commands around? i.e how do we call destroy on the matrixchain wrapper if not explicitly? + #Perhaps will be solved by: Tip 550: Garbage collection for TclOO + #Theoretically this should allow tidy up of objects created within the pipeline automatically + #If the object name is placed in the pipeline variable dict then it should survive across segment apply scripts and only go out of scope at the end. + proc matrix_command_from_rows {matrix_rows} { + set mcmd [struct::matrix] + set widest [tcl::mathfunc::max {*}[lmap v $matrix_rows {llength $v}]] + $mcmd deserialize [list [llength $matrix_rows] $widest $matrix_rows] + #return $mcmd + set wrapper [punk::matrixchain new $mcmd] + } + + #-------------------------------------------------- + + proc list_filter_cond {itemcond listval} { + set filtered_list [list] + set binding {} + if {[info level] == 1} { + #up 1 is global + set get_vars [list ::info vars] + } else { + set get_vars [list ::info locals] + } + set vars [uplevel 1 {*}$get_vars] + set posn [lsearch $vars item] + #set vars [lreplace $vars $posn $posn] + set vars [lreplace $vars[set vars {}] $posn $posn] + foreach v $vars { + upvar 1 $v var + if {(![array exists var]) && [info exists var]} { + lappend binding [list $v $var] ;#values captured as defaults for apply args. + } + } + #lappend binding [list item $args] + + #puts stderr "binding: [join $binding \n]" + #apply [list $binding $pipescript [uplevel 1 ::namespace current]] + foreach item $listval { + set bindlist [list {*}$binding [list item $item]] + if {[apply [list $bindlist $itemcond [uplevel 1 ::tcl::namespace::current]] ]} { + lappend filtered_list $item + } + } + return $filtered_list + } + + + proc ls {args} { + if {![llength $args]} { + set args [list [pwd]] + } + if {[llength $args] ==1} { + return [glob -nocomplain -tails -dir [lindex $args 0] *] + } else { + set result [dict create] + foreach a $args { + set k [file normalize $a] + set contents [glob -nocomplain -tails -dir $a *] + dict set result $k $contents + } + return $result + } + } + + + + #linelistraw is essentially split $text \n so is only really of use for pipelines, where the argument order is more convenient + #like linelist - but keeps leading and trailing empty lines + #single \n produces {} {} + #the result can be joined to reform the arg if a single arg supplied + # + proc linelistraw {args} { + set linelist [list] + foreach {a} $args { + set nlsplit [split $a \n] + lappend linelist {*}$nlsplit + } + #return [split $text \n] + return $linelist + } + proc linelist1 {args} { + set linelist [list] + foreach {a} $args { + set nlsplit [split $a \n] + set start 0 + set end "end" + + if {[lindex $nlsplit 0] eq ""} { + set start 1 + } + if {[lindex $nlsplit end] eq ""} { + set end "end-1" + } + set alist [lrange $nlsplit $start $end] + lappend linelist {*}$alist + } + return $linelist + } + + namespace eval argdoc { + set DYN_ANTIGLOB_PATHS {${[punk::args::resolved_def -types opts ::punk::path::treefilenames -exclude-paths]}} + punk::args::define { + @dynamic + @id -id ::punk::LOC + @cmd -name punk::LOC\ + -summary\ + "Lines Of Code counter"\ + -help\ + "LOC - lines of code. + An implementation of a notoriously controversial metric. + Returns a dict or dictionary-display containing various + counts such as: + 'loc' - total lines of code. + 'purepunctuationlines' - lines consisting soley of punctuation. + 'filecount' - number of files examined." + @opts + -return -default showdict -choices {dict showdict} + -dir -default "\uFFFF" + -no-dupfiles -default 1 -type boolean + -no-punctlines -default 1 -type boolean + ${$DYN_ANTIGLOB_PATHS} + -exclude-files -default "" -type list -help\ + "Exclude if file tail matches any of these patterns" + -show_largest -default 0 -type integer -help\ + "Report the top largest linecount files. + The value represents the number of files + to report on." + } " + #we could map away whitespace and use string is punct - but not as flexible? review + -punctchars -default { [list \{ \} \" \\ - _ + = . > , < ' : \; ` ~ ! @ # \$ % ^ & * \[ \] ( ) | / ?] } + " { + @values + fileglob -type string -default * -optional 1 -multiple 1 -help\ + "glob patterns to match against the filename portion (last segment) of each + file path. e.g *.tcl *.tm" + } + } + #An implementation of a notoriously controversial metric. + proc LOC {args} { + set argd [punk::args::parse $args withid ::punk::LOC] + lassign [dict values $argd] leaders opts values received + set searchspecs [dict get $values fileglob] + + # -- --- --- --- --- --- + set opt_return [dict get $opts -return] + set opt_dir [dict get $opts -dir] + if {$opt_dir eq "\uFFFF"} { + set opt_dir [pwd] ;#pwd can take over a ms on windows in a not terribly deep path even with SSDs - so as a general rule we don't use it in the original defaults list + } + # -- --- --- --- --- --- + set opt_no_dupfiles [dict get $opts -no-dupfiles] + set opt_no_punctlines [dict get $opts -no-punctlines] ;#exclude lines that consist purely of whitespace and the chars in -punctchars + set opt_punctchars [dict get $opts -punctchars] + set opt_largest [dict get $opts -show_largest] + set opt_exclude_paths [dict get $opts -exclude-paths] + set opt_exclude_files [dict get $opts -exclude-files] + # -- --- --- --- --- --- + + + set filepaths [punk::path::treefilenames -dir $opt_dir -exclude-paths $opt_exclude_paths -exclude-files $opt_exclude_files {*}$searchspecs] + set loc 0 + set dupfileloc 0 + set seentails [dict create] + set seencksums [dict create] ;#key is cksum value is list of paths + set largestloc [dict create] + set dupfilecount 0 + set extensions [list] + set purepunctlines 0 + set dupinfo [dict create] + set has_hashfunc [expr {![catch {package require sha1}]}] + set notes "" + if {$has_hashfunc} { + set dupfilemech sha1 + if {$opt_no_punctlines} { + append notes "checksums are on content stripped of whitespace lines,trailing whitespace, and pure punct lines. Does not indicate file contents equal.\n" + } else { + append notes "checksums are on content stripped of whitespace lines and trailing whitespace. Does not indicate file contents equal.\n" + } + } else { + set dupfilemech filetail + append notes "dupfilemech filetail because sha1 not loadable\n" + } + foreach fpath $filepaths { + set isdupfile 0 + set floc 0 + set fpurepunctlines 0 + set ext [file extension $fpath] + if {$ext ni $extensions} { + lappend extensions $ext + } + if {[catch {fcat $fpath} contents]} { + puts stderr "Error processing $fpath\n $contents" + continue + } + set lines [linelist -line {trimright} -block {trimall} $contents] + if {!$opt_no_punctlines} { + set floc [llength $lines] + set comparedlines $lines + } else { + set mapawaypunctuation [list] + foreach p $opt_punctchars empty {} { + lappend mapawaypunctuation $p $empty + } + set comparedlines [list] + foreach ln $lines { + if {[string length [string trim [string map $mapawaypunctuation $ln]]] > 0} { + incr floc + lappend comparedlines $ln + } else { + incr fpurepunctlines + } + } + } + if {$opt_largest > 0} { + dict set largestloc $fpath $floc + } + if {$has_hashfunc} { + set cksum [sha1::sha1 [encoding convertto utf-8 [join $comparedlines \n]]] + if {[dict exists $seencksums $cksum]} { + set isdupfile 1 + incr dupfilecount + incr dupfileloc $floc + dict lappend seencksums $cksum $fpath + } else { + dict set seencksums $cksum [list $fpath] + } + } else { + if {[dict exists $seentails [file tail $fpath]]} { + set isdupfile 1 + incr dupfilecount + incr dupfileloc $floc + } + } + if {!$isdupfile || ($isdupfile && !$opt_no_dupfiles)} { + incr loc $floc + incr purepunctlines $fpurepunctlines + } + + dict lappend seentails [file tail $fpath] $fpath + #lappend seentails [file tail $fpath] + } + if {$has_hashfunc} { + dict for {cksum paths} $seencksums { + if {[llength $paths] > 1} { + dict set dupinfo checksums $cksum $paths + } + } + } + dict for {tail paths} $seentails { + if {[llength $paths] > 1} { + dict set dupinfo sametail $tail $paths + } + } + + set result [dict create {*}[ + ] loc $loc {*}[ + ] filecount [llength $filepaths] {*}[ + ] dupfiles $dupfilecount {*}[ + ] dupfilemech $dupfilemech {*}[ + ] dupfileloc $dupfileloc {*}[ + ] dupinfo $dupinfo {*}[ + ] extensions $extensions {*}[ + # purepunctuationlines key only retained if punctuation lines are excluded from count by opt_no_punctlines + ] purepunctuationlines $purepunctlines {*}[ + ] notes $notes {*}[ + ]] + if {!$opt_no_punctlines} { + dict unset result purepunctuationlines + } + + if {$opt_largest > 0} { + set largest_n [dict create] + set sorted [lsort -stride 2 -index 1 -decreasing -integer $largestloc] + set kidx 0 + for {set i 0} {$i < $opt_largest} {incr i} { + if {$kidx+1 > [llength $sorted]} {break} + dict set largest_n [lindex $sorted $kidx] [lindex $sorted $kidx+1] + incr kidx 2 + } + dict set result largest $largest_n + } + if {$opt_return eq "showdict"} { + return [punk::lib::showdict $result @@dupinfo/*/* !@@dupinfo] + } + return $result + } + + ##dict of lists? + #a + # 1 + # 2 + #b + # 3 + # 4 + # "" + # etc + # d + # D + # "ok then" + + + ##dict of dicts + #a + # x + # 1 + # y + # 2 + #b + # x + # 11 + + ##dict of mixed + #list + # a + # b + # c + #dict + # a + # aa + # b + # bb + #val + # x + #list + # a + # b + + # each line has 1 key or value OR part of 1 key or value. ie <=1 key/val per line! + ##multiline + #key + # "multi + # line value" + # + + #-------------------------------- + #a + # 1 + # 2 + + #vs + + #a + # 1 + # 2 + + #dict of list-len 2 is equiv to dict of dict with one keyval pair + #-------------------------------- + + + + #!!!todo fix - linedict is unfinished and non-functioning + #linedict based on indents + proc linedict {args} { + puts stderr "linedict is experimental and incomplete" + set data [lindex $args 0] + set opts [lrange $args 1 end] ;#todo + set nlsplit [split $data \n] + set rootindent -1 + set stepindent -1 + + + #first do a partial loop through lines and work out the rootindent and stepindent. + #we could do this in the main loop - but we do it here to remove a small bit of logic from the main loop. + #review - if we ever move to streaming a linedict - we'll need to re-arrange to validating indents as we go anyway. + set linenum 0 + set firstkey_line "N/A" + set firstkey_linenum -1 + set firststep_line "N/A" + set firststep_linenum -1 + set indents_seen [dict create] + foreach ln $nlsplit { + incr linenum + if {![string length [string trim $ln]]} { + continue + } + + #todo - use info complete to accept keys/values with newlines + regexp {(\s*)(.*)} $ln _ space linedata + if {[catch {lindex $linedata 0}]} { + error "bad line value '$linedata' - each line must be a valid Tcl list of length 1. Use quotes or curly braces as necessary" + } + if {[llength $linedata] > 1} { + error "bad line value '$linedata' - each line must be a valid Tcl list of length 1. Use quotes or curly braces as necessary" + } + #puts stderr "--linenum:[format %-3s $linenum] line:[format "%-20s" $ln] [format %-4s [string length $space]] $linedata" + set this_indent [string length $space] + if {[dict exists $indents_seen $this_indent]} { + continue + } + if {$rootindent < 0} { + set firstkey_line $ln + set firstkey_linenum $linenum + set rootindent $this_indent + dict set indents_seen $this_indent 1 + } elseif {$stepindent < 0} { + if {$this_indent > $rootindent} { + set firststep_line $ln + set firststep_linenum $linenum + set stepindent [expr {$this_indent - $rootindent}] + dict set indents_seen $this_indent 1 + } elseif {$this_indent < $rootindent} { + error "bad root indentation ($this_indent) at line: $linenum. Smallest indent was set on linenumber: $firstkey_linenum by first key line: $firstkey_line" + } + #if equal - it's just another root key + } else { + #validate all others + if {$this_indent < $rootindent} { + error "bad root indentation ($this_indent) at line: $linenum. Smallest indent was set on linenumber: $firstkey_linenum by first key line: $firstkey_line" + } + if {($this_indent - $rootindent) % $stepindent != 0} { + error "bad indentation ($this_indent) at linenum: $linenum line:'$ln'. this_indent - rootindent ($this_indent - $rootindent == [expr {$this_indent - $rootindent}]) is not a multiple of the first key indent $stepindent seen on linenumber: $firststep_linenum value:'$firststep_line'" + } else { + dict set indents_seen $this_indent 1 + } + } + } + + + #set wordlike_parts [regexp -inline -all {\S+} $lastitem] + set d [dict create] + set keys [list] + set linenum 0 ;#line-numbers 1 based + foreach ln $nlsplit { + incr linenum + if {![string length [string trim $ln]]} { + incr linenum + continue + } + regexp {(\s*)(.*)} $ln _ space linedata + puts stderr ">>linenum:[format %-3s $linenum] line:[format "%-20s " $ln] [format %-4s [string length $space]] $linedata" + set linedata [lindex $linedata 0] + set this_indent [string length $space] + + + if {$this_indent == $rootindent} { + #is rootkey + dict set d $linedata {} + set keys [list $linedata] + } else { + set ispan [expr {$this_indent - $rootindent}] + set numsteps [expr {$ispan / $stepindent}] + #assert - since validated in initial loop - numsteps is always >= 1 + set keydepth [llength $keys] + if {$numsteps > $keydepth + 1} { + #too deep - not tested for in initial loop. ? todo - convert to leading spaces in key/val? + error "bad indentation ($this_indent) at linenum: $linenum line:'$ln'. (too deep) - review" + } + if {$numsteps > ($keydepth - 1)} { + #assert - from above test - must be 1 or 2 deeper + set parentkey [lindex $keys end] + set oldval [dict get $d {*}$parentkey] + if {$numsteps - ($keydepth -1) == 1} { + #1 deeper + if {$oldval ne {}} { + lappend keys [list {*}$parentkey $linedata] + dict unset d {*}$parentkey + #dict set d {*}$parentkey $oldval $linedata + dict set d {*}$parentkey $oldval {} ;#convert to key? + dict set d {*}$parentkey $linedata {} + } else { + dict set d {*}$parentkey $linedata + } + } else { + #2 deeper - only ok if there is an existing val + if {$oldval eq {}} { + error "bad indentation ($this_indent) at linenum: $linenum line:'$ln'. (too deep) - review" + } + puts ">>> 2deep d:'$d' oldval:$oldval linedata:$linedata parentkey:$parentkey" + dict unset d {*}$parentkey + dict set d {*}$parentkey $oldval $linedata + lappend keys [list {*}$parentkey $oldval] + } + } elseif {$numsteps < ($keydepth - 1)} { + set diff [expr {$keydepth - 1 - $numsteps}] + set keys [lrange $keys 0 end-$diff] + #now treat as same level + set parentkey [lindex $keys end-1] + lset keys end end $linedata + dict set d {*}$parentkey $linedata {} + } else { + #same level + set parentkey [lindex $keys end-1] + lset keys end end $linedata + dict set d {*}$parentkey $linedata {} + } + } + #puts ">>keys:$keys" + } + return $d + } + proc dictline {d {indent 2}} { + puts stderr "unimplemented" + set lines [list] + + return $lines + } + + + proc ooinspect {obj} { + set obj [uplevel 1 [list ::tcl::namespace::which -command $obj]] + set isa [lmap type {object class metaclass} { + if {![info object isa $type $obj]} continue + set type + }] + foreach tp $isa { + switch -- $tp { + class { + lappend info {class superclasses} {class mixins} {class filters} + lappend info {class methods} {class methods} + lappend info {class variables} {class variables} + } + object { + lappend info {object class} {object mixins} {object filters} + lappend info {object methods} {object methods} + lappend info {object variables} {object variables} + lappend info {object namespace} {object vars} ;#{object commands} + } + } + } + + set result [dict create isa $isa] + foreach args $info { + dict set result $args [info {*}$args $obj] + foreach opt {-private -all} { + catch { + dict set result [list {*}$args $opt] [info {*}$args $obj $opt] + } + } + } + dict filter $result value {?*} + } + + punk::args::define { + @id -id ::punk::inspect + @cmd -name punk::inspect -help\ + "Function to display values - used pimarily in a punk pipeline. + The raw value arguments (not options) are always returned to pass + forward in the pipeline. + (pipeline data inserted at end of each |...> segment is passed as single item unless + inserted with an expanding insertion specifier such as .=>* ) + e.g1: + .= list a b c |v1,/1-end,/0>\\ + .=>* inspect -label i1 -- |>\\ + .=v1> inspect -label i2 -- |>\\ + string toupper + (3) i1: {a b c} {b c} a + (1) i2: a b c + + - A B C + " + -label -type string -default "" -help\ + "An optional label to help distinguish output when multiple + inspect statements are in a pipeline. This appears after the + bracketed count indicating number of values supplied. + e.g (2) MYLABEL: val1 val2 + The label can include ANSI codes. + e.g + inspect -label [a+ red]mylabel -- val1 val2 val3 + " + -limit -type int -default 20 -help\ + "When multiple values are passed to inspect - limit the number + of elements displayed in -channel output. + + When truncation has occured an elipsis indication (...) will be appended. + e.g + ${[punk::args::helpers::example { + + .= lseq 20 to 50 by 3 |> .=>* inspect -limit 4 -- |> .=>* tcl::mathop::+ + (11) 20 23 26 29... + + - 385 + + }]} + + If the current pipeline data is not a list, the limit is applied to the + number of lines in the pipeline value. + + For no limit - use -limit -1 + " + -channel -type string -default stderr -help\ + "An existing open channel to write to. If value is any of nul, null, /dev/nul + the channel output is disabled. This effectively disables inspect as the args + are simply passed through in the return to continue the pipeline. + " + -showcount -type boolean -default 1 -help\ + "Display a leading indicator in brackets showing the number of arg values present." + -ansi -type integer -default 1 -nocase 1 -choices {0 1 2 VIEW 3 VIEWCODES 4 VIEWSTYLES} -choicelabels { + 0 " Strip ANSI codes from display + of values. The disply output will + still be colourised if -ansibase has + not been set to empty string or + [a+ normal]. The stderr or stdout + channels may also have an ansi colour. + (see 'colour off' or punk::config)" + 1 " Leave value as is" + 2 " Display the ANSI codes and + other control characters inline + with replacement indicators. + e.g esc, newline, space, tab" + VIEW " Alias for 2" + 3 " Display as per 2 but with + colourised ANSI replacement codes." + VIEWCODES " Alias for 3" + 4 " Display ANSI and control + chars in default colour, but + apply the contained ansi to + the text portions so they display + as they would for -ansi 1" + VIEWSTYLE "Alias for 4" + } + -ansibase -type ansistring -default {${[a+ brightgreen]}} -help\ + "Base ansi code(s) that will apply to output written to the chosen -channel. + If there are ansi resets in the displayed values - output will revert to this base. + Does not affect return value." + -- -type none -help\ + "End of options marker. + It is advisable to use this, as data in a pipeline may often begin with -" + + @values -min 0 -max -1 + arg -type string -optional 1 -multiple 1 -help\ + "value to display" + } + #pipeline inspect + #e.g + #= {a z c} |> inspect -label input_dict |> lsort |> {inspect $data} + proc inspect {args} { + set defaults [list -label "" -limit 20 -channel stderr -showcount 1 -ansi 1 -ansibase [a+ brightgreen]] + set flags [list] + set endoptsposn [lsearch $args --] ;#first -- if data expected to contain --, then should always be called with --. e.g inspect -- + if {$endoptsposn >= 0} { + set flags [lrange $args 0 $endoptsposn-1] + set pipeargs [lrange $args $endoptsposn+1 end] + } else { + #no explicit end of opts marker + #last trailing elements of args after taking *known* -tag v pairs is the value to inspect + for {set i 0} {$i < [llength $args]} {incr i} { + set k [lindex $args $i] + if {$k in [dict keys $defaults]} { + lappend flags {*}[lrange $args $i $i+1] + incr i + } else { + #first unrecognised option represents end of flags + break + } + } + set pipeargs [lrange $args $i end] + } + foreach {k v} $flags { + if {$k ni [dict keys $defaults]} { + #error "inspect: unknown option $k. Known options: [dict keys $defaults]. If data contains flaglike elements, consider calling with end-of-opts marker. e.g inspect --" + punk::args::parse $args -errorstyle minimal withid ::punk::inspect + } + } + set opts [dict merge $defaults $flags] + # -- --- --- --- --- + set label [dict get $opts -label] + set channel [dict get $opts -channel] + set showcount [dict get $opts -showcount] + if {[string length $label]} { + set label "${label}: " + } + set limit [dict get $opts -limit] + set opt_ansiraw [dict get $opts -ansi] + set opt_ansi [tcl::prefix::match -error "" [list 0 1 2 3 4 view viewcodes viewstyle] [string tolower $opt_ansiraw]] + switch -- [string tolower $opt_ansi] { + 0 - 1 - 2 - 3 - 4 {} + view {set opt_ansi 2} + viewcodes {set opt_ansi 3} + viewstyle {set opt_ansi 4} + default { + error "inspect -ansi 0|1|2|view|3|viewcodes|4|viewstyle - received -ansi $opt_ansiraw" + } + } + # -- --- --- --- --- + + set more "" + if {[llength $pipeargs] == 1} { + #usual case is data as a single element + set val [lindex $pipeargs 0] + set count 1 + } else { + #but the pipeline segment could have an insertion-pattern ending in * + set val $pipeargs + set count [llength $pipeargs] + } + switch -- [string tolower $channel] { + nul - null - /dev/null { + return $val + } + } + set displayval $val ;#default - may be overridden based on -limit + + if {$count > 1} { + #val is a list + set llen [llength $val] + if {$limit > 0 && ($limit < $llen)} { + set displayval [lrange $val 0 $limit-1] + if {$llen > $limit} { + set more "..." + } + } + } else { + #not a valid tcl list - limit by lines + if {$limit > 0} { + set rawlines [split $val \n] + set llen [llength $rawlines] + set displaylines [lrange $rawlines 0 $limit-1] + set displayval [join $displaylines "\n"] + if {$llen > $limit} { + set more "\n..." + } + } + + } + if {$showcount} { + set displaycount "[a purple bold]($count)[a] " + #if {$showcount} { + # set countspace [expr {[string length $count] + 3}] ;#lhs margin size of count number plus brackets and one space + # set margin [string repeat " " $countspace] + # set displayval [string map [list \r "" \n "\n$margin"] $displayval] + #} + } else { + set displaycount "" + } + + set ansibase [dict get $opts -ansibase] + if {$ansibase ne ""} { + #-ansibase default is hardcoded into punk::args definition + #run a test using any ansi code to see if colour is still enabled + if {[a+ red] eq ""} { + set ansibase "" ;#colour seems to be disabled + } + } + + switch -- $opt_ansi { + 0 { + set displayval $ansibase[punk::ansi::ansistrip $displayval] + } + 1 { + #val may have ansi - including resets. Pass through ansibase_lines to + if {$ansibase ne ""} { + #set displayval [::textblock::ansibase_lines $displayval $ansibase] + set displayval [punk::ansi::ansiwrap_raw $ansibase "" "" $displayval] + } + } + 2 { + set displayval $ansibase[ansistring VIEW $displayval] + if {$ansibase ne ""} { + #set displayval [::textblock::ansibase_lines $displayval $ansibase] + set displayval [punk::ansi::ansiwrap_raw $ansibase "" "" $displayval] + } + } + 3 { + set displayval $ansibase[ansistring VIEWCODE $displayval] + if {$ansibase ne ""} { + #set displayval [::textblock::ansibase_lines $displayval $ansibase] + set displayval [punk::ansi::ansiwrap_raw $ansibase "" "" $displayval] + } + } + 4 { + set displayval $ansibase[ansistring VIEWSTYLE $displayval] + if {$ansibase ne ""} { + #set displayval [::textblock::ansibase_lines $displayval $ansibase] + set displayval [punk::ansi::ansiwrap_raw $ansibase "" "" $displayval] + } + } + } + + if {![string length $more]} { + #puts $channel "$displaycount$label$displayval[a]" + set chunk [textblock::join -- $displaycount$label " " $displayval[a]] + } else { + #puts $channel "$displaycount$label$displayval[a yellow bold]$more[a]" + set chunk [textblock::join -- $displaycount$label " " "$displayval[a yellow bold]$more[a]"] + } + puts $channel $chunk + return $val + } + + + + proc help {args} { + set chunks [uplevel 1 [list ::punk::help_chunks {*}$args]] + foreach chunk $chunks { + lassign $chunk chan text + puts -nonewline $chan $text + } + puts -nonewline stdout \n + } + #return list of {chan chunk} elements + + namespace eval argdoc { + punk::args::define { + @id -id ::punk::help_chunks + @cmd -name "punk::help_chunks"\ + -summary\ + ""\ + -help\ + "" + @opts + -- -type none + @values -min 0 -max -1 + arg -type any -optional 1 -multiple 1 + } + } + proc help_chunks {args} { + set argd [punk::args::parse $args withid ::punk::help_chunks] + lassign [dict values $argd] leaders opts values received + if {[dict exists $values arg]} { + set topicparts [dict get $values arg] + } else { + set topicparts [list ""] + } + #set topic [lindex $args end] + #set argopts [lrange $args 0 end-1] + + + set chunks [list] + set linesep [string repeat - 76] + + set warningblock "" + + set I [punk::ansi::a+ italic] + set NI [punk::ansi::a+ noitalic] + + set sizedict [punk::console::get_size] + set cols [dict get $sizedict columns] + set rows [dict get $sizedict rows] + + + + #todo - provide a mechanism to configure the default frametype everywhere and describe it in this help. + + set frametype ascii ;#conservative default. + #if the test char width fails - it's likely we're on a very old terminal that doesn't support unicode at all. + if {![catch {punk::console::test_char_width \u00e9} testcharwidth]} { + if {$cols <= 80} { + # Be conservative with frame types on narrow terminals for help. + # an 80x30 terminal is more likely to be an older style terminal and may not have unicode support. + # unicode on a non-unicode terminal is a bad experience - with the frame chars showing as garbage (e.g 3 chars per grapheme). + set frametype ascii + } else { + if {$testcharwidth == 1} { + set frametype light ;#unicode box-drawing chars. + } + } + } + + + # ------------------------------------------------------- + set logoblock "" + if {[catch { + package require patternpunk + #lappend chunks [list stderr [>punk . rhs]] + append logoblock [textblock::frame -type $frametype -title "Punk Shell [package provide punk]" -width 29 -checkargs 0 [>punk . banner -title "" -left Tcl -right [package provide Tcl]]] + }]} { + append logoblock [textblock::frame -type $frametype -title "Punk Shell [package provide punk]" -subtitle "TCL [package provide Tcl]" -width 29 -height 10 -checkargs 0 ""] + } + set title "[a+ brightgreen] Help System: " + set cmdinfo [list] + lappend cmdinfo [list help "?${I}topic${NI}?" "This help.\nTo see available subitems type:\nhelp topics\n\nFor an unrecognised ${I}topic${NI}\nhelp will look for basic\ninfo for it as a command.\n"] + set t [textblock::class::table new -minwidth 51 -show_seps 0] + $t configure -frametype $frametype + foreach row $cmdinfo { + $t add_row $row + } + set width_0 [$t column_datawidth 0] + $t configure_column 0 -minwidth [expr {$width_0 + 2}] + set width_1 [$t column_datawidth 1] + $t configure_column 1 -minwidth [expr {$width_1 + 1}] + $t configure -title $title + set text [$t print] + + set introblock [textblock::join -- $logoblock $text] + + lappend chunks [list stdout $introblock\n] + # ------------------------------------------------------- + + switch -- [lindex $topicparts 0] { + "" { + + # ------------------------------------------------------- + set title "[a+ brightgreen] Filesystem navigation: " + set cmdinfo [list] + lappend cmdinfo [list ./ "?${I}glob${NI}?" "view/change dir, list dirs."] + lappend cmdinfo [list .// "?${I}glob${NI}?" "view/change dir, list dirs and files"] + lappend cmdinfo [list ../ "?${I}path${NI}" "go up one dir, then to path if given"] + lappend cmdinfo [list newdir "${I}subdir${NI}..." "make new dir or dirs and show status"] + lappend cmdinfo [list fcat "${I}file ?file?...${NI}" "cat file(s)"] + set t [textblock::class::table new -minwidth 80 -show_seps 0] + $t configure -frametype $frametype + foreach row $cmdinfo { + $t add_row $row + } + set width_0 [$t column_datawidth 0] + $t configure_column 0 -minwidth [expr {$width_0 + 2}] + set width_1 [$t column_datawidth 1] + $t configure_column 1 -minwidth [expr {$width_1 + 1}] + $t configure -title $title + + set text "" + append text [$t print] + lappend chunks [list stdout $text\n] + # ------------------------------------------------------- + + + # ------------------------------------------------------- + set title "[a+ brightgreen] Namespace navigation: " + set cmdinfo [list] + lappend cmdinfo [list n/ "?${I}ns${NI}|${I}glob${NI}?" "view/change namespace\n (accepts ns path globs e.g **::*get* to match\n commands at any level )"] + lappend cmdinfo [list n// "?${I}ns${NI}|${I}glob${NI}?" "view/change namespace (with command listing)"] + lappend cmdinfo [list "nn/" "" "go up one namespace"] + lappend cmdinfo [list "newns" "${I}ns${NI}" "make child namespace and switch to it"] + set t [textblock::class::table new -minwidth 80 -show_seps 0] + $t configure -frametype $frametype + foreach row $cmdinfo { + $t add_row $row + } + set width_0 [$t column_datawidth 0] + $t configure_column 0 -minwidth [expr {$width_0 + 2}] + set width_1 [$t column_datawidth 1] + $t configure_column 1 -minwidth [expr {$width_1 + 1}] + $t configure -title $title + + set text "" + append text [$t print] + lappend chunks [list stdout $text\n] + # ------------------------------------------------------- + + # ------------------------------------------------------- + set title "[a+ brightgreen] Command help: " + set cmdinfo [list] + lappend cmdinfo [list i "${I}cmd${NI} ?${I}subcommand${NI}...?" "Show usage for a command or ensemble subcommand"] + lappend cmdinfo [list s "${I}cmd${NI} ?${I}subcommand${NI}...?" "Show synopsis for a command or ensemble subcommand"] + lappend cmdinfo [list eg "${I}cmd${NI} ?${I}subcommand${NI}...?" "Show example from manpage"] + lappend cmdinfo [list corp "${I}proc${NI}" "View proc body and arguments with basic highlighting"] + set t [textblock::class::table new -minwidth 80 -show_seps 0] + $t configure -frametype $frametype + foreach row $cmdinfo { + $t add_row $row + } + set width_0 [$t column_datawidth 0] + $t configure_column 0 -minwidth [expr {$width_0 + 2}] + set width_1 [$t column_datawidth 1] + $t configure_column 1 -minwidth [expr {$width_1 + 1}] + $t configure -title $title + + set text "" + append text [$t print] + lappend chunks [list stdout $text\n] + # ------------------------------------------------------- + + + set title "[a+ brightgreen] Miscellaneous: " + #todo - load from source code annotation? + set cmdinfo [list] + lappend cmdinfo [list dev "?${I}subcommand${NI}?" "(ensemble command to make new projects/modules and\n to generate docs)"] + lappend cmdinfo [list a? "?${I}subcommand${NI}...?" "view ANSI colours\n e.g a? web\n or individual code samples/diagnostics\n e.g a? red bold\n e.g a? underline web-orange Term-purple3"] + lappend cmdinfo [list a+ "?${I}colourcode${NI}...?" "Return ANSI codes\n e.g puts \"\[a+ purple\]purple\[a+ Green\]purple on green\[a\]\"\n [a+ purple]purple[a+ Green]purple on green[a] "] + lappend cmdinfo [list a "?${I}colourcode${NI}...?" "Return ANSI codes (with leading reset)\n e.g puts \"\[a+ purple\]purple\[a Green\]normal on green\[a\]\"\n [a+ purple]purple[a Green]normal on green[a] "] + + set t [textblock::class::table new -minwidth 80 -show_seps 0] + $t configure -frametype $frametype + foreach row $cmdinfo { + $t add_row $row + } + set width_0 [$t column_datawidth 0] + $t configure_column 0 -minwidth [expr {$width_0 + 2}] + set width_1 [$t column_datawidth 1] + $t configure_column 1 -minwidth [expr {$width_1 + 1}] + $t configure -title $title + + set text "" + append text [$t print] + lappend chunks [list stdout $text] + # ------------------------------------------------------- + + } + tcl { + set text "Tcl Patchlevel: [info patchlevel]" + catch { + append text \n "Tcl build-info: [::tcl::build-info]" + } + #generate warningblocks for each triggered Tcl bug in namespace ::punk::lib::check + set bugcheck_procs [info procs ::punk::lib::check::has_tclbug*] + foreach bp $bugcheck_procs { + set buginfo [$bp] + if {[dict get $buginfo bug]} { + set level unknown + if {[dict exists $buginfo level]} { + set level [dict get $buginfo level] + } + switch -- $level { + minor {set highlight [punk::ansi::a+ cyan]} + medium {set highlight [punk::ansi::a+ yellow]} + major {set highlight [punk::ansi::a+ red bold]} + default {set highlight ""} + } + append warningblock \n $highlight "warning level: $level $bp triggered." + if {[dict exists $buginfo description]} { + set indent " " + append warningblock \n "[punk::lib::indent [dict get $buginfo description] $indent]" + } + if {[dict exists $buginfo bugref] && [dict get $buginfo bugref] ne ""} { + set bugref [dict get $buginfo bugref] + append warningblock \n "${indent}see [punk::ansi::hyperlink https://core.tcl-lang.org/tcl/tktview/$bugref]" + } + append warningblock [a] + } + } + + if {[catch {lsearch -stride 2 {a b} b}]} { + #has_tclbug_lsearch_strideallinline will have reported bug false because it couldn't test it. + set indent " " + append warningblock \n "[a+ web-red]warning: lsearch does not seem to support -stride option" \n + append warningblock "${indent}(Consider upgrading to a late release of tcl 8.6 or tcl 9+ )" \n + append warningblock [a] + } + lappend chunks [list stdout $text] + } + env - environment { + set text "" + #todo - move to punk::config? + upvar ::punk::config::punk_env_vars_config punkenv_config + upvar ::punk::config::other_env_vars_config otherenv_config + + set known_punk [dict keys $punkenv_config] + set known_other [dict keys $otherenv_config] + append text \n + set usetable 1 + if {$usetable} { + set t [textblock::class::table new -show_hseps 0 -show_header 1 -ansiborder_header [a+ web-green]] + $t configure -frametype $frametype + if {"windows" eq $::tcl_platform(platform)} { + #If any env vars have been set to empty string - this is considered a deletion of the variable on windows. + #The Tcl ::env array is linked to the underlying process view of the environment + #- but info exists ::env(var) can misreport as true if it has been deleted by setting to empty string rather than using unset. + #an 'array get' will resynchronise. + #Even if an env variable didn't exist before - setting it to empty string can get it to this inconsistent state. + array get ::env + } + #do an array read on ::env + foreach {v vinfo} $punkenv_config { + if {[info exists ::env($v)]} { + set c2 [set ::env($v)] + } else { + set c2 "(NOT SET)" + } + set help "" + if {[dict exists $vinfo help]} { + set help [dict get $vinfo help] + } + $t add_row [list $v $c2 $help] + } + $t configure_column 0 -headers [list "Punk environment vars"] + $t configure_column 0 -minwidth [expr {[$t column_datawidth 0]+4}] -blockalign left -textalign left -header_colspans {any} + + set punktable [$t print] + $t destroy + + set t [textblock::class::table new -show_hseps 0 -show_header 1 -ansiborder_header [a+ web-green]] + $t configure -frametype $frametype + foreach {v vinfo} $otherenv_config { + if {[info exists ::env($v)]} { + set env_val [set ::env($v)] + if {[string match "*_TM_PATH" $v]} { + set entries [split $env_val $::tcl_platform(pathSeparator)] + set c2 [join $entries \n] + } else { + set c2 $::env($v) + } + } else { + set c2 "(NOT SET)" + } + $t add_row [list $v $c2] + } + $t configure_column 0 -headers [list "Other environment vars"] + $t configure_column 0 -minwidth [expr {[$t column_datawidth 0]+4}] -blockalign left -textalign left -header_colspans {any} + + set othertable [$t print] + $t destroy + #append text [textblock::join -- $punktable " " $othertable]\n + append text $punktable\n$othertable\n + } else { + + append text $linesep\n + append text "punk environment vars:\n" + append text $linesep\n + set col1 [string repeat " " 25] + set col2 [string repeat " " 50] + foreach v $known_punk { + set c1 [overtype::left $col1 $v] + if {[info exists ::env($v)]} { + set c2 [overtype::left $col2 [set ::env($v)]] + } else { + set c2 [overtype::right $col2 "(NOT SET)"] + } + append text "$c1 $c2\n" + } + append text $linesep\n + } + + lappend chunks [list stdout $text] + } + console - term - terminal { + set term_env_vars {TERM TERM_PROGRAM TERM_PROGRAM_VERSION COLORTERM} + set term_dict [dict create] + foreach e $term_env_vars { + if {[info exists ::env($e)]} { + dict set term_dict $e [set ::env($e)] + } else { + dict set term_dict $e "(NOT SET)" + } + } + set text "Terminal environment variables:\n" + append text [punk::lib::showdict $term_dict] \n + lappend chunks [list stdout $text] + set text "" + set indent [string repeat " " [string length "WARNING: "]] + + if {[catch {package require punk::console} result]} { + set text "Unable to load punk::console package - cannot test\n$result" + lappend chunks [list stdout $text] + } else { + + if {![catch {punk::console::class_info} console_class_info]} { + set text "Terminal class info (from device secondary attributes query to terminal):\n" + append text [punk::lib::showdict $console_class_info] \n + } else { + set text "Unable to query terminal class info - err:$console_class_info\n" + } + lappend chunks [list stdout $text] + + lappend cstring_tests [dict create {*}{ + type "PM " + msg "UN" + f7 punk::ansi::controlstring_PM + f7prefix "7bit ESC ^ secret " + f7suffix "safe" + f8 punk::ansi::controlstring_PM8 + f8prefix "8bit \\x9e secret " + f8suffix "safe" + }] + lappend cstring_tests [dict create {*}{ + type SOS + msg "NOT" + f7 punk::ansi::controlstring_SOS + f7prefix "7bit ESC X string " + f7suffix " hidden" + f8 punk::ansi::controlstring_SOS8 + f8prefix "8bit \\x98 string " + f8suffix " hidden" + }] + lappend cstring_tests [dict create {*}{ + type APC + msg "NOT" + f7 punk::ansi::controlstring_APC + f7prefix "7bit ESC _ APPLICATION PROGRAM COMMAND " + f7suffix " hidden" + f8 punk::ansi::controlstring_APC8 + f8prefix "8bit \\x9f APPLICATION PROGRAM COMMAND " + f8suffix " hidden" + }] + + foreach test $cstring_tests { + set m [[dict get $test f7] [dict get $test msg]] + set hidden_width_m [punk::console::test_char_width $m] + set m8 [[dict get $test f8] [dict get $test msg]] + set hidden_width_m8 [punk::console::test_char_width $m8] + if {$hidden_width_m != 0 || $hidden_width_m8 != 0} { + if {$hidden_width_m == 0} { + set d "[a+ green bold][dict get $test f7prefix][a red]${m}[a][a+ green bold][dict get $test f7suffix][a]" + } else { + set d "[a+ yellow bold][dict get $test f7prefix][a red]$m[a][a+ yellow bold][dict get $test f7suffix][a]" + } + if {$hidden_width_m8 == 0} { + set d8 "[a+ green ][dict get $test f8prefix][a red]$m8[a][a+ green][dict get $test f8suffix][a]" + } else { + set d8 "[a+ yellow bold][dict get $test f8prefix][a red]$m8[a][a+ yellow bold][dict get $test f8suffix][a]" + } + append warningblock \n "WARNING: terminal doesn't hide all [dict get $test type] control strings: $d $d8" + } + } + if {![catch {punk::console::check::has_bug_legacysymbolwidth} result]} { + if {$result} { + append warningblock \n "WARNING: terminal has legacysymbolwidth bug - screen position for symbol reports 2 wide but displays 1 wide." + append warningblock \n $indent "Layout using 'legacy symbols for computing' affected." + append warningblock \n $indent "(e.g textblock frametype block2 unsupported)" + append warningblock \n $indent "This can cause extreme layout deformation when ANSI is present" + append warningblock \n $indent "In some cases unwanted spacing effects occur at a distance from the characters causing it" + } + } else { + append warningblock \n "WARNING: terminal unable to check for legacysymbolwidth bug. err:$result" + } + + if {![catch {punk::console::check::has_bug_zwsp} result]} { + if {$result} { + append warningblock \n "WARNING: terminal has zero width space (\\u200b) bug - cursor position incremented when it shouldn't be." + append warningblock \n $indent "The zwsp may or may not be displayed. zwsp contributes to line length and wrapping point" + } + } else { + append warningblock \n "WARNING: terminal unable to check for zwsp bug. err:$result" + } + + + set grapheme_support [punk::console::grapheme_cluster_support] + #mode, 1 = set, 2 = unset. (0 = mode not recognised, 3 = permanently set, 4 = permanently unset) + if {![dict size $grapheme_support] || [dict get $grapheme_support mode] eq "unsupported" } { + append warningblock \n "WARNING: terminal either doesn't support grapheme clusters, or doesn't report so via decmode 2027 query." + if {[dict size $grapheme_support] && [dict get $grapheme_support available]} { + append warningblock \n $indent "(but punk::console::grapheme_cluster_support has determined it is probably available)" + } + } else { + if {![dict get $grapheme_support available]} { + switch -- [dict get $grapheme_support mode] { + "unset" { + append warningblock \n "WARNING: terminal reports via decmode 2027 that grapheme cluster support is off." + } + "permanently_unset" { + append warningblock \n "WARNING: terminal reports via decmode 2027 that grapheme cluster support is permanently off." + } + "BAD_RESPONSE" { + append warningblock \n "WARNING: terminal doesn't seem to recognize decmode 2027 query. No grapheme cluster support." + } + } + } + } + set posn [punk::console::get_cursor_pos] ;#warmup call - and test if works + if {$posn eq ""} { + append warningblock \n "WARNING: terminal doesn't respond to cursor position query - may cause display bugs in some cases." + } else { + set timeresult [timerate {set cpos [punk::console::get_cursor_pos]}] + lassign [split $cpos {;}] row col + if {![string is integer -strict $row] || ![string is integer -strict $col]} { + append warningblock \n "WARNING: terminal returns non-integer values for cursor position query - may cause display bugs in some cases. got row:'$row' col:'$col'" + } else { + set micros [lindex $timeresult 0] + if {$micros > 2000} { + append warningblock \n "WARNING: terminal cursor position query is very slow ($micros microseconds - expect < 2000us )" + append warningblock \n $indent "- may cause display lag/bugs in some cases." + } else { + if {$micros > 1000} { + set text "\n[a+ yellow]Terminal cursor position query test passed." + append text \n $indent "Response time: ${micros} microseconds (OK, good would be <= 1000us).[a]" + + } else { + set text "[a+ green]Terminal cursor position query test passed." + append text \n $indent "Response time: ${micros} microseconds (GOOD).[a]" + } + lappend chunks [list stdout $text] + } + } + } + + + if {![string length $warningblock]} { + set text "[a+ green]No terminal warnings[a]\n" + lappend chunks [list stdout $text] + } else { + set mode [punk::console::mode] + if {$mode eq "line"} { + append warningblock \n "Terminal appears to be in line mode. Consider switching to raw mode and re-testing (command: punk::console::mode raw)." + } + } + puts stdout [punk::ansi::move_back 200] ;#hack for some horizontal position bugs where the above tests can leave the cursor in the wrong place for the next output. + #200 is arbitrary large number to move back enough to get to start of line. + } + } + topics - help { + set text "" + set topics [dict create {*}{ + "topics|help" "List help topics" + "tcl" "Tcl version warnings" + "env|environment" "punkshell environment vars" + "console|terminal" "Some console behaviour tests and warnings" + "*" "Try to find help on the topic as a command or external executable" + }] + + set t [textblock::class::table new -show_seps 0] + $t configure -frametype $frametype + $t add_column -headers [list "Topic"] + $t add_column + foreach {k v} $topics { + $t add_row [list $k $v] + } + set widest0 [$t column_datawidth 0] + $t configure_column 0 -minwidth [expr {$widest0 + 4}] + append text \n [$t print] + + lappend chunks [list stdout $text] + } + default { + set text "" + set cinfo [uplevel 1 [list ::punk::ns::cmdwhich [lindex $topicparts 0]]] + set wtype [dict get $cinfo whichtype] + if {$wtype eq "notfound"} { + set externalinfo [auto_execok [lindex $topicparts 0]] + if {[string length $externalinfo]} { + set text "$topicparts" + append text \n "Base type: External command" + append text \n "$externalinfo [lrange $topicparts 1 end]" + } else { + set text "$topicparts\n" + append text "No matching internal or external command found" + } + } else { + set text "[dict get $cinfo which] [lrange $topicparts 1 end]" + append text \n "Base type: $wtype" + set synopsis [uplevel 1 [list ::punk::ns::synopsis {*}$topicparts]] + set synshow "" + foreach sline [split $synopsis \n] { + if {[regexp {\s*#.*} $sline]} { + append synshow [punk::ansi::a+ bold term-darkgreen Term-white]$sline[punk::ansi::a] \n + } else { + append synshow $sline \n + } + } + if {[string index $synshow end] eq "\n"} { + set synshow [string range $synshow 0 end-1] + } + append text \n $synshow + } + lappend chunks [list stdout $text] + } + } + + + lappend chunks [list stderr $warningblock] + return $chunks + } + proc mode {{raw_or_line query}} { + package require punk::console + tailcall ::punk::console::mode $raw_or_line + } + + #this hides windows cmd's mode command - probably no big deal - anyone who needs it will know how to exec it. + interp alias {} mode {} punk::mode + + + + #proc aliases {{glob *}} { + # tailcall punk::ns::aliases $glob + #} + + ##review + #proc alias {{aliasorglob ""} args} { + # tailcall punk::ns::alias $aliasorglob {*}$args + #} + + + #pipeline-toys - put in lib/scriptlib? + ##geometric mean + #alias gmean .=> llength |> expr 1.0 / |e> .=i>* tcl::mathop::* |> .=>1,e>3 expr ** {::tcl::tm::add {*}$data; set path} |> inspect -label added_to_module_path <0/#| + + + + + + #todo - review + #interp alias {} clear {} ::punk::reset + #interp alias {} c {} ::punk::reset + + interp alias {} reset {} ::punk::reset + proc reset {} { + if {[llength [info commands ::punk::repl::reset_terminal]]} { + #punk::repl::reset_terminal notifies prompt system of reset + punk::repl::reset_terminal + } else { + puts -nonewline stdout [punk::ansi::reset] + } + } + + namespace eval argdoc { + punk::args::define { + @id -id ::punk::ansi8 + @cmd -name punk::ansi8\ + -summary\ + "Tell terminal to enable 8-bit ANSI codes."\ + -help\ + "Enable 8-bit ANSI codes in the terminal. + May not be supported by all terminals. + Some terminals may already have 8-bit ANSI enabled, but some may require an explicit command to enable it. + 7-bit ANSI codes are generally preferred - and will still work on terminals with 8-bit ANSI support. + + (This is nothing to do with 8-bit colors - it is about the underlying bytes used for ANSI control sequences). + The ANSI sequence sent to the terminal to enable 8-bit codes is: ESC 7 + + To disable 8-bit ANSI support - a reset of the terminal may be required. + " + @opts + @values -min 0 -max 0 + } + } + proc ansi8 {} { + punk::console::S8C1R + } + namespace eval argdoc { + punk::args::define { + @id -id ::punk::clear + @cmd -name punk::clear\ + -summary\ + "Clear the terminal screen (and scrollback buffer by default)."\ + -help\ + "Clear the terminal screen. + By default this will also clear scrollback if supported by the terminal. + With -x option it will preserve scrollback but clear the screen. + " + @opts + -x -optional 1 -type none -mash 1 -help\ + "Preserve scrollback (if supported by terminal) but clear screen." + -s -optional 1 -type none -mash 1 -help\ + "Stay at the current cursor position instead of moving to top-left after clearing." + @values -min 0 -max 0 + } + } + proc clear {args} { + set argd [punk::args::parse $args withid ::punk::clear] + lassign [dict values $argd] leaders opts values received + set opt_x [dict exists $received -x] + set opt_s [dict exists $received -s] + # -x preserves scrollback but clears screen + if {$opt_s} { + #set pre_move_cmd [punk::ansi::move_up 1] + #review - terminal support for save/restore. + #we can just move up one line before clearing to preserve the line we're on, + #but this won't work if we're already at the last line. + #save/restore would be better if widely supported. + + #review - get_size already calls get_cursor pos - maybe we can optimize by not calling get_cursor_pos separately? + #review - consider turning off cursor updating while doing this to avoid flicker? + set cpos [punk::console::get_cursor_pos] + set row [lindex $cpos 0] + set size [punk::console::get_size] + set lastrow [dict get $size rows] + if {$row >= $lastrow} { + set pre_move_cmd [punk::ansi::cursor_save_dec] + } else { + set pre_move_cmd [punk::ansi::move_up 1][punk::ansi::cursor_save_dec] + } + set move_cmd [punk::ansi::cursor_restore_dec] + + #set pre_move_cmd [punk::ansi::move_up 1] + #set move_cmd "" + + } else { + set pre_move_cmd "" + set move_cmd [punk::ansi::move 1 1] + } + if {$opt_x} { + puts -nonewline stdout $pre_move_cmd[punk::ansi::clear]$move_cmd + } else { + puts -nonewline stdout $pre_move_cmd[punk::ansi::clear_all]$move_cmd + } + } + #c aliased to clear -xs + #cc aliases to clear -x + + + + #fileutil::cat except with checking for windows illegal path names (when on windows platform) + interp alias {} fcat {} punk::mix::util::fcat + + #---------------------------------------------- + interp alias {} linelistraw {} punk::linelistraw + + # 'path' collides with kettle path in kettle::doc function - todo - patch kettle? + interp alias {} PATH {} punk::path + + interp alias {} path_list {} punk::path_list + interp alias {} list_filter_cond {} punk::list_filter_cond + + + interp alias {} inspect {} punk::inspect + interp alias {} ooinspect {} punk::ooinspect + + interp alias {} linedict {} punk::linedict + interp alias {} dictline {} punk::dictline + + #todo - pipepure - evaluate pipeline in a slave interp without commands that have side-effects. (safe interp?) + interp alias {} % {} punk::% + interp alias {} pipeswitch {} punk::pipeswitch + interp alias {} pipeswitchc {} punk::pipeswitchc ;#closure version - more correct + interp alias {} pipecase {} punk::pipecase + interp alias {} pipematch {} punk::pipematch + interp alias {} ispipematch {} punk::ispipematch + interp alias {} pipenomatchvar {} punk::pipenomatchvar + interp alias {} pipedata {} punk::pipedata + interp alias {} pipeset {} punk::pipeset + interp alias {} pipealias {} punk::pipealias + interp alias {} listset {} punk::listset ;#identical to pipeset + + + #non-core aliases + interp alias {} is_list_all_in_list {} punk::lib::is_list_all_in_list + interp alias {} is_list_all_ni_list {} punk::libis_list_all_ni_list + + + + #interp alias {} = {} ::punk::pipeline = "" "" + #interp alias {} = {} ::punk::match_assign "" "" + interp alias {} .= {} ::punk::pipeline .= "" "" + #proc .= {args} { + # #uplevel 1 [list ::punk::pipeline .= "" "" {*}$args] + # tailcall ::punk::pipeline .= "" "" {*}$args + #} + + + interp alias {} rep {} ::tcl::unsupported::representation + interp alias {} dis {} ::tcl::unsupported::disassemble + + + + # ls aliases - note that tcl doesn't exand * but sh_xxx functions pass to sh -c allowing shell expansion + interp alias {} l {} sh_runout -n ls -A ;#plain text listing + #interp alias {} ls {} sh_runout -n ls -AF --color=always + interp alias {} ls {} shellrun::runconsole ls -AF --color=always ;#use unknown to use terminal and allow | more | less + #note that shell globbing with * won't work on unix systems when using unknown/exec + interp alias {} lw {} sh_runout -n ls -AFC --color=always ;#wide listing (use A becaus no extra info on . & ..) + interp alias {} ll {} sh_runout -n ls -laFo --color=always ;#use a instead of A to see perms/owner of . & .. + # -v for natural number sorting not supported on freeBSD. Todo - test at startup and modify aliases? + #interp alias {} lw {} ls -aFv --color=always + + interp alias {} dir {} shellrun::runconsole dir + + # punk::nav::fs + package require punk::nav::fs + package require punk::nav::ns + + + + variable pshell_path "" + # ---------------------------------------- + set pshell_path [auto_execok pwsh] ;#Still not installed by default on win10 11? + if {$pshell_path eq ""} { + #fallback to powershell 5 + #set pshell_path [auto_execok powershell] + set pshell_path powershell ;#temp + } else { + set pshell_path pwsh ;#temp + } + #todo - review run commands and handling of paths with spaces + # ---------------------------------------- + + + + if {$pshell_path eq ""} { + set has_powershell 0 + } else { + #todo - review powershell detection on non-windows platforms + set has_powershell 1 + } + + if {$::tcl_platform(platform) eq "windows"} { + interp alias {} dl {} dir /q + interp alias {} dw {} dir /W/D + } else { + #todo - natsorted equivalent + #interp alias {} dl {} + interp alias {} dl {} puts stderr "not implemented" + interp alias {} dw {} puts stderr "not implemented" + } + + #todo - distinguish non-preinstalled pwsh (powershell core) from powershell which is available by default + if {$has_powershell} { + #see also powershell runspaces etc: + # powershell runspaces e.g $rs=[RunspaceFactory]::CreateRunspace() + # $ps = [Powershell]::Create() + + interp alias {} pse {} exec >@stdout {*}$pshell_path -nolo -nop -c + interp alias {} psx {} runx -n {*}$pshell_path -nop -nolo -c + interp alias {} psr {} run -n {*}$pshell_path -nop -nolo -c + interp alias {} psout {} runout -n {*}$pshell_path -nop -nolo -c + interp alias {} pserr {} runerr -n {*}$pshell_path -nop -nolo -c + #interp alias {} psls {} shellrun::runconsole $pshell_path -nop -nolo -c ls + #interp alias {} psls {} shellrun::runconsole {*}$pshell_path -nop -nolo -c {ls | Select-Object Mode, @{Name='Owner';Expression={(Get-Acl $_.FullName).Owner}}, LastWriteTime, Length, Name | Format-Table} + proc psls args { + variable pshell_path + shellrun::runconsole {*}$pshell_path -nop -nolo -c {*}[string map [list %a% $args] {{ls %a% | Select-Object Mode, @{Name='Owner';Expression={(Get-Acl $_.FullName).Owner}}, LastWriteTime, Length, Name | Format-Table}}] + } + interp alias {} psls {} punk::psls + interp alias {} psps {} shellrun::runconsole {*}$pshell_path -nop -nolo -c ps + } else { + set ps_missing "powershell missing (powershell is MIT licensed open source and can be installed on windows and most unix-like platforms)" + interp alias {} pse {} puts stderr $ps_missing + interp alias {} psx {} puts stderr $ps_missing + interp alias {} psr {} puts stderr $ps_missing + interp alias {} psout {} puts stderr $ps_missing + interp alias {} pserr {} puts stderr $ps_missing + interp alias {} psls {} puts stderr $ps_missing + interp alias {} psps {} puts stderr $ps_missing + } + proc psencode {cmdline} { + + } + proc psdecode {encodedcmd} { + + } + + #proc repl {startstop} { + # switch -- $startstop { + # stop { + # if {[punk::repl::codethread::is_running]} { + # puts stdout "Attempting repl stop. Try ctrl-c or exit command to leave interpreter" + # set ::repl::done 1 + # } + # } + # start { + # if {[punk::repl::codethread::is_running]} { + # repl::start stdin + # } + # } + # default { + # error "repl unknown action '$startstop' - must be start or stop" + # } + # } + #} + +} + + +# -- --- --- --- +#Load decks. commandset packages are not loaded until the deck is called. +# -- --- --- --- +package require punk::mod +#punk::mod::cli set_alias pmod +punk::mod::cli set_alias app + +#todo - change to punk::dev +package require punk::mix +punk::mix::cli set_alias dev +punk::mix::cli set_alias deck ;#deprecate! + +#todo - add punk::deck for managing cli modules and commandsets + +package require punkcheck::cli +punkcheck::cli set_alias pcheck +punkcheck::cli set_alias punkcheck +# -- --- --- --- + +package provide punk [namespace eval punk { + #FUNCTL + variable version + set version 0.1.1 +}] + + + diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/aliascore-0.1.0.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/aliascore-0.1.0.tm index 296fa148..bea6a48f 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/aliascore-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/aliascore-0.1.0.tm @@ -123,6 +123,7 @@ tcl::namespace::eval punk::aliascore { ansistrip ::punk::ansi::ansistrip stripansi ::punk::ansi::ansistrip ansiwrap ::punk::ansi::ansiwrap + ansisplit ::punk::ansi::ta::split_codes_single grepstr ::punk::ansi::grepstr untabify ::punk::ansi::untabify colour ::punk::console::colour diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/ansi-0.1.1.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/ansi-0.1.1.tm index e8518d0f..53ffd420 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/ansi-0.1.1.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/ansi-0.1.1.tm @@ -127,7 +127,8 @@ tcl::namespace::eval punk::ansi::class { -width -type integer -default "" -height -type integer -default "" -crm_mode -type boolean -default 0 - -binarytext -type string -default "" -choices {"" bios ice} + -format -type string -choices {ansi binarytext-bios binarytext-ice xbin} -help\ + "Format of new data being applied as an overlay" @values -min 0 -max 0 }] method rendertest {args} { @@ -135,7 +136,7 @@ tcl::namespace::eval punk::ansi::class { set opt_width [dict get $argd opts -width] set opt_height [dict get $argd opts -height] set opt_crm_mode [dict get $argd opts -crm_mode] - set opt_binarytext [dict get $argd opts -binarytext] + set opt_format [dict get $argd opts -format] set existing_dimensions $o_render_dimensions if {![regexp {^([0-9]+)[xX]([0-9]+)$} $existing_dimensions _m w h]} { @@ -150,8 +151,7 @@ tcl::namespace::eval punk::ansi::class { set o_render_dimensions ${w}x${h} - - set rendered [overtype::renderspace -binarytext $opt_binarytext -cp437 1 -crm_mode $opt_crm_mode -expand_right 0 -wrap 1 -width $w -height $h -appendlines 1 "" [$o_ansistringobj get]] + set rendered [overtype::renderspace -format $opt_format -cp437 1 -crm_mode $opt_crm_mode -expand_right 0 -wrap 1 -width $w -height $h -appendlines 1 "" [$o_ansistringobj get]] return $rendered } @@ -630,7 +630,8 @@ tcl::namespace::eval punk::ansi { package require punk::ansi::sauce set sdict [punk::ansi::sauce::from_file $filename] set result "" - if {[dict size $sdict]} { + #if no sauce header - sdict will contain only posn -1 + if {[dict size $sdict] > 1} { if {$opt_return eq "dict"} { return $sdict } @@ -695,33 +696,75 @@ tcl::namespace::eval punk::ansi { } set opt_crm_mode [dict get $opts -crm_mode] - set binarytext "" set sdict [dict create] #if SAUCE data is present - it may give an indication of encoding as well as number of columns/lines if {![catch {package require punk::ansi::sauce}]} { if {[catch {punk::ansi::sauce::from_file $fname} sdict]} { - #no 128 Byte SAUCE record at end of file + #error parsing 128 Byte SAUCE record at end of file set sdict [dict create] } + #if no error - there may be no SAUCE record at all (sdict is just posn -1) } else { puts stderr "Warning punk::ansi::sauce package not loaded - unable to detect or use any SAUCE data to aid in display" } - if {![dict size $sdict]} { - if {[string tolower [file extension $fname]] eq ".bin"} { - #In the absence of SAUCE data - assume .bin is binary text - set binarytext bios ;#16 fg, 8 bg + blink + + set format ansi ;#default assumption + + + if {[dict size $sdict] < 2} { + #either no SAUCE (dict is just posn -1) or there was an error during sauce::from_file parsing (empty sdict) + switch -exact -- [string tolower [file extension $fname]] { + .bin { + #In the absence of SAUCE data - assume .bin is binary text + set format binarytext-bios ;#16 fg, 8 bg + blink + } + .xb { + set format xbin + } } } + + #review - we open and read from file twice - once for sauce, once to slurp in whole file. + # - consider optimising to read file in first and use slurped data for sauce + #(create punk::ansi::sauce::from_data ?) + set ansidata [fcat -translation binary $fname] + if {[dict size $sdict] && [dict get $sdict posn] != -1} { + #the SAUCE ctrl-z may not be the only ctrl-z in the file data + #use the position returned by sauce::from_file rather than splitting on ctrl-z + #posn will be -1 if no SAUCE, or the position of the ctrl-z immediatly before the entire SAUCE block (including comments) + set ansidata [string range $ansidata 0 [dict get $sdict posn]-1] + } + + if {[dict exists $sdict datatype_name]} { - if {[dict get $sdict datatype_name] eq "binarytext"} { - #todo - SAUCE ANSiFlags - ice vs default bios - if {[dict exists $sdict ansiflags_ice] && [dict get $sdict ansiflags_ice]} { - set binarytext ice - } else { - set binarytext bios + switch -- [dict get $sdict datatype_name] { + binarytext { + #SAUCE ANSiFlags - iCE vs default bios + if {[dict exists $sdict ansiflags_ice] && [dict get $sdict ansiflags_ice]} { + set format binarytext-ice + } else { + set format binarytext-bios + } + } + xbin { + set format xbin + } + default { } } } + + if {$format eq "xbin"} { + #set ansidata [fcat -translation binary $fname] ;#don't split on \x1a - this is also present in xbin header + set xbin_header [string range $ansidata 0 10] ;#11 bytes + set non_header [string range $ansidata 11 end] + #set ansidata $xbin_header[lindex [split $non_header \x1a] 0] ;#ignore sauce at tail + set xbin_header_info [punk::ansi::xbin::parse_header $xbin_header] + #keys width height fontsize flags + set dimensions [dict get $xbin_header_info width]x[dict get $xbin_header_info height] ;#cols x rows + } + + if {$encoding eq ""} { if {[dict exists $sdict codepage]} { set encoding [dict get $sdict codepage] @@ -733,11 +776,13 @@ tcl::namespace::eval punk::ansi { if {$dimensions eq ""} { # defaults - if {$binarytext ne ""} { + if {[string match binarytext* $format]} { set cols 160 } else { set cols 80 } + + #sauce-specified if {[dict exists $sdict columns]} { set c [dict get $sdict columns] if {$c > 0} { @@ -764,17 +809,24 @@ tcl::namespace::eval punk::ansi { } lassign [split $dimensions x] cols rows - #set ansidata [fcat -encoding $encoding $fname] - set ansidata [lindex [split [fcat -translation binary $fname] \x1a] 0] - #hack - #if {$binarytext eq ""} { + if {$format eq "xbin"} { + #review + ##don't decode binary xbin header + #set hdr [string range $ansidata 0 10] + #set data [encoding convertfrom $encoding [string range $ansidata 11 end]] + #set ansidata $hdr$data + + #don't convert at all - compressed is binary? + } elseif {[string match binarytext* $format]} { + #don't convert - this is binary data - the rendering obj will handle it as binary + } else { set ansidata [encoding convertfrom $encoding $ansidata] - #} + } set obj [punk::ansi::class::class_ansi new $ansidata] if {$encoding eq "cp437"} { - set result [$obj rendertest -binarytext $binarytext -width $cols -height $rows -crm_mode $opt_crm_mode] + set result [$obj rendertest -format $format -width $cols -height $rows -crm_mode $opt_crm_mode] } else { set result [$obj render $dimensions] } @@ -6193,24 +6245,12 @@ be as if this was off - ie lone CR. #counterintuitively "x\b" still shows the x ie length is still one. The backspace just moves the position. There must be a char following \b for it to affect the length. #(we are not interested in the destructive backspace case present in editors,terminals etc - that is a different context) - set n 0 - #set chars [split $line ""] ; #review - graphemes vs chars? Terminals differ in how they treat this. - set chars [punk::char::grapheme_split $line] - set cr_posns [lsearch -all $chars \r] - set bs_posns [lsearch -all $chars \b] - foreach p $cr_posns { - lset chars $p - } - foreach p $bs_posns { - lset chars $p - } #mintty seems more 'correct'. It will backspace over an entire grapheme (char+combiners) whereas windows terminal/wezterm etc remove a combiner #build an output set idx 0 set outchars [list] - set outsizes [list] # -- #tcl8.6/8.7 we can get a fast byte-compiled switch statement only with literals in the source code #this is difficult/risky to maintain - hence the lsearch and grapheme-replacement above @@ -6220,39 +6260,65 @@ be as if this was off - ie lone CR. #set cr ? # -- - - #consider also that AB\0\bC will usually render as AC not ABC - foreach c $chars { - switch -- $c { - { - if {$idx > 0} { - incr idx -1 - } - } - { - set idx 0 - } - default { - if {$c eq "\0"} { - #nulls don't print - and backspace will ignore them and remove the preceding char if there is one. - #we need to remove them here or else backspace processing will only remove the null and not the preceding char - which is not how terminals work. - #review - other zero-width chars? - continue - } - #set nxt [llength $outchars] - if {$idx < [llength $outchars]} { - #overstrike? - should usually have no impact on width - width taken as last grapheme in that column - #e.g nroff would organise text such that underline written first, then backspace, then the character - so that terminals without overstrike would display something useful if no overstriking is done - #Conceivably double_wide_char then backspace then underscore would underreport the length if overstriking were intended. - lset outchars $idx $c - } else { - lappend outchars $c - } - #punk::ansi::internal::printing_length_addchar $idx $c - incr idx - } + set graphemes [punk::char::grapheme_split $line] + foreach g $graphemes { + if {$g eq "\0"} { + #nulls don't print - and backspace will ignore them and remove the preceding char if there is one. + #we need to remove them here or else backspace processing will only remove the null and not the preceding char - which is not how terminals work. + #review - other zero-width chars? + continue + } elseif {$g eq "\r"} { + set idx 0 + } elseif {$g eq "\b"} { + incr idx -1 + set idx [expr {max(0,$idx)}] + } else { + lset outchars $idx $g ;#lset will append if $idx is equal to the current length of the list - since we only increment idx by 1, this should be safe to do without checking the length first + #if {$idx < [llength $outchars]} { + # #overstrike? - should usually have no impact on width - width taken as last grapheme in that column + # #e.g nroff would organise text such that underline written first, then backspace, then the character - so that terminals without overstrike would display something useful if no overstriking is done + # #Conceivably double_wide_char then backspace then underscore would underreport the length if overstriking were intended. + # lset outchars $idx $g + #} else { + # lappend outchars $g + #} + incr idx } } + + + + #consider also that AB\0\bC will usually render as AC not ABC + #foreach g $graphemes { + # switch -exact -- $g { + # { + # if {$idx > 0} { + # incr idx -1 + # } + # } + # { + # set idx 0 + # } + # { + # #nulls don't print - and backspace will ignore them and remove the preceding char if there is one. + # #we need to remove them here or else backspace processing will only remove the null and not the preceding char - which is not how terminals work. + # #review - other zero-width chars? + # continue + # } + # default { + # #set nxt [llength $outchars] + # if {$idx < [llength $outchars]} { + # #overstrike? - should usually have no impact on width - width taken as last grapheme in that column + # #e.g nroff would organise text such that underline written first, then backspace, then the character - so that terminals without overstrike would display something useful if no overstriking is done + # #Conceivably double_wide_char then backspace then underscore would underreport the length if overstriking were intended. + # lset outchars $idx $g + # } else { + # lappend outchars $g + # } + # incr idx + # } + # } + #} #we already have the string split into grapheme clusters. #we should calculate length as the sum of the widths of the graphemes in the output list rather #than passing to a function that will need to split into graphemes again. @@ -6287,7 +6353,7 @@ be as if this was off - ie lone CR. set max_component_width 1 } } - } elseif {$c < 917504 || $c > 917631} { + } elseif {$dec < 917504 || $dec > 917631} { #codepoint not in the zero-width unicode tag block - \UE0000-\UE000F #set w [punk::char::char_width $dec] set w [textutil::wcswidth_char $dec] @@ -6314,19 +6380,6 @@ be as if this was off - ie lone CR. return $sumwidth #return [punk::char::ansifreestring_width [join $outchars ""]] } - namespace eval internal { - proc printing_length_addchar {i c} { - #review - upvar outchars outc - upvar outsizes outs - set nxt [llength $outc] - if {$i < $nxt} { - lset outc $i $c - } else { - lappend outc $c - } - } - } # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- @@ -7070,6 +7123,12 @@ be as if this was off - ie lone CR. set prev_stop_idx [lsearch -integer -bisect $tstops $current_column] set next_stop [lindex $tstops $prev_stop_idx+1] ;#if our current_column is exactly on a stop, we still want to move to the next stop. + if {$next_stop eq ""} { + #if we run out of stops + #Review + break + } + # how far is the next tab position ? #set dist [expr {$num - ($currPos % $num)}] set this_tab_width [expr {$next_stop - $current_column}] ;#diff between two adjacent columns is one. @@ -7515,6 +7574,10 @@ tcl::namespace::eval punk::ansi { #} #------------------------------------------------------- proc sgr_merge {codelist args} { + if {[llength $codelist] == 0 && [llength $args] == 0} { + return "" + } + #pass through even single code or empty codelist to sgr_merge_singles - as there may be arguments such as -info or -filter_* set allparts [list] foreach c $codelist { #set cparts [punk::ansi::ta::split_codes_single $c] @@ -8959,7 +9022,6 @@ tcl::namespace::eval punk::ansi::class { -overflow 0 -appendlines 1 -looplimit 15000 - -experimental {} -cursor_column 1 -cursor_row 1 -insert_mode 0 @@ -8970,7 +9032,7 @@ tcl::namespace::eval punk::ansi::class { foreach {k v} $argsflags { switch -- $k { -width - -height - - -overflow - -appendlines - -looplimit - -experimental - + -overflow - -appendlines - -looplimit - -autowrap_mode - -insert_mode - -initial_ansistring { @@ -9671,7 +9733,8 @@ tcl::namespace::eval punk::ansi::class { upvar ${ns}::o_gx0states new_gx0states upvar ${ns}::o_splitindex new_splitindex - lset o_ansisplits end [tcl::string::cat [lindex $o_ansisplits end] [lindex $new_ansisplits 0]] lappend o_ansisplits {*}[lrange $new_ansisplits 1 end] + lset o_ansisplits end [tcl::string::cat [lindex $o_ansisplits end] [lindex $new_ansisplits 0]] + lappend o_ansisplits {*}[lrange $new_ansisplits 1 end] lset o_ptlist end [tcl::string::cat [lindex $o_ptlist end] [lindex $new_ptlist 0]] lappend o_ptlist {*}[lrange $new_ptlist 1 end] @@ -10286,8 +10349,9 @@ tcl::namespace::eval punk::ansi::ansistring { set hack [tcl::dict::create] tcl::dict::set hack BOM1 [list \uFEFF "${obm}\U1f4a3$cbm"] ;#byte order mark/ ZWNBSP (ZWNBSP usage generally deprecated) - a picture of a bomb(2wide glyph) tcl::dict::set hack ZWSP [list \u200B "${obm}ZWSP$cbm"] - tcl::dict::set hack ZWNJ [list \u200D "${obm}ZWNJ$cbm"] ;#zero width non-joiner. + tcl::dict::set hack ZWNJ [list \u200C "${obm}ZWNJ$cbm"] ;#zero width non-joiner. tcl::dict::set hack ZWJ [list \u200D "${obm}ZWJ$cbm"] + tcl::dict::set hack CGJ [list \u034F "${obm}CGJ$cbm"] ;#combining grapheme joiner (MISNOMER) - zero width, but semantically important in some contexts - for example in indic scripts - where it can affect the shaping of the preceding character(s) #review - other boms? Encoding dependent? @@ -10561,6 +10625,7 @@ tcl::namespace::eval punk::ansi::ansistring { #Note that trim/trimleft/trimright will trim spaces at the extremities that are styled with background colour, underline etc #that may be unexpected, but it's probably the only thing that makes sense. Plain string trim can chop off whitespace that is extraneous to the ansi entirely. proc trimleft {string args} { + #todo - don't just trim whitespace - need to accept optional ?chars? to trim. set intext 0 set out "" #for split_codes only first or last pt can be empty string - but we can also get an empty ansiblock by using foreach with 2 vars on an odd-length list @@ -11808,7 +11873,7 @@ namespace eval punk::ansi::colour { @cmd -name "punk::ansi::colour::byteAnsi" -summary\ "ANSI/BIOS colour codes from attribute byte."\ -help\ - "Convert an attribute-byte (character) to ANSI SGR + "Convert a binarytext (.bin) attribute-byte (character) to ANSI SGR foreground and background colour. This is allows 16 foreground colours and only 8 background colours, with the highest bit being @@ -11828,7 +11893,7 @@ namespace eval punk::ansi::colour { lappend PUNKARGS [list { @id -id "::punk::ansi::colour::byteAnsiIce" @cmd -name "punk::ansi::colour::byteAnsiIce" -summary\ - "iCE colour codes from attribute byte."\ + "iCE colour codes from binarytext (.bin) attribute byte."\ -help\ "Convert an attribute-byte (character) to ANSI SGR foreground and background colour. @@ -11847,6 +11912,945 @@ namespace eval punk::ansi::colour { dict get $byte_to_ansi_ice $char } } +tcl::namespace::eval punk::ansi::xbin { + proc parse_header {str} { + #https://web.archive.org/web/20120204063040/http://www.acid.org/info/xbin/x_spec.htm + if {[string length $str] < 11} { + error "punk::ansi::xbin::parse_header error - invalid XBIN header - less than 11 bytes received" + } + set xbin_header [string range $str 0 10] ;#11 bytes + + set xbin_id [string range $xbin_header 0 3] + if {$xbin_id ne "XBIN"} { + error "punk::ansi::xbin::parse_header error - invalid XBIN header" + } + set xbin_eofchar [string index $xbin_header 4] + set xbin_width_raw [string range $xbin_header 5 6] + binary scan $xbin_width_raw su xbin_width ;#16bit unsigned little-endian + set xbin_height_raw [string range $xbin_header 7 8] + binary scan $xbin_height_raw su xbin_height ;#16bit unsigned little-endian + + set xbin_fontsize_raw [string index $xbin_header 9] + if {[binary scan $xbin_fontsize_raw cu xbin_fontsize]} { + #1 byte - unsigned + #numeric number of pixel rows (scanlines) in font. + #Any value from 1 to 32 is technically possible on VGA. + #Any other values should be considered illegal + if {$xbin_fontsize < 1 || $xbin_fontsize > 32} { + error "punk::ansi::xbin::parse_header error - invalid XBIN header - fontsize not in range 1 to 32 inclusive. received $xbin_fontsize" + } + } + set xbin_flags_raw [string index $xbin_header 10] + #valid flags: 512chars nonblink compress font palette + #bits: + #7 unused 6 unused 5 unused 4 512chars 3 nonblink 2 compress 1 font 0 palette + binary scan $xbin_flags_raw B8 flagbits + set flagbits [lrange [split $flagbits ""] 3 end] ;#skip first 3 unused + set allflags [list 512chars nonblink compress font palette] + set xbin_flags [list] + #puts "flagbits $flagbits" + foreach b $flagbits f $allflags { + if {$b} { + lappend xbin_flags $f + } + } + #width - number of columns, height - number of character rows + return [dict create width $xbin_width height $xbin_height fontsize $xbin_fontsize flags $xbin_flags] + } + proc default_palette {} { + # VGA 16-colour default palette as RGB 0-255 triples. + return { + {0 0 0} + {0 0 170} + {0 170 0} + {0 170 170} + {170 0 0} + {170 0 170} + {170 85 0} + {170 170 170} + {85 85 85} + {0 0 255} + {0 255 0} + {0 255 255} + {255 0 0} + {255 0 255} + {255 255 0} + {255 255 255} + } + } + + proc palette_value_8bit {value} { + if {$value < 0 || $value > 63} { + error "punk::ansi::xbin::palette_value_8bit error - expected palette value from 0 to 63 inclusive. received $value" + } + return [expr {round(($value * 255.0) / 63.0)}] + } + proc parse_palette {str} { + if {[string length $str] < 48} { + error "punk::ansi::xbin::parse_palette error - invalid XBIN palette - less than 48 bytes received" + } + binary scan [string range $str 0 47] cu* components + set palette [list] + foreach {r g b} $components { + lappend palette [list [palette_value_8bit $r] [palette_value_8bit $g] [palette_value_8bit $b]] + } + #for {set i 0} {$i < 48} {incr i 3} { + # set r [palette_value_8bit [lindex $components $i]] + # set g [palette_value_8bit [lindex $components $i+1]] + # set b [palette_value_8bit [lindex $components $i+2]] + # lappend palette [list $r $g $b] + #} + return $palette + } + proc attribute_ansi {char palette nonblink} { + #convert a binarytext (.bin) attribute byte (character) to ANSI SGR + #foreground and background colour. + #When nonblink is false, this allows 16 foreground colours and only 8 + #background colours, with the highest bit being + #used to set 'blink' on. + if {![binary scan $char cu value]} { + error "punk::ansi::xbin::attribute_ansi error - expected a single character for attribute byte. received string of length [string length $char] - '[ansistring VIEW $char]'" + } + + set fg_index [expr {$value & 0x0F}] + if {$nonblink} { + set bg_index [expr {($value >> 4) & 0x0F}] + set blink noblink + } else { + set bg_index [expr {($value >> 4) & 0x07}] + if {$value & 0x80} { + set blink blink + } else { + set blink noblink + } + } + lassign [lindex $palette $fg_index] fr fg fb + lassign [lindex $palette $bg_index] br bg bb + return [punk::ansi::a+ $blink rgb-$fr-$fg-$fb Rgb-$br-$bg-$bb] + } + + proc parse {xbindata} { + set bytenum 0 + set xbin_header [string range $xbindata 0 10] ;#11 bytes + set xbin_header_info [punk::ansi::xbin::parse_header $xbin_header] + set xbin_body [string range $xbindata 11 end] + incr bytenum 11 + + set flags [dict get $xbin_header_info flags] + set xbin_width [dict get $xbin_header_info width] + set xbin_height [dict get $xbin_header_info height] + set expected_cells [expr {$xbin_width * $xbin_height}] + set xbin_nonblink [expr {"nonblink" in $flags}] ;# ice. + set xbin_palette [punk::ansi::xbin::default_palette] + + set parse_warnings [list] + + #optional 16-entry palette, 3 bytes per entry, RGB values 0..63 + if {"palette" in $flags} { + #puts stderr "renderspace warning - palette unimplemented" + set xbin_palette [punk::ansi::xbin::parse_palette [string range $xbin_body 0 47]] + set xbin_body_after_palette [string range $xbin_body 48 end] + incr bytenum 48 + } else { + set xbin_body_after_palette $xbin_body + } + + #todo - font. + #hack - skip over font 256 x fontsize or 512 x fontsize + if {"512chars" in $flags} { + set sz 512 + } else { + set sz 256 + } + #temp + set skip [expr {$sz * [dict get $xbin_header_info fontsize]}] + if {"font" in $flags} { + #todo - consider sixel or similar for font data - but for now we just skip over it. + #puts stderr "punk::ansi::xbin::parse warning - xbin font unimplemented" + lappend parse_warnings "XBIN_FONT_UNIMPLEMENTED skipping over font data" + set celldata [string range $xbin_body_after_palette $skip end] + incr bytenum $skip + } else { + set celldata $xbin_body_after_palette + } + set celldata_bytes [split $celldata ""] + #puts stdout "xbin image data size [llength $celldata_bytes]" + + set decoded_cells 0 + set ansisplit [list ""] + if {"compress" in $flags} { + #puts stderr "renderspace warning - compress experimental" + #process 'repeatcounter' bytes + #first 2 bits - compression type + # 00 - no compression + # 01 - character compression + # 10 - attribute compression + # 11 - character/attribute compression + #remaining 6 bits - counter + set input "" + set byte_count [llength $celldata_bytes] + for {set b 0} {$b < $byte_count} {} { + set rc [lindex $celldata_bytes $b] + set dec [scan $rc %c] + set ctype [expr {$dec >> 6}] + #0x3F - 00111111 + set count [expr {$dec & 0x3F}] + incr count ;#count stored as 1 less than actual number of repeats + if {$count < 1 || $count > 64} { + #generally unlikely to occur if we are decoding 6 bits of count correctly. + # - but will be zero for example if we have a trailing carriage return. + puts stderr "punk::ansi::xbin::parse - max count must be between 1 and 64 inclusive. received $count" + } + incr b + if {$decoded_cells + $count > $expected_cells} { + #some of the more common causes of this could be additional non xbin data after the expected end of celldata, eg: + #\x1a (ctrl-z) decimal value 26 (= count 27) delimiter for start of SAUCE record. + #\r (carriage regurn) decimal value 13 (= count 14) + #\n (line feed) decimal value 10 (= count 11) + # or it could be more celldata but the header dimensions are wrong + #- either way we should probably just warn and stop processing. + lappend parse_warnings "XBIN_OVERFLOW - record would emit $count cells at decoded offset $decoded_cells, expected total $expected_cells cells for header dimensions ${xbin_width}x${xbin_height} (possible trailing SAUCE record or newlines)" + break + } + switch -exact -- $ctype { + 0 { + set needed [expr {$count * 2}] + } + 1 - + 2 { + set needed [expr {$count + 1}] + } + 3 { + set needed 2 + } + default { + #hard error - will probably cause desynchronization between decoder and byte stream + error "punk::ansi::xbin::parse - invalid compression type $ctype in repeatcounter byte '$rc' at offset $b" + } + } + if {$b + $needed > $byte_count} { + lappend parse_warnings "XBIN_BAD_RECORD - truncated record: type $ctype requires $needed bytes at payload offset $b, but only [expr {$byte_count - $b}] bytes remain." + #abort processing - would probably raise an error in the compression switch cases below. + #This may indicate a truncated file, but it could also be a file with additional data after the expected end of celldata. + #This is likely to happen if the xbindata includes a trailing SAUCE record. + #we shouldn't raise a hard error - as the caller may want to salvage what data they can from the file, and report the issue via warnings. + break + } + switch -exact -- $ctype { + 0 { + #no compression + for {set c 0} {$c < $count*2} {incr c 2} { + set ch [lindex $celldata_bytes $b+$c] + set ch [encoding convertfrom cp437 $ch] + set at [lindex $celldata_bytes [expr {$b+$c+1}]] + #binary scan $at cu code + #set clr [a+ term-$code] + #set clr [a+ red] ;#debug + set clr [punk::ansi::xbin::attribute_ansi $at $xbin_palette $xbin_nonblink] + lappend ansisplit $clr $ch + } + incr b [expr {$count*2}] + } + 1 { + #char compression + set ch [lindex $celldata_bytes $b] + set ch [encoding convertfrom cp437 $ch] + incr b + for {set c 0} {$c < $count} {incr c} { + set at [lindex $celldata_bytes $b+$c] + #binary scan $at cu code + #set clr [a+ term-$code] + #set clr [a+ cyan] ;#debug + set clr [punk::ansi::xbin::attribute_ansi $at $xbin_palette $xbin_nonblink] + lappend ansisplit $clr $ch + } + incr b [expr {$count}] + } + 2 { + #attribute compression + set at [lindex $celldata_bytes $b] + #binary scan $at cu code + #set clr [a+ term-$code] + #set clr [a+ green] ;#debug + set clr [punk::ansi::xbin::attribute_ansi $at $xbin_palette $xbin_nonblink] + incr b + for {set c 0} {$c < $count} {incr c} { + set ch [lindex $celldata_bytes $b+$c] + set ch [encoding convertfrom cp437 $ch] + lappend ansisplit $clr $ch + } + incr b $count + } + 3 { + #attribute and char compression + set ch [lindex $celldata_bytes $b] + set ch [encoding convertfrom cp437 $ch] + set at [lindex $celldata_bytes $b+1] + #binary scan $at cu code + #set clr [a+ term-$code] + #set clr [a+ white] ;#debug + set clr [punk::ansi::xbin::attribute_ansi $at $xbin_palette $xbin_nonblink] + for {set c 0} {$c < $count} {incr c} { + lappend ansisplit $clr $ch + } + incr b 2 + } + } + incr decoded_cells $count + } + if {$decoded_cells != $expected_cells} { + lappend parse_warnings "XBIN_CELLCOUNT_MISMATCH decoded $decoded_cells cells, expected $expected_cells cells for image dimensions ${xbin_width}x${xbin_height}" + } + } else { + foreach {ch at} $celldata_bytes { + #binary scan $at cu code + #set clr [a+ term-$code] + if {$at eq ""} { + #eg src/testansi/formatsamples/image/xbin/test.xb + #has missing last byte. for now just warn. + #puts stderr "renderspace warning - xbin attribute byte is empty at char '[ansistring VIEW $ch]'" + lappend parse_warnings "XBIN_MISSING_BYTE attribute byte is empty at byte [expr {$bytenum + 1}] char '[ansistring VIEW $ch]'" + #experiment - treat as a reset. + lappend ansisplit [a+] $ch + } else { + set clr [punk::ansi::xbin::attribute_ansi $at $xbin_palette $xbin_nonblink] + set ch [encoding convertfrom cp437 $ch] + lappend ansisplit $clr $ch + } + incr bytenum 2 + incr decoded_cells + } + } + #lappend inputchunks [list ansisplit $ansisplit] + + #_reset key with ansi reset to ensure direct display of dict in terminal is readable. + return [dict create header $xbin_header_info palette $xbin_palette ansisplit $ansisplit _reset \x1b\[m warnings $parse_warnings decoded_cells $decoded_cells expected_cells $expected_cells] + } + +} +tcl::namespace::eval punk::ansi::png { + + proc paethPredictor {a b c} { + #A Paeth PNG filter is a pre-compression image processing algorithm used in the Portable Network Graphics (PNG) format. + #It is designed to prepare image data for the format's lossless compression by predicting the color of a pixel based on + #its neighbors + set p [expr {$a + $b - $c}] + set pa [expr {abs($p - $a)}] + set pb [expr {abs($p - $b)}] + set pc [expr {abs($p - $c)}] + if {$pa <= $pb && $pa <= $pc} { return $a } + if {$pb <= $pc} { return $b } + return $c + } + + proc pngdataToAnsi {pngdata} { + #This will create very large ansi images as the smallest possible colorised cell is the half-block character. + #To create smaller images, we could consider some kind of lossy conversion to a smaller palette, or even to monochrome with dithering. + #A better alternative might be sixel or similar. + + #if {[::png::validate $filename] ne "OK"} { + # error "Invalid PNG file." + #} + # Extract PNG header metadata + #set info [::png::imageInfo $filename] + + if {[string range $pngdata 0 7] ne "\x89PNG\r\n\x1a\n"} { + error "pngdataToAnsi: Invalid PNG data - missing PNG signature" + } + + #----------------------------------------------------------------------------------------- + #set info [::png::imageInfo $filename] + #----------------------------------------------------------------------------------------- + set posn [expr {8}] ;# Skip PNG signature + binary scan [string range $pngdata $posn [expr {$posn + 7}]] Ia4 len type + incr posn 8 + set r [string range $pngdata $posn [expr {$posn + $len - 1}]] + incr posn $len + if {$type eq "IHDR"} { + binary scan $r IIccccc width height depth color compression filter interlace + binary scan [string range $pngdata $posn [expr {$posn + 3}]] I check + if {$check < 0} { + set check [format %u [expr {$check & 0xffffffff}]] + } + if {![catch {package present crc32}] && [::crc32::crc32 IHDR$r] != $check} { + error "pngdataToAnsi: Invalid PNG data - IHDR chunk CRC mismatch" + } + set info [list width $width height $height depth $depth color $color compression $compression filter $filter interlace $interlace] + } else { + error "pngdataToAnsi: Invalid PNG data - missing IHDR chunk" + } + #----------------------------------------------------------------------------------------- + + + set width [dict get $info width] + set height [dict get $info height] + set depth [dict get $info depth] + set color [dict get $info color] + set filter [dict get $info filter] + set interlace [dict get $info interlace] + set compression [dict get $info compression] + if {$compression != 0} { + #true as at PNG-3 2025 + error "pngdataToAnsi: Unsupported PNG compression method $compression - only method 0 (deflate/inflate) is supported." + } + puts stderr "pngdataToAnsi: PNG image info - width $width height $height depth $depth color $color interlace $interlace filter $filter" + + set color_types { + 0 Grayscale + 2 TrueColor (RGB) + 3 Indexed-color + 4 Grayscale with alpha + 6 TrueColor with alpha (RGBA) + } + switch -exact $color { + 0 { + error "pngdataToAnsi warning - PNG color type 0 (grayscale) not supported - todo: treat as RGB with R=G=B ?" + set ctype "grayscale" + if {$depth ni {1 2 4 8 16}} { + error "Unsupported format. Only grayscale PNGs with bit depths of 1, 2, 4, 8, or 16 are supported." + } + } + 2 { + # RGB TrueColor - supported + set ctype "rgb" + #todo depth 16 + if {$depth != 8} { + error "Unsupported format. Only 8-bit RGB or RGBA PNGs are supported." + } + set bpp 3 + } + 3 { + set ctype "indexed" + puts stderr "pngdataToAnsi warning - PNG color type 3 (indexed colour)" + if {$depth ni {1 2 4 8}} { + error "Unsupported format. Only indexed-color PNGs with 1,2,4 or 8 bit depth are supported." + } + set bpp 1 + } + 4 { + error "pngdataToAnsi warning - PNG color type 4 (grayscale with alpha) not supported - todo: treat as RGBA with R=G=B and alpha channel" + set ctype "grayscale_alpha" + set bpp 3 ;#Bytes per pixel + if {$depth ni {8 16}} { + error "Unsupported format. Only grayscale PNGs with bit depths of 8 or 16 are supported." + } + } + 6 { + puts stderr "pngdataToAnsi warning - PNG color type 6 (truecolor with alpha)" + set ctype "rgba" + if {$depth == 8} { + set bpp 4 ;#Bytes per pixel + } elseif {$depth == 16} { + set bpp 8 ;#Bytes per pixel + } else { + error "Unsupported format. Only depths of 8 or 16 bits per channel are supported for RGBA PNGs." + } + } + default { + error "pngdataToAnsi: Unsupported PNG color type $color" + } + } + + + #------------------------------------------ + # Extract raw compressed IDAT stream chunks + #set chunks [::png::getChunks $filename] + set chunks [list] + set posn [expr {8}] ;# Skip PNG signature + while {[set r [string range $pngdata $posn [incr posn 8]]] ne ""} { + binary scan $r Ia4 len type + if {$type eq "IEND"} { + #end of PNG data - stop processing chunks + #(important to stop before we try to process any trailing non-PNG data such as a SAUCE record) + break + } + lappend chunks [list $type $posn $len] + incr posn [expr {$len + 4}] + } + #------------------------------------------ + puts stderr "pngdataToAnsi: found [llength $chunks] chunks in PNG data" + foreach chunk $chunks { + puts stderr "pngdataToAnsi: chunk type '[lindex $chunk 0]' length [lindex $chunk 2]" + } + + + set paletteRaw "" + + set idatData "" + foreach chunk $chunks { + switch -exact -- [lindex $chunk 0] { + "IDAT" { + set posn [lindex $chunk 1] + append idatData [string range $pngdata $posn [expr {$posn + [lindex $chunk 2] - 1}]] + } + "PLTE" { + set posn [lindex $chunk 1] + puts stderr "pngdataToAnsi warning - PNG PLTE chunk" + #implement PLTE chunk parsing and support for indexed colour PNGs + append paletteRaw [string range $pngdata $posn [expr {$posn + [lindex $chunk 2] - 1}]] + } + "tEXt" { + set posn [lindex $chunk 1] + #todo - consider supporting tEXt chunks for metadata such as title, author, description etc. + set textData [string range $pngdata $posn [expr {$posn + [lindex $chunk 2] - 1}]] + set nullpos [string first \x00 $textData] + #neither the keyword nor text data is supposed to contain nulls. + if {$nullpos >= 0} { + set keyword [string range $textData 0 [expr {$nullpos - 1}]] + set text [string range $textData [expr {$nullpos + 1}] end]] + puts stderr "pngdataToAnsi warning - PNG tEXt chunk - keyword '$keyword' text '$text'" + } else { + puts stderr "pngdataToAnsi warning - PNG tEXt chunk - no separator null found: $textData" + } + } + "zTXt" { + #set posn [lindex $chunk 1] + #todo - consider supporting zTXt chunks for compressed metadata such as title, author, description etc. + #puts stderr "pngdataToAnsi warning - PNG zTXt chunk - [string range $pngdata $posn [expr {$posn + [lindex $chunk 2] - 1}]]" + } + "iTXt" { + #set posn [lindex $chunk 1] + #todo - consider supporting iTXt chunks for international text metadata such as title, author, description etc. + #puts stderr "pngdataToAnsi warning - PNG iTXt chunk - [string range $pngdata $posn [expr {$posn + [lindex $chunk 2] - 1}]]" + } + "IEND" { + } + default { + #ignore other chunk types for now + } + } + } + if {$ctype eq "indexed" && $paletteRaw eq ""} { + error "pngdataToAnsi: Indexed colour PNG missing PLTE chunk" + } + if {[string match grayscale* $ctype] && $paletteRaw ne ""} { + puts stderr "pngdataToAnsi warning - PNG PLTE chunk present in grayscale image - ignoring palette data" + } + if {$paletteRaw ne ""} { + set palette [list] + binary scan $paletteRaw c* components + puts "components: $components '[ansistring VIEW $paletteRaw]'" + foreach {r g b} $components { + lappend palette [list [expr {$r & 0xFF}] [expr {$g & 0xFF}] [expr {$b & 0xFF}]] + } + } + + # Decompress using raw Tcl zlib inflation + set decompressed [zlib decompress $idatData] + #set decompressed [zlib deflate $idatData] + #PLTE data is not compressed. + + #set stride [expr {1 + ($width * $bpp)}] + #set prevLine [binary format x[expr {$width * $bpp}]] ;# Row 0 baseline + + if {$ctype eq "indexed"} { + set bytesPerLine [expr {($width * $depth + 7) / 8}] + } else { + set bytesPerLine [expr {$width * $bpp}] + } + set stride [expr {1 + $bytesPerLine}] ;# Filter type byte + pixel data bytes + set prevLine [binary format x$bytesPerLine] ;# Row 0 baseline + set allRows [list] + + + # Process rows + for {set y 0} {$y < $height} {incr y} { + set offset [expr {$y * $stride}] + + # Unpack the filter type byte at start of each scanline + #puts "---> filter type byte: [ansistring VIEW [string range $decompressed $offset $offset]] at offset $offset for row $y" + binary scan [string range $decompressed $offset $offset] c filterType + set filterType [expr {$filterType & 0xFF}] + if {$filterType < 0 || $filterType > 4} { + puts stderr "pngdataToAnsi warning - invalid filter type $filterType at row $y - treating as no filter" + set filterType 0 + } + + # Get filtered pixel payload bytes for the row + set rawRow [string range $decompressed [expr {$offset + 1}] [expr {$offset + $stride - 1}]] + set currentLine "" + + # Defilter scanline bytes based on specification types + for {set xBytes 0} {$xBytes < $bytesPerLine} {incr xBytes} { + binary scan [string range $rawRow $xBytes $xBytes] c origByte + set origByte [expr {$origByte & 0xFF}] + + # Get left byte (A) and upper byte (B) and upper-left byte (C) + #set leftVal [expr {$xBytes >= $bpp ? [string index $currentLine [expr {$xBytes - $bpp}]] : 0}] + #binary scan $leftVal c a + #set a [expr {$a & 0xFF}] + if {$xBytes >= $bpp} { + binary scan [string index $currentLine [expr {$xBytes - $bpp}]] c a + set a [expr {$a & 0xFF}] + } else { + set a 0 + } + + binary scan [string range $prevLine $xBytes $xBytes] c b; + set b [expr {$b & 0xFF}] + + #set upLeftVal [expr {$xBytes >= $bpp ? [string index $prevLine [expr {$xBytes - $bpp}]] : 0}] + #binary scan $upLeftVal c c + #set c [expr {$c & 0xFF}] + if {$xBytes >= $bpp} { + binary scan [string index $prevLine [expr {$xBytes - $bpp}]] c c + set c [expr {$c & 0xFF}] + } else { + set c 0 + } + + # Reverse the PNG filter transformations + switch -- $filterType { + 0 { set reconByte $origByte } ;# None + 1 { set reconByte [expr {($origByte + $a) % 256}] } ;# Sub + 2 { set reconByte [expr {($origByte + $b) % 256}] } ;# Up + 3 { set reconByte [expr {($origByte + (($a + $b) / 2)) % 256}] } ;# Average + 4 { set reconByte [expr {($origByte + [paethPredictor $a $b $c]) % 256}] } ;# Paeth + default { + } + } + append currentLine [binary format c $reconByte] + } + set prevLine $currentLine + + if {$ctype eq "indexed"} { + # For indexed colour PNGs, map pixel values to RGB using the PLTE chunk palette + set pixelRow [list] + set pixelCount 0 + + #pre-calculate masks and steps based on depth + # depth 4: mask = 15 (0x0F), pixels per byte = 2 + # depth 2: mask = 3 (0x03), pixels per byte = 4 + # depth 1: mask = 1 (0x01), pixels per byte = 8 + set mask [expr {(1 << $depth) - 1}] + set pixelsPerByte [expr {8 / $depth}] + + for {set x 0} {$x < $bytesPerLine} {incr x} { + binary scan [string range $currentLine $x $x] c packedByte + set byteVal [expr {$packedByte & 0xFF}] + + #read left-to-right within the byte, extracting pixel values based on depth and mask + for {set p 0} {$p < $pixelsPerByte} {incr p} { + if {$pixelCount < $width} { + #set shift [expr {($pixelsPerByte - 1 - $p) * $depth}] + set shift [expr {8 - $depth - ($p * $depth)}] + set idx [expr {($byteVal >> $shift) & $mask}] + set rgb [lindex $palette $idx] + #append outputBuffer [format "\x1b\[48\;2\;%d\;%d\;%dm " [lindex $rgb 0] [lindex $rgb 1] [lindex $rgb 2]] + #lappend pixelRow $idx + lappend pixelRow [list [lindex $rgb 0] [lindex $rgb 1] [lindex $rgb 2]] + incr pixelCount + } + } + + } + } else { + #RGB + set pixelRow [list] + for {set x 0} {$x < $width} {incr x} { + set idx [expr {$x * $bpp}] + #pull either 3 bytes (RGB) or 4 bytes (RGBA) for the pixel, depending on bpp + if {$depth == 16} { + binary scan [string range $currentLine $idx [expr {$idx + 3}]] c4 rgba + set r [expr {[lindex $rgba 0] & 0xFF}] + set g [expr {[lindex $rgba 1] & 0xFF}] + set b [expr {[lindex $rgba 2] & 0xFF}] + set a [expr {[lindex $rgba 3] & 0xFF}] + + #terminal fallback background colour .eg dark terminal grey + set bgR 30 + set bgG 30 + set bgB 30 + set alpha [expr {$a / 255.0}] + + set r [expr {int(($r * $alpha) + ($bgR * (1 - $alpha)))}] + set g [expr {int(($g * $alpha) + ($bgG * (1 - $alpha)))}] + set b [expr {int(($b * $alpha) + ($bgB * (1 - $alpha)))}] + } else { + binary scan [string range $currentLine $idx [expr {$idx + 2}]] c3 rgb + set r [expr {[lindex $rgb 0] & 0xFF}] + set g [expr {[lindex $rgb 1] & 0xFF}] + set b [expr {[lindex $rgb 2] & 0xFF}] + #puts stderr "pixel $x,$y - RGB($r,$g,$b)" + } + + + # Use background-color escape sequence with two blank spaces to build a square pixel + #append outputBuffer "\x1b\[48\;2\;${r}\;${g}\;${b}m " + lappend pixelRow [list $r $g $b] + } + #append outputBuffer "\x1b\[m\n" ;# Reset row styling + } + lappend allRows $pixelRow + } + + set symbols 1 + # ------------------------------------------------------------- + # Unicode Quadrant Mosaic Definition Matrix + # ------------------------------------------------------------- + # Maps a 4-bit representation of a 2x2 grid to a structural character. + # Layout: Bit 3 = TopLeft, Bit 2 = TopRight, Bit 1 = BottomLeft, Bit 0 = BottomRight + variable MOSAIC_MAP + array set MOSAIC_MAP { + 0 " " 1 "▗" 2 "▖" 3 "▄" + 4 "▝" 5 "▐" 6 "▞" 7 "▟" + 8 "▘" 9 "▚" 10 "▌" 11 "▙" + 12 "▀" 13 "▜" 14 "▛" 15 "█" + } + + # ------------------------------------------------------------- + # Sub-Pixel Structural Rendering Engine + # ------------------------------------------------------------- + proc renderSymbols {allRows width height} { + variable MOSAIC_MAP + set outputBuffer "" + fconfigure stdout -encoding utf-8 + + # Process chunks of 2 vertical rows and 2 horizontal columns + for {set y 0} {$y < $height} {incr y 2} { + set rowTop [lindex $allRows $y] + + # Edge safety padding for odd vertical bounds + if {($y + 1) < $height} { + set rowBottom [lindex $allRows [expr {$y + 1}]] + } else { + set rowBottom $rowTop + } + + for {set x 0} {$x < $width} {incr x 2} { + # Extract 4 pixels of the 2x2 cluster + set p_tl [lindex $rowTop $x] + + if {($x + 1) < $width} { + set p_tr [lindex $rowTop [expr {$x + 1}]] + set p_bl [lindex $rowBottom $x] + set p_br [lindex $rowBottom [expr {$x + 1}]] + } else { + # Pad horizontally if image width is odd + set p_tr $p_tl; set p_bl $p_tl; set p_br $p_tl + } + + # Calculate individual pixel luminance values (Standard Rec. 601 weights) + set l_tl [expr {[lindex $p_tl 0]*0.299 + [lindex $p_tl 1]*0.587 + [lindex $p_tl 2]*0.114}] + set l_tr [expr {[lindex $p_tr 0]*0.299 + [lindex $p_tr 1]*0.587 + [lindex $p_tr 2]*0.114}] + set l_bl [expr {[lindex $p_bl 0]*0.299 + [lindex $p_bl 1]*0.587 + [lindex $p_bl 2]*0.114}] + set l_br [expr {[lindex $p_br 0]*0.299 + [lindex $p_br 1]*0.587 + [lindex $p_br 2]*0.114}] + + # Block Threshold: Local average brightness + set avg_lum [expr {($l_tl + $l_tr + $l_bl + $l_br) / 4.0}] + + # Build the 4-bit structure index mapping bitwise states + set bitmask 0 + if {$l_tl >= $avg_lum} { set bitmask [expr {$bitmask | 8}] } + if {$l_tr >= $avg_lum} { set bitmask [expr {$bitmask | 4}] } + if {$l_bl >= $avg_lum} { set bitmask [expr {$bitmask | 2}] } + if {$l_br >= $avg_lum} { set bitmask [expr {$bitmask | 1}] } + + # Segregate pixels into foreground (bright) and background (dark) sets + set fg_r 0; set fg_g 0; set fg_b 0; set fg_count 0 + set bg_r 0; set bg_g 0; set bg_b 0; set bg_count 0 + + foreach p [list $p_tl $p_tr $p_bl $p_br] lum [list $l_tl $l_tr $l_bl $l_br] { + if {$lum >= $avg_lum} { + incr fg_r [lindex $p 0]; incr fg_g [lindex $p 1]; incr fg_b [lindex $p 2] + incr fg_count + } else { + incr bg_r [lindex $p 0]; incr bg_g [lindex $p 1]; incr bg_b [lindex $p 2] + incr bg_count + } + } + + # Compute color averages for both states + if {$fg_count > 0} { + set fR [expr {$fg_r / $fg_count}]; set fG [expr {$fg_g / $fg_count}]; set fB [expr {$fg_b / $fg_count}] + } else { + set fR 0; set fG 0; set fB 0 + } + if {$bg_count > 0} { + set bR [expr {$bg_r / $bg_count}]; set bG [expr {$bg_g / $bg_count}]; set bB [expr {$bg_b / $bg_count}] + } else { + # If everything is uniform, match foreground color to prevent ghosting borders + set bR $fR; set bG $fG; set bB $fB + } + + # Pull symbol match out of the layout map + set symbol $MOSAIC_MAP($bitmask) + + # Generate the combined true color escape output string + append outputBuffer "\x1b\[48\;2\;${bR}\;${bG}\;${bB}m\x1b\[38\;2\;${fR}\;${fG}\;${fB}m${symbol}" + } + append outputBuffer "\x1b\[m\n" + } + return $outputBuffer + } + # ------------------------------------------------------------- + # High-Density 8x4 Block (Braille Mosaic) Rendering Engine + # ------------------------------------------------------------- + proc renderBrailleDensity {allRows width height} { + set outputBuffer "" + fconfigure stdout -encoding utf-8 + + # We skip 8 vertical rows and 4 horizontal pixels per cell cycle + # to achieve a 4x reduction factor (accounting for terminal aspect ratios) + for {set y 0} {$y < $height} {incr y 8} { + + # Buffer up to 8 rows for processing this line + set activeRows [list] + for {set r 0} {$r < 8} {incr r} { + if {($y + $r) < $height} { + lappend activeRows [lindex $allRows [expr {$y + $r}]] + } else { + lappend activeRows "" ;# Pad vertical overflow with empty lines + } + } + + for {set x 0} {$x < $width} {incr x 4} { + + # --- 1. Downsample the 8x4 cluster into a 4x2 grid for Braille --- + # Each cell in our 4x2 grid averages a 2x2 pixel area from the image + set subGridLums [list 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0] + set subGridRgbs [list] + set totalBlockLum 0.0 + + set cellIdx 0 + for {set subY 0} {$subY < 8} {incr subY 2} { + for {set subX 0} {$subX < 4} {incr subX 2} { + + # Accumulate colors for this specific 2x2 sub-pixel zone + set sR 0; set sG 0; set sB 0; set sCount 0 + for {set dy 0} {$dy < 2} {incr dy} { + set rowIdx [expr {$subY + $dy}] + set currRow [lindex $activeRows $rowIdx] + if {$currRow eq ""} { continue } + + for {set dx 0} {$dx < 2} {incr dx} { + set pixelX [expr {$x + $subX + $dx}] + if {$pixelX >= $width} { continue } + + set pixel [lindex $currRow $pixelX] + incr sR [lindex $pixel 0] + incr sG [lindex $pixel 1] + incr sB [lindex $pixel 2] + incr sCount + } + } + + # Store sub-zone averages + if {$sCount > 0} { + set sR [expr {$sR / $sCount}]; set sG [expr {$sG / $sCount}]; set sB [expr {$sB / $sCount}] + } else { + set sR 0; set sG 0; set sB 0 + } + + set sLum [expr {$sR*0.299 + $sG*0.587 + $sB*0.114}] + lset subGridLums $cellIdx $sLum + lappend subGridRgbs [list $sR $sG $sB] + set totalBlockLum [expr {$totalBlockLum + $sLum}] + incr cellIdx + } + } + + # --- 2. Calculate Thresholding & Grouping --- + set avgBlockLum [expr {$totalBlockLum / 8.0}] + + set fg_r 0; set fg_g 0; set fg_b 0; set fg_count 0 + set bg_r 0; set bg_g 0; set bg_b 0; set bg_count 0 + set brailleOffset 0 + + # Unicode Braille bitmask generation table for 4x2 cells + # Maps sequential list index (0-7) to Unicode Braille bit flags + set bitWeights [list 1 8 2 16 4 32 64 128] + + for {set i 0} {$i < 8} {incr i} { + set sLum [lindex $subGridLums $i] + set sRgb [lindex $subGridRgbs $i] + + if {$sLum >= $avgBlockLum} { + # This sub-zone is bright: Turn on the Braille dot + set brailleOffset [expr {$brailleOffset | [lindex $bitWeights $i]}] + incr fg_r [lindex $sRgb 0]; incr fg_g [lindex $sRgb 1]; incr fg_b [lindex $sRgb 2] + incr fg_count + } else { + # This sub-zone is dark + incr bg_r [lindex $sRgb 0]; incr bg_g [lindex $sRgb 1]; incr bg_b [lindex $sRgb 2] + incr bg_count + } + } + + # --- 3. Compute Final Colors --- + if {$fg_count > 0} { + set fR [expr {$fg_r / $fg_count}]; set fG [expr {$fg_g / $fg_count}]; set fB [expr {$fg_b / $fg_count}] + } else { + set fR 0; set fG 0; set fB 0 + } + if {$bg_count > 0} { + set bR [expr {$bg_r / $bg_count}]; set bG [expr {$bg_g / $bg_count}]; set bB [expr {$bg_b / $bg_count}] + } else { + set bR $fR; set bG $fG; set bB $fB + } + + # Construct the final Unicode character using the Braille base boundary block (\u2800) + set brailleChar [format %c [expr {0x2800 + $brailleOffset}]] + + # Append the ANSI sequence + append outputBuffer "\x1b\[48\;2\;${bR}\;${bG}\;${bB}m\x1b\[38\;2\;${fR}\;${fG}\;${fB}m${brailleChar}" + } + append outputBuffer "\x1b\[m\n" + } + return $outputBuffer + } + + if {$symbols} { + # return [renderSymbols $allRows $width $height] + return [renderBrailleDensity $allRows $width $height] + } + + set outputBuffer "" + for {set y 0} {$y < $height} {incr y 2} { + set topRow [lindex $allRows $y] + #if image has an odd height, use pure black {0 0 0} for the missing bottom row of the final half-block character row. + set hasBottom [expr {$y + 1 < $height}] + if {$hasBottom} { + set bottomRow [lindex $allRows [expr {$y + 1}]] + } + for {set x 0} {$x < $width } {incr x} { + #set topIdx [lindex $topRow $x] + set topRgb [lindex $topRow $x] + set tR [lindex $topRgb 0] + set tG [lindex $topRgb 1] + set tB [lindex $topRgb 2] + if {$hasBottom} { + #set bottomIdx [lindex $bottomRow $x] + set bottomRgb [lindex $bottomRow $x] + set bR [lindex $bottomRgb 0] + set bG [lindex $bottomRgb 1] + set bB [lindex $bottomRgb 2] + } else { + set bR 0 + set bG 0 + set bB 0 + } + foreach v {bR bG bB tR tG tB} { + if {[set $v] eq ""} { + set $v 0 + } + } + append outputBuffer [format "\x1b\[38\;2\;%d\;%d\;%dm\x1b\[48\;2\;%d\;%d\;%dm▄" $tR $tG $tB $bR $bG $bB] + } + append outputBuffer "\x1b\[m\n" ;# Reset row styling + } + + return $outputBuffer + } + + proc pngfileToAnsi {filename} { + set f [open $filename rb] + set pngdata [read $f] + close $f + return [pngdataToAnsi $pngdata] + } + +} tcl::namespace::eval punk::ansi::internal { proc splitn {str {len 1}} { #from textutil::split::splitn diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/ansi/sauce-0.1.0.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/ansi/sauce-0.1.0.tm index e7428d84..0d3b53de 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/ansi/sauce-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/ansi/sauce-0.1.0.tm @@ -39,32 +39,35 @@ tcl::namespace::eval punk::ansi::sauce { proc from_file {fname} { if {[file size $fname] < 128} { - return + return [dict create posn -1] } set fd [open $fname r] chan conf $fd -translation binary chan seek $fd -128 end + set sauce_block_posn [expr {[chan tell $fd] -1}] ;#entire sauce block including ctrl-z and any comments - initial value assuming no comments + #If we treat the ctrl-z (\x1a) as part of the sauce - actual start of entire sauce info is 1 before sauce_header_posn, + #or further back if there are comments. set srec [read $fd] set srec_len 128 ;#This is the normal length of a SAUCE record - we may need to set it shorter if truncation detected if {[catch {set sdict [to_dict $srec]}]} { #review - have seen truncated SAUCE records < 128 bytes #we could search for SAUCE00 in the tail and see what records can be parsed? #specifically publicdomain roysac images sometimes only 99 Bytes of sauce - suspect remaining were null \x0 padded and trimmed - set sauceposn [string first SAUCE00 $srec] - if {$sauceposn <= 0} { + set saucestart [string first SAUCE00 $srec] + if {$saucestart <= 0} { close $fd - return + return [dict create posn -1] } #emit something to give user an indication something isn't right puts stderr "punk::ansi::sauce::from_file WARNING SAUCE record seems to be truncated - padding rhs with nulls and trying again.." #SAUCE00 is not at the beginning #pad the tail with nulls and try again - set srec [string range $srec $sauceposn end] + set srec [string range $srec $saucestart end] set srec_len [string length $srec] set srec ${srec}[string repeat \x0 [expr {128 - [string length $srec]}]] if {[catch {set sdict [to_dict $srec]}]} { close $fd - return + return [dict create posn -1] } dict set sdict warning "SAUCE truncation to $srec_len bytes detected" } @@ -73,6 +76,7 @@ tcl::namespace::eval punk::ansi::sauce { #Use srec_len instead of 128 - in case we had truncated source record which we padded and were able to parse set offset [expr {-1 *($srec_len + ($clines * 64) + 5)}] chan seek $fd $offset end + set sauce_block_posn [expr {[chan tell $fd] -1}] ;#entire sauce block including ctrl-z and any comments set tag [chan read $fd 5] if {$tag eq "COMNT"} { #'character' data - shouldn't be null terminated c-style string - but can be @@ -95,6 +99,7 @@ tcl::namespace::eval punk::ansi::sauce { dict set sdict commentlines $commentlines } } + dict set sdict posn $sauce_block_posn close $fd return $sdict } @@ -213,7 +218,9 @@ tcl::namespace::eval punk::ansi::sauce { - + #--------------------------------------------------------------------------------------------------------------------------------------------- + # This data comes from the sauce spec. + #--------------------------------------------------------------------------------------------------------------------------------------------- #todo - fontName - which can also specify e.g code page 437 ## Font name [1] Font size Resolution [2] Aspect ratio [3] Vertical stretch [6] Description ## Display [4] Pixel [5] @@ -221,7 +228,14 @@ tcl::namespace::eval punk::ansi::sauce { set fontnames [dict create] ## IBM VGA 9×16 [7] 720×400 4:3 20:27 (1:1.35) 35% Standard hardware font on VGA cards for 80×25 text mode (code page 437) - dict set fontnames "IBM VGA" [list fontsize "9x16" resolution "720x400" aspect_ratio_display "4:3" aspect_ratio_pixel "20:27 (1:1.35)" vertical_stretch "35%" description "Standard hardware font on VGA cards for 80×25 text mode (code page 437)"] + dict set fontnames "IBM VGA" [list {*}{ + fontsize "9x16" + resolution "720x400" + aspect_ratio_display "4:3" + aspect_ratio_pixel "20:27 (1:1.35)" + vertical_stretch "35%" + description "Standard hardware font on VGA cards for 80×25 text mode (code page 437)" + }] ## IBM VGA ### [8] 9×16 [7] 720×400 4:3 20:27 (1:1.35) 35% Software installed code page font for VGA 80×25 text mode # - where ### is placeholder for 437,720,737 etc @@ -247,6 +261,7 @@ tcl::namespace::eval punk::ansi::sauce { ## C64 PETSCII unshifted 8×8 [10] 320×200 4:3 5:6 (1:1.2) 20% Original Commodore PETSCII font (PET, VIC-20, C64, CBM-II, Plus/4, C16, C116 and C128) in the unshifted mode. Unshifted mode (graphics) only has uppercase letters and additional graphic characters. This is the normal boot font. ## C64 PETSCII shifted 8×8 [10] 320×200 4:3 5:6 (1:1.2) 20% Original PETSCII font in shifted mode. Shifted mode (text) has both uppercase and lowercase letters. This mode is actuated by pressing Shift+Commodore key. ## Atari ATASCII 8×8 [11] 320×192 4:3 4:5 (1:1.25) 25% Original ATASCII font (Atari 400, 800, XL, XE) + #--------------------------------------------------------------------------------------------------------------------------------------------- #expect a 128 Byte sauce record @@ -256,6 +271,7 @@ tcl::namespace::eval punk::ansi::sauce { variable datatypes variable filetypes variable encodings + set warnings [list] if {[string length $saucerecord] != 128} { error "punk::ansi::sauce::to_dict: Unable to interpret data as a SAUCE record - length != 128" } @@ -321,6 +337,8 @@ tcl::namespace::eval punk::ansi::sauce { dict set sdict filetype_name "" } } else { + #how can a byte fail to scan with cu? is this even reachable? + puts stderr "punk::ansi::sauce::to_dict filetype byte failed to scan - setting filetype and filetype_name to empty string byte: [ansistring VIEW -lf 1 [string range $saucerecord 95 95]]" dict set sdict filetype "" dict set sdict filetype_name "" } @@ -417,25 +435,40 @@ tcl::namespace::eval punk::ansi::sauce { 5 { #binarytext #filetype is supposed to represent half the characterwidth (only widths with multiples of 2 can be specified) - #HOWEVER - in the wild we may see width/height specified in tinfo1/tinfo2 with some other value in filetype (eg 1) - #If both tinfo1 and tinfo2 are non zero - we will use them, even though it's not in spec. - set t1 [dict get $sdict tinfo1] - if {$t1 eq ""} { - set t1 0 - } - set t2 [dict get $sdict tinfo2] - if {$t2 eq ""} { - set t2 0 + #HOWEVER - in the wild we may see width/height specified in tinfo1/tinfo2 with some apparently unrelated value in filetype (eg 0 or 1) that doesn't match the intended image dimensions. + #If both tinfo1 and tinfo2 are non zero - we *could* use them, even though it's not in spec. + #An example file (us-used1.bin) has filetype 0 and tinfo1/tinfo2 640/350 + #It's possible tinfo1/tinfo2 represent pixel dimensions for a 'standard' 8x16 font, but this image is 160 columns wide, so we would expect tinfo1 to be 1280. + #The sauce spec seems to indicate we should ignore tinfo1/tinfo2 for binarytext and only use filetype to determine width. + #the default for binarytext is 160 columns. + + #filetype 1 is theoretically possible, representing 2 columns + #in practice we see this value for binarytext images that are definitely not intended to be 2 columns wide. Why? + #is there some assumption that that images are at least a certain width, and filetype has been repurposed to indicate something else? + #The spec would seem to rule out images of a single column due to filetype being half the character width but a value of 0.5 isn't supported. + #It specifically mentions that only even widths up to 510 can be specified. ($filetype * 2 where filetype is 1-255?) + + + #proper mechanism to specify columns for binarytext is the datatype field. + set cols [expr {2*[dict get $sdict filetype]}] + if {$cols == 0} { + lappend warnings "binarytext filetype value of [dict get $sdict filetype] - using binarytext default cols of 160" + #default for binarytext is 160 columns + set cols 160 } - if {$t1 != 0 && $t2 != 0} { + if {$cols == 2 && [dict get $sdict tinfo1] != 0 && [dict get $sdict tinfo2] != 0} { #not to spec - but we will assume these have values for a reason.. - puts stderr "punk::ansi::sauce::to_dict using tinfo1/tinfo2 data for columns/rows (non-compliant SAUCE data)" - dict set sdict columns [expr {2 * $t1}] - dict set sdict rows $t2 + #--------------------------------------------------------------------------------------------------------------------- + #The sample file src/testansi/formatsamples/image/binaryText/test.bin has a filetype 1 and tinfo1 40 and tinfo2 25. + #(similarly ppe-ansi.bin has tinfo1 80 and tinfo2 26) + #They seem to use the 1 in filetype to indicate that the tinfo1/tinfo2 values should be used. + #(The 80 cols wide test.bin binaryText image matches the xbin sample file src/testansi/formatsamples/image/xbin/test.xb which is a more fully specified format using a header) + #--------------------------------------------------------------------------------------------------------------------- + lappend warnings "binarytext filetype of 1 with non-zero tinfo1/tinfo2 - using tinfo1/tinfo2 data for columns/rows (possibly non-conforming SAUCE data - matching observed data in the wild)" + set cols [expr {2 * [dict get $sdict tinfo1]}] + dict set sdict columns $cols + dict set sdict rows [dict get $sdict tinfo2] } else { - #proper mechanism to specify columns for binarytext is the datatype field. - - set cols [expr {2*[dict get $sdict filetype]}] dict set sdict columns $cols #rows must be calculated from file size #rows = (filesize - sauceinfosize)/ filetype * 2 * 2 @@ -447,11 +480,13 @@ tcl::namespace::eval punk::ansi::sauce { } 6 { - #xbin - only filtype is 0 + #xbin - only filetype is 0 #https://web.archive.org/web/20120204063040/http://www.acid.org/info/xbin/x_spec.htm dict set sdict columns [dict get $sdict tinfo1] dict set sdict rows [dict get $sdict tinfo2] dict set sdict fontname [dict get $sdict tinfos] + #Values from sauce record are probably only informational, because xbin has an 11-byte header with width,height,fontsize and flags. + #presumably the header-info should take precedence over all sauce data (? review) } } if {[dict exists $sdict fontname]} { @@ -474,6 +509,9 @@ tcl::namespace::eval punk::ansi::sauce { } } } + if {[llength $warnings]} { + dict set sdict warnings $warnings + } return $sdict } diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args-0.2.1.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args-0.2.1.tm index 1ff7fd37..24c2ddf7 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args-0.2.1.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args-0.2.1.tm @@ -9086,7 +9086,7 @@ tcl::namespace::eval punk::args { } if {!([tcl::string::first " " $a]>=0 || [tcl::string::first \t $a]>=0 || [tcl::string::last \n $a]>=0)} { if {$OPT_ANY} { - #exlude argument with whitespace from being a possible option e.g dict + #exclude argument with whitespace from being a possible option e.g dict #todo - passthrough of unrecognised --longopt=xxx without looking for following flag-value set eposn [string first = $a] if {$eposn > 2 && [string match --* $a]} { diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/char-0.1.0.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/char-0.1.0.tm index 53ef8ec1..349cc3b7 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/char-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/char-0.1.0.tm @@ -3033,14 +3033,18 @@ tcl::namespace::eval punk::char { #This still leaves a whole class of clusters.. korean etc unhandled :/ #todo - tk::startOfCluster / tk::endOfCluster - try to get it brought into Tcl #https://core.tcl-lang.org/tcl/tktview/a4c7eeaf63 - proc grapheme_split {text} { + proc grapheme_split {text {return list}} { #we should treat \r\n as a single grapheme cluster (as tk::endOfCluster does) set components [list] set csplits [combiner_split $text] foreach {pt combiners} [lrange $csplits 0 end-1] { set clist [split $pt ""] - lappend components {*}[lrange $clist 0 end-1] - lappend components [tcl::string::cat [lindex $clist end] $combiners] + #review + #lset clist end [tcl::string::cat [lindex $clist end] $combiners] + ledit clist end end [tcl::string::cat [lindex $clist end] $combiners] + lappend components {*}$clist + #lappend components {*}[lrange $clist 0 end-1] + #lappend components [tcl::string::cat [lindex $clist end] $combiners] } #last csplit never has a combiner (_perlish_split style) - and may be empty - in which case we don't append it as a grapheme if {[lindex $csplits end] ne ""} { @@ -3066,127 +3070,126 @@ tcl::namespace::eval punk::char { #review \uFE0F variation selector 16 - forces emoji presentation for preceding char - if 1 { - #This is a basic implementation that does not check that all combinations are valid. - set graphemes [list] - set current_cluster "" - - set cluster_base 0 ;#is the current cluster based on a char that can be combined with modifiers/ZWJs (e.g emoji or other cluster-based char) - # or is it based on a char that can't be combined with modifiers/ZWJs (e.g ascii letter) - set cluster_base_RI 0 ;#is the current cluster based on a regional indicator char - which can only combine in pairs, and don't combine with modifiers or ZWJs to form longer clusters - so not extensible. - - set current_cluster_is_extensible 0 - for {set i 0} {$i < [llength $components] } {incr i} { - set component [lindex $components $i] - if {$component eq "\r" && [lindex $components $i+1] eq "\n"} { - if {$current_cluster ne ""} { - lappend graphemes $current_cluster - } - lappend graphemes "\r\n" - incr i ;#skip the \n as we've already processed it as part of the cluster - set current_cluster "" - grapheme_split::reset_base + #This is a basic implementation that does not check that all combinations are valid. + set graphemes [list] + set current_cluster "" + + set cluster_base 0 ;#is the current cluster based on a char that can be combined with modifiers/ZWJs (e.g emoji or other cluster-based char) + # or is it based on a char that can't be combined with modifiers/ZWJs (e.g ascii letter) + set cluster_base_RI 0 ;#is the current cluster based on a regional indicator char - which can only combine in pairs, and don't combine with modifiers or ZWJs to form longer clusters - so not extensible. + + set current_cluster_is_extensible 0 + for {set i 0} {$i < [llength $components] } {incr i} { + set component [lindex $components $i] + if {$component eq "\r" && [lindex $components $i+1] eq "\n"} { + if {$current_cluster ne ""} { + lappend graphemes $current_cluster + } + lappend graphemes "\r\n" + incr i ;#skip the \n as we've already processed it as part of the cluster + set current_cluster "" + set cluster_base 0; set cluster_base_RI 0 ;#grapheme_split::reset_base + set current_cluster_is_extensible 0 + } elseif {$component eq "\u200d"} { + if {$current_cluster eq ""} { + #ZWJ at start of string - treat as separate grapheme cluster - but isn't a valid base for further combining with more ZWJs or modifiers + set current_cluster $component + set cluster_base 0; set cluster_base_RI 0 ;#grapheme_split::reset_base set current_cluster_is_extensible 0 - } elseif {$component eq "\u200d"} { - if {$current_cluster eq ""} { - #ZWJ at start of string - treat as separate grapheme cluster - but isn't a valid base for further combining with more ZWJs or modifiers - set current_cluster $component - grapheme_split::reset_base - set current_cluster_is_extensible 0 - } else { - if {$cluster_base} { - if {$current_cluster_is_extensible} { - #a double (or longer) ZWJ sequence in a row is part of the last cluster - but not extensible anymore. - append current_cluster $component - set current_is_cluster_extensible 0 - } else { - append current_cluster $component - if {$cluster_base_RI} { - #regional indicators can only combine in pairs, and don't combine with modifiers or ZWJs to form longer clusters - so not extensible. - grapheme_split::reset_base - set current_cluster_is_extensible 0 - #we can keep adding ZWJs or modifiers though - } else { - set current_cluster_is_extensible 1 - } - } + } else { + if {$cluster_base} { + if {$current_cluster_is_extensible} { + #a double (or longer) ZWJ sequence in a row is part of the last cluster - but not extensible anymore. + append current_cluster $component + set current_is_cluster_extensible 0 } else { - #ZWJ after non-cluster-based char - non extensible but we continue appending ZWJs to the current cluster. append current_cluster $component - set current_cluster_is_extensible 0 - } - - } - } elseif {[regexp {[\U1f3fb-\U1f3ff]} $component]} { - #emoji modifier - join with previous component - if {$current_cluster eq ""} { - #modifier at start of string - not a valid base for further combining with more modifiers or ZWJs - but we continue appending modifiers to the current cluster. - set current_cluster $component - grapheme_split::reset_base - } else { - if {$cluster_base} { - if {$current_cluster_is_extensible} { - append current_cluster $component - #invalidate the base! - grapheme_split::reset_base + if {$cluster_base_RI} { + #regional indicators can only combine in pairs, and don't combine with modifiers or ZWJs to form longer clusters - so not extensible. + set cluster_base 0; set cluster_base_RI 0 ;#grapheme_split::reset_base + set current_cluster_is_extensible 0 + #we can keep adding ZWJs or modifiers though } else { - append current_cluster $component + set current_cluster_is_extensible 1 } + } + } else { + #ZWJ after non-cluster-based char - non extensible but we continue appending ZWJs to the current cluster. + append current_cluster $component + set current_cluster_is_extensible 0 + } + + } + } elseif {[regexp {[\U1f3fb-\U1f3ff]} $component]} { + #emoji modifier - join with previous component + if {$current_cluster eq ""} { + #modifier at start of string - not a valid base for further combining with more modifiers or ZWJs - but we continue appending modifiers to the current cluster. + set current_cluster $component + set cluster_base 0; set cluster_base_RI 0 ;#grapheme_split::reset_base + } else { + if {$cluster_base} { + if {$current_cluster_is_extensible} { + append current_cluster $component + #invalidate the base! + set cluster_base 0; set cluster_base_RI 0 ;#grapheme_split::reset_base } else { - #modifier after non-cluster-based char - non extensible but we continue appending modifiers to the current cluster. append current_cluster $component } - #review - # \u1f33e\u1f3fe\u200d\u2f3fe\u200d\u1f33e is 2 clusters - #This is because after first zwj, we applied a modifier - not a valid base. + } else { + #modifier after non-cluster-based char - non extensible but we continue appending modifiers to the current cluster. + append current_cluster $component } - set current_cluster_is_extensible 0 + #review + # \u1f33e\u1f3fe\u200d\u2f3fe\u200d\u1f33e is 2 clusters + #This is because after first zwj, we applied a modifier - not a valid base. + } + set current_cluster_is_extensible 0 + } else { + if {$current_cluster eq ""} { + grapheme_split::start_cluster $component } else { - if {$current_cluster eq ""} { - grapheme_split::start_cluster $component - } else { - #have existing cluster data - if {$current_cluster_is_extensible} { - #assert - if current_cluster_is_extensible then cluster_base should currently be true. - #if the current char is a base - we can append to existing cluster, but if it's not a base, then we start a new cluster even if we had seen a ZWJ before. - if {[regexp {[\U1f600-\U1f64f\U1f300-\U1f5ff\U1f900-\U1f9ff\U1fa70-\U1faff\U1f680-\U1f6ff\U2700-\U27bf\U2600-\u26ff]} $component]} { - append current_cluster $component - set cluster_base 1 - } else { - lappend graphemes $current_cluster - set current_cluster $component - grapheme_split::reset_base - } - set current_cluster_is_extensible 0 - } elseif {$cluster_base_RI} { - #regional indicators can only combine in pairs, and don't combine with modifiers or ZWJs to form longer clusters - so not extensible. - if {[regexp {[\U1f1e6-\U1f1ff]} $component]} { - append current_cluster $component - - #invalidate the base - we can't combine more than 2 RIs in a cluster, and they don't combine with modifiers or ZWJs to form longer clusters. - #we can however add more ZWJs or modifiers to the cluster - but they don't make it extensible for combining with more RIs - grapheme_split::reset_base - } else { - #something else while RI cluster is open - end the current cluster and start a new one with the current char. - lappend graphemes $current_cluster - grapheme_split::start_cluster $component - } - set current_cluster_is_extensible 0 + #have existing cluster data + if {$current_cluster_is_extensible} { + #assert - if current_cluster_is_extensible then cluster_base should currently be true. + #if the current char is a base - we can append to existing cluster, but if it's not a base, then we start a new cluster even if we had seen a ZWJ before. + if {[regexp {[\U1f600-\U1f64f\U1f300-\U1f5ff\U1f900-\U1f9ff\U1fa70-\U1faff\U1f680-\U1f6ff\U2700-\U27bf\U2600-\u26ff]} $component]} { + append current_cluster $component + set cluster_base 1 + } else { + lappend graphemes $current_cluster + set current_cluster $component + set cluster_base 0; set cluster_base_RI 0 ;#grapheme_split::reset_base + } + set current_cluster_is_extensible 0 + } elseif {$cluster_base_RI} { + #regional indicators can only combine in pairs, and don't combine with modifiers or ZWJs to form longer clusters - so not extensible. + if {[regexp {[\U1f1e6-\U1f1ff]} $component]} { + append current_cluster $component + + #invalidate the base - we can't combine more than 2 RIs in a cluster, and they don't combine with modifiers or ZWJs to form longer clusters. + #we can however add more ZWJs or modifiers to the cluster - but they don't make it extensible for combining with more RIs + set cluster_base 0; set cluster_base_RI 0 ;#grapheme_split::reset_base } else { + #something else while RI cluster is open - end the current cluster and start a new one with the current char. lappend graphemes $current_cluster grapheme_split::start_cluster $component } + set current_cluster_is_extensible 0 + } else { + lappend graphemes $current_cluster + grapheme_split::start_cluster $component } } } - if {$current_cluster ne ""} { - lappend graphemes $current_cluster - } + } + if {$current_cluster ne ""} { + lappend graphemes $current_cluster + } + if {$return eq "list"} { + return $graphemes } else { - set graphemes $components + return [dict create list $graphemes last_extensible $current_cluster_is_extensible base $cluster_base RI_base $cluster_base_RI] } - - return $graphemes } namespace eval grapheme_split { proc about {} { diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/console-0.1.1.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/console-0.1.1.tm index b7c4cd7a..913e09ac 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/console-0.1.1.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/console-0.1.1.tm @@ -71,11 +71,6 @@ package require punk::args -#if {"windows" eq $::tcl_platform(platform)} { -# #package require zzzload -# #zzzload::pkg_require twapi -#} - #see https://learn.microsoft.com/en-us/windows/console/classic-vs-vt #https://learn.microsoft.com/en-us/windows/console/creating-a-pseudoconsole-session diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/du-0.1.0.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/du-0.1.0.tm index 8dd91089..ca7f58e9 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/du-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/du-0.1.0.tm @@ -2529,21 +2529,30 @@ namespace eval punk::du { #jmn disable twapi #tailcall du_dirlisting_generic $folderpath {*}$args - package require zzzload - set loadstate [zzzload::pkg_require twapi] - - if {$loadstate ni [list loading failed]} { - #either already loaded by zzload or ordinary package require - package require twapi ;#should be fast once twapi dll loaded in zzzload thread + #package require zzzload + #set loadstate [zzzload::pkg_require twapi] + + #if {$loadstate ni [list loading failed]} { + # #either already loaded by zzload or ordinary package require + # package require twapi ;#should be fast once twapi dll loaded in zzzload thread + # set ::punk::du::has_twapi 1 + # punk::du::active::set_active_function du_dirlisting du_dirlisting_twapi + # tailcall du_dirlisting_twapi $folderpath {*}$args + #} else { + # if {$loadstate eq "failed"} { + # puts stderr "punk::du defaulting to du_dirlisting_generic because twapi load failed" + # punk::du::active::set_active_function du_dirlisting du_dirlisting_generic + # } + # tailcall du_dirlisting_generic $folderpath {*}$args + #} + if {[catch {package require twapi} errM]} { + puts stderr "punk::du defaulting to du_dirlisting_generic because twapi load failed: $errM" + punk::du::active::set_active_function du_dirlisting du_dirlisting_generic + tailcall du_dirlisting_generic $folderpath {*}$args + } else { set ::punk::du::has_twapi 1 punk::du::active::set_active_function du_dirlisting du_dirlisting_twapi tailcall du_dirlisting_twapi $folderpath {*}$args - } else { - if {$loadstate eq "failed"} { - puts stderr "punk::du defaulting to du_dirlisting_generic because twapi load failed" - punk::du::active::set_active_function du_dirlisting du_dirlisting_generic - } - tailcall du_dirlisting_generic $folderpath {*}$args } } default { diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/lib-0.1.6.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/lib-0.1.6.tm index ada0f900..5fecb48d 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/lib-0.1.6.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/lib-0.1.6.tm @@ -138,36 +138,29 @@ tcl::namespace::eval punk::lib::check { if {"windows" ne $::tcl_platform(platform)} { set bug 0 } else { - if {![catch {file tempdir} tmpdir]} { - #tcl 9+ has 'file tempdir' - set testfile [file join $tmpdir "bugtest"] - } else { - #fallback for older tcl versions - use env TEMP/TMP or current directory - set tmpdir "" - foreach e {TEMP TMP} { - if {[info exists ::env($e)] && [file isdirectory ::env($e)]} { - set tmpdir ::env($e) + set tmpdir [punk::lib::tempdir_newfolder] ;#uses 'file tempdir' on tcl9+ or fallback to env vars or current directory on older versions + set testfile [file join $tmpdir "bugtest"] + + try { + set fd [open $testfile w] + puts $fd test + close $fd + set globresult [glob -nocomplain -directory $tmpdir -types f -tail BUGTEST {BUGTES{T}} {[B]UGTEST} {\BUGTEST} BUGTES? BUGTEST*] + if {[file exists $testfile]} { + file delete $testfile + } + foreach r $globresult { + if {$r ne "bugtest"} { + set bug 1 break } } - if {$tmpdir eq ""} { - #no env vars - fallback to current directory - set tmpdir [pwd] + } finally { + if {[file exists $testfile]} { + file delete $testfile } - set testfile [file join $tmpdir "bugtest"] - } - - set fd [open $testfile w] - puts $fd test - close $fd - set globresult [glob -nocomplain -directory $tmpdir -types f -tail BUGTEST {BUGTES{T}} {[B]UGTEST} {\BUGTEST} BUGTES? BUGTEST*] - if {[file exists $testfile]} { - file delete $testfile - } - foreach r $globresult { - if {$r ne "bugtest"} { - set bug 1 - break + if {[file exists $tmpdir]} { + file delete -force $tmpdir } } } @@ -679,7 +672,207 @@ namespace eval punk::lib { } } + namespace eval argdoc { + variable PUNKARGS + lappend PUNKARGS [list { + @id -id ::punk::lib::tempdir + @cmd -name punk::lib::tempdir\ + -summary\ + "Determine an appropriate temp dir for the process we are running under."\ + -help\ + "On windows: + If the process is running under the system account use the modern windows location: %SystemRoot%\SystemTemp + Detection of the system account relies on either twapi, or a combination of the whoami command and the + registry package. + Proceeds with same fallback logic as for other platforms if we fail to detect the system account or its temp location. + + + For other platforms we use the environment variables TMPDIR/TEMP/TMP or fallback to /tmp or /var/tmp if those + env vars aren't set or aren't writable directories. + + Final fallback attempt is the current working directory. + Result is normalized so resulting path will have forward slashes on all platforms. + + Alternatives: see the tcllib fileutil::tempdir function. + " + @values -min 0 -max 0 + }] + } + proc tempdir {} { + set trydirs [list] + if {"windows" eq $::tcl_platform(platform)} { + #review. + #consider also checking for whether running under various service accounts + + if {![catch {package require twapi}]} { + set tok [twapi::open_process_token] ;#first call is a little pricy. + set sid [twapi::get_token_user $tok] + if {$sid eq "S-1-5-18"} { + #system account - use system account temp location + set sysroot [twapi::get_shell_folder csidl_windows] ;#first call is a little pricy. + lappend trydirs [file join $sysroot "SystemTemp"] + } + #if not system account - use env vars as first choice. + } else { + #twapi not available - try to use builtin windows whoami to detect if we're running under system account - but this is less reliable than using twapi to check the process token - so we warn about it. + set whoami_exe [auto_execok whoami] + #test that system32 is somewhere in the whoami path as a basic attempt to avoid non-windows whoami commands that might be present in the path + set whoami_exe_parts [file split $whoami_exe] + if {"system32" in [string tolower $whoami_exe_parts]} { + set whoamiresult [string trim [exec {*}$whoami_exe /USER /FO LIST] \n\r] + set whoamiresult [string map {\r\n \n} $whoamiresult] + set whoamiresult_lines [split $whoamiresult \n] + set sid "" + foreach line $whoamiresult_lines { + if {[string match "SID:*" $line]} { + set sid [lindex $line 1] + break + } + } + set has_registry [expr {![catch {package require registry}]}] + if {$sid eq "S-1-5-18"} { + #system account - use system account temp location + set sysroot "" + if {$has_registry} { + #registry path is case-insensitive. + catch { + set sysroot [registry get {HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows NT\CurrentVersion} SystemRoot] + } + } else { + if {[info exists ::env(SystemRoot)]} { + set sysroot [set ::env(SystemRoot)] + } + } + if {$sysroot ne ""} { + lappend trydirs [file join $sysroot "SystemTemp"] + } + } + #if not system account - use env vars as first choice. + } + } + } + + foreach t {TMPDIR TEMP TMP} { + #TMPDIR is the posix standard as first choice for temp dir env var. + if {[info exists ::env($t)]} { + lappend trydirs $::env($t) + } + } + + if {"windows" ne $::tcl_platform(platform)} { + #suitable for macos,linux and freebsd at least. + lappend trydirs [file join / tmp] [file join / var tmp] + #/usr/tmp is probably not a common location for a temp dir on modern unix-based systems. + } + + foreach d $trydirs { + if {[file isdirectory $d] && [file writable $d]} { + return [file normalize $d] + } + } + + #only even call 'pwd' as a last resort (mildly slow on first call). + set cwd [pwd] + if {[file isdirectory $cwd] && [file writable $cwd]} { + return $cwd + } + + return -code error "punk::lib::tempdir unable to determine a suitable temp directory - tried: $trydirs" + } + + namespace eval argdoc { + variable PUNKARGS + lappend PUNKARGS [list { + @id -id ::punk::lib::tempdir_newfolder + @cmd -name punk::lib::tempdir_newfolder\ + -summary\ + "Create unique folder within temp dir (or cwd as last resort)"\ + -help\ + "Creates a new unique folder within the temp dir determined by punk::lib::tempdir. + The folder is created before returning its full path and will be empty. + The folder is named with a tcl_ prefix followed by a random string. + + See also: 'file tempdir' in tcl 9+ or fileutil::maketempdir from tcllib" + @opts + -dir -type string -default "" -help\ + "Base directory to create the temp folder in - defaults to the result of punk::lib::tempdir" + -prefix -type string -default tcl -help\ + "Prefix for the temp folder name + An underscore is automatically appended to the prefix in the generated folder name. + If prefix is the empty string - then the generated folder name will still be autoprefixed + with tcl_ (consistent with tcl9 'file tempdir')" + @values -min 0 -max 0 + }] + } + proc tempdir_newfolder {args} { + set argd [punk::args::parse $args withid ::punk::lib::tempdir_newfolder] + set opt_dir [dict get $argd opts -dir] + set opt_prefix [dict get $argd opts -prefix] + puts "opt_prefix: $opt_prefix" + if {[llength [file split $opt_prefix]] > 1} { + error "punk::lib::tempdir_newfolder -prefix option should not contain any path separators" + } + if {$opt_prefix eq ""} { + #don't allow empty prefix - for consistency with tcl9 'file tempdir' - which would still prefix with 'tcl_' even if prefix is empty string. + set opt_prefix "tcl" + } + + if {$opt_dir ne ""} { + if {[file isdirectory $opt_dir] && [file writable $opt_dir]} { + set tmpbase [file normalize $opt_dir] + } else { + error "punk::lib::tempdir_newfolder -dir option '$opt_dir' is not a writable directory" + } + } else { + set tmpbase [punk::lib::tempdir] ;#will raise an error if no writable temp dir or cwd found. + } + #assert: tmpbase has no trailing slash - unless it is a root dir (e.g / on unix, or C:/ on windows) + #assert: tmpbase is normalized with forward slashes on all platforms. + + set tcl9_template_base [string trimright $tmpbase "/"] ;#set it to a form that can join along with a forward slash to prefix for tcl 9 'file tempdir' style template. + #tcl9 'file tempdir' separates the prefix in the template from the random string with an underscore. + #now form template by always joining with a slash (even if opt_prefix is empty) + #(avoiding file join and file normalize to ensure template is properly formed) + #whether or not opt_prefix ends with an underscore - another will be added. (by file tempdir, or by our own code if tcl9 'file tempdir' isn't available) + #assert: opt_prefix is not empty string (will have defaulted to 'tcl') and does not contain any path separators. + set tcl9_template "$tcl9_template_base/$opt_prefix" + + + #tcl 9+ has 'file tempdir' + #we don't support the same template as 'file tempdir' + if {[catch {file tempdir $tcl9_template} tmpdir]} { + + set prefix tcl_ ;#todo - accept option: -prefix + + set chars abcddefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789 + set nrand_chars 8 + set maxtries 100 + for {set i 0} {$i < $maxtries} {incr i} { + set dirname ${opt_prefix}_ ;#always add underscore for consistency with tcl9 'file tempdir'. + for {set j 0} {$j < $nrand_chars} {incr j} { + append dirname [string index $chars [expr {int(rand()*62)}]] + } + set path [file join $tmpbase $dirname] + if {[file exists $path]} { + continue + } + if {[catch { + file mkdir $path + if {"windows" ne $::tcl_platform(platform)} { + file attributes $path -permissions 0o700 + } + }]} { + continue + } + return $path + } + return -code error "punk::lib::tempdir_newfolder unable to create unique tempdir in $tmpbase after $maxtries attempts - too many collisions - aborting" + } + #tcl 9 'file tempdir' return. + #normalize because on early tcl 9 versions on windows it can return with mixed forward and backward slashes when a template is supplied with forward slashes. + return [file normalize $tmpdir] + } # == == == == == == == == == == == == == == == == == == == == == == == == == == == == == == == # Maintenance - This is the primary source for tm_version... functions @@ -814,6 +1007,89 @@ namespace eval punk::lib { error "tm_version_required_canonical should have already returned a canonicalised versionspec - or produced an error with reason before this point" } } + proc tm_version_magic {} { + #maintenance instruction: + # This specific 12 character nnnnnn.0a1.0 version number is used in text replacement when installing modules. + # It should not be modified without also considering the impact on existing projects based on punkshell that may have used this version number in their own code or documentation as a placeholder for tm version handling. + # A copy of this is also present in punk::lib. + # Essentially this should probably never be changed - and instead deprecated if we want to stop using it and replaced with a different mechanism/placeholder. + + #tm versioning is not quite the same as semantic versioning - but similarly we should see extremely high major version numbers rarely if ever in real use, + #even over decades of development. + set magicbase 999999 ;#deliberately large so given load-preference when testing! + #we split the literal to avoid the literal appearing here - reduce risk of accidentally converting to a release version + return ${magicbase}.0a1.0 + } + + namespace eval argdoc { + lappend PUNKARGS [list { + @id -id ::punk::lib::tm_split_name + @cmd -name punk::lib::tm_split_name\ + -summary\ + "Split a versioned module name into name and version parts, dropping trailing .tcl/.tm if any."\ + -help\ + "Splits a versioned module name (as present in a filename or namespaced name) into name and version parts, + Ignores any trailing .tm or .tcl file extension. + + If the fullmodulename given is a namespaced name - then the returned modulename will also be namespaced, + but with any leading :: removed. + + Returns a two element list - with the first element being the modulename and the second element being the version. + + Tcl module version numbers are understood with leading zeros in each dotted part, but leading zeros are not canonical. + + This split does not canonicalise the version number. + If the last dash-separated segment of the name doesn't look like a valid version number + - then it is treated as part of the modulename and an empty version string is returned. + e.g + mymod-1.2.3.tm -> mymod 1.2.3 + mymod-1aa2.3.tm -> mymod-1aa2.3 {} + (repeated a is not a valid version segment - so the entire '1aa2.3' is treated as part of the modulename) + + see also: tm_version_canonical + " + @values -min 1 -max 1 + fullmodulename -type string -help\ + "The full module name to split - as present in a filename or namespaced name. E.g: + mymod-1.2.3 + mymod-1.2.3.tm + mymod-1.2.3.tcl + /some/where/mymod-123.0a4.0.tm + mymod + mymod.tm + mymod.tcl + ns1::ns2::mymod-1.2.3 + ::ns1::ns2::mymod" + }] + } + proc tm_split_name {fullmodulename} { + #split modulename (as present in a filename or namespaced name) into name/version ignoring leading namespace path + #ignore trailing .tm .TM if present + #if version doesn't pass validation - treat it as part of the modulename and return empty version string without error + #Up to caller to validate. + set lastpart [namespace tail $fullmodulename] + set lastpart [file tail $lastpart] ;# should be ok to use file tail now that we've ensured no namespace components + if {[string tolower [file extension $fullmodulename]] in {.tcl .tm}} { + set fileparts [split [file rootname $lastpart] -] + } else { + set fileparts [split $lastpart -] + } + if {[tm_version_isvalid [lindex $fileparts end]]} { + set versionsegment [lindex $fileparts end] + set namesegment [join [lrange $fileparts 0 end-1] -];#re-stitch + } else { + set namesegment [join $fileparts -] + set versionsegment "" + } + set base [string trimleft [namespace qualifiers $fullmodulename] :] + if {$base ne ""} { + set modulename "${base}::$namesegment" + } else { + set modulename $namesegment + } + return [list $modulename $versionsegment] + } + # end tm_version... functions # == == == == == == == == == == == == == == == == == == == == == == == == == == == == == == == @@ -4210,6 +4486,9 @@ namespace eval punk::lib { if {[string index $key 0] ne "%"} { set key %$key } + #puts "---key:'$key'" + set key [string map {; \\;} $key] ;#review + #puts "---key:'$key'" #pipeline - use punk patterns. % thisval.= $key= $thisval } diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/cli-0.3.1.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/cli-0.3.1.tm index 793736b8..6ac3cc1e 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/cli-0.3.1.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/cli-0.3.1.tm @@ -499,7 +499,7 @@ namespace eval punk::mix::cli { # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- set opt_punkcheck_eventobj [dict get $opts -punkcheck_eventobj] - set magicversion [punk::mix::util::magic_tm_version] ;#deliberately large so given load-preference when testing + set magicversion [punk::mix::util::tm_version_magic] ;#deliberately large so given load-preference when testing set module_list [list] if {[file tail [file dirname $srcdir]] ne "src"} { diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/commandset/loadedlib-0.1.0.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/commandset/loadedlib-0.1.0.tm index a07aca09..2cc6ff98 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/commandset/loadedlib-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/commandset/loadedlib-0.1.0.tm @@ -54,13 +54,18 @@ namespace eval punk::mix::commandset::loadedlib { if {$opt_refresh} { catch {package require frobznodule666} ;#ensure pkg system has loaded/searched for everything REVIEW - this doesn't result in full scans foreach tm_path [tcl::tm::list] { + #review - todo - adjust punk::path::subfolders to take arguments to do some filtering itself rather than recurse down unnecessary branches. set paths_below [punk::path::subfolders -recursive $tm_path] foreach folder $paths_below { + if {[string match */_build/* $folder]} {continue} set tail [file tail $folder] - if {[string match #modpod-* $tail] || [string match #tarjar-* $tail]} { + if {[string match #tarjar-* $tail]} { + continue + } + if {[string match #modpod-* $tail]} { + #manually do a 'package ifneeded' fore each module found here. continue } - if {[string match */_build/* $folder]} {continue} set relpath [string tolower [punk::path::relative $tm_path $folder]] set modpath [string map {/ ::} $relpath] catch {package require ${modpath}::flobrudder99} diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/commandset/module-0.1.0.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/commandset/module-0.1.0.tm index 4c75b10e..3626d2d0 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/commandset/module-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/commandset/module-0.1.0.tm @@ -362,7 +362,7 @@ namespace eval punk::mix::commandset::module { file mkdir $modulefolder set moduletail [namespace tail $modulename] - set magicversion [punk::mix::util::magic_tm_version] ;#deliberately large so given load-preference when testing + set magicversion [punk::mix::util::tm_version_magic] ;#deliberately large so given load-preference when testing diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/commandset/project-0.1.0.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/commandset/project-0.1.0.tm index 8384197a..9b1263e3 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/commandset/project-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/commandset/project-0.1.0.tm @@ -380,25 +380,25 @@ namespace eval punk::mix::commandset::project { puts stdout ">>> about to call punkcheck::install $layout_path $projectdir" set resultdict [dict create] - set antipaths [list\ - src/doc/*\ - src/doc/include/*\ - src/PROJECT_LAYOUTS_*\ - ] - - #set antiglob_dir [list\ - # _ignore_*\ - #] - set antiglob_dir [list\ - ] - - #default antiglob_dir_core will stop .fossil* from being updated - which is generally desirable as these are likely to be customized + set antipaths [list {*}{ + src/doc/* + src/doc/include/* + src/PROJECT_LAYOUTS_* + }] + + #set exclude_dirsegments [list {*}{ + # _ignore_* + #}] + set exclude_dirsegments [list {*}{ + }] + + #default -exclude-dirsegments_core will stop .fossil* from being updated - which is generally desirable as these are likely to be customized if {$opt_force} { puts stdout "copying layout files - with force applied - overwrite all-targets" - set resultdict [punkcheck::install $layout_path $projectdir -installer project.new -createempty 1 -overwrite ALL-TARGETS -antiglob_paths $antipaths -antiglob_dir $antiglob_dir] + set resultdict [punkcheck::install $layout_path $projectdir -installer project.new -createempty 1 -overwrite ALL-TARGETS -antiglob_paths $antipaths -exclude-dirsegments $exclude_dirsegments] } else { puts stdout "copying layout files - (if source file changed)" - set resultdict [punkcheck::install $layout_path $projectdir -installer project.new -createempty 1 -overwrite installedsourcechanged-targets -antiglob_paths $antipaths -antiglob_dir $antiglob_dir] + set resultdict [punkcheck::install $layout_path $projectdir -installer project.new -createempty 1 -overwrite installedsourcechanged-targets -antiglob_paths $antipaths -exclude-dirsegments $exclude_dirsegments] } puts stdout [punkcheck::summarize_install_resultdict $resultdict] @@ -412,11 +412,11 @@ namespace eval punk::mix::commandset::project { #target folders .fossil-custom and .fossil-settings may not exist. use -createdir 1 to ensure existence. #In this case we need to override the default dir antiglob - as .fossil-xxx folders need to be installed from template if missing, or if target is uncustomized. - ## default_antiglob_dir_core [list "#*" "_aside" ".git" ".fossil*"] - set override_antiglob_dir_core [list #* _aside .git] + ## default_exclude_dirsegments_core [list "#*" "_aside" ".git" ".fossil*"] + set override_exclude_dirsegments_core [list #* _aside .git] if {[file exists $layout_path/.fossil-custom]} { puts stdout "copying layout src/.fossil-custom files (if target missing or uncustomised)" - set resultdict [punkcheck::install $layout_path/.fossil-custom $projectdir/.fossil-custom -createdir 1 -createempty 1 -punkcheck_folder $projectdir -installer project.new -antiglob_dir_core $override_antiglob_dir_core -overwrite SYNCED-TARGETS] + set resultdict [punkcheck::install $layout_path/.fossil-custom $projectdir/.fossil-custom -createdir 1 -createempty 1 -punkcheck_folder $projectdir -installer project.new -exclude-dirsegments_core $override_exclude_dirsegments_core -overwrite SYNCED-TARGETS] puts stdout [punkcheck::summarize_install_resultdict $resultdict] } else { puts stdout "no .fossil-custom in source template - update not required" @@ -424,7 +424,7 @@ namespace eval punk::mix::commandset::project { if {[file exists $layout_path/.fossil-settings]} { puts stdout "copying layout src/.fossil-settings files (if target missing or uncustomised)" - set resultdict [punkcheck::install $layout_path/.fossil-settings $projectdir/.fossil-settings -createdir 1 -createempty 1 -punkcheck_folder $projectdir -installer project.new -antiglob_dir_core $override_antiglob_dir_core -overwrite SYNCED-TARGETS] + set resultdict [punkcheck::install $layout_path/.fossil-settings $projectdir/.fossil-settings -createdir 1 -createempty 1 -punkcheck_folder $projectdir -installer project.new -exclude-dirsegments_core $override_exclude_dirsegments_core -overwrite SYNCED-TARGETS] puts stdout [punkcheck::summarize_install_resultdict $resultdict] } else { puts stdout "no .fossil-settings in source template - update not required" @@ -470,8 +470,8 @@ namespace eval punk::mix::commandset::project { if {[file exists $projectdir/src/modules]} { foreach m $opt_modules { #check if mod-ver.tm file or #modpod-mod-ver folder exist - set tmfile $projectdir/src/modules/$m-[punk::mix::util::magic_tm_version].tm - set podfile $projectdir/src/modules/#modpod-$m-[punk::mix::util::magic_tm_version]/$m-[punk::mix::util::magic_tm_version].tm + set tmfile $projectdir/src/modules/$m-[punk::mix::util::tm_version_magic].tm + set podfile $projectdir/src/modules/#modpod-$m-[punk::mix::util::tm_version_magic]/$m-[punk::mix::util::tm_version_magic].tm set has_tm [file exists $tmfile] set has_pod [file exists $podfile] diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/util-0.1.0.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/util-0.1.0.tm index 7f55005b..8dbe8feb 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/util-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/util-0.1.0.tm @@ -367,7 +367,16 @@ namespace eval punk::mix::util { } #todo - semver conversion/validation for other systems? - proc magic_tm_version {} { + proc tm_version_magic {} { + #maintenance instruction: + # This specific 12 character nnnnnn.0a1.0 version number is used in text replacement when installing modules. + # It should not be modified without also considering the impact on existing projects based on punkshell that may have used this version number in their own code or documentation as a placeholder for tm version handling. + # A copy of this is also present in punk::lib to aid in dependency management. + # These 2 copies should be kept in sync. + # Essentially this should probably never be changed - and instead deprecated if we want to stop using it and replaced with a different mechanism/placeholder. + + #tm versioning is not quite the same as semantic versioning - but similarly we should see extremely high major version numbers rarely if ever in real use, + #even over decades of development. set magicbase 999999 ;#deliberately large so given load-preference when testing! #we split the literal to avoid the literal appearing here - reduce risk of accidentally converting to a release version return ${magicbase}.0a1.0 diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mod-0.1.1.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mod-0.1.1.tm new file mode 100644 index 00000000..e09ff748 --- /dev/null +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mod-0.1.1.tm @@ -0,0 +1,158 @@ +#punkapps app manager +# deck cli + +namespace eval punk::mod::cli { + namespace export help list run + namespace ensemble create + + # namespace ensemble configure [namespace current] -unknown punk::mod::cli::_unknown + if 0 { + proc _unknown {ns args} { + puts stderr "punk::mod::cli::_unknown '$ns' '$args'" + puts stderr "punk::mod::cli::help $args" + puts stderr "arglen:[llength $args]" + punk::mod::cli::help {*}$args + } + } + + #cli must have _init method - usually used to load commandsets lazily + # + variable initialised 0 + proc _init {args} { + variable initialised + if {$initialised} { + return + } + #... + set initialised 1 + } + + proc help {args} { + set basehelp [punk::mix::base help {*}$args] + #namespace export + return $basehelp + } + proc getraw {appname} { + set app_folders [punk::config::configure running apps] + #todo search each app folder + set bases [::list] + set versions [::list] + set mains [::list] + set appinfo [::list bases {} mains {} versions {}] + + foreach containerfolder $app_folders { + lappend bases $containerfolder + if {[file exists $containerfolder]} { + if {[file exists $containerfolder/$appname/main.tcl]} { + #exact match - only return info for the exact one specified + set namematches $appname + set parts [split $appname -] + } else { + set namematches [glob -nocomplain -dir $containerfolder -type d -tail ${appname}-*] + set namematches [lsort $namematches] ;#todo - -ascii? -dictionary? natsort? + } + foreach nm $namematches { + set mainfile $containerfolder/$nm/main.tcl + set parts [split $nm -] + if {[llength $parts] == 1} { + set ver "" + } else { + set ver [lindex $parts end] + } + if {$ver ni $versions} { + lappend versions $ver + lappend mains $ver $mainfile + } else { + puts stderr "punk::apps::app version '$ver' of app '$appname' already encountered at $mainfile. (will use earliest encountered in running-config apps and ignore others of same version)" + } + } + } else { + puts stderr "punk::apps::app missing apps_folder:'$containerfolder' Ensure apps_folder is set in punk::config" + } + } + dict set appinfo versions $versions + #todo - natsort! + set sorted_versions [lsort $versions] + set latest [lindex $sorted_versions 0] + if {$latest eq "" && [llength $sorted_versions] > 1} { + set latest [lindex $sorted_versions 1] + } + dict set appinfo latest $latest + + dict set appinfo bases $bases + dict set appinfo mains $mains + return $appinfo + } + + proc list {{glob *}} { + set apps_folder [punk::config::configure running apps] + if {[file exists $apps_folder]} { + if {[file exists $apps_folder/$glob]} { + #tailcall source $apps_folder/$glob/main.tcl + return $glob + } + set apps [glob -nocomplain -dir $apps_folder -type d -tail $glob] + if {[llength $apps] == 0} { + if {[string first * $glob] <0 && [string first ? $glob] <0} { + #no glob chars supplied - only launch if exact match for name part + set namematches [glob -nocomplain -dir $apps_folder -type d -tail ${glob}-*] + set namematches [lsort $namematches] ;#todo - -ascii? -dictionary? natsort? + if {[llength $namematches] > 0} { + set latest [lindex $namematches end] + lassign $latest nm ver + #tailcall source $apps_folder/$latest/main.tcl + } + } + } + return $apps + } + } + + #todo - way to launch as separate process + # solo-opts only before appname - args following appname are passed to the app + proc run {args} { + set nameposn [lsearch -not $args -*] + if {$nameposn < 0} { + error "punkapp::run unable to determine application name" + } + set appname [lindex $args $nameposn] + set controlargs [lrange $args 0 $nameposn-1] + set appargs [lrange $args $nameposn+1 end] + + set appinfo [punk::mod::cli::getraw $appname] + if {[llength [dict get $appinfo versions]]} { + set ver [dict get $appinfo latest] + puts stdout "info: $appinfo" + set ::argc [llength $appargs] + set ::argv $appargs + source [dict get $appinfo mains $ver] + if {"-hideconsole" in $controlargs} { + puts stderr "attempting console hide" + #todo - something better - a callback when window mapped? + after 500 {::punkapp::hide_console} + } + return $appinfo + } else { + error "punk::mod::cli unable to run '$appname'. main.tcl not found in [dict get $appinfo bases]" + } + } +} + +namespace eval punk::mod::cli { + proc _cli {args} { + #don't use tailcall - base uses info level to determine caller + ::punk::mix::base::_cli {*}$args + } + variable default_command help + package require punk::mix::base + package require punk::overlay + punk::overlay::custom_from_base [namespace current] ::punk::mix::base +} + +package provide punk::mod [namespace eval punk::mod { + variable version + set version 0.1.1 +}] + + + diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/nav/fs-0.1.0.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/nav/fs-0.1.0.tm index 7d85e311..e0f29d66 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/nav/fs-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/nav/fs-0.1.0.tm @@ -847,7 +847,7 @@ tcl::namespace::eval punk::nav::fs { Regardless of whether -nonportable is supplied or not, some characters are not suitable for windows or most other platforms and will be rejected with an error. - An example of this is the null character (\0)." + An example of this is the null character (\\0)." @values -min 1 -max -1 -type string path -type string -multiple 1 -help\ "Path(s) to create. Can be absolute or relative. diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/ns-0.1.0.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/ns-0.1.0.tm index db6acbb4..ad3cd57e 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/ns-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/ns-0.1.0.tm @@ -721,6 +721,22 @@ tcl::namespace::eval punk::ns { } + punk::args::define { + @id -id ::punk::ns::nstree_list + @cmd -name punk::ns::nstree_list\ + -summary\ + ""\ + -help\ + "" + @leaders + location -type path -optional 0 + @opts + -subnslist -type list -default {} -help\ + "" + -allbelow -type boolean -default 1 -help\ + "" + @values -min 0 -max 0 + } #important: add tests for tricky cases - e.g punk::m**::util vs punk::m*::util vs punk::m*::**::util - these should all be able to return different results depending on namespace structure. #e.g punk::m**::util will return punk::mix::util but punk::m*::**::util will not because punk::mix::util is too short to match. Both will return deeper matches such as: punk::mix::commandset::repo::util proc nstree_list {location args} { @@ -775,13 +791,8 @@ tcl::namespace::eval punk::ns { #set parent [nsprefix $ns_absolute] #set tail [nstail $ns_absolute] - #jjj #set allchildren [lsort [nseval $base [list ::namespace children]]] - #set allchildren [lsort [tcl::namespace::eval $base [list ::namespace children]]] - set allchildren [lsort [nseval $base [list ::namespace children]]] - #puts "->base:$base tailparts:$tailparts allchildren: $allchildren" - #puts "->base:$base tailparts:$tailparts childcount: [llength $allchildren]" #** only significant when it is the trailing part of a segment eg ::**::xxx ::a**::xxx if {[llength $tailparts]} { @@ -790,6 +801,7 @@ tcl::namespace::eval punk::ns { set nslist [nstree_list $base -subnslist {} -allbelow 1] } elseif {[regexp {[*]{2}$} $nextglob]} { set nslist [list] + set allchildren [lsort [nseval $base [list ::namespace children]]] lappend nsmatches {*}[lsearch -all -inline -glob $allchildren [nsjoin ${base} $nextglob]] foreach ch $nsmatches { lappend nslist $ch @@ -799,6 +811,7 @@ tcl::namespace::eval punk::ns { } else { #lsearch with -glob ok even if nextglob has no globchars (no discernable speed diff, and earlier parts may have globchars anyway) set nslist [list] + set allchildren [lsort [nseval $base [list ::namespace children]]] lappend nsmatches {*}[lsearch -all -inline -glob $allchildren [nsjoin ${base} $nextglob]] if {[llength $tailparts] >1 || $allbelow} { foreach ch $nsmatches { @@ -812,6 +825,7 @@ tcl::namespace::eval punk::ns { } } else { #puts "nstree_list: no tailparts base:$base" + set allchildren [lsort [nseval $base [list ::namespace children]]] if {$allbelow} { set nsmatches $allchildren set nslist [list] @@ -2134,8 +2148,8 @@ y" {return quirkykeyscript} tcl::dict::set tinfo($target) procoffset 0 tcl::dict::set tinfo($target) level [expr {[::tcl::info::level]+1}] tcl::dict::set tinfo($target) subcmds 0 - puts "enter: $target -- $args" - puts "frame-2: [::tcl::info::frame -2]" + puts stderr "enter: $target -- $args" + #puts stderr "frame-2: [::tcl::info::frame -2]" set _cmdtrace_disabled false } @@ -2481,7 +2495,7 @@ y" {return quirkykeyscript} set line $traceline dict set linedict $target eval_base $traceline dict set linedict $target eval_offset 1 - puts " step type: proc traceline:$traceline ** $args" + puts " step type: proc traceline:$traceline ** $args\x1b\[m" #puts "** $callinfo" if {[dict exists $callinfo cmd]} { #set cmd [string trim [dict get $callinfo cmd]] ;#raw 'unexpanded' script from the stack frame @@ -2504,8 +2518,8 @@ y" {return quirkykeyscript} set eval_base [dict get $linedict $target eval_base] set eval_offset [dict get $linedict $target eval_offset] set line [expr {$eval_base + ($eval_offset-1) + ($traceline-1)}] - puts "stack-- $callinfo" - puts " step type: eval traceline: $traceline -- " + #puts "stack-- $callinfo" + puts stderr " step type: eval traceline: $traceline -- " if {[dict exists $callinfo cmd]} { #set cmd [string trim [dict get $callinfo cmd]] set cmdlist [lindex $args 0] @@ -2627,6 +2641,8 @@ y" {return quirkykeyscript} }] } proc cmdtrace {args} { + #review - displaying argument values has to be done carefully. Small values are ok, but large lists or dicts can be overwhelming. + #Potentially we could apply some heuristics to truncate or summarise them. package require dictn ;#convenience to allow dictn::incr d {key subkey} variable tinfo array unset tinfo @@ -2676,7 +2692,7 @@ y" {return quirkykeyscript} #if the target command has a leading colon (e.g expr alternative :) we can't put a trace directly on a fully qualified name with a triple colon such as ::: #we will need to evaluate in the namespace foreach {tgt_cmd ns nscmd} $resolved_targets { - puts "tracing target: $tgt_cmd whilst running: $origin $arglist" + puts stderr "tracing target: $tgt_cmd whilst running: $origin $arglist" #::tcl::namespace::eval $ns [list ::trace add execution $nscmd enter [list ::punk::ns::_cmdtrace_enter ::punk::ns::linedict $tgt_cmd]] #::tcl::namespace::eval $ns [list ::trace add execution $nscmd enterstep [list ::punk::ns::_cmdtrace_enterstep ::punk::ns::linedict $tgt_cmd]] diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/overlay-0.1.1.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/overlay-0.1.1.tm new file mode 100644 index 00000000..eff01253 --- /dev/null +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/overlay-0.1.1.tm @@ -0,0 +1,192 @@ + + +package require punk::mix::util +package require punk::args + +tcl::namespace::eval ::punk::overlay { + #based *loosely* on: wiki.tcl-lang.org/page/ensemble+extend + # extend an ensemble-like routine with the routines in some namespace + # + # e.g custom_from_base ::punk::mix::cli ::punk::mix::base + # + proc custom_from_base {routine base} { + if {![tcl::string::match ::* $routine]} { + set resolved [uplevel 1 [list ::tcl::namespace::which $routine]] + if {$resolved eq {}} { + error [list {no such routine} $routine] + } + set routine $resolved + } + set routinens [tcl::namespace::qualifiers $routine] + if {$routinens eq {::}} { + set routinens {} + } + set routinetail [tcl::namespace::tail $routine] + + if {![tcl::string::match ::* $base]} { + set base [uplevel 1 [ + list [tcl::namespace::which namespace] current]]::$base + } + + if {![tcl::namespace::exists $base]} { + error [list {no such namespace} $base] + } + + set base [tcl::namespace::eval $base [ + list [tcl::namespace::which namespace] current]] + + + #while 1 { + # set renamed ${routinens}::${routinetail}_[info cmdcount] + # if {[namespace which $renamed] eq {}} break + #} + + tcl::namespace::eval $routine [ + ::list tcl::namespace::ensemble configure $routine -unknown [ + ::list ::apply {{base ensemble subcommand args} { + ::list ${base}::_redirected $ensemble $subcommand + }} $base + ] + ] + + punk::mix::util::namespace_import_pattern_to_namespace_noclobber ::punk::mix::util::* ${routine}::util + #namespace eval ${routine}::util { + #::namespace import ::punk::mix::util::* + #} + punk::mix::util::namespace_import_pattern_to_namespace_noclobber ${base}::lib::* ${routine}::lib + #namespace eval ${routine}::lib [string map [list $base] { + # ::namespace import ::lib::* + #}] + + tcl::namespace::eval ${routine}::lib [tcl::string::map [list $base $routine] { + if {[tcl::namespace::exists ::lib]} { + ::set current_paths [tcl::namespace::path] + if {"" ni $current_paths} { + ::lappend current_paths + } + tcl::namespace::path $current_paths + } + }] + + tcl::namespace::eval $routine { + ::set exportlist [::list] + ::foreach cmd [tcl::info::commands [tcl::namespace::current]::*] { + ::set c [tcl::namespace::tail $cmd] + if {![tcl::string::match _* $c]} { + ::lappend exportlist $c + } + } + tcl::namespace::export {*}$exportlist + } + + return $routine + } + punk::args::define { + @id -id ::punk::overlay::import_commandset + @cmd -name punk::overlay::import_commandset\ + -summary\ + "Import commands into caller's namespace with optional prefix and separator."\ + -help\ + "Import commands that have been exported by another namespace into the caller's + namespace. Usually a prefix and optionally a separator should be used. + This is part of the punk::mix CLI commandset infrastructure - design in flux. + Todo - .toml configuration files for defining CLI configurations." + @values + prefix -type string + separator -type string -help\ + "A string, usually punctuation, to separate the prefix and the command name + of the final imported command. The value \"::\" is disallowed in this context." + cmdnamespace -type string -help\ + "Namespace from which to import commands. Commands are those that have been exported." + } + #load *exported* commands from cmdnamespace into caller's namespace - prefixing each command with $prefix + #Note: commandset may be imported by different CLIs with different bases *at the same time* + #so we don't make commands from the cli or its base available automatically (will generally require fully-qualified commands to use code from cli/base) + #we do load punk::mix::util::* into the util subnamespace even though the commandset might not be loaded in a cli using punk::mix::base i.e punk::mix::util is a common dependency for CLIs. + #commandsets designed to be used with a specific cli/base may choose to do their own import e.g with util::namespace_import_pattern_to_namespace_noclobber and/or set namespace path if they + #want the convenience of using lib:xxx with commands coming from those packages. + #This won't stop the commandset being used with other cli/bases unless the import is done by looking up the callers namespace. + #The basic principle is that the commandset is loaded into the caller(s) with a prefix + #- but commandsets should explicitly package require if they have any backwards dependencies on cli/base (which they may or may not be loaded into) + proc import_commandset {prefix separator cmdnamespace} { + set bad_seps [list "::"] + if {$separator in $bad_seps} { + error "import_commandset invalid separator '$separator'" + } + if {$prefix in $bad_seps} { + error "import_commandset invalid prefix '$prefix'" + } + if {"$prefix$separator" in $bad_seps} { + error "import_commandset invalid prefix/separator combination '$prefix$separator'" + } + if {"[string index $prefix end][string index $separator 0]" in $bad_seps} { + error "import_commandset invalid prefix/separator combination '$prefix$separator'" + } + #review - do we allow prefixes/separators such as a::b? + + #namespace may or may not be a package + # allow with or without leading :: + if {[tcl::string::range $cmdnamespace 0 1] eq "::"} { + set cmdpackage [tcl::string::range $cmdnamespace 2 end] + } else { + set cmdpackage $cmdnamespace + set cmdnamespace ::$cmdnamespace + } + + if {![tcl::namespace::exists $cmdnamespace]} { + #only do package require if the namespace not already present + catch {package require $cmdpackage} pkg_load_info + #recheck + if {![tcl::namespace::exists $cmdnamespace]} { + set prov [package provide $cmdpackage] + if {[tcl::string::length $prov]} { + set provinfo "(package $cmdpackage is present with version $prov)" + } else { + set provinfo "(package $cmdpackage not present)" + } + error "punk::overlay::import_commandset supplied namespace '$cmdnamespace' doesn't exist. $provinfo Pkg_load_result: $pkg_load_info Usage: import_commandset prefix separator namespace" + } + } + + punk::mix::util::namespace_import_pattern_to_namespace_noclobber ::punk::mix::util::* ${cmdnamespace}::util + + #let child namespace 'lib' resolve parent namespace and thus util::xxx + tcl::namespace::eval ${cmdnamespace}::lib [tcl::string::map [list $cmdnamespace] { + ::set nspaths [tcl::namespace::path] + if {"" ni $nspaths} { + ::lappend nspaths + } + tcl::namespace::path $nspaths + }] + + set imported_commands [list] + set imported_tails [list] + set nscaller [uplevel 1 [list tcl::namespace::current]] + if {[catch { + #review - noclobber? + tcl::namespace::eval ${nscaller}::temp_import [list tcl::namespace::import ${cmdnamespace}::*] + foreach cmd [tcl::info::commands ${nscaller}::temp_import::*] { + set cmdtail [tcl::namespace::tail $cmd] + if {$cmdtail eq "_default"} { + set import_as ${nscaller}::${prefix} + } else { + set import_as ${nscaller}::${prefix}${separator}${cmdtail} + } + rename $cmd $import_as + lappend imported_commands $import_as + lappend imported_tails [namespace tail $import_as] + } + #make imported commands exported so they are available to the ensemble + tcl::namespace::eval ${nscaller} [list namespace export {*}$imported_tails] + } errM]} { + puts stderr "Error loading commandset $prefix $separator $cmdnamespace" + puts stderr "err: $errM" + } + return $imported_commands + } +} + +package provide punk::overlay [tcl::namespace::eval punk::overlay { + variable version + set version 0.1.1 +}] diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/path-0.1.0.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/path-0.1.0.tm index aff97595..4527dbb2 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/path-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/path-0.1.0.tm @@ -565,10 +565,45 @@ namespace eval punk::path { end]] } + + ## for comparison + #proc nsglob_as_re {glob} { + # #any segment that is not just * must match exactly one segment in the path + # set pats [list] + # foreach seg [nsparts_cached $glob] { + # switch -exact -- $seg { + # "" { + # lappend pats "" + # } + # * { + # #review - ::g*t will not find ::got:it (won't match single inner colon) - this should be fixed + # #lappend pats {[^:]*} + # #negative lookahead + # #any number of chars not followed by ::, followed by any number of non : + # lappend pats {(?:.(?!::))*[^:]*} + # } + # ** { + # lappend pats {.*} + # } + # default { + # set seg [string map {. [.]} $seg] + # if {[regexp {[*?]} $seg]} { + # #set pat [string map [list ** {.*} * {[^:]*} ? {[^:]}] $seg] + # set pat [string map [list ** {.*} * {(?:.(?!::))*[^:]*} ? {[^:]}] $seg] + # lappend pats "$pat" + # } else { + # lappend pats "$seg" + # } + # } + # } + # } + # return "^[join $pats ::]\$" + #} proc pathglob_as_re {pathglob} { #*** !doctools #[call [fun pathglob_as_re] [arg pathglob]] #[para] Returns a regular expression for matching a path to a glob pattern which can contain glob chars *|? in any segment of the path structure + #[para] Does not support square bracket globs or character classes. #[para] ** matches any number of subdirectories. #[para] e.g /etc/**/*.txt will match any .txt files at any depth below /etc (except directly within /etc itself) #[para] e.g /etc/**.txt will match any .txt files at any depth below /etc @@ -589,7 +624,7 @@ namespace eval punk::path { * {lappend pats {[^/]*}} ** {lappend pats {.*}} default { - set seg [string map [list {^ {\^} $ {\$} [} {\[} ( {\(} \{ \\\{ \\ {\\}] $seg] ;#treat regex characters in the input as literals + set seg [string map [list ^ {\^} $ {\$} \[ {\[} \] {\]} ( {\(} ) {\)} \{ \\\{ \\ {\\}] $seg] ;#treat regex characters (or tcl glob square bracket chars) in the input as literals #set seg [string map [list . {[.]}] $seg] set seg [string map {. [.]} $seg] if {[regexp {[*?]} $seg]} { @@ -603,6 +638,52 @@ namespace eval punk::path { } return "^[join $pats /]\$" } + + punk::args::define { + @id -id ::punk::path::globmatchpath + @cmd -name punk::path::globmatchpath\ + -summary\ + "Match path to *|**|? glob patterns"\ + -help\ + "Return a boolean indicating whether the path matches the specialised glob pattern. + A pattern such as /usr/*/bin will match any path that has /usr as the first segment and bin as the third segment, + with any single segment in between. + A pattern such as /usr/**/bin will match any path that has /usr as the first segment and bin as the last segment, + with 1 or more segments in between (so it will not match /usr/bin). + A pattern such as /usr/** will match any path that has /usr as the first segment, with 1 or more segments + following (so it will not match /usr itself). + A pattern such as **/*.txt will match any path that ends with .txt, with 1 or more leading segments + (so it will not match test.txt or .txt). + A pattern such as ** will match any path. + The glob characters * and ? are the only special characters in the pathglob syntax. + - they are treated as glob characters regardless of where they appear in the pathglob string. + Note that this is different from other Tcl glob contexts where square brackets can be used. + The pathglob syntax treats other characters, including square brackets as literals. + For example, the pattern /usr/te?t will match /usr/test and /usr/text but not /usr/texxt, and the pattern /usr/te*t + will match /usr/test, /usr/teat, and /usr/teeeet but not /usr/te/t. + The pathglob syntax does not support escaping of glob characters - any glob characters in the pathglob are treated + as glob characters. For example, the pattern /usr/* will match any path that has /usr as the first segment and any + single segment as the second segment, but there is no way to specify a pattern that matches any path that has /usr + as the first segment and a literal * as the second segment. + Caller must ensure that file separator is forward slash. (e.g use file normalize on windows) + + options: + -nocase 0|1 (default 0 - case sensitive) + If -nocase is not supplied - default to case sensitive *except for driveletter* + ie - the driveletter alone in paths such as c:/etc will still be case insensitive. (ie c:/ETC/* will match C:/ETC/blah but not C:/etc/blah) + Explicitly specifying -nocase 0 will require the entire case to match including the driveletter. + " + @leaders + pathglob -type string -help "glob pattern to match path against. See [fun pathglob_as_re] for syntax of glob patterns" + path -type string -help "path to match against glob pattern" + @opts + -nocase -type boolean -default 0 -help\ + "case insensitive matching (default false - case sensitive) + - except for driveletter on windows which is always case insensitive + unless -nocase 0 is explicitly specified" + @values -min 0 -max 0 + } + # -id proc globmatchpath {pathglob path args} { #*** !doctools #[call [fun globmatchpath] [arg pathglob] [arg path] [opt {option value...}]] @@ -659,349 +740,689 @@ namespace eval punk::path { return $ismatch } punk::args::define { - @id -id ::punk::path::subfolders - @cmd -name punk::path::subfolders\ + @id -id ::punk::path::subfolders1 + @cmd -name punk::path::subfolders1\ -summary\ - "Listing of directories within supplied path."\ + "Listing of directories below supplied path."\ -help\ "List of folders below path. The resulting list is unsorted." @opts -recursive -type none -help\ "" + -exclude-paths -type list -default {} -help\ + "list of path patterns to exclude from results. + May include * and ** path segments e.g /usr/** + A single /*/ will match any single segment in the path, and a single /**/ will match any number of segments in the path. + + e.g to exclude any path with _aside as a segment in the middle: -exclude-paths **/_aside/** + i.e this would exclude /usr/_aside/etc and /usr/x/_aside/etc but not /usr/x/_aside or _aside/etc + + To exclude all paths with _aside as a segment anywhere: -exclude-paths { **/_aside/** **/_aside _aside/**} + " #todo -depth @values -min 0 -max 1 path -type directory -optional 1 -help\ - "Path of folder. If not supplied current directory is used." + "Path of folder. If not supplied current directory is used. + This may be a relative or absolute path. Relative paths are treated as relative to current directory. + When using relative paths - the result will also be relative paths with the same relative prefix. + (e.g if path is ../test - the results will be ../test/subfolder1 ../test/subfolder2 etc) + Patterns in -exclude-paths are matched against the resulting paths + (so should be written to match the same relative prefix if path is relative)" } - proc subfolders {args} { - set argd [punk::args::parse $args withid ::punk::path::subfolders] + + proc subfolders1 {args} { + #NOTE - this algorithm based on omit_only_patterns and prune_base_patterns was suggested by a 2026 AI model - it is apparent to this programmer that it is inadequate for the purpose. + #e.g consider subfolders1 -recursion -exclude {**/vfs/** **/src/**} + #This can still return something like c:/repo/etc/src/vfs - which should be excluded by the pattern **/src/** + #todo - review and fix properly. + set argd [punk::args::parse $args withid ::punk::path::subfolders1] lassign [dict values $argd] leaders opts values received - set do_recursion [dict exists $received -recursive] + set do_recursion [dict exists $received -recursive] + set exclude_paths [dict get $opts -exclude-paths] + if {"**" in $exclude_paths} { + #if ** is in exclude_paths - then we can skip all glob matching and just return empty list + #This is likely user error - so we'll be loud about it for now but will still return empty list rather than erroring. + #If user code is building exclude_paths dynamically - they can check for this case themselves and avoid the call to subfolders1 to suppress this message. + puts stderr "punk::path::subfolders1 Warning - exclude_paths contains '**' - all paths will be excluded" + return [list] + } if {[dict exists $received path]} { set path [dict get $values path] } else { set path [pwd] } - set folders [glob -nocomplain -directory $path -types d *] + + set all_subfolders [glob -nocomplain -directory $path -types d *] + + + #example of expected exclude_paths pattern behaviour when recursion is enabled: + # **/dirname -> omit /x/y/dirname, but still visit /x/y/dirname/* + + # **/dirname/* -> include /x/y/dirname and /x/y/dirname/a/b but omit directories that are a single level below /x/y/dirname such as /x/y/dirname/a + + #c:/** - would exclude all subfolders below c: but not c: itself + + # **/test/** - would exclude any path with test as a segment and all its subfolders + #- but not paths with test as a segment that is the final segment + + set folders [list] + set recurse_subdirs [list] + + foreach f $all_subfolders { + set include_in_results 1 + set allow_recurse 1 + foreach pat $exclude_paths { + set pat_parts [file split $pat] ;#note file split c:/test gives {c:/ test} but file split **/test gives {** test} + #also note that file split on windows treats forward slashes and backslashes the same. + #by using file split, we gain some flexibility in syntax of paths and patterns, + #but lose the ability to use backslashes as escapes to allow literal glob characters in path segments. + #This is almost always a non-issue on windows since * and ? are not valid in path segments there, and is rarely an issue on unix even though + # * and ? are technically valid in path segments, but it is inadvisable there anyway for compatibility with shells etc. + if {[llength $pat_parts] >= 2 && [lindex $pat_parts end] eq "**"} { + set base_pat [file join {*}[lrange $pat_parts 0 end-1]] + if {[globmatchpath $pat $f]} { + set include_in_results 0 + set allow_recurse 0 + } elseif {[globmatchpath $base_pat $f]} { + set allow_recurse 0 + } + } elseif {[globmatchpath $pat $f]} { + set include_in_results 0 + } + if {!$include_in_results && !$allow_recurse} { + break + } + } + if {$include_in_results} { + lappend folders $f + } + if {$allow_recurse} { + lappend recurse_subdirs $f + } + } if {$do_recursion} { - foreach subdir $folders { - lappend folders {*}[subfolders -recursive $subdir] + foreach subdir $recurse_subdirs { + lappend folders {*}[subfolders1 -exclude-paths $exclude_paths -recursive $subdir] } } return $folders } - #todo - treefolders with similar search caps as treefilenames + namespace eval subfolder_priv { + proc classify_exclude_pattern {pat} { + set parts [file split $pat] + if {[llength $parts] >= 2 && [lindex $parts end] eq "**"} { + set boundary_pat [file join {*}[lrange $parts 0 end-1]] + return [dict create \ + pattern $pat \ + kind subtree \ + boundary_pat $boundary_pat \ + descend_pat $pat] + } + if {[llength $parts] >= 2 && [lindex $parts end] eq "*"} { + return [dict create \ + pattern $pat \ + kind child_only \ + match_pat $pat] + } + return [dict create \ + pattern $pat \ + kind exact \ + match_pat $pat] + } - punk::args::define { - @id -id ::punk::path::treefilenames - -directory -type directory -help\ - "folder in which to begin recursive scan for files." - -call-depth-internal -default 0 -type integer - -sort -type any -default natural -choices {none ascii dictionary natural} - -antiglob_paths -default {} -help\ - "list of path patterns to exclude - may include * and ** path segments e.g - /usr/** (exlude subfolders based at /usr but not - files within /usr itself) - **/_aside (exlude files where _aside is last segment) - **/_aside/* (exclude folders one below an _aside folder) - **/_aside/** (exclude all folders with _aside as a segment)" - -antiglob_files -default {} - @values -min 0 -max -1 -optional 1 -type string - tailglobs -default * -multiple 1 -help\ - "Patterns to match against filename portion (last segment) of each file path - within the directory tree being searched." + proc compile_exclude_rules {exclude_paths} { + set rules [list] + foreach pat $exclude_paths { + lappend rules [classify_exclude_pattern $pat] + } + return $rules + } + + proc match_rule_at_node {rule path} { + set kind [dict get $rule kind] + switch -- $kind { + exact - child_only { + if {[::punk::path::globmatchpath [dict get $rule match_pat] $path]} { + return [dict create include_current 0 recurse_below 1 child_rules [list $rule]] + } + return [dict create include_current 1 recurse_below 1 child_rules [list $rule]] + } + subtree { + set descend_pat [dict get $rule descend_pat] + set boundary_pat [dict get $rule boundary_pat] + if {[::punk::path::globmatchpath $descend_pat $path]} { + return [dict create include_current 0 recurse_below 0 child_rules [list]] + } + if {[::punk::path::globmatchpath $boundary_pat $path]} { + return [dict create include_current 1 recurse_below 0 child_rules [list]] + } + return [dict create include_current 1 recurse_below 1 child_rules [list $rule]] + } + default { + error "Unknown exclude rule kind '$kind'" + } + } + } + + proc walk_subfolders {path rules do_recursion} { + set all_subfolders [glob -nocomplain -directory $path -types d *] + set folders [list] + foreach f $all_subfolders { + set include_current 1 + set recurse_below $do_recursion + set child_rules [list] + foreach rule $rules { + set outcome [match_rule_at_node $rule $f] + if {![dict get $outcome include_current]} { + set include_current 0 + } + if {![dict get $outcome recurse_below]} { + set recurse_below 0 + } + if {$do_recursion} { + lappend child_rules {*}[dict get $outcome child_rules] + } + if {!$include_current && !$recurse_below} { + break + } + } + if {$include_current} { + lappend folders $f + } + if {$do_recursion && $recurse_below} { + lappend folders {*}[walk_subfolders $f $child_rules $do_recursion] + } + } + return $folders + } } - #todo - implement treefiles which acts like dirfiles but allows path globbing in the same way as punk::ns::ns/ - #then review if treefiles can replace dirfiles or if both should exist (dirfiles can have literal glob chars in path segments - but that is a rare usecase) - proc treefilenames {args} { - #*** !doctools - #[call [fun treefilenames] [opt {option value...}] [opt {globpattern...}]] - #[para]basic (glob based) list of filenames matching each pattern in tailglobs - recursive - #[para] options: - #[para] [opt -dir] - #[para] defaults to [lb]pwd[rb] - base path for tree to search - #[para] [opt -antiglob_paths] - #[para] list of path patterns to exclude - may include * and ** path segments e.g /usr/** - #[para]no natsorting - so order is dependent on filesystem + punk::args::define { + @id -id ::punk::path::subfolders + @cmd -name punk::path::subfolders\ + -summary\ + "Listing of directories below supplied path."\ + -help\ + "List of folders below path. + The resulting list is unsorted. + " + @opts + -recursive -type none -help\ + "" + -exclude-paths -type list -default {} -help\ + "list of path patterns to exclude from results. + May include * and ** path segments e.g /usr/** + A single /*/ will match any single segment in the path, and a single /**/ will match any number of segments in the path. - set argd [punk::args::parse $args withid ::punk::path::treefilenames] + e.g to exclude any path with _aside as a segment in the middle: -exclude-paths **/_aside/** + i.e this would exclude /usr/_aside/etc and /usr/x/_aside/etc but not /usr/x/_aside or _aside/etc + + To exclude all paths with _aside as a segment anywhere: -exclude-paths { **/_aside/** **/_aside ./_aside/**} + " + #todo -depth + @values -min 0 -max 1 + path -type directory -optional 1 -help\ + "Path of base folder. If not supplied current directory is used. + This may be a relative or absolute path. Relative paths are treated as relative to current directory. + When using relative paths - the result will also be relative paths with the same relative prefix. + (e.g if path is ../test - the results will be ../test/subfolder1 ../test/subfolder2 etc) + Patterns in -exclude-paths are matched against the resulting paths + (so should be written to match the same relative prefix if path is relative)" + } + + proc subfolders {args} { + set argd [punk::args::parse $args withid ::punk::path::subfolders] lassign [dict values $argd] leaders opts values received - set tailglobs [dict get $values tailglobs] - # -- --- --- --- --- --- --- - set opt_sort [dict get $opts -sort] - set opt_antiglob_paths [dict get $opts -antiglob_paths] - set opt_antiglob_files [dict get $opts -antiglob_files] - set CALLDEPTH [dict get $opts -call-depth-internal] - # -- --- --- --- --- --- --- - # -- --- --- --- --- --- --- - - set files [list] - if {$CALLDEPTH == 0} { - if {$opt_sort eq "natural"} { - package require natsort + set do_recursion [dict exists $received -recursive] + set exclude_paths [dict get $opts -exclude-paths] + if {"**" in $exclude_paths} { + puts stderr "punk::path::subfolders Warning - exclude_paths contains '**' - all paths will be excluded" + return [list] + } + if {[dict exists $received path]} { + set path [dict get $values path] + } else { + set path [pwd] + } + set compiled_rules [subfolder_priv::compile_exclude_rules $exclude_paths] + return [subfolder_priv::walk_subfolders $path $compiled_rules $do_recursion] + } + + namespace eval treefile_priv { + proc _pattern_prefix_viable_parts {pattern_parts path_parts} { + if {![llength $path_parts]} { + return 1 } - #set opts [dict merge $opts [list -directory $opt_dir]] - if {![dict exists $received -directory]} { - set opt_dir [pwd] - } else { - set opt_dir [dict get $opts -directory] + if {![llength $pattern_parts]} { + return 0 } - if {![file isdirectory $opt_dir]} { - return [list] + + set pattern_head [lindex $pattern_parts 0] + set path_head [lindex $path_parts 0] + + if {$pattern_head eq "**"} { + if {[_pattern_prefix_viable_parts [lrange $pattern_parts 1 end] $path_parts]} { + return 1 + } + return [_pattern_prefix_viable_parts $pattern_parts [lrange $path_parts 1 end]] } - } else { - #assume/require to exist in any recursive call - set opt_dir [dict get $opts -directory] + + if {[::punk::path::globmatchpath $pattern_head $path_head]} { + return [_pattern_prefix_viable_parts [lrange $pattern_parts 1 end] [lrange $path_parts 1 end]] + } + return 0 } - #comment out to compare timings with treefilenames_zipfs - if {[string match //zipfs:/* $opt_dir]} { - return [treefilenames_zipfs {*}$args] + proc pattern_prefix_viable {pattern path} { + return [_pattern_prefix_viable_parts [file split $pattern] [file split $path]] } - set skip 0 - foreach anti $opt_antiglob_paths { - if {[globmatchpath $anti $opt_dir]} { - set skip 1 - break + proc pattern_boundary {pattern} { + set parts [file split $pattern] + if {[llength $parts] >= 2 && [lindex $parts end] eq "**"} { + return [file join {*}[lrange $parts 0 end-1]] } - } - if {$skip} { - return [list] + return "" } - #todo - account for vfs where matched path could appear to be a directory but is mounted so could be a desired match? - if {[catch {glob -nocomplain -dir $opt_dir -type f {*}$tailglobs} matches]} { - #we can get for example a permissions error - puts stderr "treefilenames error while listing files in dir $opt_dir\n $matches" - set dirfiles [list] - } else { - set retained [list] - if {[llength $opt_antiglob_files]} { - foreach m $matches { - set skip 0 - set ftail [file tail $m] - foreach anti $opt_antiglob_files { - if {[string match $anti $ftail]} { - set skip 1; break - } - } - if {!$skip} { - lappend retained $m + proc directory_state {glob_paths path inherited_allbelow} { + if {$inherited_allbelow} { + return [dict create include_files 1 recurse_below 1 next_allbelow 1] + } + + set include_files 0 + set recurse_below 0 + set next_allbelow 0 + + foreach gp $glob_paths { + if {[::punk::path::globmatchpath $gp $path]} { + set include_files 1 + set recurse_below 1 + set next_allbelow 1 + break + } + + set boundary [pattern_boundary $gp] + if {$boundary ne "" && [::punk::path::globmatchpath $boundary $path]} { + set recurse_below 1 + set next_allbelow 1 + continue + } + + if {[pattern_prefix_viable $gp $path]} { + set recurse_below 1 + } + } + + return [dict create {*}{ + } include_files $include_files {*}{ + } recurse_below $recurse_below {*}{ + } next_allbelow $next_allbelow {*}{ } + ] + } + + proc child_path_state {glob_paths child_path inherited_allbelow} { + if {$inherited_allbelow} { + return 1 + } + foreach gp $glob_paths { + if {[pattern_prefix_viable $gp $child_path]} { + return 1 } - } else { - set retained $matches } - switch -- $opt_sort { + return 0 + } + + proc _sort_paths {paths sortmode} { + switch -- $sortmode { ascii { - set dirfiles [lsort $retained] + return [lsort $paths] } dictionary { - set dirfiles [lsort -dictionary $retained] + return [lsort -dictionary $paths] } natural { - set dirfiles [natsort::sort $retained] + return [natsort::sort $paths] } default { - set dirfiles $retained + return $paths } } } - lappend files {*}$dirfiles - if {[catch {glob -nocomplain -dir $opt_dir -type d *} dirdirs]} { - puts stderr "treefilenames error while listing subdirs in dir $opt_dir\n $dirdirs" - set dirdirs [list] - } - set okdirs [list] - foreach dir $dirdirs { - set skip 0 - foreach anti $opt_antiglob_paths { - if {[globmatchpath $anti $dir]} { - set skip 1 - break + proc _path_matches_any {patterns path} { + foreach pattern $patterns { + if {[::punk::path::globmatchpath $pattern $path]} { + return 1 } } - if {!$skip} { - lappend okdirs $dir + return 0 + } + + proc _tailbase_relative {tailbase path} { + if {$tailbase eq ""} { + return $path } + return [::punk::path::relative $tailbase $path] } - if {[llength $okdirs]} { - switch -- $opt_sort { - ascii { - set finaldirs [lsort $okdirs] + + proc _tailbase_match_path {tailbase path} { + set match_path [_tailbase_relative $tailbase $path] + if {$match_path eq "."} { + return "" + } + return $match_path + } + + proc _tailbase_relative_list {tailbase paths} { + if {$tailbase eq ""} { + return $paths + } + set relative_paths [list] + foreach path $paths { + lappend relative_paths [_tailbase_relative $tailbase $path] + } + return $relative_paths + } + + proc _retain_files {matches exclude_files sortmode} { + set retained [list] + foreach match $matches { + set skip 0 + set file_tail [file tail $match] + foreach anti $exclude_files { + if {[string match $anti $file_tail]} { + set skip 1 + break + } } - dictionary { - set finaldirs [lsort -dictionary $okdirs] + if {!$skip} { + lappend retained $match } - natural { - set finaldirs [natsort::sort $okdirs] + } + return [_sort_paths $retained $sortmode] + } + + proc _state_from_argd {argd} { + set opts [dict get $argd opts] + set values [dict get $argd values] + set received [dict get $argd received] + + if {[dict exists $received -directory]} { + set directory [dict get $opts -directory] + } else { + set directory [pwd] + } + + set glob_paths [dict get $opts -include-paths] + if {"*" in $glob_paths} { + set glob_paths {*} + } + + set sortmode [dict get $opts -sort] + if {$sortmode eq "natural"} { + package require natsort + } + + return [dict create {*}{ + depth 0 + subvector {} + allbelow 0 + } sort $sortmode {*}{ + } directory $directory {*}{ + } tailbase [dict get $opts -tailbase] {*}{ + } exclude_paths [dict get $opts -exclude-paths] {*}{ + } exclude_files [dict get $opts -exclude-files] {*}{ + } glob_paths $glob_paths {*}{ + } tailglobs [dict get $values tailglobs] {*}{ } - default { - set finaldirs $okdirs + ] + } + + proc walk_treefilenames {state} { + set opt_dir [dict get $state directory] + set opt_tailbase [dict get $state tailbase] + set depth [dict get $state depth] + set subvector [dict get $state subvector] + set callallbelow [dict get $state allbelow] + set opt_sort [dict get $state sort] + set opt_exclude_paths [dict get $state exclude_paths] + set opt_exclude_files [dict get $state exclude_files] + set opt_glob_paths [dict get $state glob_paths] + set tailglobs [dict get $state tailglobs] + + if {![file isdirectory $opt_dir]} { + return [list] + } + if {[string match //zipfs:/* $opt_dir]} { + return [walk_treefilenames_zipfs $state] + } + set opt_dir_match [_tailbase_match_path $opt_tailbase $opt_dir] + if {[_path_matches_any $opt_exclude_paths $opt_dir_match]} { + return [list] + } + + set files [list] + set dir_state [directory_state $opt_glob_paths $opt_dir_match $callallbelow] + if {[dict get $dir_state include_files]} { + if {[catch {glob -nocomplain -dir $opt_dir -type f {*}$tailglobs} matches]} { + puts stderr "treefilenames error while listing files in dir $opt_dir\n $matches" + set dirfiles [list] + } else { + set dirfiles [_retain_files $matches $opt_exclude_files $opt_sort] } + lappend files {*}[_tailbase_relative_list $opt_tailbase $dirfiles] } - foreach dir $finaldirs { - set nextopts [dict merge $opts [list -directory $dir -call-depth-internal [incr CALLDEPTH]]] - lappend files {*}[treefilenames {*}$nextopts {*}$tailglobs] + + if {![dict get $dir_state recurse_below]} { + return $files } - } - return $files - } - proc treefilenames_zipfs {args} { - #seems to be 2 or 3 times faster than treefilenames for //zipfs:/ paths - REVIEW - # is sort order the same? - set argd [punk::args::parse $args withid ::punk::path::treefilenames] - lassign [dict values $argd] leaders opts values received - set tailglobs [dict get $values tailglobs] - # -- --- --- --- --- --- --- - set opt_antiglob_paths [dict get $opts -antiglob_paths] - set opt_antiglob_files [dict get $opts -antiglob_files] - set opt_sort [dict get $opts -sort] - set CALLDEPTH [dict get $opts -call-depth-internal] - # -- --- --- --- --- --- --- - # -- --- --- --- --- --- --- - - set files [list] - if {$CALLDEPTH == 0} { - if {$opt_sort eq "natural"} { - package require natsort + + if {[catch {glob -nocomplain -dir $opt_dir -type d *} dirdirs]} { + puts stderr "treefilenames error while listing subdirs in dir $opt_dir\n $dirdirs" + set dirdirs [list] + } + set okdirs [list] + foreach dir $dirdirs { + if {![_path_matches_any $opt_exclude_paths [_tailbase_match_path $opt_tailbase $dir]]} { + lappend okdirs $dir + } } - #set opts [dict merge $opts [list -directory $opt_dir]] - if {![dict exists $received -directory]} { - set opt_dir [pwd] + + if {$opt_glob_paths eq "*"} { + set matchdirs $okdirs } else { - set opt_dir [dict get $opts -directory] + set matchdirs [list] + foreach dir $okdirs { + if {$callallbelow || [child_path_state $opt_glob_paths [_tailbase_match_path $opt_tailbase $dir] $callallbelow]} { + lappend matchdirs $dir + } + } } - if {![file isdirectory $opt_dir]} { - return [list] + + set finaldirs [_sort_paths $matchdirs $opt_sort] + set childallbelow [expr {$callallbelow || [dict get $dir_state next_allbelow]}] + set nextsubvector [list {*}$subvector [file tail $opt_dir]] + foreach dir $finaldirs { + set child_state [dict merge $state [dict create {*}{} \ + directory $dir \ + depth [expr {$depth + 1}] \ + subvector $nextsubvector \ + allbelow $childallbelow]] + lappend files {*}[walk_treefilenames $child_state] } - } else { - #assume/require to exist in any recursive call - set opt_dir [dict get $opts -directory] - } - if {![string match [zipfs root]* $opt_dir]} { - error "treefilenames_zipfs can only be used on paths beginning with [zipfs root] on this systems" + return $files } - set dir [string trimright $opt_dir "/"] ;#e.g normalize //zipfs:/x/ to //zipfs:/x - set dirlen [string length $dir] - - set skip 0 - foreach anti $opt_antiglob_paths { - if {[globmatchpath $anti $dir]} { - set skip 1 - break + + proc walk_treefilenames_zipfs {state} { + set opt_dir [dict get $state directory] + set opt_tailbase [dict get $state tailbase] + set opt_exclude_paths [dict get $state exclude_paths] + set opt_exclude_files [dict get $state exclude_files] + set opt_glob_paths [dict get $state glob_paths] + set opt_sort [dict get $state sort] + set tailglobs [dict get $state tailglobs] + + if {![string match [zipfs root]* $opt_dir]} { + error "treefilenames_zipfs can only be used on paths beginning with [zipfs root] on this systems" } - } - if {$skip} { - return [list] - } - set subpaths [zipfs list $dir/*] - set dirlist [list] - set skipdirs [list] - set filelist [list] - #process in the order they came - sorting large list more expensive?? review - foreach sub $subpaths { - set tail [string range $sub $dirlen+1 end] ;#dirlen is without trailing slash - set tailparts [file split $tail] - set accum "" - set skipdir 0 - foreach tp [lrange $tailparts 0 end-1] { - append accum "/$tp" - set superpath "${dir}${accum}" - if {$superpath in $skipdirs} { - #subpart already in skipdirs - set skipdir 1 - break - } - if {$superpath ni $dirlist} { - set skip2 0 - foreach anti $opt_antiglob_paths { - if {[globmatchpath $anti $superpath]} { - set skip2 1 + set dir [string trimright $opt_dir "/"] + if {[_path_matches_any $opt_exclude_paths [_tailbase_match_path $opt_tailbase $dir]]} { + return [list] + } + set dirlen [string length $dir] + set subpaths [zipfs list $dir/*] + set dirlist [list] + set skipdirs [list] + set filelist [list] + foreach sub $subpaths { + set tail [string range $sub $dirlen+1 end] + set tailparts [file split $tail] + set accum "" + set skipdir 0 + foreach tailpart [lrange $tailparts 0 end-1] { + append accum "/$tailpart" + set superpath "${dir}${accum}" + if {$superpath in $skipdirs} { + set skipdir 1 + break + } + if {$superpath ni $dirlist} { + if {[_path_matches_any $opt_exclude_paths [_tailbase_match_path $opt_tailbase $superpath]]} { lappend skipdirs $superpath + set skipdir 1 break + } else { + lappend dirlist $superpath } } - if {!$skip2} { - lappend dirlist $superpath - } else { - set skipdir 1 - break - } } - } - if {!$skipdir} { - #process final part of path - append accum "/[lindex $tailparts end]" - set finalpart "${dir}${accum}" - if {$finalpart ni $dirlist} { - if {[file type $finalpart] eq "file"} { - set ftail [lindex $tailparts end] - set match 0 - if {"*" ni $tailglobs} { - foreach tg $tailglobs { - if {[string match $tg $ftail]} { - set match 1 - break + if {!$skipdir} { + append accum "/[lindex $tailparts end]" + set finalpart "${dir}${accum}" + if {$finalpart ni $dirlist} { + if {[file type $finalpart] eq "file"} { + set file_tail [lindex $tailparts end] + set match 0 + if {"*" ni $tailglobs} { + foreach tailglob $tailglobs { + if {[string match $tailglob $file_tail]} { + set match 1 + break + } + } + } else { + set match 1 + } + if {$match} { + if {$opt_glob_paths ne "*"} { + set file_dir_match [_tailbase_match_path $opt_tailbase [file dirname $finalpart]] + set file_dir_state [directory_state $opt_glob_paths $file_dir_match 0] + set match [dict get $file_dir_state include_files] } } - } else { - set match 1 - } - if {$match} { - if {[llength $opt_antiglob_files]} { + if {$match} { set skipfile 0 - foreach anti $opt_antiglob_files { - if {[string match $anti $ftail]} { - set skipfile 1; break + foreach anti $opt_exclude_files { + if {[string match $anti $file_tail]} { + set skipfile 1 + break } } if {!$skipfile} { - lappend filelist $finalpart + lappend filelist [_tailbase_relative $opt_tailbase $finalpart] } - } else { - lappend filelist $finalpart } - } - } else { - if {$finalpart ni $dirlist} { - set skip2 0 - foreach anti $opt_antiglob_paths { - if {[globmatchpath $anti $finalpart]} { - set skip2 1 + } else { + if {$finalpart ni $dirlist} { + if {[_path_matches_any $opt_exclude_paths [_tailbase_match_path $opt_tailbase $finalpart]]} { lappend skipdirs $finalpart - break + } else { + lappend dirlist $finalpart } } - if {!$skip2} { - lappend dirlist $finalpart - } } } } } + return [_sort_paths $filelist $opt_sort] } - switch -- $opt_sort { - ascii { - set finalfilelist [lsort $filelist] - } - dictionary { - set finalfilelist [lsort -dictionary $filelist] - } - natural { - set finalfilelist [natsort::sort $filelist] - } - default { - set finalfilelist $filelist - } + } + + #todo - treefolders with similar search caps as treefilenames + + punk::args::define { + @id -id ::punk::path::treefilenames + @cmd -name punk::path::treefilenames\ + -summary\ + "List of filenames below supplied path."\ + -help\ + "List of filenames below path. + The resulting list is unsorted. + + The path globbing syntax supports *, ** and ? as glob characters in any segment of the path, with the following semantics: + * matches any single segment in the path + ** matches 1 or more segments in the path (so /usr/**/bin will match /usr/x/bin and user/x/y/bin but not /usr/bin ) + ? matches any single character in a single segment of the path (so /usr/te?t will match /usr/test and /usr/text but not /usr/texxt) + " + -directory -type directory -help\ + "folder in which to begin recursive scan for files." + -tailbase -type string -default "" -help\ + "if supplied, only the relative path compared to the tailbase will be returned for each file. + So if tailbase is /usr and a file is found at /usr/x/y/file.txt, the returned path for that file would be x/y/file.txt. + If tailbase is not supplied, the full path to each file will be returned. + + If tailbase is supplied, it should be a prefix of the directory supplied (or the directory itself) + The patterns in -exclude-paths should be written to match the returned paths (i.e with the tailbase prefix removed) if -tailbase is supplied. + If the tailbase is not a prefix of the directory supplied, the resulting paths may have /../ components in them to account for the difference, + but the behaviour is not well defined in this case and it is recommended to ensure tailbase is a prefix of the directory supplied if using -tailbase. + + see: punk::path::relative to compute relative paths + " + -sort -type any -default natural -choices {none ascii dictionary natural} + -exclude-paths -default {} -help\ + "list of path patterns to exclude + may include * and ** path segments e.g + /usr/** (exclude subfolders based at /usr but not + files within /usr itself) + **/_aside (exclude files where _aside is last segment) + **/_aside/* (exclude folders one below an _aside folder) + **/_aside/** (exclude files in all folders with _aside as a segment)" + -exclude-files -default {} + -include-paths -default {**} -help\ + "list of path patterns to include + may include * and ** path segments e.g + /usr/** (include files in subfolders based at /usr but not + files within /usr itself) + **/_aside (include files where _aside is last segment in the folder) + **/_aside/* (include files in folders one below an _aside folder) + **/_aside/** (include all files in folders with _aside as a segment)" + @values -min 0 -max -1 -optional 1 -type string + tailglobs -default * -multiple 1 -help\ + "Patterns to match against filename portion (last segment) of each file path + within the directory tree being searched." + } + + #todo - implement treefiles which acts like dirfiles but allows path globbing in the same way as punk::ns::ns/ + #then review if treefiles can replace dirfiles or if both should exist (dirfiles can have literal glob chars in path segments - but that is a rare usecase) + proc treefilenames {args} { + set argd [punk::args::parse $args withid ::punk::path::treefilenames] + set state [treefile_priv::_state_from_argd $argd] + return [treefile_priv::walk_treefilenames $state] + } + punk::args::set_idalias ::punk::path::treefilenames_zipfs ::punk::path::treefilenames + proc treefilenames_zipfs {args} { + #seems to be 2 or 3 times faster than treefilenames for //zipfs:/ paths - REVIEW + # is sort order the same? + set argd [punk::args::parse $args withid ::punk::path::treefilenames] + set state [treefile_priv::_state_from_argd $argd] + if {![file isdirectory [dict get $state directory]]} { + return [list] } - return $finalfilelist + return [treefile_priv::walk_treefilenames_zipfs $state] } #maint warning - also in punkcheck diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/pipe-1.0.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/pipe-1.0.tm index 034fae01..eae8731c 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/pipe-1.0.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/pipe-1.0.tm @@ -169,8 +169,8 @@ tcl::namespace::eval punk::pipe::lib { #This stops us matching {/@**@x x} vs {/@**@x x} #--- - set rhs [tcl::string::map {: ? * [ ] \\ {"} " " } $rhs] - #review - we don't expect other command-incompatible chars such as colon? + set rhs [tcl::string::map {: ; ? * [ ] \\ {"} " " } $rhs] + #review - we don't expect other command-incompatible chars? return $rhs } @@ -187,6 +187,7 @@ tcl::namespace::eval punk::pipe::lib { #exclude quoted whitespace proc arg_is_script_shaped {arg} { + set arg [string map {\\; ""} $arg] if {[tcl::string::first \n $arg] >= 0} { return 1 } elseif {[tcl::string::first ";" $arg] >= 0} { diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/repo-0.1.1.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/repo-0.1.1.tm index 5fd534dc..049ed2e7 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/repo-0.1.1.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/repo-0.1.1.tm @@ -1817,17 +1817,13 @@ namespace eval punk::repo { error "unimplemented" } - #file normalize is expensive so this is too + #file normalize can be a little expensive so this is too proc norm {path {platform env}} { - #kettle::path::norm - #see also wiki - #full path normalization - - set platform [string tolower $platform] - if {$platform eq "env"} { - set platform $::tcl_platform(platform) - } + #set platform [string tolower $platform] + #if {$platform eq "env"} { + # set platform $::tcl_platform(platform) + #} #No - don't do this sort of path translation here - leave as option for specific utils only such as ./ #Windows volume-relative syntax with specific volume specified is somewhat broken in Tcl - but leading slash volume-relative does work #We shouldn't break it totally just because accessing WSL/mingw paths is slightly more useful @@ -1835,6 +1831,9 @@ namespace eval punk::repo { #return [file dirname [file normalize [punk::unixywindows::towinpath $path]/__]] #} + #kettle::path::norm + #see also wiki + #full path normalization return [file dirname [file normalize $path/__]] } diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punkapp-0.1.1.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punkapp-0.1.1.tm new file mode 100644 index 00000000..2ccf6afa --- /dev/null +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punkapp-0.1.1.tm @@ -0,0 +1,240 @@ +#utilities for punk apps to call + + +namespace eval punkapp { + variable result + variable waiting "no" + proc hide_dot_window {} { + #alternative to wm withdraw . + #see https://wiki.tcl-lang.org/page/wm+withdraw + wm geometry . 1x1+0+0 + wm overrideredirect . 1 + wm transient . + } + proc is_toplevel {w} { + if {![llength [info commands winfo]]} { + return 0 + } + expr {[winfo toplevel $w] eq $w && ![catch {$w cget -menu}]} + } + proc get_toplevels {{w .}} { + if {![llength [info commands winfo]]} { + return [list] + } + set list {} + if {[is_toplevel $w]} { + lappend list $w + } + foreach w [winfo children $w] { + lappend list {*}[get_toplevels $w] + } + return $list + } + + proc make_toplevel_next {prefix} { + set top [get_toplevel_next $prefix] + return [toplevel $top] + } + #possible race condition if multiple calls made without actually creating the toplevel, or gap if highest existing closed in the meantime + #todo - reserve_toplevel_next ? keep list of toplevels considered 'allocated' even if never created or already destroyed? what usecase? + #can call wm withdraw to to reserve newly created toplevel. To stop re-use of existing names after destruction would require a list or at least a record of highest created for each prefix + proc get_toplevel_next {prefix} { + set base [string trim $prefix .] ;# .myapp -> myapp .myapp.somewindow -> myapp.somewindow . -> "" + + + + } + proc exit {{toplevel ""}} { + variable waiting + variable result + variable default_result + set toplevels [get_toplevels] + if {[string length $toplevel]} { + set wposn [lsearch $toplevels $toplevel] + if {$wposn > 0} { + destroy $toplevel + } + } else { + #review + if {[package provide punk::repl::codethread] ne "" && [punk::repl::codethread::is_running]} { + puts stderr "punkapp::exit called without toplevel - showing console" + show_console + return 0 + } else { + puts stderr "punkapp::exit called without toplevel - exiting" + if {$waiting ne "no"} { + if {[info exists result(shell)]} { + set temp [set result(shell)] + unset result(shell) + set waiting $temp + } else { + set waiting "" + } + } else { + ::exit + } + } + } + + set controllable [get_user_controllable_toplevels] + if {![llength $controllable]} { + if {[package provide punk::repl::codethread] ne "" && [punk::repl::codethread::is_running]} { + show_console + } else { + if {$waiting ne "no"} { + if {[info exists result(shell)]} { + set temp [set result(shell)] + unset result(shell) + set waiting $temp + } elseif {[info exists result($toplevel)]} { + set temp [set result($toplevel)] + unset result($toplevel) + set waiting $temp + } elseif {[info exists default_result]} { + set temp $default_result + unset default_result + set waiting $temp + } else { + set waiting "" + } + } else { + ::exit + } + } + } + } + proc close_window {toplevel} { + wm withdraw $toplevel + if {![llength [get_user_controllable_toplevels]]} { + punkapp::exit $toplevel + } + destroy $toplevel + } + proc wait {args} { + variable waiting + variable default_result + if {[dict exists $args -defaultresult]} { + set default_result [dict get $args -defaultresult] + } + foreach t [punkapp::get_toplevels] { + if {[wm protocol $t WM_DELETE_WINDOW] eq ""} { + wm protocol $t WM_DELETE_WINDOW [list punkapp::close_window $t] + } + } + if {[package provide punk::repl::codethread] ne "" && [punk::repl::codethread::is_running]} { + puts stderr "repl eventloop seems to be running - punkapp::wait not required" + } else { + if {$waiting eq "no"} { + set waiting "waiting" + vwait ::punkapp::waiting + return $::punkapp::waiting + } + } + } + + #A window can be 'visible' according to this - but underneath other windows etc + #REVIEW - change name? + proc get_visible_toplevels {{w .}} { + if {![llength [info commands winfo]]} { + return [list] + } + set list [get_toplevels $w] + set mapped [lmap v $list {expr {[winfo ismapped $v] ? $v : {}}}] + set mapped [concat {*}$mapped] ;#ignore {} + set visible [list] + foreach m $mapped { + if {[wm overrideredirect $m] == 0 } { + lappend visible $m + } else { + if {[winfo height $m] >1 && [winfo width $m] > 1} { + #technically even a 1x1 is visible.. but in practice even a 10x10 is hardly likely to be noticeable when overrideredirect == 1 + #as a convention - 1x1 with no controls is used to make a window invisible so we'll treat anything larger as visible + lappend visible $m + } + } + } + return $visible + } + proc get_user_controllable_toplevels {{w .}} { + set visible [get_visible_toplevels $w] + set controllable [list] + foreach v $visible { + if {[wm overrideredirect $v] == 0} { + lappend controllable $v + } + } + #only return visible windows with overrideredirect == 0 because there exists some user control. + #todo - review.. consider checking if position is outside screen areas? Technically controllable.. but not easily + return $controllable + } + proc hide_console {args} { + set opts [dict create -force 0] + if {([llength $args] % 2) != 0} { + error "hide_console expects pairs of arguments. e.g -force 1" + } + #set known_opts [dict keys $defaults] + foreach {k v} $args { + switch -- $k { + -force { + dict set opts $k $v + } + default { + error "Unrecognised options '$k' known options: [dict keys $opts]" + } + } + } + set force [dict get $opts -force] + + if {!$force} { + if {![llength [get_user_controllable_toplevels]]} { + puts stderr "Cannot hide console while no user-controllable windows available" + return 0 + } + } + if {$::tcl_platform(platform) eq "windows"} { + #hide won't work for certain consoles cush as conemu,wezterm - and doesn't really make sense for tabbed windows anyway. + #It would be nice if we could tell the console window to hide just the relevant tab - or the whole window if only one tab present - but this is unlikely to be possible in any standard way. + #an ordinary cmd.exe or pwsh.exe or powershell.exe window can be hidden ok though. + #(but with wezterm - process is cmd.exe - but it has style popup and can't be hidden with a twapi::hide_window call) + package require twapi + set h [twapi::get_console_window] + set pid [twapi::get_window_process $h] + set pinfo [twapi::get_process_info $pid -name] + set pname [dict get $pinfo -name] + set wstyle [twapi::get_window_style $h] + #tclkitsh/tclsh? + if {($pname in [list cmd.exe pwsh.exe powershell.exe] || [string match punk*.exe $pname]) && "popup" ni $wstyle} { + twapi::hide_window $h + return 1 + } else { + puts stderr "punkapp::hide_console unable to hide this type of console window" + return 0 + } + } else { + #todo + puts stderr "punkapp::hide_console unimplemented on this platform (todo)" + return 0 + } + } + + proc show_console {} { + if {$::tcl_platform(platform) eq "windows"} { + package require twapi + if {![catch {set h [twapi::get_console_window]} errM]} { + twapi::show_window $h -activate -normal + } else { + #no console - assume launched from something like wish? + catch {console show} + } + } else { + #todo + puts stderr "punkapp::show_console unimplemented on this platform" + } + } + +} + +package provide punkapp [namespace eval punkapp { + variable version + set version 0.1.1 +}] \ No newline at end of file diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punkcheck-0.1.1.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punkcheck-0.1.1.tm new file mode 100644 index 00000000..bdff666e --- /dev/null +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punkcheck-0.1.1.tm @@ -0,0 +1,2458 @@ +# -*- tcl -*- +# Maintenance Instruction: leave the 999999.xxx.x as is and use 'dev make' or src/make.tcl to update from -buildversion.txt +# +# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. +# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# (C) 2023 +# +# @@ Meta Begin +# Application punkcheck 0.1.0 +# Meta platform tcl +# Meta license +# @@ Meta End + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +##e.g package require frobz + +package require punk::tdl +package require punk::path +package require punk::repo +package require punk::mix::util + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# Punkcheck uses the TDL format which is a list of lists in Tcl format +# It is intended primarily for source build/distribution tracking within a punk project or single filesystem - with relative paths. +# +#see following article regarding the many problems with using mtime for build-decisions: https://apenwarr.ca/log/20181113 +# +namespace eval punkcheck { + namespace export {*}{ + uuid + installtrack + install + install_tm_files + install_non_tm_files + summarize_install_resultdict + } + + #exclude-dir & exclude-file entries match the pattern at any level - should not contain path separators + variable default_excludedirseg_core [list "#*" "_aside" "_build" ".git" ".fossil*"] + variable default_excludefiletail_core "" + + set has_twapi 0 + if {"windows" eq $::tcl_platform(platform)} { + set has_twapi [expr {![catch {package require twapi}]}] + } + if {$has_twapi} { + interp alias "" ::punkcheck::uuid "" ::twapi::new_uuid + } else { + catch {package require uuid} + interp alias "" ::punkcheck::uuid "" ::uuid::uuid generate + } + + proc default_excludedirseg_core {} { + variable default_excludedirseg_core + return $default_excludedirseg_core + } + proc default_excludefiletail_core {} { + variable default_excludefiletail_core + if {$default_excludefiletail_core eq ""} { + set default_excludefiletail_core [list "*.swp" "*[punk::mix::util::tm_version_magic]*" "*-buildversion.txt" ".punkcheck"] + } + return $default_excludefiletail_core + } + + + proc load_records_from_file {punkcheck_file} { + set record_list [list] + if {[file exists $punkcheck_file]} { + set tdlscript [punk::mix::util::fcat $punkcheck_file] + if {[catch { + set record_list [punk::tdl::prettyparse $tdlscript] + } errparse]} { + error "punkcheck::load_records_from_file failed to parse '$punkcheck_file'\n error:$errparse" + } + } + return $record_list + } + proc save_records_to_file {recordlist punkcheck_file {trigger {}} {debugchannel ""}} { + set newtdl [punk::tdl::prettyprint $recordlist] + set linecount [llength [split $newtdl \n]] + + if {$debugchannel ne "" && $trigger ne ""} { + puts $debugchannel "\x1b\[36mSaving [llength $recordlist] records as $linecount lines to file '$punkcheck_file' trigger: \x1b\[32m$trigger\x1b\[m" + } + #puts stdout $newtdl + set fd [open $punkcheck_file w] + chan configure $fd -translation binary + puts -nonewline $fd $newtdl + flush $fd + close $fd + return [list recordcount [llength $recordlist] linecount $linecount] + } + + + #todo - work out way to use same punkcheck file for multiple installers running concurrently. Thread? + #an installtrack objects represents an installation path from sourceroot to targetroot + #The source and target folders should be as specific as possible but it is valid to specify for example c:/ -> c:/ (or / -> /) if source and targets within the installation operation are spread around. + # + set objname [namespace current]::installtrack + if {$objname ni [info commands $objname]} { + package require oolib + + #FILEINFO record - target fileset with body records: INSTALL-RECORD,INSTALL-INPROGRESS,INSTALL-SKIPPED,DELETE-RECORD,DELETE-INPROGRESS,MODIFY-INPROGRESS,MODIFY-RECORD + #each FILEINFO body being a list of SOURCE records + oo::class create targetset { + variable o_targets + variable o_keep_installrecords + variable o_keep_skipped + variable o_keep_inprogress + variable o_records + constructor {args} { + #set o_records [oolib::collection create [namespace current]::recordcollection] + set o_records [list] + + } + + method as_record {} { + dict create {*}{ + } tag FILEINFO {*}{ + } -targets $o_targets {*}{ + } -keep_installrecords $o_keep_installrecords {*}{ + } -keep_skipped $o_keep_skipped {*}{ + } -keep_inprogress $o_keep_inprogress {*}{ + } body $o_records {*}{ + } + } + + #retrieve last completed record for the fileset ie exclude SKIPPED,INSTALL-INPROGRESS,DELETE-INPROGRESS,MODIFY-INPROGRESS + method get_last_record {fileset_record} { + set body [dict_getwithdefault $fileset_record body [list]] + set previous_records [lrange $body 0 end-1] + #get last previous that is tagged INSTALL-RECORD,MODIFY-RECORD,DELETE-RECORD + set revlist [lreverse $previous_records] + foreach rec $revlist { + switch -- [dict get $rec tag] { + INSTALL-RECORD - MODIFY-RECORD - DELETE-RECORD - VIRTUAL-RECORD { + return $rec + } + } + } + return [list] + } + } + + #instances created by an installtrack object in method start_event + #also in installtrack constructor - to represent existing events from the .punkcheck data + oo::class create installevent { + variable o_id + variable o_rel_sourceroot + variable o_rel_targetroot + variable o_ts_begin + variable o_ts_end + variable o_types + variable o_configdict + variable o_targets + variable o_operation + variable o_operation_start_ts + variable o_path_cksum_cache + variable o_fileset_record + variable o_installer ;#parent object + variable o_debugchannel + constructor {installer rel_sourceroot rel_targetroot args} { + set o_installer $installer + set o_debugchannel [$installer get_debugchannel] + set o_operation_start_ts "" + set o_path_cksum_cache [dict create] + set o_operation "" + set defaults [dict create {*}{ + -id "" + -tsbegin "" + -config {} + -tsend "" + -types {} + }] + set opts [dict merge $defaults $args] + if {[dict get $opts -id] eq ""} { + set o_id [punkcheck::uuid] + } else { + set o_id [dict get $opts -id] + } + if {[dict get $opts -tsbegin] eq ""} { + set o_ts_begin [clock microseconds] + } else { + set o_ts_begin [dict get $opts -tsbegin] + } + set o_ts_end [dict get $opts -tsend] + set o_types [dict get $opts -types] + set o_configdict [dict get $opts -config] + + set o_rel_sourceroot $rel_sourceroot + set o_rel_targetroot $rel_targetroot + } + destructor { + #puts "[self] destructor called" + } + method as_record {} { + set begin_seconds [expr {$o_ts_begin / 1000000}] + set tsiso_begin [clock format $begin_seconds -format "%Y-%m-%dT%H:%M:%S"] + if {$o_ts_end ne ""} { + set end_seconds [expr {$o_ts_end / 1000000}] + set tsiso_end [clock format $end_seconds -format "%Y-%m-%dT%H:%M:%S"] + } else { + set tsiso_end "" + } + + dict create {*}{ + } tag EVENT {*}{ + } -tsiso_begin $tsiso_begin {*}{ + } -ts_begin $o_ts_begin {*}{ + } -tsiso_end $tsiso_end {*}{ + } -ts_end $o_ts_end {*}{ + } -id $o_id {*}{ + } -source $o_rel_sourceroot {*}{ + } -targets $o_rel_targetroot {*}{ + } -types $o_types {*}{ + } -config $o_configdict {*}{ + } + } + method get_id {} { + return $o_id + } + method get_operation {} { + return $o_operation + } + method get_targets {} { + return $o_targets + } + method get_targets_exist {} { + set punkcheck_folder [file dirname [$o_installer get_checkfile]] + #puts stdout "### punkcheck glob -dir $punkcheck_folder -tails {*}$o_targets" + #targets can be paths such as punk/mix/commandset/module-0.1.0.tm - glob can search levels below supplied -dir + set existing [glob -nocomplain -dir $punkcheck_folder -tails {*}$o_targets] + + return $existing + } + method end {} { + set o_ts_end [clock microseconds] + } + method targetset_dict {} { + punk::records_as_target_dict [$o_installer get_recordlist] + } + + #related - installfile_begin + #call init before we know if we are going to run the operation vs skip + method targetset_init {operation targetset} { + set known_ops [list QUERY INSTALL MODIFY DELETE VIRTUAL] + if {[string toupper $operation] ni $known_ops} { + error "[self] add_target unknown operation '$operation'. Known operations $known_ops" + } + set o_operation [string toupper $operation] + + if {$o_operation_start_ts ne ""} { + error "[self] targetset_init $o_operation operation already in progress. Use targetset_finished or targetset_complete to finish." + } + set o_operation_start_ts [clock microseconds] + set seconds [expr {$o_operation_start_ts / 1000000}] + set tsiso [clock format $seconds -format "%Y-%m-%dT%H:%M:%S"] + set punkcheck_file [$o_installer get_checkfile] + set punkcheck_folder [file dirname $punkcheck_file] + + set relativepath_targetset [list] + if {$o_operation eq "VIRTUAL"} { + foreach p $targetset { + lappend relativepath_targetset $p + } + } else { + foreach p $targetset { + if {[file pathtype $p] eq "absolute"} { + lappend relativepath_targetset [punkcheck::lib::path_relative $punkcheck_folder $p] + } else { + lappend relativepath_targetset $p + } + } + } + + + set fields [list {*}{ + } -tsiso $tsiso {*}{ + } -ts $o_operation_start_ts {*}{ + } -installer [$o_installer get_name] {*}{ + } -eventid $o_id {*}{ + } + ] + + set o_targets [lsort -dictionary -increasing $relativepath_targetset] ;#exact sort order not critical - but must be consistent + + + set record_list [punkcheck::load_records_from_file $punkcheck_file] + + #--------------------------------------------------------------------------- + #load as dict to test for dupes + #set _targetdict [my targetset_dict] + if {[catch { + set _targetdict [punkcheck::recordlist::records_as_target_dict $record_list] + } errMsg]} { + error "targetset_init operation:$operation error verifying existing records from file $punkcheck_file. Error: $errMsg" + } + #--------------------------------------------------------------------------- + + set extractioninfo [punkcheck::recordlist::extract_or_create_fileset_record $o_targets $record_list] + set o_fileset_record [dict get $extractioninfo record] + set record_list [dict get $extractioninfo recordset] ;#if fileset wasn't present, same as original record_list, otherwise full recordset with the fileset record removed, ready for reinsertion. + set isnew [dict get $extractioninfo isnew] + set oldposition [dict get $extractioninfo oldposition] + unset extractioninfo + + #INSTALL-INPROGRESS will become INSTALL-RECORD or INSTALL-FAILED or INSTALL-SKIPPED upon finalisation + #-installer and -eventid keys are added here + set new_inprogress_record [dict create tag [string toupper $operation]-INPROGRESS {*}$fields -tempcontext [my as_record] body {}] + #set existing_body [dict_getwithdefault $o_fileset_record body [list]] + #todo - look for existing "-INPROGRESS" records - mark as failed or incomplete? + dict lappend o_fileset_record body $new_inprogress_record + + if {$isnew} { + lappend record_list $o_fileset_record + } else { + #set record_list [linsert $record_list[unset record_list] $oldposition $o_fileset_record] + ledit record_list $oldposition -1 $o_fileset_record + } + if {$o_operation ne "QUERY"} { + punkcheck::save_records_to_file $record_list $punkcheck_file "targetset_init $o_operation [llength $targetset] targets" + } + return $o_fileset_record + + } + #operation has been started + #todo - upgrade .punkcheck format to hold more than just list of SOURCE entries in each record. + # - allow arbitrary targetset_startphase targetset_endphase calls to store timestamps and calculate elapsed time + method targetset_started {} { + set punkcheck_folder [file dirname [$o_installer get_checkfile]] + if {$o_operation eq "QUERY"} { + set fileinfo_body [dict get $o_fileset_record body] ;#body of FILEINFO record + set installing_record [lindex $fileinfo_body end] + + set ts_start [dict get $installing_record -ts] + set ts_now [clock microseconds] + set metadata_us [expr {$ts_now - $ts_start}] + + #?? + #JJJ + #dict set installing_record -metadata_us $metadata_us + dict set installing_record -ts_start_transfer $ts_now + + lset fileinfo_body end $installing_record + + return [dict set o_fileset_record body $fileinfo_body] + } else { + #legacy call + #saves to .punkcheck file + return [set o_fileset_record [punkcheck::installfile_started_install $punkcheck_folder $o_fileset_record]] + } + } + method targetset_end {status args} { + set defaults [dict create {*}{ + -note \uFFFF + }] + set known_opts [dict keys $defaults] + if {[llength $args] % 2} { + error "targetset_end arguments after status must be in the form of -flag value pairs. known flags: $known_opts" + } + set opts [dict merge $defaults $args] + if {[dict get $opts -note] eq "\uFFFF"} { + dict unset opts -note + } + + set status [string toupper $status] + set statusdict [dict create OK RECORD SKIPPED SKIPPED FAILED FAILED] + if {$o_operation_start_ts eq ""} { + error "[self] targetset_end $status - no current operation - call targetset_started first" + } + if {$status ni [dict keys $statusdict]} { + error "[self] targetset_end unrecognized status:$status known values: [dict keys $statusdict]" + } + if {![punkcheck::lib::is_file_record_inprogress $o_fileset_record]} { + error "targetset_end $status error: bad fileset_record - expected FILEINFO with last body element *-INPROGRESS" + } + set targetlist [dict get $o_fileset_record -targets] + if {$targetlist ne $o_targets} { + error "targetset_end $status error. targetlist mismatch between file : $targetlist vs $o_targets" + } + set operation_end_ts [clock microseconds] + set elapsed_us [expr {$operation_end_ts - $o_operation_start_ts}] + set file_record_body [dict get $o_fileset_record body] + set installing_record [lindex $file_record_body end] + set punkcheck_file [$o_installer get_checkfile] + set punkcheck_folder [file dirname $punkcheck_file] + set record_list [punkcheck::load_records_from_file $punkcheck_file] + if {[dict exists $installing_record -ts_start_transfer]} { + set ts_start_transfer [dict get $installing_record -ts_start_transfer] + set transfer_us [expr {$operation_end_ts - $ts_start_transfer}] + dict set installing_record -transfer_us $transfer_us + } + if {[dict exists $opts -note]} { + dict set installing_record -note [dict get $opts -note] + } + + dict set installing_record -elapsed_us $elapsed_us + dict unset installing_record -tempcontext + dict set installing_record tag "${o_operation}-[dict get $statusdict $status]" ;# e.g INSTALL-RECORD, INSTALL-SKIPPED + if {$o_operation in [list INSTALL MODIFY] && [dict get $statusdict $status] eq "RECORD"} { + #only calculate and store post operation target cksums on successful INSTALL or MODIFY, doesn't make sense for DELETE or VIRTUAL operations + set new_targets_cksums [list] ;#ordered list of cksums matching targetset order + set cksum_all_opts "" ;#same cksum opts for each target so we store it once + set ts_begin_cksum [clock microseconds] + foreach p $o_targets { + set tgt_cksum_info [punk::mix::base::lib::cksum_path [file join $punkcheck_folder $p]] + lappend new_targets_cksums [dict get $tgt_cksum_info cksum] + if {$cksum_all_opts eq ""} { + set cksum_all_opts [dict get $tgt_cksum_info opts] + } + } + set cksum_us [expr {[clock microseconds] - $ts_begin_cksum}] + dict set installing_record -targets_cksums $new_targets_cksums + dict set installing_record -cksum_all_opts $cksum_all_opts + dict set installing_record -cksum_us $cksum_us + } + lset file_record_body end $installing_record + dict set o_fileset_record body $file_record_body + set o_fileset_record [punkcheck::recordlist::file_record_prune $o_fileset_record] + + set oldrecordinfo [punkcheck::recordlist::get_file_record $targetlist $record_list] + set old_posn [dict get $oldrecordinfo position] + if {$old_posn == -1} { + lappend record_list $o_fileset_record + } else { + lset record_list $old_posn $o_fileset_record + } + if {$o_operation ne "QUERY"} { + punkcheck::save_records_to_file $record_list $punkcheck_file "targetset_end $o_operation $status [llength $o_targets] targets" + } + set o_operation_start_ts "" + set o_operation "" + return $o_fileset_record + } + #can supply empty cksum value + # - that will influence the opts used if there is no existing install record + method targetset_cksumcache_set {path_cksum_dict} { + set o_path_cksum_cache $path_cksum_dict + } + method targetset_cksumcache_configure {path {cksuminfodict {}}} { + if {$cksuminfodict eq {}} { + if {[dict exists $o_path_cksum_cache $path]} { + return [dict get $o_path_cksum_cache $path] + } else { + return + } + } + dict for {k v} $cksuminfodict { + switch -- $k { + cksum - opts {} + default { + error "targetset_cksumcache_configure error. Unknown dict value $k. Allowed values {cksum opts}" + } + } + } + dict set o_path_cksum_cache $path $cksuminfodict + } + method targetset_addsource {source_path} { + set punkcheck_file [$o_installer get_checkfile] + set punkcheck_folder [file dirname $punkcheck_file] + if {[file pathtype $source_path] eq "absolute"} { + set rel_source_path [punkcheck::lib::path_relative $punkcheck_folder $source_path] + } else { + set rel_source_path $source_path + } + + #installfile_add_source_and_fetch_metadata accepts list of {cksum opt } dictionaries - although we only have one per path from our configured cksumcache + if {[dict exists $o_path_cksum_cache $rel_source_path]} { + set path_cksum_caches [list [dict get $o_path_cksum_cache $rel_source_path]] + } else { + set path_cksum_caches [list] + } + set o_fileset_record [punkcheck::installfile_add_source_and_fetch_metadata $punkcheck_folder $rel_source_path $o_fileset_record $path_cksum_caches] + #JJJ - update -metadata_us here? + + } + method targetset_last_complete {} { + #retrieve last completed record for the fileset ie exclude SKIPPED,INSTALL-INPROGRESS,DELETE-INPROGRESS,MODIFY-INPROGRESS + set body [punkcheck::dict_getwithdefault $o_fileset_record body [list]] + set previous_records [lrange $body 0 end] + #get last that is tagged INSTALL-RECORD,MODIFY-RECORD,DELETE-RECORD + set revlist [lreverse $previous_records] + foreach rec $revlist { + if {[dict get $rec tag] in [list "INSTALL-RECORD" "MODIFY-RECORD" "DELETE-RECORD" "VIRTUAL-RECORD"]} { + return $rec + } + } + return [list] + + } + method targetset_source_changes {} { + punkcheck::recordlist::file_install_record_source_changes [lindex [dict get $o_fileset_record body] end] + } + + } + + + oo::class create installtrack { + variable o_name + variable o_tsiso + variable o_ts + variable o_keep_events + variable o_checkfile + variable o_sourceroot + variable o_rel_sourceroot + variable o_targetroot + variable o_rel_targetroot + variable o_record_list + variable o_active_event + variable o_events + variable o_debugchannel + constructor {installername punkcheck_file {debugchannel ""}} { + set o_debugchannel $debugchannel + set o_active_event "" + set o_name $installername + + set o_checkfile [file normalize $punkcheck_file] + set o_sourceroot "" + set o_targetroot "" + set o_rel_sourceroot "" + set o_rel_targetroot "" + set o_record_list [list] + + #todo - validate punkcheck file location further?? + set punkcheck_folder [file dirname $o_checkfile] + if {![file isdirectory $punkcheck_folder]} { + error "[self] constructor error. Folder for punkcheck_file not found - $o_checkfile" + } + + my load_all_records + if {![llength $o_record_list] && $o_debugchannel ne ""} { + puts $o_debugchannel "\x1b\[32mNo existing records found in punkcheck file '$o_checkfile' for installer '$installername'. Starting with empty record list.\x1b\[m" + } else { + #verify no duplicate installer records for this installer. + #JMN + set sanity_dict [dict create] + set insane "" + foreach rec $o_record_list { + if {[dict get $rec tag] eq "INSTALLER"} { + set name [dict get $rec -name] + if {[dict exists $sanity_dict $name]} { + #todo - warn - duplicate record for same targetlist - shouldn't happen as we should be using get_file_record to find existing records + if {$o_debugchannel ne ""} { + puts $o_debugchannel "\x1b\[31mpunkcheck installtrack - multiple INSTALLER records with same name '$name'\x1b\[m" + } + set insane "$name" + break + } + dict set sanity_dict $name {} + } + } + if {$insane ne ""} { + set msg "Sanity check: punkcheck file '$o_checkfile' contains multiple records for INSTALLER -name '$insane'." + append msg \n "This may indicate a problem such as multiple concurrent installtrack instances using the same punkcheck file," + append msg \n " or a previous installtrack instance that did not complete properly." + append msg \n " Do you want to DELETE the .punkcheck file?" + append msg \n " It is safe to delete .punkcheck files, at the cost of loss of history and checksums used to optimize installs." + append msg \n " They are a record of installation events and checksums used to avoid unnecessary reinstalls." + append msg \n " If not confirmed, an error will be raised - likely aborting the current operation." + append msg \n "confirm deletion and continue by regenerating the file, by typing the 3 letters: 'yes'." + set answer [punk::lib::askuser $msg] + if {[string tolower $answer] ne "yes"} { + error "Failing due to sanity check failure. User did not confirm with 'yes'." + } + if {[file exists $o_checkfile] && [file isfile $o_checkfile]} { + file delete $o_checkfile + } + if {[file exists $o_checkfile]} { + error "Failed to delete punkcheck file '$o_checkfile' after sanity check failure. Please investigate and resolve the issue before proceeding." + } + set o_record_list [list] + } else { + if {$o_debugchannel ne ""} { + puts $o_debugchannel "\x1b\[32mSanity check passed: no duplicate INSTALLER records found for installer '$installername' in punkcheck file '$o_checkfile'.\x1b\[m" + } + } + unset sanity_dict + } + + set resultinfo [punkcheck::recordlist::get_installer_record $o_name $o_record_list] + set existing_header_posn [dict get $resultinfo position] + if {$existing_header_posn == -1} { + set this_installer_record [punkcheck::recordlist::new_installer_record $o_name] + #set o_record_list [linsert $o_record_list 0 $this_installer_record] + ledit o_record_list -1 -1 $this_installer_record + } else { + set this_installer_record [dict get $resultinfo record] + } + set o_tsiso [dict get $this_installer_record -tsiso] + set o_ts [dict get $this_installer_record -ts] + set o_keep_events [dict get $this_installer_record -keep_events] + + set o_events [oolib::collection create [namespace current]::eventcollection] + set eventlist [punkcheck::dict_getwithdefault $this_installer_record body [list]] + foreach e $eventlist { + set eobj [punkcheck::installevent create [namespace current]::event_[my events count] [self] [dict get $e -source] [dict get $e -targets] {*}$e] + #$o_events add $e [dict get $e -id] + $o_events add $eobj [dict get $e -id] + } + + } + destructor { + #puts "[self] destructor called" + } + method test {} { + return [self] + } + method get_name {} { + return $o_name + } + method get_checkfile {} { + return $o_checkfile + } + method get_debugchannel {} { + return $o_debugchannel + } + + #call set_source_target before calling start_event/end_event + #each event can have different source->target pairs - but may often have same, so set on installtrack as defaults. Only persisted in event records. + method set_source_target {sourceroot targetroot} { + if {[file pathtype $sourceroot] ne "absolute"} { + error "[self] set_source_target error: sourceroot must be absolute path. Received '$sourceroot'" + } + if {[file pathtype $targetroot] ne "absolute"} { + error "[self] set_source_target error: targetroot must be absolute path. Received '$targetroot'" + } + set punkcheck_folder [file dirname $o_checkfile] + set o_sourceroot $sourceroot + set o_targetroot $targetroot + set o_rel_sourceroot [punkcheck::lib::path_relative $punkcheck_folder $sourceroot] + set o_rel_targetroot [punkcheck::lib::path_relative $punkcheck_folder $targetroot] + return [list $o_rel_sourceroot $o_rel_targetroot] + } + #review/fix to allow multiple installtrack objects on same punkcheck file. + method load_all_records {} { + set o_record_list [punkcheck::load_records_from_file $o_checkfile] + } + + #does not include associated FILEINFO records - as a targetset (FILEINFO record) can be associated with events from multiple installers over time. + #e.g a logfile common to installers, or a separate installer that updates a previous output. + method as_record {} { + set eventrecords [list] + foreach eobj [my events items] { + lappend eventrecords [$eobj as_record] + } + set fields [list {*}{ + } -tsiso $o_tsiso {*}{ + } -ts $o_ts {*}{ + } -name $o_name\ {*}{ + } -keep_events $o_keep_events {*}{ + } body $eventrecords {*}{ + } + ] + set record [dict create tag INSTALLER {*}$fields] + } + #open file and save only own records + method save_all_records {} { + my save_installer_record + #todo - save FILEINFO targetset records + } + method save_installer_record {} { + set file_records [punkcheck::load_records_from_file $o_checkfile] + + set this_installer_record [my as_record] + + set persistedinfo [punkcheck::recordlist::get_installer_record $o_name $file_records] + set existing_header_posn [dict get $persistedinfo position] + if {$existing_header_posn == -1} { + #set file_records [linsert $file_records 0 $this_installer_record] + ledit file_records -1 -1 $this_installer_record + } else { + lset file_records $existing_header_posn $this_installer_record + } + punkcheck::save_records_to_file $file_records $o_checkfile "save_installer_record" + } + method events {args} { + tailcall $o_events {*}$args + } + method start_event {configdict} { + if {$o_active_event ne ""} { + error "[self] start_event error - event already started: $o_active_event" + } + if {$o_rel_sourceroot eq "" || $o_rel_targetroot eq ""} { + error "[self] No configured sourceroot or targetroot. Call [self] set_source_target first" + } + + if {[llength $configdict] %2 != 0} { + error "[self] new_event configdict must have an even number of elements" + } + set resultinfo [punkcheck::recordlist::get_installer_record $o_name $o_record_list] + set existing_header_posn [dict get $resultinfo position] + if {$existing_header_posn == -1} { + error "[self] start_event - installer record missing. installer: $o_name" + } else { + set this_installer_record [dict get $resultinfo record] + } + + set eventobj [punkcheck::installevent create [namespace current]::event_[my events count] [self] $o_rel_sourceroot $o_rel_targetroot -config $configdict] + set eventid [$eventobj get_id] + set event_record [$eventobj as_record] + + set this_installer_record [punkcheck::recordlist::installer_record_add_event $this_installer_record $event_record] + set this_installer_record [punkcheck::recordlist::installer_record_pruneevents $this_installer_record $o_record_list] + + #replace + lset o_record_list $existing_header_posn $this_installer_record + + punkcheck::save_records_to_file $o_record_list $o_checkfile "start_event $eventid" + set o_active_event $eventobj + my events add $eventobj $eventid + return $eventobj + } + method installer_record_from_file {} { + set resultinfo [punkcheck::recordlist::get_installer_record $o_name $o_record_list] + } + method get_recordlist {} { + return $o_recordlist + } + method end_event {} { + if {$o_active_event eq ""} { + error "[self] end_event error - no active event" + } + $o_active_event end + } + method get_event {} { + return $o_active_event + } + } + } + proc start_installer_event {punkcheck_file installername from_fullpath to_fullpath config} { + set eventid [punkcheck::uuid] + if {[file pathtype $from_fullpath] ne "absolute"} { + error "start_installer_event error: from_fullpath must be absolute path. Received '$from_fullpath'" + } + if {[file pathtype $to_fullpath] ne "absolute"} { + error "start_installer_event error: to_fullpath must be absolute path. Received '$to_fullpath'" + } + set punkcheck_folder [file dirname $punkcheck_file] + set rel_source [punkcheck::lib::path_relative $punkcheck_folder $from_fullpath] + set rel_target [punkcheck::lib::path_relative $punkcheck_folder $to_fullpath] + + + set record_list [punkcheck::load_records_from_file $punkcheck_file] + set resultinfo [punkcheck::recordlist::get_installer_record $installername $record_list] + set existing_header_posn [dict get $resultinfo position] + if {$existing_header_posn == -1} { + set this_installer_record [punkcheck::recordlist::new_installer_record $installername] + } else { + set this_installer_record [dict get $resultinfo record] + } + + set event_record [punkcheck::recordlist::new_installer_event_record install {*}{ + -id $eventid + -source $rel_source + -targets $rel_target + -config $config + }] + + set this_installer_record [punkcheck::recordlist::installer_record_add_event $this_installer_record $event_record] + set this_installer_record [punkcheck::recordlist::installer_record_pruneevents $this_installer_record $record_list] + + if {$existing_header_posn == -1} { + #not found - prepend + #set record_list [linsert $record_list 0 $this_installer_record] + ledit record_list -1 -1 $this_installer_record + } else { + #replace + lset record_list $existing_header_posn $this_installer_record + } + + punkcheck::save_records_to_file $record_list $punkcheck_file "start_installer_event $eventid" + return [list eventid $eventid recordset $record_list] + } + #----------------------------------------------- + proc installfile_help {} { + set msg "" + append msg "Call in order:" \n + append msg " start_installer_event (get dict with eventid and recordset keys)" + append msg " installfile_begin (to return a new INSTALLING record) - must pass in a valid eventid" \n + append msg " installfile_add_source_and_fetch_metadata (1+ times to update SOURCE record with checksum/timestamp info from source)" \n + append msg " ( - possibly with same algorithm as previous installrecord)" \n + append msg " ( - todo - search/load metadata for this source from other FILEINFO records for same installer)" \n + append msg "Finalize by calling:" \n + append msg " installfile_started_install" \n + append msg " (install the file e.g file copy)" \n + append msg " installfile_finished_install" \n + append msg " OR" \n + append msg " installfile_skipped_install" \n + } + proc installfile_begin {punkcheck_folder target_relpath installername args} { + if {[llength $args] %2 !=0} { + error "punkcheck installfile_begin args must be name-value pairs" + } + set target_relpath [lsort -dictionary -increasing $target_relpath] ;#exact sort order not critical - but must be consistent + set ts [clock microseconds] + set seconds [expr {$ts / 1000000}] + set tsiso [clock format $seconds -format "%Y-%m-%dT%H:%M:%S"] + set defaults [list {*}{ + } -tsiso $tsiso {*}{ + } -ts $ts {*}{ + } -installer $installername {*}{ + } -eventid unspecified {*}{ + } + ] + set opts [dict merge $defaults $args] + set opt_eventid [dict get $opts -eventid] + + set punkcheck_file [file join $punkcheck_folder/.punkcheck] + set record_list [load_records_from_file $punkcheck_file] + + set resultinfo [punkcheck::recordlist::get_installer_record $installername $record_list] + set installer_record_position [dict get $resultinfo position] + if {$installer_record_position == -1} { + error "installfile_begin error: Failed to retrieve installer record for installer name:'$installername' - ensure start_installer_event has been called with same installer, and -eventid is passed to installfile_begin" + } + set this_installer_record [dict get $resultinfo record] + set events [dict get $this_installer_record body] + set active_event [list] + foreach evt [lreverse $events] { + if {[dict get $evt -id] eq $opt_eventid} { + set active_event $evt + break + } + } + if {![llength $active_event]} { + error "installfile_begin error: eventid $opt_eventid not found for installer '$installername' - aborting" + } + + + set extractioninfo [punkcheck::recordlist::extract_or_create_fileset_record $target_relpath $record_list] + set file_record [dict get $extractioninfo record] + set record_list [dict get $extractioninfo recordset] + set isnew [dict get $extractioninfo isnew] + set oldposition [dict get $extractioninfo oldposition] + unset extractioninfo + + #INSTALL-INPROGRESS will become INSTALL-RECORD or INSTALL-FAILED or INSTALL-SKIPPED upon finalisation + #-installer and -eventid keys are added here + set new_installing_record [dict create tag INSTALL-INPROGRESS {*}$opts -tempcontext $active_event body {}] + #set existing_body [dict_getwithdefault $file_record body [list]] + #todo - look for existing "INSTALL-INPROGRESS" records - mark as failed? + dict lappend file_record body $new_installing_record + + if {$isnew} { + lappend record_list $file_record + } else { + #set record_list [linsert $record_list[unset record_list] $oldposition $file_record] + ledit record_list $oldposition -1 $file_record + } + + save_records_to_file $record_list $punkcheck_file "installfile_begin $installername $opt_eventid $target_relpath" + return $file_record + } + + #todo - ensure that removing a dependency is noticed as a change + #e.g previous installrecord had 2 source records - but we now only depend on one. + #The files we depended on for the previous record haven't changed themselves - but the list of files has (reduced by one) + #cached_cksums is list of dicts with keys cksum & opts + #Will only be used if any opts values present match those from file_record's -cksum_all_opts (in last install record) or first cached_cksum will be used if no last install record values + proc installfile_add_source_and_fetch_metadata {punkcheck_folder source_relpath file_record {cached_cksums {}}} { + if {![lib::is_file_record_inprogress $file_record]} { + error "installfile_add_source_and_fetch_metadata error: bad file_record - expected FILEINFO with last body element *-INPROGRESS ($file_record)" + } + #validate any passed cached_cksums + foreach cacheinfo $cached_cksums { + if {[llength $cacheinfo] % 2 != 0} { + error "installfile_add_source_and_fetch_metadata error.If cached_cksums is supplied, it must be a list of dicts containing keys cksum & opts" + } + dict for {k v} $cacheinfo { + switch -- $k { + cksum {} + opts { + #todo - validate $v keys + } + default { + error "installfile_add_source_and_fetch_metadata error. Unrecognised key $k. Known keys {cksum opts}" + } + } + + } + } + set ts_start [clock microseconds] + set last_installrecord [lib::file_record_get_last_installrecord $file_record] + set prev_ftype "" + set prev_fsize "" + set prev_cksum "" + set prev_cksum_opts "" + if {[llength $last_installrecord]} { + set src [lib::install_record_get_matching_source_record $last_installrecord $source_relpath] + if {[llength $src]} { + if {[dict_getwithdefault $src -path ""] eq $source_relpath} { + set prev_ftype [dict_getwithdefault $src -type ""] + set prev_fsize [dict_getwithdefault $src -size ""] + set prev_cksum [dict_getwithdefault $src -cksum ""] + set prev_cksum_opts [dict_getwithdefault $src -cksum_all_opts ""] + } + } + } + #check that this relpath not already added as child of *-INPROGRESS + set file_record_body [dict_getwithdefault $file_record body [list]] ;#new file_record may have no body + set installing_record [lindex $file_record_body end] + set already_present_record [lib::install_record_get_matching_source_record $installing_record $source_relpath] + if {[llength $already_present_record]} { + error "installfile_add_source_and_fetch_metadata error: source path $source_relpath already exists in the file_record - cannot add again" + } + + set use_cache 0 + if {$prev_cksum_opts ne ""} { + set cksum_opts $prev_cksum_opts + #find first cached_cksum that is compatible with cksum opts used in latest install record + foreach cacheinfo $cached_cksums { + set cachedopts [dict get $cacheinfo opts] + set cache_is_match 1 + dict for {k v} $cachedopts { + if {[dict exists $prev_cksum_opts $k] && $v ne [dict get $prev_cksum_opts $k]} { + set cache_is_match 0 + break + } + } + if {$cache_is_match} { + set use_cache_record $cacheinfo + set use_cache 1 + break + } + } + + } else { + #no cksum opts available from an install record + set cksum_opts "" + #use first entry in cached_cksums if we can + if {[llength $cached_cksums]} { + set use_cache 1 + set use_cache_record [lindex $cached_cksums 0] + } + } + + #todo - accept argument of cached source cksum info (for client calling multiple targets with same source in quick succession e.g when building .vfs kits with multiple runtimes) + #if same cksum_opts - then use cached data instead of checksumming here. + + #allow nonexistant as a source + set fpath [file join $punkcheck_folder $source_relpath] + #windows: file exist + file type = 2ms vs 500ms for 2x glob + set floc [file dirname $fpath] + set fname [file tail $fpath] + set file_set [glob -nocomplain -dir $floc -type f -tails $fname] + set dir_set [glob -nocomplain -dir $floc -type d -tails $fname] + set link_set [glob -nocomplain -dir $floc -type l -tails $fname] + if {[llength $file_set] == 0 && [llength $dir_set] == 0 && [llength $link_set] == 0} { + #could also theoretically exist as less common types, b,c,p,s (block,char,pipe,socket) + #- we don't expect them here - REVIEW - ever possible? + #- installing/examining such things an unlikely usecase and would require special handling anyway. + set ftype "missing" + set fsize "" + } else { + if {[llength $dir_set]} { + set ftype "directory" + set fsize "NA" + } elseif {[llength $link_set]} { + set ftype "link" + set fsize 0 + } else { + set ftype "file" + #todo - optionally use mtime instead of cksum (for files only)? + #mtime is not reliable across platforms and filesystems though.. see article linked at top. + set fsize [file size $fpath] + } + } + + #if {![file exists $fpath]} { + # set ftype "missing" + # set fsize "" + #} else { + # set ftype [file type $fpath] + # if {$ftype eq "directory"} { + # set fsize "NA" + # } else { + # #todo - optionally use mtime instead of cksum (for files only)? + # #mtime is not reliable across platforms and filesystems though.. see article linked at top. + # set fsize [file size $fpath] + # } + #} + #get_relativecksum_from_base and fill_relativecksums_from_base_and_relativepathdict will set cksum to if fpath doesn't exist + if {$use_cache} { + set source_cksum_info [punk::mix::base::lib::fill_relativecksums_from_base_and_relativepathdict $punkcheck_folder [dict create $source_relpath $use_cache_record]] + } else { + set source_cksum_info [punk::mix::base::lib::get_relativecksum_from_base $punkcheck_folder $source_relpath {*}$cksum_opts] + } + + + lassign $source_cksum_info pathkey ckinfo + if {$pathkey ne $source_relpath} { + error "installfile_add_source_and_fetch_metadata error: cksum returned wrong path info '$pathkey' expected '$source_relpath'" + } + set cksum [dict get $ckinfo cksum] + #set cksum_all_opts [dict get $ckinfo cksum_all_opts] + set cksum_all_opts [dict get $ckinfo opts] + if {$cksum ne $prev_cksum || $ftype ne $prev_ftype || $fsize ne $prev_fsize} { + set changed 1 + } else { + set changed 0 + } + set installing_record_sources [dict_getwithdefault $installing_record body [list]] + set ts_now [clock microseconds] ;#gathering metadata - especially checksums on folder can take some time - calc and store elapsed us for time taken to gather metadata + set metadata_us [expr {$ts_now - $ts_start}] + set this_source_record [dict create tag SOURCE -type $ftype -size $fsize -path $source_relpath -cksum $cksum -cksum_all_opts $cksum_all_opts -changed $changed -metadata_us $metadata_us] + lappend installing_record_sources $this_source_record + dict set installing_record body $installing_record_sources + + lset file_record_body end $installing_record + + dict set file_record body $file_record_body + return $file_record + } + + #write back to punkcheck - don't accept recordset - invalid to update anything other than the installing_record at this time + proc installfile_started_install {punkcheck_folder file_record} { + if {![lib::is_file_record_inprogress $file_record]} { + error "installfile_started_install error: bad file_record - expected FILEINFO with last body element *-INPROGRESS" + } + set punkcheck_file [file join $punkcheck_folder/.punkcheck] + set record_list [load_records_from_file $punkcheck_file] + + set file_record_body [dict get $file_record body] + set targetlist [dict get $file_record -targets] + set installing_record [lindex $file_record_body end] + + set ts_start [dict get $installing_record -ts] + set ts_now [clock microseconds] + set metadata_us [expr {$ts_now - $ts_start}] + + dict set installing_record -metadata_us $metadata_us + dict set installing_record -ts_start_transfer $ts_now + + lset file_record_body end $installing_record + + dict set file_record body $file_record_body + + + set getresult [punkcheck::recordlist::get_file_record $targetlist $record_list] + set old_posn [dict get $getresult position] + if {$old_posn == -1} { + lappend record_list $file_record + } else { + lset record_list $old_posn $file_record + } + + save_records_to_file $record_list $punkcheck_file "installfile_started_install [llength $targetlist] targets" + return $file_record + } + proc installfile_finished_install {punkcheck_folder file_record} { + if {![lib::is_file_record_inprogress $file_record]} { + error "installfile_finished_install error: bad file_record - expected FILEINFO with last body element *-INPROGRESS" + } + set punkcheck_file [file join $punkcheck_folder/.punkcheck] + set record_list [load_records_from_file $punkcheck_file] + + set file_record_body [dict get $file_record body] + set targetlist [dict get $file_record -targets] + set installing_record [lindex $file_record_body end] + + set ts_start [dict get $installing_record -ts] + set ts_start_transfer [dict get $installing_record -ts_start_transfer] + set ts_now [clock microseconds] + set elapsed_us [expr {$ts_now - $ts_start}] + set transfer_us [expr {$ts_now - $ts_start_transfer}] + dict set installing_record -transfer_us $transfer_us + dict set installing_record -elapsed_us $elapsed_us + dict unset installing_record -tempcontext + dict set installing_record tag "INSTALL-RECORD" + + lset file_record_body end $installing_record + dict set file_record body $file_record_body + + set file_record [punkcheck::recordlist::file_record_prune $file_record] + + set oldrecordinfo [punkcheck::recordlist::get_file_record $targetlist $record_list] + set old_posn [dict get $oldrecordinfo position] + if {$old_posn == -1} { + lappend record_list $file_record + } else { + lset record_list $old_posn $file_record + } + + save_records_to_file $record_list $punkcheck_file "installfile_finished_install [llength $targetlist] targets" + return $file_record + } + proc installfile_skipped_install {punkcheck_folder file_record} { + if {![lib::is_file_record_inprogress $file_record]} { + set msg "installfile_skipped_install error: bad file_record - expected FILEINFO with last body element *-INPROGRESS" + append msg \n "received:" + append msg \n $file_record + error $msg + } + set punkcheck_file [file join $punkcheck_folder/.punkcheck] + set record_list [load_records_from_file $punkcheck_file] + + set file_record_body [dict get $file_record body] + set targetlist [dict get $file_record -targets] + set installing_record [lindex $file_record_body end] + + set ts_start [dict get $installing_record -ts] + set tsnow [clock microseconds] + set elapsed_us [expr {$tsnow - $ts_start}] + dict set installing_record -elapsed_us $elapsed_us + dict set installing_record tag "INSTALL-SKIPPED" + + lset file_record_body end $installing_record + dict set file_record body $file_record_body + + set file_record [punkcheck::recordlist::file_record_prune $file_record] + + set getresult [punkcheck::recordlist::get_file_record $targetlist $record_list] + set old_posn [dict get $getresult position] + if {$old_posn == -1} { + lappend record_list $file_record + } else { + lset record_list $old_posn $file_record + } + + save_records_to_file $record_list $punkcheck_file "installfile_skipped_install [llength $targetlist] targets" + return $file_record + } + #----------------------------------------------- + #then: file_record_add_installrecord + + namespace eval lib { + set pkg punkcheck + namespace path ::punkcheck + proc is_file_record_inprogress {file_record} { + if {[dict get $file_record tag] ne "FILEINFO"} { + return 0 + } + set installing_record [lindex [dict_getwithdefault $file_record body [list]] end] + if {[dict_getwithdefault $installing_record tag [list]] ni [list QUERY-INPROGRESS INSTALL-INPROGRESS MODIFY-INPROGRESS DELETE-INPROGRESS VIRTUAL-INPROGRESS]} { + return 0 + } + return 1 + } + proc is_file_record_installing {file_record} { + if {[dict get $file_record tag] ne "FILEINFO"} { + return 0 + } + set installing_record [lindex [dict_getwithdefault $file_record body [list]] end] + if {[dict_getwithdefault $installing_record tag [list]] ne "INSTALL-INPROGRESS"} { + return 0 + } + return 1 + } + proc file_record_get_last_installrecord {file_record} { + set body [dict_getwithdefault $file_record body [list]] + set previous_install_records [lrange $body 0 end-1] + #get last previous that is tagged INSTALL-RECORD,MODIFY-RECORD,VIRTUAL-RECORD + #REVIEW DELETERECORD ??? + set revlist [lreverse $previous_install_records] + foreach rec $revlist { + if {[dict get $rec tag] in [list "INSTALL-RECORD" "MODIFY-RECORD" "VIRTUAL-RECORD"]} { + return $rec + } + } + return [list] + } + + #should work on *-INPROGRESS or INSTALL(etc) record - don't restrict tag to INSTALL + proc install_record_get_matching_source_record {install_record source_relpath} { + set body [dict_getwithdefault $install_record body [list]] + foreach src $body { + if {[dict get $src tag] eq "SOURCE"} { + if {[dict_getwithdefault $src -path ""] eq $source_relpath} { + return $src + } + } + } + return [list] + } + + + + #maint warning - also in punk::mix::util + proc path_relative {base dst} { + #see also kettle + # Modified copy of ::fileutil::relative (tcllib) + # Adapted to 8.5 ({*}). + # + # Taking two _directory_ paths, a base and a destination, computes the path + # of the destination relative to the base. + # + # Arguments: + # base The path to make the destination relative to. + # dst The destination path + # + # Results: + # The path of the destination, relative to the base. + + # Ensure that the link to directory 'dst' is properly done relative to + # the directory 'base'. + + #review - check volume info on windows.. UNC paths? + if {[file pathtype $base] ne [file pathtype $dst]} { + return -code error "Unable to compute relation for paths of different pathtypes: [file pathtype $base] vs. [file pathtype $dst], ($base vs. $dst)" + } + + #avoid normalizing if possible - at least for relative paths which we are likely to loop on (file normalize *very* expensive on windows) + set do_normalize 0 + if {[file pathtype $base] eq "relative"} { + #if base is relative so is dst + if {[regexp {[.]{2}} [list $base $dst]]} { + set do_normalize 1 + } + if {[regexp {[.]/} [list $base $dst]]} { + set do_normalize 1 + } + } else { + #case differences in volumes is common on windows + set do_normalize 1 + } + if {$do_normalize} { + set base [file normalize $base] + set dst [file normalize $dst] + } + + set save $dst + set base [file split $base] + set dst [file split $dst] + + while {[lindex $dst 0] eq [lindex $base 0]} { + set dst [lrange $dst 1 end] + set base [lrange $base 1 end] + if {![llength $dst]} {break} + } + + set dstlen [llength $dst] + set baselen [llength $base] + + if {($dstlen == 0) && ($baselen == 0)} { + # Cases: + # (a) base == dst + + set dst . + } else { + # Cases: + # (b) base is: base/sub = sub + # dst is: base = {} + + # (c) base is: base = {} + # dst is: base/sub = sub + + while {$baselen > 0} { + #set dst [linsert $dst 0 ..] + ledit dst -1 -1 .. + incr baselen -1 + } + set dst [file join {*}$dst] + } + + return $dst + } + } + #skip writing punkcheck during checksum/timestamp checks + + #todo - punk::args - fetch from punkcheck::install (with overrides) + proc install_tm_files {srcdir basedir args} { + set defaults [list {*}{ + -glob *.tm + -installer punkcheck::install_tm_files + } -exclude-filetails [list "*[punk::mix::util::tm_version_magic]*"] {*}{ + } + ] + set opts [dict merge $defaults $args] + punkcheck::install $srcdir $basedir {*}$opts + } + proc install_non_tm_files {srcdir basedir args} { + #set keys [dict keys $args] + #adjust the default excludedirseg_core entries so that .fossil-custom, .fossil-settings are copied + set excludedirseg_core [punkcheck::default_excludedirseg_core] + set posn [lsearch $excludedirseg_core ".fossil*"] + if {$posn >=0} { + ledit excludedirseg_core $posn $posn + } + set defaults [list {*}{ + } -glob * {*}{ + } -exclude-filetails [list "*.tm" "*-buildversion.txt" "*.exe"] {*}{ + } -exclude-dirsegments_core $excludedirseg_core {*}{ + } -installer punkcheck::install_non_tm_files {*}{ + } + ] + set opts [dict merge $defaults $args] + punkcheck::install $srcdir $basedir {*}$opts + } + + #for tcl8.6 - tcl8.7+ has dict getwithdefault (dict getdef) + proc dict_getwithdefault {dictValue args} { + if {[llength $args] < 2} { + error {wrong # args: should be "dict_getdef dictionary ?key ...? key default"} + } + set keys [lrange $args 0 end-1] + if {[dict exists $dictValue {*}$keys]} { + return [dict get $dictValue {*}$keys] + } else { + return [lindex $args end] + } + } + lappend PUNKARGS [list { + @id -id ::punkcheck::install + @cmd -name ::punkcheck::install -help\ + "Unidirectional file transfer to possibly non-empty target folder. + This is the simpler form of the API, performing a transfer from one + directory tree to another, copying each file when changes in the source + file are detected. + Changes are detected by content checksum. The first install will record + source checksums in a .punkcheck file (ideally located at the root of the + target folder). Subsequent installs will compare stored checksums with + the current checksums of the source files. + For more advanced install operations, the object command installtrack + can be used to define install operations. e.g when the transfer is not + one-to-one and a target file depends on multiple source files." + @leaders -min 2 -max 2 + srcdir -type directory + tgtdir -type directory + -call-depth-internal -type integer -default 0 -help "(internal recursion tracker)" + -subdirlist -type list -default "" -help "(primarily internal - length generally matching -call-depth-internal)" + -max_depth -type integer -default 1000 -help\ + "Deepest subdirectory - use -1 for no limit." + -createdir -type boolean -default 0 -help\ + "Whether to create the folder at tgtdir. + Any required subdirectories are created regardless of this setting." + -createempty -type boolean -default 0 -help\ + "Whether to create folders at target that had no matches for our glob" + -glob -type string -default "*" -help\ + "Pattern matching for source file(s) to copy. Can be glob based or exact match." + -exclude-filetails_core -default {${[::punkcheck::default_excludefiltail_core]}} + -exclude-filetails -default "" + -exclude-dirsegments_core -default {${[::punkcheck::default_excludedirseg_core]}} + -exclude-dirsegments -default "" + -antiglob_paths -default {} + -overwrite -default no-targets\ + -choices {no-targets newer-targets older-targets all-targets installedsourcechanged-targets synced-targets}\ + -choicecolumns 1\ + -choicelabels { + no-targets "only copy files that are missing at the target" + newer-targets "copy files with older source timestamp over newer + target timestamp and those missing at the target + (a form of 'restore' operation)" + older-targets "copy files with newer source timestamp over older + target timestamp and those missing at the target" + all-targets "copy regardless of timestamp at target" + installedsourcechanged-targets "copy if the target doesn't exist or the source changed" + synced-targets "copy if the target doesn't exist or the source changed + and the target cksum is the same as the last INSTALL-RECORD -targets_cksums entry" + } + -source_checksum -default comparestore -choicecolumns 3 -choices {compare store comparestore false true}\ + -choicelabels { + true "same as comparestore" + } + -punkcheck_folder -default target -choices {target source project} -choicerestricted 0 -help\ + "The location of the .punkcheck file to track installations and checksums. + The default value 'target' is generally recommended. + Can also be an absolute path to a folder." + -punkcheck_records -default "" -help\ + "Empty string or a parsed TDL records structure. + e.g + {tag FILEINFO - ... body { + {tag INSTALL-RECORD - ... body {}} + ... + }... + }" + -installer -default "punkcheck::install" -help\ + "A user nominated string that is stored in the .punkcheck file + This might be the name of a script or installation process." + -progresschannel -default none -type string -help\ + "Name of channel e.g stderr, stdout to which progress messages are written. + This includes the tree-like output consisting of dots (or green U) for each + file processed. As the number of files in a tree is not known beforehand, + it isn't useful for a percentage-based progress meter, but it could potentially + be used to drive a spinner if the textual data is not desired. + Setting to none or an invalid channel will deactivate the output." + }] + ## unidirectional file transfer to possibly non empty folder + #default of -overwrite no-targets will only copy files that are missing at the target + # -overwrite newer-targets will copy files with older source timestamp over newer target timestamp and those missing at the target (a form of 'restore' operation) + # -overwrite older-targets will copy files with newer source timestamp over older target timestamp and those missing at the target + # -overwrite all-targets will copy regardless of timestamp at target + # -overwrite installedsourcechanged-targets will copy if the target doesn't exist or the source changed + # -overwrite synced-targets will copy if the target doesn't exist or the source changed and the target cksum is the same as the last INSTALL-RECORD -targets_cksums entry + # review - timestamps unreliable + # - what about slightly mismatched system clocks and mounted filesystems? caller responsibility to verify first? + # if timestamp exactly equal - should we check content-hash? This is presumably only likely to occur deliberately(maliciously?) + # e.g some process that digitally signs or otherwise modifies a file and preserves update timestmp? + # if such a content-mismatch - what default behaviour and what options would make sense? + # probably it's reasonable that only all-targets would overwrite such files. + # consider -source_fudge_seconds +-X ?, -source_override_timestamp ts ??? etc which only adjust timestamp for calculation purposes? Define a specific need/usecase when reviewing. + # + # valid filetypes for src tgt + # src dir tgt dir + # todo - review and consider enabling symlink src and dst + # no need for src file - as we use -glob with no glob characters to match one source file file + # no ability to target file with different name - keep it simpler and caller will have to use an intermediate folder/file if they need to rename something? + # + # todo - determine what happens if mismatch between file type of a src vs target e.g target has dir matching filename at source + # A pre-scan to determine no such conflict - before attempting to copy anything might provide the most integrity at slight cost in speed. + # REVIEW we should only expect dirs to be created as necessary to hold files? i.e target folder won't be created if no source file matches for that folder + # -source_checksum compare|store|comparestore|false|true where true == comparestore + # -punkcheck_folder target|source|project| target is default and is generally recommended + # -punkcheck_records empty string | parsed TDL records ie {tag xxx k v} structure + # install creates FILEINFO records with a single entry in the -targets field (it is legitimate to have a list of targets for an installation operation - the oo interface supports this) + proc install {srcdir tgtdir args} { + set defaults [list {*}{ + -call-depth-internal 0 + -max_depth 1000 + -subdirlist {} + -createdir 0 + -createempty 0 + -glob * + -exclude-filetails_core "\uFFFF" + -exclude-filetails "" + -exclude-dirsegments_core "\uFFFF" + -exclude-dirsegments {} + -antiglob_paths {} + -overwrite no-targets + -source_checksum comparestore + -punkcheck_folder target + -punkcheck_eventid "\uFFFF" + -punkcheck_records "" + -installer punkcheck::install + -progresschannel none + }] + + if {([llength $args] %2) != 0} { + error "punkcheck::install requires option-style arguments to be in pairs. Received args: $args" + } + foreach {k -} $args { + if {$k ni [dict keys $defaults]} { + error "punkcheck::install unrecognised option '$k' known options: '[dict keys $defaults]'" + } + } + set opts [dict merge $defaults $args] + + #The choice to recurse using the original values of srcdir & tgtdir, and passing the subpath down as a list in -subdirlist seems an odd one. + #(as opposed to a more 'standard' mechanism of adjusting srcdir & tgtdir as we move down the tree) + #It comes from build_modules_from_source_to_base where we need to keep track of position relative to our targetdir starting point to handle submodules e.g pkg::something::mypkg-0.1.tm + #It could have been handled with some other parameter such as -depth, but this -subdirlist mechanism, whilst perhaps not beautiful, is straightforward enough + #and may be less error prone than doing slightly more opaque path manipulations at each recursion level to determine where we started + #For consistency - we'll use the same mechanism in various recursive directory walking procedures such as this one. + set CALLDEPTH [dict get $opts -call-depth-internal] ;#added for extra debug/sanity checking - clearer test for initial function call ie CALLDEPTH = 0 + set max_depth [dict get $opts -max_depth] ;# -1 for no limit + set subdirlist [dict get $opts -subdirlist] ;# generally should be same length as CALLDEPTH - but user could prefill + set fileglob [dict get $opts -glob] + set createdir [dict get $opts -createdir] ;#defaults to zero to help avoid mistakes with initial target dir - required target subdirs are created regardless of this setting + set opt_createempty [dict get $opts -createempty] + set opt_progresschannel [dict get $opts -progresschannel] + if {$opt_progresschannel in {"" none} || [catch {chan configure $opt_progresschannel}]} { + set opt_progresschannel "" + } + + if {$CALLDEPTH == 0} { + #expensive to normalize but we need to do it at least once + set srcdir [file normalize $srcdir] + set tgtdir [file normalize $tgtdir] + if {$createdir} { + file mkdir $tgtdir + } else { + if {![file exists $tgtdir]} { + error "punkcheck::install base target dir:'$tgtdir' doesn't exist (srcdir:$srcdir tgtdir:$tgtdir args:'$args')" + } + } + if {([file type $srcdir] ni [list directory]) || ([file type $tgtdir] ni [list directory])} { + error "punkcheck::install requires source and target dirs to be of type 'directory' type current source: [file type $srcdir] type current target: [file type $tgtdir]" + } + #now the values we build from these will be properly cased + } + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + set opt_excludefiletail_core [dict get $opts -exclude-filetails_core] + if {$opt_excludefiletail_core eq "\uFFFF"} { + set opt_excludefiletail_core [default_excludefiletail_core] + dict set opts -exclude-filetails_core $opt_excludefiletail_core + } + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + set opt_excludefiletail [dict get $opts -exclude-filetails] + #validate no path seps + foreach af $opt_excludefiletail { + if {[llength [file split $af]] > 1} { + error "punkcheck::install received invalid -exclude-filetails entry '$af'. -exclude-filetails entries are meant to match to a file name at any level so cannot contain path separators" + } + } + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + set opt_excludedirseg_core [dict get $opts -exclude-dirsegments_core] + if {$opt_excludedirseg_core eq "\uFFFF"} { + set opt_excludedirseg_core [default_excludedirseg_core] + dict set opts -exclude-dirsegments_core $opt_excludedirseg_core + } + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + set opt_excludedirseg [dict get $opts -exclude-dirsegments] + #validate no path seps + foreach ad $opt_excludedirseg { + if {[llength [file split $ad]] > 1} { + error "punkcheck::install received invalid -exclude-dirsegments entry '$ad'. -exclude-dirsegments entries are meant to match to a directory name at any level so cannot contain path separators" + } + } + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + set opt_antiglob_paths [dict get $opts -antiglob_paths] ;#todo - combine with config file in source tree .punkcheckpublish (?) + #antiglob_paths will usually contain file separators - and may contain glob patterns within each segment + set antiglob_paths_matched [list] + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + set known_whats [list no-targets newer-targets older-targets all-targets installedsourcechanged-targets synced-targets] + set overwrite_what [string tolower [dict get $opts -overwrite]]; #accept any case for value to allow emphasis by caller e.g -overwrite NEWER-TARGETS + if {$overwrite_what ni $known_whats} { + error "punkcheck::install received unrecognised value for -overwrite. Received value '$overwrite_what' vs known values '$known_whats'" + } + if {$overwrite_what in [list newer-targets older-targets]} { + error "punkcheck::install newer-target, older-targets not implemented - sorry" + #TODO - check crossplatform availability of ctime (on windows it still seems to be creation time, but on bsd/linux it's last attribute mod time) + # external pkg? use twapi and ctime only on other platforms? + } + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + set opt_source_checksum [dict get $opts -source_checksum] + if {[string is boolean $opt_source_checksum]} { + if {$opt_source_checksum} { + set opt_source_checksum "comparestore" + } else { + set opt_source_checksum 0 + } + dict set opts -source_checksum $opt_source_checksum + } + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + set opt_punkcheck_folder [dict get $opts -punkcheck_folder] + if {$opt_punkcheck_folder eq "target"} { + set punkcheck_folder $tgtdir + } elseif {$opt_punkcheck_folder eq "source"} { + set punkcheck_folder $srcdir + } elseif {$opt_punkcheck_folder eq "project"} { + set sourceprojectinfo [punk::repo::find_repos $srcdir] + set targetprojectinfo [punk::repo::find_repos $tgtdir] + set srcproj [lindex [dict get $sourceprojectinfo project] 0] + set tgtproj [lindex [dict get $targetprojectinfo project] 0] + if {$srcproj eq $tgtproj} { + set punkcheck_folder $tgtproj + } else { + error "copy_files_from_source_to_target error: Unable to find common project dir for source and target folder - use absolutepath for -punkcheck_folder if source and target are not within same project" + } + } else { + set punkcheck_folder $opt_punkcheck_folder + } + if {$punkcheck_folder ne ""} { + if {[file pathtype $punkcheck_folder] ne "absolute"} { + error "copy_files_from_source_to_target error: -punkcheck_folder '$punkcheck_folder' must be an absolute path, or one of: target|source|project" + } + if {![file isdirectory $punkcheck_folder]} { + error "copy_files_from_source_to_target error: -punkcheck_folder '$punkcheck_folder' not found" + } + } else { + #review - leave empty? use pwd? + } + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + set punkcheck_records [dict get $opts -punkcheck_records] + set punkcheck_records_init $punkcheck_records ;#change-detection + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + set opt_installer [dict get $opts -installer] + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + set opt_punkcheck_eventid [dict get $opts -punkcheck_eventid] + + + + set punkcheck_file [file join $punkcheck_folder/.punkcheck] + + if {$CALLDEPTH == 0} { + set punkcheck_eventid "" + if {$punkcheck_folder ne ""} { + set config $opts + dict unset config -call-depth-internal + dict unset config -max_depth + dict unset config -subdirlist + dict unset config -progresschannel + tcl::dict::for {k v} $config { + if {$v eq "\uFFFF"} { + dict unset config $k + } + } + lassign [punkcheck::start_installer_event $punkcheck_file $opt_installer $srcdir $tgtdir $config] _eventid punkcheck_eventid _recordset punkcheck_records + } + } else { + set punkcheck_eventid $opt_punkcheck_eventid + } + + + + if {$opt_source_checksum != 0} { + #we need to read the file even if only set to store (or we would overwrite entries) + set compare_cksums 1 + } else { + set compare_cksums 0 + } + + if {[string match *store* $opt_source_checksum]} { + set store_source_cksums 1 + } else { + set store_source_cksums 0 + } + + + + + + if {[llength $subdirlist] == 0} { + set current_source_dir $srcdir + set current_target_dir $tgtdir + } else { + set current_source_dir $srcdir/[file join {*}$subdirlist] + set current_target_dir $tgtdir/[file join {*}$subdirlist] + } + + + set relative_target_dir [lib::path_relative $tgtdir $current_target_dir] + if {$relative_target_dir eq "."} { + set relative_target_dir "" + } + set relative_source_dir [lib::path_relative $srcdir $current_source_dir] + if {$relative_source_dir eq "."} { + set relative_source_dir "" + } + set target_relative_to_punkcheck_dir [lib::path_relative $punkcheck_folder $current_target_dir] + if {$target_relative_to_punkcheck_dir eq "."} { + set target_relative_to_punkcheck_dir "" + } + foreach unpub $opt_antiglob_paths { + #puts "testing folder - globmatchpath $unpub $relative_source_dir" + if {[punk::path::globmatchpath $unpub $relative_source_dir]} { + lappend antiglob_paths_matched $current_source_dir + return [list files_copied {} files_skipped {} sources_unchanged {} punkcheck_records $punkcheck_records antiglob_paths_matched $antiglob_paths_matched srcdir $srcdir tgtdir $tgtdir punkcheck_folder $punkcheck_folder] + } + } + + + if {![file exists $current_source_dir]} { + error "punkcheck::install current source dir:'$current_source_dir' doesn't exist (srcdir:$srcdir tgtdir:$tgtdir args:'$args')" + } + + set files_copied [list] + set files_skipped [list] + set sources_unchanged [list] + + + set candidate_list [glob -nocomplain -dir $current_source_dir -type f -tail $fileglob] + set hidden_candidate_list [glob -nocomplain -dir $current_source_dir -types {hidden f} -tail $fileglob] + foreach h $hidden_candidate_list { + if {$h ni $candidate_list} { + lappend candidate_list $h + } + } + set match_list [list] + foreach m $candidate_list { + set suppress 0 + foreach anti [concat $opt_excludefiletail_core $opt_excludefiletail] { + if {[string match $anti $m]} { + #puts stderr "anti: $anti vs m:$m" + set suppress 1 + break + } + } + if {$suppress == 0} { + lappend match_list $m + } + } + + #sample .punkcheck file record (raw form) to make the code clearer + #punk::tdl converts to dict form e.g: tag FILEINFO -targets filename body sublist + #Valid installrecord types are INSTALL-RECORD SKIPPED INSTALL-INPROGRESS, MODIFY-RECORD MODIFY-INPROGRESS DELETE-RECORD DELETE-INPROGRESS + # + #FILEINFO -targets jjjetc-0.1.0.tm -keep_installrecords 2 -keep_skipped 1 -keep_inprogress 2 { + # INSTALL-RECORD -tsiso 2023-09-20T07:30:30 -ts 1695159030266610 -installer punk::mix::cli::build_modules_from_source_to_base -metadata_us 18426 -ts_start_transfer 1695159030285036 -transfer_us 10194 -elapsed_us 28620 { + # SOURCE -type file -path ../src/modules/jjjetc-buildversion.txt -cksum c7c71839c36b3d21c8370fed106192fcd659eca9 -cksum_all_opts {-cksum_content 1 -cksum_meta 0 -cksum_acls 0 -cksum_usetar 0 -cksum_algorithm sha1} -changed 1 -metadata_us 3423 + # SOURCE -type file -path ../src/modules/jjjetc-0.1.1.tm -cksum b646fc2ee88cbd068d2e946fe929b7aea96bd39d -cksum_all_opts {-cksum_content 1 -cksum_meta 0 -cksum_acls 0 -cksum_usetar 0 -cksum_algorithm sha1} -changed 1 -metadata_us 3413 + # } + # INSTALL-SKIPPED -tsiso 2023-09-20T08:14:26 -ts 1695161666087880 -installer punk::mix::cli::build_modules_from_source_to_base -elapsed_us 18914 { + # SOURCE -type file -path ../src/modules/jjjetc-buildversion.txt -cksum c7c71839c36b3d21c8370fed106192fcd659eca9 -cksum_all_opts {-cksum_content 1 -cksum_meta 0 -cksum_acls 0 -cksum_usetar 0 -cksum_algorithm sha1} -changed 0 -metadata_us 3435 + # SOURCE -type file -path ../src/modules/jjjetc-0.1.1.tm -cksum b646fc2ee88cbd068d2e946fe929b7aea96bd39d -cksum_all_opts {-cksum_content 1 -cksum_meta 0 -cksum_acls 0 -cksum_usetar 0 -cksum_algorithm sha1} -changed 0 -metadata_us 3338 + # } + #} + + if {[llength $match_list]} { + #example - target dir has a file where there is a directory at the source + if {[file exists $current_target_dir] && ([file type $current_target_dir] ni [list directory])} { + error "punkcheck::install target subfolder $current_target_dir exists but is not of type 'directory'. Type current target folder: [file type $current_target_dir]" + } + } + + #proc get_relativecksum_from_base_and_fullpath {base fullpath args} + + + #puts stdout "Current target dir: $current_target_dir" + set last_depth "" + foreach m $match_list { + set new_tgt_cksum_info [list] + set relative_target_path [file join $relative_target_dir $m] + set relative_source_path [file join $relative_source_dir $m] + set punkcheck_target_relpath [file join $target_relative_to_punkcheck_dir $m] + set is_antipath 0 + foreach antipath $opt_antiglob_paths { + #puts "testing file - globmatchpath $antipath vs $relative_source_path" + if {[punk::path::globmatchpath $antipath $relative_source_path]} { + lappend antiglob_paths_matched $current_source_dir + set is_antipath 1 + break + } + } + if {$is_antipath} { + continue + } + + set ts_start [clock microseconds] + set seconds [expr {$ts_start / 1000000}] + set ts_start_iso [clock format $seconds -format "%Y-%m-%dT%H:%M:%S"] + + + #puts stdout " rel_target: $punkcheck_target_relpath" + + set fetch_filerec_result [punkcheck::recordlist::get_file_record $punkcheck_target_relpath $punkcheck_records] + #change to use extract_or_create_fileset_record ? + set existing_filerec_posn [dict get $fetch_filerec_result position] + if {$existing_filerec_posn == -1} { + if {$opt_progresschannel ne ""} { + puts stdout "\nNO existing record for $punkcheck_target_relpath" + } + set has_filerec 0 + set new_filerec [dict create tag FILEINFO -targets $punkcheck_target_relpath] + set filerec $new_filerec + } else { + set has_filerec 1 + #puts stdout " TDL existing FILEINFO record for $punkcheck_target_relpath" + #puts stdout " $existing_install_record" + set filerec [dict get $fetch_filerec_result record] + } + set filerec [punkcheck::recordlist::file_record_set_defaults $filerec] + + #new INSTALLREC must be tagged as INSTALL-INPROGRESS to use recordlist::installfile_ method + set new_install_record [dict create tag INSTALL-INPROGRESS -tsiso $ts_start_iso -ts $ts_start -installer $opt_installer -eventid $punkcheck_eventid] + dict lappend filerec body $new_install_record ;#can't use recordlist::file_record_add_installrecord as '*-INPROGRESS' isn't a final tag - so pruning would be mucked up. No need to prune now anyway. + unset new_install_record + + + if {$opt_progresschannel ne ""} { + if {$last_depth ne $CALLDEPTH} { + if {$CALLDEPTH <=1} { + puts -nonewline $opt_progresschannel \n[string repeat " " $CALLDEPTH][file tail $relative_source_dir] + } + flush $opt_progresschannel + ##set last_depth $CALLDEPTH ;# done down below + } + } + + + + set relative_source_path [lib::path_relative $punkcheck_folder $current_source_dir/$m] + #puts stdout " rel_source: $relative_source_path" + #if {[file pathtype $relative_source_path] ne "relative"} { + #REVIEW + #different volume or root + #} + #Note this isn't a recordlist function - so it doesn't purely operate on the records + #this hits the filesystem for the sourcepath - gets checksums/timestamps depending on config. + #It doesn't save to .punkcheck (the only punkcheck::installfile_ method which doesn't) + set ts1 [clock milliseconds] + set filerec [punkcheck::installfile_add_source_and_fetch_metadata $punkcheck_folder $relative_source_path $filerec] + set ts2 [clock milliseconds] + set diff [expr {$ts2 - $ts1}] + if {$diff > 100} { + #todo -errorchannel + set errprefix ">>> punkcheck:" + puts stderr "\n$errprefix performance warning: fetch_metadata for $m took $diff ms." + set lb [lindex [dict get $filerec body] end] + #puts stderr "$errprefix filerec last body record:$lb" + set records [dict get $lb body] + set lr [lindex $records end] + set alg [dict get $lr -cksum_all_opts -cksum_algorithm] + if {$alg eq "sha1"} { + puts stderr "$errprefix cksum_algorithm: sha1 (accelerators: [::sha1::Implementations])" + puts stderr "$errprefix sha1 from: [package ifneeded sha1 [package present sha1]]" + } else { + puts stderr "$errprefix cksum_algorithm: $alg" + } + } + + + + #changeinfo comes from last record in body - which is the record we are working on and so will always exist + set changeinfo [punkcheck::recordlist::file_install_record_source_changes [lindex [dict get $filerec body] end]] + set changed [dict get $changeinfo changed] + set unchanged [dict get $changeinfo unchanged] + + if {[llength $unchanged]} { + lappend sources_unchanged $current_source_dir/$m + } + + set is_skip 0 + set is_new 0 + if {$overwrite_what eq "all-targets"} { + file mkdir $current_target_dir + #-------------------------------------------- + #sometimes we get the error: 'error copying "file1" to "file2": invalid argument' + #-------------------------------------------- + puts stderr "punkcheck: about to: file copy -force $current_source_dir/$m $current_target_dir" + file copy -force $current_source_dir/$m $current_target_dir + lappend files_copied $current_source_dir/$m + } else { + if {![file exists $current_target_dir/$m]} { + #puts stderr "punkcheck: first copy to $current_target_dir/$m " + file mkdir $current_target_dir + puts stderr "punkcheck: about to: file copy $current_source_dir/$m $current_target_dir" + file copy $current_source_dir/$m $current_target_dir + set new_tgt_cksum_info [punk::mix::base::lib::cksum_path $current_target_dir/$m] + lappend files_copied $current_source_dir/$m + incr filecount_new + set is_new 1 + } else { + switch -- $overwrite_what { + installedsourcechanged-targets { + if {[llength $changed]} { + #An unrecorded installation is considered a source change (from unknown/unrecorded source to recorded) + puts -nonewline stderr "punkcheck: about to: file copy -force $current_source_dir/$m $current_target_dir" + set ts1 [clock milliseconds] + file mkdir $current_target_dir + file copy -force $current_source_dir/$m $current_target_dir + set ts2 [clock milliseconds] + puts -nonewline stderr " (copy time [expr {$ts2 - $ts1}] ms)" + set new_tgt_cksum_info [punk::mix::base::lib::cksum_path $current_target_dir/$m] + set ts3 [clock milliseconds] + puts stderr " (cksum time [expr {$ts2 - $ts1}] ms)" + lappend files_copied $current_source_dir/$m + } else { + set is_skip 1 + lappend files_skipped $current_source_dir/$m + } + } + synced-targets { + #disallow overwriting of target that has been modified by some other mechanism + #review + if {[llength $changed]} { + #only overwrite if the target file checksum equals the last installed checksum (ie target is in sync with previous source-set and so hasn't been customized) + set existing_tgt_cksum_info [punk::mix::base::lib::cksum_path $current_target_dir/$m] + set is_target_unmodified_since_install 0 + set target_cksum_compare "unknown" + set latest_install_record [punkcheck::recordlist::file_record_latest_installrecord $filerec] ;#may be no such record - in which case we get an empty list + if {[dict exists $latest_install_record -targets_cksums]} { + set last_install_cksum [dict get $latest_install_record -targets_cksums] ;#in this case we know there is only one as 'install' always uses targetset size of 1. (FILEINFO record per file in source folder) + if {[dict get $existing_tgt_cksum_info cksum] eq $last_install_cksum} { + set is_target_unmodified_since_install 1 + set target_cksum_compare "match" + } else { + set target_cksum_compare "nomatch" + } + } else { + set target_cksum_compare "norecord" + } + if {$is_target_unmodified_since_install} { + file mkdir $current_target_dir + puts stderr "punkcheck: synced-targets about to: file copy -force $current_source_dir/$m $current_target_dir" + file copy -force $current_source_dir/$m $current_target_dir + set new_tgt_cksum_info [punk::mix::base::lib::cksum_path $current_target_dir/$m] + lappend files_copied $current_source_dir/$m + } else { + #either cksum is different or we were unable to verify the record. Either way we can't know if the target is in sync so we must skip it + set is_skip 1 + puts stderr "Skipping file copy $m target $current_target_dir/$m - require synced_target to overwrite - current target cksum compared to previous install: $target_cksum_compare" + lappend files_skipped $current_source_dir/$m + } + } else { + set is_skip 1 + lappend files_skipped $current_source_dir/$m + } + } + default { + set is_skip 1 + puts stderr "Skipping file copy $m target $current_target_dir/$m already exists (use -overwrite all-targets to overwrite)" + #TODO! implement newer-targets older-targets? (note ctimes/mtimes are unreliable - may not be worth implementing) + lappend files_skipped $current_source_dir/$m + } + } + } + } + #target dir was created as necessary if files matched above + #now ensure target dir exists if -createempty true + if {$opt_createempty && ![file exists $current_target_dir]} { + file mkdir $current_target_dir + } + + + + + set ts_now [clock microseconds] + set elapsed_us [expr {$ts_now - $ts_start}] + + #if {$store_source_cksums} { + #} + + set install_records [dict get $filerec body] + set current_install_record [lindex $install_records end] + #change the tag from *-INPROGRESS to INSTALL-RECORD/SKIPPED + if {$is_skip} { + set tag INSTALL-SKIPPED + } else { + set tag INSTALL-RECORD + } + dict set current_install_record tag $tag + dict set current_install_record -elapsed_us $elapsed_us + if {[llength $new_tgt_cksum_info]} { + dict set current_install_record -targets_cksums [list [dict get $new_tgt_cksum_info cksum]] + dict set current_install_record -cksum_all_opts [dict get $new_tgt_cksum_info opts] + } + lset install_records end $current_install_record + dict set filerec body $install_records + set filerec [punkcheck::recordlist::file_record_prune $filerec] ;#prune now that tag is finalized + if {!$has_filerec} { + #not found in original recordlist - append + lappend punkcheck_records $filerec + } else { + lset punkcheck_records $existing_filerec_posn $filerec + } + + + #------------------------------------------------------------ + if {$is_skip} { + set mark . + } else { + if {$is_new} { + set mark \x1b\[32\;1mN\x1b\[m + } else { + #updated + set mark \x1b\[32\;1mU\x1b\[m + } + } + if {$opt_progresschannel ne ""} { + if {$last_depth ne $CALLDEPTH} { + puts -nonewline $opt_progresschannel \n[string repeat " " $CALLDEPTH]$mark + flush $opt_progresschannel + set last_depth $CALLDEPTH + } else { + puts -nonewline $opt_progresschannel $mark + } + } + #------------------------------------------------------------ + + } + + if {$max_depth != -1 && $CALLDEPTH >= $max_depth} { + #don't process any more subdirs + #sometimes deliberately called with max_depth 1 - so don't warn here. review + #puts stderr "punkcheck::install warning - reached max_depth $max_depth" + set subdirs [list] + } else { + set subdirs [glob -nocomplain -dir $current_source_dir -type d -tail *] + set hiddensubdirs [glob -nocomplain -dir $current_source_dir -type {hidden d} -tail *] + foreach h $hiddensubdirs { + switch -- $h { + "." - ".." { + continue + } + default { + if {$h ni $subdirs} { + lappend subdirs $h + } + } + } + } + } + #puts stderr "subdirs: $subdirs" + foreach d $subdirs { + set skipd 0 + foreach dg [concat $opt_excludedirseg_core $opt_excludedirseg] { + if {[string match $dg $d]} { + #puts stdout "SKIPPING FOLDER $d due to excludedirseg-match: $dg " + set skipd 1 + break + } + } + if {$skipd} { + continue + } + + set relative_source_path [file join $relative_source_dir $d] + set is_antipath 0 + foreach antipath $opt_antiglob_paths { + #puts "testing folder - globmatchpath $antipath vs $relative_source_path" + if {[punk::path::globmatchpath $antipath $relative_source_path]} { + lappend antiglob_paths_matched [file join $current_source_dir $d] + #puts stdout "SKIPPING FOLDER $relative_source_path due to antiglob_path-match: $antipath " + set is_antipath 1 + break + } + } + if {$is_antipath} { + continue + } + + #if {![file exists $current_target_dir/$d]} { + # file mkdir $current_target_dir/$d + #} + + + set sub_opts_1 [list {*}{ + } -call-depth-internal [expr {$CALLDEPTH + 1}] {*}{ + } -subdirlist [list {*}$subdirlist $d] {*}{ + } -glob $fileglob {*}{ + } -exclude-filetails_core $opt_excludefiletail_core {*}{ + } -exclude-filetails $opt_excludefiletail {*}{ + } -exclude-dirsegments_core $opt_excludedirseg_core {*}{ + } -exclude-dirsegments $opt_excludedirseg {*}{ + } -overwrite $overwrite_what {*}{ + } -source_checksum $opt_source_checksum {*}{ + } -punkcheck_folder $punkcheck_folder {*}{ + } -punkcheck_eventid $punkcheck_eventid {*}{ + } -punkcheck_records $punkcheck_records {*}{ + } -installer $opt_installer {*}{ + } + ] + set sub_opts [list {*}{ + } -call-depth-internal [expr {$CALLDEPTH + 1}] {*}{ + } -subdirlist [list {*}$subdirlist $d] {*}{ + } -punkcheck_folder $punkcheck_folder {*}{ + } -punkcheck_eventid $punkcheck_eventid {*}{ + } -punkcheck_records $punkcheck_records {*}{ + } -progresschannel $opt_progresschannel {*}{ + } + ] + set sub_opts [dict merge $opts $sub_opts] + set sub_result [punkcheck::install $srcdir $tgtdir {*}$sub_opts] + + lappend files_copied {*}[dict get $sub_result files_copied] + lappend files_skipped {*}[dict get $sub_result files_skipped] + lappend sources_unchanged {*}[dict get $sub_result sources_unchanged] + lappend antiglob_paths_matched {*}[dict get $sub_result antiglob_paths_matched] + set punkcheck_records [dict get $sub_result punkcheck_records] + } + + if {[string match *store* $opt_source_checksum]} { + #puts "subdirlist: $subdirlist" + if {$CALLDEPTH == 0} { + if {[llength $files_copied] || [llength $files_skipped]} { + #puts stdout ">>>>>>>>>>>>>>>>>>>" + set saveresult [punkcheck::save_records_to_file $punkcheck_records $punkcheck_file "install $srcdir to $tgtdir"] + puts stdout "\npunkcheck::install [dict get $saveresult recordcount] records saved as [dict get $saveresult linecount] lines to $punkcheck_file copied: [llength $files_copied] skipped: [llength $files_skipped]" + #puts stdout ">>>>>>>>>>>>>>>>>>>" + } else { + #todo - write db INSTALLER record if -debug true + + } + #puts stdout "sources_unchanged" + #puts stdout "$sources_unchanged" + #puts stdout "- -- --- --- --- ---" + } + } + + return [list files_copied $files_copied files_skipped $files_skipped sources_unchanged $sources_unchanged antiglob_paths_matched $antiglob_paths_matched punkcheck_records $punkcheck_records punkcheck_folder $punkcheck_folder srcdir $srcdir tgtdir $tgtdir] + } + + + lappend PUNKARGS [list { + @id -id ::punkcheck::summarize_install_resultdict + @cmd -name punkcheck::summarize_install_resultdict -help\ + "Emits a string summarizing a punkcheck resultdict, showing + how many items were copied, and the source, target locations" + @opts + -title -type string -default "" + -forcecolour -type boolean -default 0 -help\ + "When true, passes the forcecolour tag to punk::ansi functions. + This enables ANSI sgr colours even when colour + is off. (ignoring env(NO_COLOR)) + To disable colour - ensure the NO_COLOR env var is set, + or use: + namespace eval ::punk::console {variable colour_disabled 1}" + @values -min 1 -max 1 + resultdict -type dict + }] + proc summarize_install_resultdict {args} { + set argd [punk::args::parse $args withid ::punkcheck::summarize_install_resultdict] + lassign [dict values $argd] leaders opts values received + set title [dict get $opts -title] + set forcecolour [dict get $opts -forcecolour] + set resultdict [dict get $values resultdict] + + set has_ansi [expr {![catch {package require punk::ansi}]}] + if {$has_ansi} { + if {$forcecolour} { + set fc "forcecolour" + } else { + set fc "" + } + set R [punk::ansi::a] ;#reset + set LINE_COLOUR [punk::ansi::a+ {*}$forcecolour bold cyan] + set LOW_COLOUR [punk::ansi::a+ {*}$forcecolour bold green] + set HIGH_COLOUR [punk::ansi::a+ {*}$forcecolour bold yellow] + } else { + set R "" + set LINE_COLOUR "" + set LOW_COLOUR "" + set HIGH_COLOUR "" + } + + set msg "" + if {[dict size $resultdict]} { + set copied [dict get $resultdict files_copied] + if {[llength $copied] == 0} { + set HIGHLIGHT $LOW_COLOUR + } else { + set HIGHLIGHT $HIGH_COLOUR + } + set ruler $LINE_COLOUR[string repeat - 78]$R + if {$title ne ""} { + append msg $ruler \n + append msg $title \n + } + append msg $ruler \n + #append msg "[dict keys $resultdict]" \n + set tgtdir [dict get $resultdict tgtdir] + set checkfolder [dict get $resultdict punkcheck_folder] + append msg "${HIGHLIGHT}Copied [llength $copied] files from [dict get $resultdict srcdir] to [dict get $resultdict tgtdir]$R" \n + foreach f $copied { + append msg "COPIED [punkcheck::lib::path_relative $checkfolder $f]" \n + append msg " TO $tgtdir" \n + } + append msg "[llength [dict get $resultdict sources_unchanged]] unchanged source files" \n + append msg "[llength [dict get $resultdict files_skipped]] skipped files" \n + append msg $ruler \n + } + return $msg + } + + namespace eval recordlist { + set pkg punkcheck + namespace path ::punkcheck + + proc records_as_target_dict {record_list} { + set result [dict create] + foreach rec $record_list { + if {[dict get $rec tag] eq "FILEINFO"} { + set tgtlist [dict get $rec -targets] + if {[dict exists $result $tgtlist]} { + #todo - warn - duplicate record for same targetlist - shouldn't happen as we should be using get_file_record to find existing records + error "punkcheck::recordlist::records_as_target_dict - multiple records with same targetlist '$tgtlist'" + } + dict set result $tgtlist $rec + } + } + return $result + } + + + #will only match if same base was used.. and same targetlist + proc get_file_record {targetlist record_list} { + set posn 0 + set found_posn -1 + set record "" + foreach rec $record_list { + if {[dict get $rec tag] eq "FILEINFO"} { + if {[dict get $rec -targets] eq $targetlist} { + set found_posn $posn + set record $rec + break + } + } + incr posn + } + return [list position $found_posn record $record] + } + proc file_install_record_source_changes {install_record} { + #reject INSTALLFAILED items ? + switch -- [dict get $install_record tag] { + "QUERY-INPROGRESS" - + "INSTALL-RECORD" - + "INSTALL-SKIPPED" - + "INSTALL-INPROGRESS" - + "MODIFY-INPROGRESS" - + "MODIFY-RECORD" - + "MODIFY-SKIPPED" - + "VIRTUAL-INPROGRESS" - + "VIRTUAL-RECORD" - + "VIRTUAL-SKIPPED" - + "DELETE-RECORD" - + "DELETE-INPROGRESS" - + "DELETE-SKIPPED" { + } + default { + error "file_install_record_source_changes bad install record: tag '[dict get $install_record tag]' not INSTALL-RECORD|SKIPPED|INSTALL-INPROGRESS|MODIFY-RECORD|MODIFY-INPROGRESS|VIRTUAL-RECORD|VIRTUAL-INPROGRESS|DELETE-RECORD|DELETE-INPROGRESS" + } + } + set source_list [dict_getwithdefault $install_record body [list]] + set changed [list] + set unchanged [list] + foreach src $source_list { + if {[dict exists $src -changed]} { + if {[dict get $src -changed] !=0} { + lappend changed [dict get $src -path] + } else { + lappend unchanged [dict get $src -path] + } + } else { + lappend changed [dict get $src -path] + } + } + return [dict create changed $changed unchanged $unchanged] + } + + #assume only one for name - use first encountered? + proc get_installer_record {name record_list} { + set posn 0 + set found_posns [list] + set record "" + #puts ">>>> checking [llength $record_list] punkcheck records" + foreach rec $record_list { + if {[dict get $rec tag] eq "INSTALLER"} { + if {[dict get $rec -name] eq $name} { + set found_posn $posn + set record $rec + lappend found_posns $posn + } + } + incr posn + } + if {[llength $found_posns] > 1} { + error "punkcheck::recordlist::get_installer_record - multiple installer records with name '$name' found at positions $found_posns" + } elseif {[llength $found_posns] == 0} { + return [list position -1 record ""] + } else { + #single record found + return [list position [lindex $found_posn 0] record $record] + } + + } + + proc new_installer_record {name args} { + if {[llength $args] %2 !=0} { + error "punkcheck new_installer_record args must be name-value pairs" + } + set ts [clock microseconds] + set seconds [expr {$ts / 1000000}] + set tsiso [clock format $seconds -format "%Y-%m-%dT%H:%M:%S"] + + #put -tsiso first so it lines up with -tsiso in event records + set defaults [list {*}{ + } -tsiso $tsiso {*}{ + } -ts $ts {*}{ + } -name $name {*}{ + } -keep_events 5 {*}{ + } + ] + set opts [dict merge $defaults $args] + + #set this_installer_record_list [punk::tdl::prettyparse [list INSTALLER name $opt_installer ts $ts tsiso $tsiso keep_events 5 {}]] + #set this_installer_record [lindex $this_installer_record_list 0] + + set record [dict create tag INSTALLER {*}$opts body {}] + + + return $record + } + proc new_installer_event_record {type args} { + if {[llength $args] %2 !=0} { + error "punkcheck new_installer_event_record args must be name-value pairs" + } + set ts [clock microseconds] + set seconds [expr {$ts / 1000000}] + set tsiso [clock format $seconds -format "%Y-%m-%dT%H:%M:%S"] + set defaults [list {*}{ + } -tsiso $tsiso {*}{ + } -ts $ts {*}{ + } -type $type {*}{ + } + ] + set opts [dict merge $defaults $args] + + set record [dict create tag EVENT {*}$opts] + } + #need to scan entire set if filerecords to check if event is still referenced + proc installer_record_pruneevents {installer_record record_list} { + set keep 5 + if {[dict exists $installer_record -keep_events]} { + set keep [dict get $installer_record -keep_events] + } + + if {[dict exists $installer_record body]} { + set body_items [dict get $installer_record body] + } else { + set body_items [list] + } + set kept_body_items [list] + set kcount 0 + foreach item [lreverse $body_items] { + if {[dict get $item tag] eq "EVENT"} { + incr kcount + if {$keep < 0 || $kcount <= $keep} { + lappend kept_body_items $item + } else { + set eventid "" + if {[dict exists $item -id]} { + set eventid [dict get $item -id] + } + if {$eventid ne "" && $eventid ne "unspecified"} { + #keep if referenced, discard if not, or if eventid empty/unspecified + set is_referenced 0 + foreach rec $record_list { + if {[dict get $rec tag] eq "FILEINFO"} { + if {[dict exists $rec body]} { + foreach install [dict get $rec body] { + if {[dict exists $install -eventid] && [dict get $install -eventid] eq $eventid} { + set is_referenced 1 + break + } + } + } + } + if {$is_referenced} { + break + } + } + if {$is_referenced} { + lappend kept_body_items $item + } + } + } + } else { + lappend kept_body_items $item + } + } + set kept_body_items [lreverse $kept_body_items] + dict set installer_record body $kept_body_items + return $installer_record + } + proc installer_record_add_event {installer_record event} { + if {[dict get $installer_record tag] ne "INSTALLER"} { + error "installer_record_add_event bad installer record: tag not INSTALLER" + } + if {[dict get $event tag] ne "EVENT"} { + error "installer_record_add_event bad event record: tag not EVENT" + } + if {[dict exists $installer_record body]} { + set body_items [dict get $installer_record body] + } else { + set body_items [list] + } + lappend body_items $event + dict set installer_record body $body_items + return $installer_record + } + proc file_record_latest_installrecord {file_record} { + tailcall file_record_latest_operationrecord INSTALL $file_record + } + proc file_record_latest_operationrecord {operation file_record} { + set operation [string toupper $operation] + if {[dict get $file_record tag] ne "FILEINFO"} { + error "file_record_latest_operationrecord bad file_record: tag not FILEINFO" + } + if {![dict exists $file_record body]} { + return [list] + } + set body_items [dict get $file_record body] + foreach item [lreverse $body_items] { + if {[dict get $item tag] eq "$operation-RECORD"} { + return $item + } + } + return [list] + } + + + proc file_record_set_defaults {file_record} { + if {[dict get $file_record tag] ne "FILEINFO"} { + error "file_record_set_defaults bad file_record: tag not FILEINFO" + } + set defaults [list -keep_installrecords 3 -keep_skipped 1 -keep_inprogress 2] + foreach {k v} $defaults { + if {![dict exists $file_record $k]} { + dict set file_record $k $v + } + } + return $file_record + } + + #negative keep_ value will keep all + proc file_record_prune {file_record} { + if {[dict get $file_record tag] ne "FILEINFO"} { + error "file_record_prune bad file_record: tag not FILEINFO" + } + set file_record [file_record_set_defaults $file_record] + set kmap [list -keep_installrecords *-RECORD -keep_skipped *-SKIPPED -keep_inprogress *-INPROGRESS] + foreach {key rtype} $kmap { + set keep [dict get $file_record $key] + if {[dict exists $file_record body]} { + set body_items [dict get $file_record body] + } else { + set body_items [list] + } + set kept_body_items [list] + set kcount 0 + foreach item [lreverse $body_items] { + if {[string match $rtype [dict get $item tag]]} { + incr kcount + if {$keep < 0 || $kcount <= $keep} { + lappend kept_body_items $item + } + } else { + lappend kept_body_items $item + } + } + set kept_body_items [lreverse $kept_body_items] + dict set file_record body $kept_body_items + } + return $file_record + } + + #extract new or existing filerecord for path given + #REVIEW - locking/concurrency + proc extract_or_create_fileset_record {relative_target_paths recordset} { + set fetch_record_result [punkcheck::recordlist::get_file_record $relative_target_paths $recordset] + set existing_posn [dict get $fetch_record_result position] + if {$existing_posn == -1} { + puts stdout "punkcheck NO existing record for $relative_target_paths" + set isnew 1 + set fileset_record [dict create tag FILEINFO -targets $relative_target_paths body {}] + } else { + #set recordset [lreplace $recordset[unset recordset] $existing_posn $existing_posn] + #set recordset [lreplace $recordset[set recordset {}] $existing_posn $existing_posn] + ledit recordset $existing_posn $existing_posn + set isnew 0 + set fileset_record [dict get $fetch_record_result record] + } + return [list record $fileset_record recordset $recordset isnew $isnew oldposition $existing_posn] + } + + } + +} + + + + +namespace eval ::punk::args::register { + #use fully qualified so 8.6 doesn't find existing var in global namespace + lappend ::punk::args::register::NAMESPACES ::punkcheck +} + + + + + + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Ready +package provide punkcheck [namespace eval punkcheck { + set pkg punkcheck + variable version + set version 0.1.1 +}] +return diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punkcheck/cli-0.1.0.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punkcheck/cli-0.1.0.tm index bbf882a0..ed3a5b5e 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punkcheck/cli-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punkcheck/cli-0.1.0.tm @@ -64,7 +64,7 @@ namespace eval punkcheck::cli { #vfs can mask mounted files - so we can't just use 'file type' or glob with -type f ##set files [glob -nocomplain -dir $fullpath -type f *] package require punk::nav::fs - + #TODO - get all files in tree!!! set folderinfo [punk::nav::fs::dirfiles_dict $fullpath] set files [concat [dict get $folderinfo files] [dict get $folderinfo underlayfiles]] @@ -81,7 +81,7 @@ namespace eval punkcheck::cli { foreach p $punkcheck_files { set basedir [file dirname $p] set recordlist [punkcheck::load_records_from_file $p] - set tgt_dict [punkcheck::recordlist::records_as_target_dict $recordlist] + set tgt_dict [punkcheck::recordlist::records_as_target_dict $recordlist] foreach f $files { set relpath [punkcheck::lib::path_relative $basedir $f] @@ -137,13 +137,13 @@ namespace eval punkcheck::cli { } } } - } + } } if {[llength $source_files]} { - append pcheck " source files : [llength $source_files] (changed [llength $source_files_changed])" + append pcheck " source files : [llength $source_files] (changed [llength $source_files_changed])" } if {[llength $source_folders]} { - append pcheck " source folders: [llength $source_folders] (changed [llength $source_folders_changed])" + append pcheck " source folders: [llength $source_folders] (changed [llength $source_folders_changed])" } append pcheck \n @@ -152,7 +152,7 @@ namespace eval punkcheck::cli { } } } - append table "$f $pcheck" \n + append table "$f $pcheck" \n } } } @@ -182,7 +182,7 @@ namespace eval punkcheck::cli { foreach p $punkcheck_files { set basedir [file dirname $p] set recordlist [punkcheck::load_records_from_file $p] - set tgt_dict [punkcheck::recordlist::records_as_target_dict $recordlist] + set tgt_dict [punkcheck::recordlist::records_as_target_dict $recordlist] foreach f $files { set relpath [punkcheck::lib::path_relative $basedir $f] @@ -235,13 +235,13 @@ namespace eval punkcheck::cli { } } } - } + } } if {[llength $source_files]} { - append pcheck " source files : [llength $source_files] (changed [llength $source_files_changed])" + append pcheck " source files : [llength $source_files] (changed [llength $source_files_changed])" } if {[llength $source_folders]} { - append pcheck " source folders: [llength $source_folders] (changed [llength $source_folders_changed])" + append pcheck " source folders: [llength $source_folders] (changed [llength $source_folders_changed])" } append pcheck \n @@ -250,7 +250,7 @@ namespace eval punkcheck::cli { } } } - append table "$f $pcheck" \n + append table "$f $pcheck" \n } } } @@ -259,14 +259,13 @@ namespace eval punkcheck::cli { } - # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ namespace eval punkcheck::cli::lib { namespace path ::punk::mix::util ;#askuser, do_in_path, foreach-file etc proc find_nearest_file {{path {}}} { if {$path eq {}} { set path [pwd] } - set folder [lib::scanup $path lib::is_punkchecked_folder] + set folder [lib::scanup $path lib::is_punkchecked_folder] if {$folder eq ""} { return "" } else { @@ -307,7 +306,6 @@ namespace eval punkcheck::cli::lib { } return {} } - } @@ -320,15 +318,15 @@ namespace eval punkcheck::cli { variable default_command status package require punk::mix::base package require punk::overlay - punk::overlay::custom_from_base [namespace current] ::punk::mix::base + punk::overlay::custom_from_base [namespace current] ::punk::mix::base } # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready +## Ready package provide punkcheck::cli [namespace eval punkcheck::cli { variable version - set version 0.1.0 + set version 0.1.0 }] return diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/shellfilter-0.2.2.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/shellfilter-0.2.2.tm index 6a948593..a841bd6e 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/shellfilter-0.2.2.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/shellfilter-0.2.2.tm @@ -326,18 +326,34 @@ namespace eval shellfilter::chan { #method flush {ch} { # return "" #} + #method flush {transform_handle} { + # #puts stdout "" + # #review - just clear o_encbuf and emit nothing? + # #we wouldn't have a value there if it was convertable from the channel encoding? + # if {[string length $o_encbuf]} { + # #if we have data in the buffer that we haven't been able to convert to a string + # #- then we probably have some kind of encoding mismatch. Is it safer to discard it than to emit garbage chars to the channel or var? + # #REVIEW - log that we are discarding the buffer contents on flush? + # puts stderr "WARNING: flush called on tee_to_var with non-empty buffer. This probably indicates an encoding mismatch between the channel encoding and the encoding expected by the transform. Discarding buffer contents: '$o_encbuf'" + # } + # set clear $o_encbuf + # set o_encbuf "" + # return $clear + #} method flush {transform_handle} { - #puts stdout "" - #review - just clear o_encbuf and emit nothing? - #we wouldn't have a value there if it was convertable from the channel encoding? - if {[string length $o_encbuf]} { - #if we have data in the buffer that we haven't been able to convert to a string - #- then we probably have some kind of encoding mismatch. Is it safer to discard it than to emit garbage chars to the channel or var? - #REVIEW - log that we are discarding the buffer contents on flush? - puts stderr "WARNING: flush called on tee_to_var with non-empty buffer. This probably indicates an encoding mismatch between the channel encoding and the encoding expected by the transform. Discarding buffer contents: '$o_encbuf'" + #puts stderr " $transform_handle o_encbuf: '$o_encbuf' datavars: $o_datavars" + set clear $o_encbuf + if {[catch {tcl::encoding::convertfrom $o_enc $clear} stringdata]} { + #if we can't convert the buffer contents to a string - does it make sense to emit the raw bytes? + # - probably not. + #REVIEW? + return "" } set o_encbuf "" - return "" + foreach v $o_datavars { + append $v $stringdata + } + return $stringdata } method write {ch bytes} { #test with set x [string repeat " \U1f6c8" 2043] @@ -442,16 +458,29 @@ namespace eval shellfilter::chan { # flush $o_localchan # return $clear #} + #method flush {transform_handle} { + # #we wouldn't have a value in o_encbuf if it was convertable from the channel encoding? + # if {[string length $o_encbuf]} { + # #if we have data in the buffer that we haven't been able to convert to a string + # #- then we probably have some kind of encoding mismatch. Is it safer to discard it than to emit garbage chars to the channel or var? + # #REVIEW - log that we are discarding the buffer contents on flush? + # puts stderr "WARNING: flush called on tee_to_pipe with non-empty buffer. This probably indicates an encoding mismatch between the channel encoding and the encoding expected by the transform. Discarding buffer contents: '$o_encbuf'" + # } + # set clear $o_encbuf + # set o_encbuf "" + # return $clear + #} method flush {transform_handle} { - #we wouldn't have a value in o_encbuf if it was convertable from the channel encoding? - if {[string length $o_encbuf]} { - #if we have data in the buffer that we haven't been able to convert to a string - #- then we probably have some kind of encoding mismatch. Is it safer to discard it than to emit garbage chars to the channel or var? - #REVIEW - log that we are discarding the buffer contents on flush? - puts stderr "WARNING: flush called on tee_to_pipe with non-empty buffer. This probably indicates an encoding mismatch between the channel encoding and the encoding expected by the transform. Discarding buffer contents: '$o_encbuf'" + set clear $o_buffered$o_encbuf + if {[catch {tcl::encoding::convertfrom $o_enc $clear} stringdata]} { + #if we can't convert the buffer contents to a string - does it make sense to emit the raw bytes? + # - probably not. + #REVIEW? + return "" } + set o_buffered "" set o_encbuf "" - return "" + return $stringdata } method write {transform_handle bytes} { #set logdata [tcl::encoding::convertfrom $o_enc $bytes] @@ -533,11 +562,24 @@ namespace eval shellfilter::chan { ::shellfilter::log::write $o_logsource $logdata return $bytes } + #method flush {transform_handle} { + # #return "" + # set clear $o_encbuf + # set o_encbuf "" + # #review + # return $clear + #} method flush {transform_handle} { - #return "" - set clear $o_encbuf + set clear $o_buffered$o_encbuf + if {[catch {tcl::encoding::convertfrom $o_enc $clear} stringdata]} { + #if we can't convert the buffer contents to a string - does it make sense to emit the raw bytes? + # - probably not. + #REVIEW? + return "" + } + set o_buffered "" set o_encbuf "" - return $o_encbuf + return $stringdata } method write {ch bytes} { #set logdata [tcl::encoding::convertfrom $o_enc $bytes] @@ -613,9 +655,21 @@ namespace eval shellfilter::chan { my destroy } #clear? + #method flush {transform_handle} { + # #we wouldn't have a value in o_encbuf if it was convertable from the channel encoding? + # if {[string length $o_encbuf]} { + # #if we have data in the buffer that we haven't been able to convert to a string + # #- then we probably have some kind of encoding mismatch. Is it safer to discard it than to emit garbage chars to the log? + # #REVIEW. - we are writing the raw bytes to the log here because we can't convert them to a string. + # #This may be useful for debugging issues, but it may also result in garbage data in the log. + # ::shellfilter::log::write $o_logsource $o_encbuf + # set o_encbuf "" + # } + # return + #} method flush {transform_handle} { - #we wouldn't have a value in o_encbuf if it was convertable from the channel encoding? - if {[string length $o_encbuf]} { + set clear $o_buffered$o_encbuf + if {[catch {tcl::encoding::convertfrom $o_enc $clear} stringdata]} { #if we have data in the buffer that we haven't been able to convert to a string #- then we probably have some kind of encoding mismatch. Is it safer to discard it than to emit garbage chars to the log? #REVIEW. - we are writing the raw bytes to the log here because we can't convert them to a string. @@ -755,6 +809,110 @@ namespace eval shellfilter::chan { } } + + #experimental + #applying this to stdout breaks console query/responses - why? + #- probably because we are splitting graphemes across writes and flushes and the console doesn't know how to handle that? + oo::class create unicode_normalize { + variable o_trecord + variable o_enc + variable o_encbuf + variable o_graphemebuf + variable o_mode + variable o_is_junction + constructor {tf} { + package require punk::ansi + set o_trecord $tf + set o_enc [::tcl::dict::get $tf -encoding] + set o_encbuf "" + set o_graphemebuf "" + set settingsdict [tcl::dict::get $tf -settings] + if {[dict exists $settingsdict -mode]} { + set o_mode [dict get $settingsdict -mode] + if {$o_mode ni {nfc nfd nfkc nfkd none}} { + error "unicode_normalize transform - invalid mode '$o_mode' in settings" + } + if {$o_mode ne "none"} { + #we get dll dependent load errors on windows sometimes - but still seems to work - REVIEW/FIX. + catch {::tcl::unsupported::loadIcu} + } + } else { + #if no mode specified - default to 'none' which just does grapheme splitting without any unicode normalization + set o_mode "none" + } + if {[::tcl::dict::exists $tf -junction]} { + set o_is_junction [::tcl::dict::get $tf -junction] + } else { + set o_is_junction 0 + } + } + method initialize {transform_handle mode} { + return [list initialize write flush finalize] + } + method finalize {transform_handle} { + my destroy + } + method flush {transform_handle} { + #flush seems to do nothing - why? + set clear $o_encbuf[unset o_encbuf] + if {[catch {tcl::encoding::convertfrom $o_enc $clear} stringdata]} { + #if we can't convert the buffer contents to a string - put it back and try again with more data later + #REVIEW? + set o_encbuf $clear + return "" + } + #review + + set graphemes [punk::char::grapheme_split $o_graphemebuf$stringdata] + set outstring [join $graphemes ""] + #puts "outstring: '$outstring' graphemes: $graphemes" + if {$o_mode ne "none"} { + set outstring [::tcl::unsupported::icu::normalize -mode $o_mode $outstring] + } + set o_graphemebuf "" + return [tcl::encoding::convertto $o_enc $outstring] + } + method write {transform_handle bytes} { + set inputbytes $o_encbuf$bytes + set o_encbuf "" + set tail_offset 0 + + if {$inputbytes eq ""} { + #review - do we even get empty writes? + puts stderr "WARNING: write called on unicode_normalize with empty inputbytes. This may be a no-op, but it may also indicate an issue with the upstream transform or channel. Emitting no data for this write." + set stringdata "" + } + + while {$tail_offset < [::tcl::string::length $inputbytes] && [catch {tcl::encoding::convertfrom $o_enc [::tcl::string::range $inputbytes 0 end-$tail_offset]} stringdata]} { + incr tail_offset + } + if {$tail_offset > 0} { + if {$tail_offset < [::tcl::string::length $inputbytes]} { + #stringdata from catch statement must be a valid result + set t [expr {$tail_offset - 1}] + set o_encbuf [::tcl::string::range $inputbytes end-$t end] + } else { + set stringdata "" + set o_encbuf $inputbytes + return "" + } + } + set graphemes [punk::char::grapheme_split $o_graphemebuf$stringdata] + set outstring [join [lrange $graphemes 0 end-1] ""] + set o_graphemebuf [lindex $graphemes end] + + if {$o_mode ne "none"} { + set outstring [::tcl::unsupported::icu::normalize -mode $o_mode $outstring] + } + + return [tcl::encoding::convertto $o_enc $outstring] + } + method meta_is_redirection {} { + return $o_is_junction + } + } + + #a test oo::class create reconvert { variable o_trecord @@ -1114,7 +1272,6 @@ namespace eval shellfilter::chan { # return $emit #} method flush {transform_handle} { - #return "" set clear $o_buffered$o_encbuf if {[catch {tcl::encoding::convertfrom $o_enc $clear} stringdata]} { #if we can't convert the buffer contents to a string - does it make sense to emit the raw bytes? diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/shellrun-0.1.2.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/shellrun-0.1.2.tm new file mode 100644 index 00000000..7a353961 --- /dev/null +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/shellrun-0.1.2.tm @@ -0,0 +1,897 @@ +# vim: set ft=tcl +# +#purpose: handle the run commands that call shellfilter::run +#e.g run,runout,runerr,runx + +package require shellfilter +package require punk::ansi + +#NOTE: the run,runout,runerr,runx commands only produce an error if the command didn't run. +# - If it did run, but there was a non-zero exitcode it is up to the application to check that. +#This is deliberate, but means 'catch' doesn't catch errors within the command itself - the exitcode has to be checked. +#The user can always use exec for different process error semantics (they don't get exitcode with exec) + +namespace eval shellrun { + variable PUNKARGS + variable runout + variable runerr + + #do we need these? + #variable punkout + #variable punkerr + + #some ugly coupling with punk/punk::config for now + #todo - something better + if {[info exists ::punk::config::configdata]} { + set conf_running [punk::config::configure running] + set syslog_stdout [dict get $conf_running syslog_stdout] + set syslog_stderr [dict get $conf_running syslog_stderr] + set logfile_stdout [dict get $conf_running logfile_stdout] + set logfile_stderr [dict get $conf_running logfile_stderr] + } else { + lassign [list "" "" "" ""] syslog_stdout syslog_stderr logfile_stdout logfile_stderr + } + if {"punkshout" ni [shellfilter::stack::items]} { + set outdevice [shellfilter::stack::new punkshout -settings [list -tag "punkshout" -buffering none -raw 1 -syslog $syslog_stdout -file $logfile_stdout]] + set out [dict get $outdevice localchan] + } else { + set out [dict get [shellfilter::stack::item punkshout] device localchan] + } + if {"punksherr" ni [shellfilter::stack::items]} { + set errdevice [shellfilter::stack::new punksherr -settings [list -tag "punksherr" -buffering none -raw 1 -syslog $syslog_stderr -file $logfile_stderr]] + set err [dict get $errdevice localchan] + } else { + set err [dict get [shellfilter::stack::item punksherr] device localchan] + } + + namespace import ::punk::ansi::a+ + namespace import ::punk::ansi::a + + + + + #repltelemetry - additional/alternative display info used in a repl context i.e info directed towards the screen + #todo - package up in repltelemetry module and rewrite proc based on whether the module was found/loaded. + #somewhat strong coupling to punk - but let's try to behave decently if it's not loaded + #The last_run_display is actually intended for the repl - but is resident in the punk namespace with a view to the possibility of a different repl being in use. + proc set_last_run_display {chunklist} { + #chunklist as understood by the + if {![info exists ::punk::repltelemetry_emmitters]} { + namespace eval ::punk { + variable repltelemetry_emmitters + set repltelemetry_emmitters "shellrun" + } + } else { + if {"shellrun" ni $::punk::repltelemetry_emmitters} { + lappend punk::repltelemetry_emmitters "shellrun" + } + } + + #most basic of validity tests here.. just that it is a list (can be empty). We don't want to duplicate or over-constrain the way repls/shells/terminals interpet the info + if {[catch {llength $chunklist} errMsg]} { + error "set_last_run_display expects a list. Value supplied doesn't appear to be a well formed tcl list. '$errMsg'" + } + #todo - + tsv::lappend repl runchunks-[tsv::get repl runid] {*}$chunklist + } + + + + #maintenance: similar used in punk::ns & punk::winrun + #todo - take runopts + aliases as args + #longopts must be passed as a single item ie --timeout=100 not --timeout 100 + proc get_run_opts {arglist} { + if {[catch { + set callerinfo [info level -1] + } errM]} { + set caller "" + } else { + set caller [lindex $callerinfo 0] + } + + #we provide -nonewline even for 'run' even though run doesn't deliver stderr or stdout to the tcl return value + #This is for compatibility with other runX commands, and the difference is also visible when calling from repl. + set known_runopts [list "-echo" "-e" "-nonewline" "-n" "-tcl" "-debug"] + set known_longopts [list "--timeout"] + set known_longopts_msg "" + foreach lng $known_longopts { + append known_longopts_msg "${lng}=val " + } + set aliases [list "-e" "-echo" "-echo" "-echo" "-n" "-nonewline" "-nonewline" "-nonewline" "-tcl" "-tcl" "-debug" "-debug"] ;#include map to self + set runopts [list] + set runoptslong [list] + set cmdargs [list] + + set idx_first_cmdarg [lsearch -not $arglist "-*"] + + set allopts [lrange $arglist 0 $idx_first_cmdarg-1] + set cmdargs [lrange $arglist $idx_first_cmdarg end] + foreach o $allopts { + if {[string match --* $o]} { + lassign [split $o =] flagpart valpart + if {$valpart eq ""} { + error "$caller: longopt $o seems to be missing a value - must be of form --option=value" + } + if {$flagpart ni $known_longopts} { + error "$caller: Unknown runoption $o - known options $known_runopts $known_longopts_msg" + } + lappend runoptslong $flagpart $valpart + } else { + if {$o ni $known_runopts} { + error "$caller: Unknown runoption $o - known options $known_runopts $known_longopts_msg" + } + lappend runopts [dict get $aliases $o] + } + } + return [list runopts $runopts runoptslong $runoptslong cmdargs $cmdargs] + } + + + #todo - investigate cause of punk86 run hanging sometimes. An 'after 500' before exit in the called script fixes the issue. punk87 doesn't seem to be affected. + lappend PUNKARGS [list { + @id -id ::shellrun::run + @leaders -min 0 -max 0 + @opts + -nonewline -type none + -tcl -type none -default 0 + -debug -type none -default 0 + --timeout= -type integer + @values -min 1 -max -1 + cmdname -type string + cmdarg -type any -multiple 1 -optional 1 + }] + proc run {args} { + #set_last_run_display [list] + + #set splitargs [get_run_opts $args] + #set runopts [dict get $splitargs runopts] + #set runoptslong [dict get $splitargs runoptslong] + #set cmdargs [dict get $splitargs cmdargs] + set argd [punk::args::parse $args withid ::shellrun::run] + lassign [dict values $argd] leaders opts values received + + if {[dict exists $received "-nonewline"]} { + set nonewline 1 + } else { + set nonewline 0 + } + #review nonewline does nothing here.. + + set idlist_stderr [list] + #we leave stdout without imposed ansi colouring - because the source may be colourised and because ansi-wrapping a stream at whatever boundaries it comes in at isn't a really nice thing to do. + #stderr might have source colouring - but it usually doesn't seem to, and the visual distiction of red stderr can be very handy for the run command. + #A further enhancement could be to detect well-known options such as --color and/or use a configuration for specific commands that have useful colourised stderr, + #but having an option to configure stderr to red is a compromise. + #Note that the other run commands, runout,runerr, runx don't emit in real-time - so for those commands there may be options to detect and/or post-process stdout and stderr. + #TODO - fix. This has no effect if/when the repl adds an ansiwrap transform + # what we probably want to do is 'aside' that transform for runxxx commands only. + #lappend idlist_stderr [shellfilter::stack::add stderr ansiwrap -settings {-colour {red bold}}] + + set callopts [dict create] + if {[dict exists $received "-tcl"]} { + dict set callopts -tclscript 1 + } + if {[dict exists $received "-debug"]} { + dict set callopts -debug 1 + } + if {[dict exists $received --timeout]} { + dict set callopts -timeout [dict get $opts --timeout] ;#convert to single dash + } + set cmdname [dict get $values cmdname] + if {[dict exists $received cmdarg]} { + set cmdarglist [dict get $values cmdarg] + } else { + set cmdarglist {} + } + set cmdargs [concat $cmdname $cmdarglist] + #--------------------------------------------------------------------------------------------- + set exitinfo [shellfilter::run $cmdargs {*}$callopts -teehandle punksh -inbuffering none -outbuffering none ] + #--------------------------------------------------------------------------------------------- + foreach id $idlist_stderr { + shellfilter::stack::remove stderr $id + } + #puts stderr "shellrun::run exitinfo: $exitinfo" + + flush stderr + flush stdout + + if {[dict exists $exitinfo error]} { + error "[dict get $exitinfo error]\n$exitinfo" + } + + return $exitinfo + } + + lappend PUNKARGS [list { + @id -id ::shellrun::runconsole + @leaders -min 0 -max 0 + @opts + @values -min 1 -max -1 + cmdname -type string + cmdarg -type any -multiple 1 -optional 1 + }] + #run in the way tcl unknown does - but without regard to auto_noexec + proc runconsole {args} { + set argd [punk::args::parse $args withid ::shellrun::runconsole] + lassign [dict values $argd] leaders opts values received + set cmdname [dict get $values cmdname] + if {[dict exists $received cmdarg]} { + set arglist [dict get $values cmdarg] + } else { + set arglist {} + } + + set resolved_cmdname [auto_execok $cmdname] + if {$resolved_cmdname eq ""} { + error "Cannot find path for executable '$cmdname'" + } + set repl_runid [punk::get_repl_runid] + #set ::punk::last_run_display [list] + + set redir ">&@stdout <@stdin" + uplevel 1 [list ::catch [concat exec $redir $resolved_cmdname $arglist] ::tcl::UnknownResult ::tcl::UnknownOptions] + #we can't detect stdout/stderr output from the exec + #for now emit an extra \n on stderr + #todo - there is probably no way around this but to somehow exec in the context of a completely separate console + #This is probably a tricky problem - especially to do cross-platform + # + # - use [dict get $::tcl::UnknownOptions -code] (0|1) exit + if {[dict get $::tcl::UnknownOptions -code] == 0} { + set c green + set m "ok" + } else { + set c yellow + set m "errorCode $::errorCode" + } + set chunklist [list] + lappend chunklist [list "info" "[a $c]$m[a] " ] + if {$repl_runid != 0} { + tsv::lappend repl runchunks-$repl_runid {*}$chunklist + } + + dict incr ::tcl::UnknownOptions -level + return -options $::tcl::UnknownOptions $::tcl::UnknownResult + } + lappend PUNKARGS [list { + @id -id ::shellrun::runout + @leaders -min 0 -max 0 + @opts + -echo -type none + -nonewline -type none + -tcl -type none -default 0 + -debug -type none -default 0 + --timeout= -type integer + @values -min 1 -max -1 + cmdname -type string + cmdarg -type any -multiple 1 -optional 1 + }] + proc runout {args} { + set argd [punk::args::parse $args withid ::shellrun::runout] + lassign [dict values $argd] leaders opts values received + + if {[dict exists $received "-nonewline"]} { + set nonewline 1 + } else { + set nonewline 0 + } + + #set_last_run_display [list] + variable runout + variable runerr + set runout "" + set runerr "" + set RST [a] + + #set splitargs [get_run_opts $args] + #set runopts [dict get $splitargs runopts] + #set cmdargs [dict get $splitargs cmdargs] + + + #puts stdout "RUNOUT cmdargs: $cmdargs" + + #todo add -data boolean and -data lastwrite to -settings with default being -data all + # because sometimes we're only interested in last char (e.g to detect something was output) + + #set outvar_stackid [shellfilter::stack::add commandout tee_to_var -action float -settings {-varname ::runout}] + # + #when not echoing - use float-locked so that the repl's stack is bypassed + if {[dict exists $received "-echo"]} { + set stdout_stackid [shellfilter::stack::add stdout tee_to_var -action float-locked -settings {-varname ::shellrun::runout}] + set stderr_stackid [shellfilter::stack::add stderr tee_to_var -action float-locked -settings {-varname ::shellrun::runerr}] + #set stderr_stackid [shellfilter::stack::add stderr tee_to_var -action sink-locked -settings {-varname ::shellrun::runerr}] + } else { + set stdout_stackid [shellfilter::stack::add stdout var -action float-locked -settings {-varname ::shellrun::runout}] + set stderr_stackid [shellfilter::stack::add stderr var -action float-locked -settings {-varname ::shellrun::runerr}] + } + + set callopts [dict create] + if {[dict exists $received "-tcl"]} { + dict set callopts -tclscript 1 + } + if {[dict exists $received "-debug"]} { + dict set callopts -debug 1 + } + if {[dict exists $received --timeout]} { + dict set callopts -timeout [dict get $opts --timeout] ;#convert to single dash + } + set cmdname [dict get $values cmdname] + if {[dict exists $received cmdarg]} { + set cmdarglist [dict get $values cmdarg] + } else { + set cmdarglist {} + } + set cmdargs [concat $cmdname $cmdarglist] + + #shellfilter::run [lrange $args 1 end] -teehandle punksh -outchan stdout -inbuffering none -outbuffering none -stdinhandler ::repl::repl_handler + set exitinfo [shellfilter::run $cmdargs {*}$callopts -teehandle punksh -inbuffering none -outbuffering none ] + + flush stderr + flush stdout + + shellfilter::stack::remove stdout $stdout_stackid + shellfilter::stack::remove stderr $stderr_stackid + + #shellfilter::stack::remove commandout $outvar_stackid + + if {[dict exists $exitinfo error]} { + if {[dict exists $received "-tcl"]} { + + } else { + #we must raise an error. + #todo - check errorInfo makes sense.. return -code? tailcall? + # + set msg "" + append msg [dict get $exitinfo error] + append msg "\n(add -tcl option to run as a tcl command/script instead of an external command)" + error $msg + } + } + + set chunklist [list] + + #exitcode not part of return value for runout - colourcode appropriately + set n $RST + set c "" + + if {[dict exists $exitinfo exitcode]} { + set code [dict get $exitinfo exitcode] + if {$code == 0} { + set c [a+ green] + } else { + set c [a+ white bold] + } + lappend chunklist [list "info" "$c$exitinfo$n"] + } elseif {[dict exists $exitinfo error]} { + # -tcl (with error) + set c [a+ yellow bold] + lappend chunklist [list "info" "${c}error [dict get $exitinfo error]$n"] + lappend chunklist [list "info" "errorCode [dict get $exitinfo errorCode]"] + #lappend chunklist [list "info" "errorInfo [list [dict get $exitinfo errorInfo]]"] + lappend chunklist [list "info" errorInfo] + lappend chunklist [list "stderr" [dict get $exitinfo errorInfo]] + } else { + # -tcl (without error) + set c [a+ Green white bold] + #lappend chunklist [list "info" "$c$exitinfo$n"] + lappend chunklist [list "info" [punk::ansi::ansiwrap_raw $c \x1b\[m "" $exitinfo]] + } + + + set chunk "[a+ red bold]stderr$RST" + lappend chunklist [list "info" $chunk] + + set chunk "" + if {[string length $::shellrun::runerr]} { + if {$nonewline} { + set e [string trimright $::shellrun::runerr \r\n] + } else { + set e $::shellrun::runerr + } + #append chunk "[a+ red normal]$e$RST\n" + append chunk "[a+ red normal]$e$RST" + } + lappend chunklist [list stderr $chunk] + + + + + lappend chunklist [list "info" "[a+ white bold]stdout$RST"] + set chunk "" + if {[string length $::shellrun::runout]} { + if {$nonewline} { + set o [string trimright $::shellrun::runout \r\n] + } else { + set o $::shellrun::runout + } + append chunk "$o" + } + lappend chunklist [list result $chunk] + + + #set_last_run_display $chunklist + tsv::lappend repl runchunks-[tsv::get repl runid] {*}$chunklist + + if {$nonewline} { + return [string trimright $::shellrun::runout \r\n] + } else { + return $::shellrun::runout + } + } + + lappend PUNKARGS [list { + @id -id ::shellrun::runerr + @leaders -min 0 -max 0 + @opts + -echo -type none + -nonewline -type none + -tcl -type none -default 0 + -debug -type none -default 0 + --timeout= -type integer + @values -min 1 -max -1 + cmdname -type string + cmdarg -type any -multiple 1 -optional 1 + }] + proc runerr {args} { + set argd [punk::args::parse $args withid ::shellrun::runerr] + lassign [dict values $argd] leaders opts values received + + if {[dict exists $received "-nonewline"]} { + set nonewline 1 + } else { + set nonewline 0 + } + + #set_last_run_display [list] + variable runout + variable runerr + set runout "" + set runerr "" + + #set splitargs [get_run_opts $args] + #set runopts [dict get $splitargs runopts] + #set cmdargs [dict get $splitargs cmdargs] + + set callopts [dict create] + if {[dict exists $received "-tcl"]} { + dict set callopts -tclscript 1 + } + if {[dict exists $received "-debug"]} { + dict set callopts -debug 1 + } + if {[dict exists $received --timeout]} { + dict set callopts -timeout [dict get $opts --timeout] ;#convert to single dash + } + set cmdname [dict get $values cmdname] + if {[dict exists $received cmdarg]} { + set cmdarglist [dict get $values cmdarg] + } else { + set cmdarglist {} + } + set cmdargs [concat $cmdname $cmdarglist] + + if {[dict exists $received "-tcl"]} { + append callopts " -tclscript 1" + } + if {[dict exists $received "-echo"]} { + set stderr_stackid [shellfilter::stack::add stderr tee_to_var -action float-locked -settings {-varname ::shellrun::runerr}] + set stdout_stackid [shellfilter::stack::add stdout tee_to_var -action float-locked -settings {-varname ::shellrun::runout}] + } else { + set stderr_stackid [shellfilter::stack::add stderr var -action float-locked -settings {-varname ::shellrun::runerr}] + set stdout_stackid [shellfilter::stack::add stdout var -action float-locked -settings {-varname ::shellrun::runout}] + } + + + set exitinfo [shellfilter::run $cmdargs {*}$callopts -teehandle punksh -inbuffering none -outbuffering none -stdinhandler ::repl::repl_handler] + shellfilter::stack::remove stderr $stderr_stackid + shellfilter::stack::remove stdout $stdout_stackid + + + flush stderr + flush stdout + + #we raise an error because an error during calling is different to collecting stderr from a command, and the caller should be able to wrap in a catch + # to determine something other than just a nonzero exit code or output on stderr. + if {[dict exists $exitinfo error]} { + if {[dict exists $received "-tcl"]} { + + } else { + #todo - check errorInfo makes sense.. return -code? tailcall? + error [dict get $exitinfo error] + } + } + + set chunklist [list] + + set n [a] + set c "" + if {[dict exists $exitinfo exitcode]} { + set code [dict get $exitinfo exitcode] + if {$code == 0} { + set c [a+ green] + } else { + set c [a+ white bold] + } + lappend chunklist [list "info" "$c$exitinfo$n"] + } elseif {[dict exists $exitinfo error]} { + # -tcl (with error) + set c [a+ yellow bold] + lappend chunklist [list "info" "error [dict get $exitinfo error]"] + lappend chunklist [list "info" "errorCode [dict get $exitinfo errorCode]"] + lappend chunklist [list "info" "errorInfo [list [dict get $exitinfo errorInfo]]"] + } else { + # -tcl (without error) + set c [a+ Green white bold] + #lappend chunklist [list "info" "$c$exitinfo$n"] + lappend chunklist [list "info" [punk::ansi::ansiwrap_raw $c "\x1b\[m" "" $exitinfo]] + } + + + lappend chunklist [list "info" "[a+ white bold]stdout[a]"] + set chunk "" + if {[string length $::shellrun::runout]} { + if {$nonewline} { + set o [string trimright $::shellrun::runout \r\n] + } else { + set o $::shellrun::runout + } + append chunk "[a+ white normal]$o[a]\n" ;#this newline is the display output separator - always there whether data has trailing newline or not. + } + lappend chunklist [list stdout $chunk] + + + #set c_stderr [punk::config] + set chunk "[a+ red bold]stderr[a]" + lappend chunklist [list "info" $chunk] + + set chunk "" + if {[string length $::shellrun::runerr]} { + if {$nonewline} { + set e [string trimright $::shellrun::runerr \r\n] + } else { + set e $::shellrun::runerr + } + append chunk "$e" + } + lappend chunklist [list resulterr $chunk] + + + #set_last_run_display $chunklist + tsv::lappend repl runchunks-[tsv::get repl runid] {*}$chunklist + + if {$nonewline} { + return [string trimright $::shellrun::runerr \r\n] + } + return $::shellrun::runerr + } + + + proc runx {args} { + #set_last_run_display [list] + variable runout + variable runerr + set runout "" + set runerr "" + + set splitargs [get_run_opts $args] + set runopts [dict get $splitargs runopts] + set cmdargs [dict get $splitargs cmdargs] + + if {"-nonewline" in $runopts} { + set nonewline 1 + } else { + set nonewline 0 + } + + #shellfilter::stack::remove stdout $::repl::id_outstack + + if {"-echo" in $runopts} { + #float to ensure repl transform doesn't interfere with the output data + set stderr_stackid [shellfilter::stack::add stderr tee_to_var -action float -settings {-varname ::shellrun::runerr}] + set stdout_stackid [shellfilter::stack::add stdout tee_to_var -action float -settings {-varname ::shellrun::runout}] + } else { + #set stderr_stackid [shellfilter::stack::add stderr var -action sink-locked -settings {-varname ::shellrun::runerr}] + #set stdout_stackid [shellfilter::stack::add stdout var -action sink-locked -settings {-varname ::shellrun::runout}] + + #float above the repl's tee_to_var to deliberately block it. + #a var transform is naturally a junction point because there is no flow-through.. + # - but mark it with -junction 1 just to be explicit + set stderr_stackid [shellfilter::stack::add stderr var -action float-locked -junction 1 -settings {-varname ::shellrun::runerr}] + set stdout_stackid [shellfilter::stack::add stdout var -action float-locked -junction 1 -settings {-varname ::shellrun::runout}] + } + + set callopts "" + if {"-tcl" in $runopts} { + append callopts " -tclscript 1" + } + #set exitinfo [shellfilter::run $cmdargs -teehandle punksh -inbuffering none -outbuffering none -stdinhandler ::repl::repl_handler] + set exitinfo [shellfilter::run $cmdargs {*}$callopts -teehandle punksh -inbuffering none -outbuffering none] + + shellfilter::stack::remove stdout $stdout_stackid + shellfilter::stack::remove stderr $stderr_stackid + + + flush stderr + flush stdout + + if {[dict exists $exitinfo error]} { + if {"-tcl" in $runopts} { + + } else { + #todo - check errorInfo makes sense.. return -code? tailcall? + error [dict get $exitinfo error] + } + } + + #set x [shellfilter::stack::add stdout var -action sink-locked -settings {-varname ::repl::runxoutput}] + + set chunk "" + if {[string length $::shellrun::runout]} { + if {$nonewline} { + set o [string trimright $::shellrun::runout \r\n] + } else { + set o $::shellrun::runout + } + set chunk $o + } + set chunklist [list] + lappend chunklist [list "info" " "] + lappend chunklist [list "result" stdout] ;#key 'stdout' forms part of the resulting dictionary output + lappend chunklist [list "info" "[a+ white bold]stdout[a]"] + lappend chunklist [list result $chunk] ;#value corresponding to 'stdout' key in resulting dict + + + lappend chunklist [list "info" " "] + set chunk "[a+ red bold]stderr[a]" + lappend chunklist [list "result" $chunk] + lappend chunklist [list "info" stderr] + + set chunk "" + if {[string length $::shellrun::runerr]} { + if {$nonewline} { + set e [string trimright $::shellrun::runerr \r\n] + } else { + set e $::shellrun::runerr + } + set chunk $e + } + #stderr is part of the result + lappend chunklist [list "resulterr" $chunk] + + + + set n [a] + set c "" + if {[dict exists $exitinfo exitcode]} { + set code [dict get $exitinfo exitcode] + if {$code == 0} { + set c [a+ green] + } else { + set c [a+ yellow bold] + } + lappend chunklist [list "info" " "] + lappend chunklist [list "result" exitcode] + lappend chunklist [list "info" "exitcode $code"] + lappend chunklist [list "result" "$c$code$n"] + set exitdict [list exitcode $code] + } elseif {[dict exists $exitinfo result]} { + # presumably from a -tcl call + set val [dict get $exitinfo result] + lappend chunklist [list "info" " "] + lappend chunklist [list "result" result] + lappend chunklist [list "info" result] + lappend chunklist [list "result" $val] + set exitdict [list result $val] + } elseif {[dict exists $exitinfo error]} { + # -tcl call with error + #set exitdict [dict create] + lappend chunklist [list "info" " "] + lappend chunklist [list "result" error] + lappend chunklist [list "info" error] + lappend chunklist [list "result" [dict get $exitinfo error]] + + lappend chunklist [list "info" " "] + lappend chunklist [list "result" errorCode] + lappend chunklist [list "info" errorCode] + lappend chunklist [list "result" [dict get $exitinfo errorCode]] + + lappend chunklist [list "info" " "] + lappend chunklist [list "result" errorInfo] + lappend chunklist [list "info" errorInfo] + lappend chunklist [list "result" [dict get $exitinfo errorInfo]] + + set exitdict $exitinfo + } else { + #review - if no exitcode or result. then what is it? + lappend chunklist [list "info" exitinfo] + set c [a+ yellow bold] + lappend chunklist [list result "$c$exitinfo$n"] + set exitdict [list exitinfo $exitinfo] + } + + #set_last_run_display $chunklist + tsv::lappend repl runchunks-[tsv::get repl runid] {*}$chunklist + + #set ::repl::result_print 0 + #return [lindex [list [list stdout $::runout stderr $::runerr {*}$exitinfo] [shellfilter::stack::remove stdout $x][puts -nonewline stdout $pretty][set ::repl::output ""]] 0] + + + if {$nonewline} { + return [list {*}$exitdict stdout [string trimright $::shellrun::runout \r\n] stderr [string trimright $::shellrun::runerr \r\n]] + } + #always return exitinfo $code at beginning of dict (so that punk unknown can interpret the exit code as a unix-style bool if double evaluated) + return [list {*}$exitdict stdout $::shellrun::runout stderr $::shellrun::runerr] + } + + #an experiment + # + #run as raw string instead of tcl-list - no variable subst etc + # + #dummy repl_runraw that repl will intercept + proc repl_runraw {args} { + error "runraw: only available in repl as direct call - not from script" + } + #we can only call runraw with a single (presumably braced) string if we want to use it from both repl and tcl scripts (why? todo with unbalanced quotes/braces?) + proc runraw {commandline} { + #runraw fails as intended - because we can't bypass exec/open interference quoting :/ + #set_last_run_display [list] + variable runout + variable runerr + set runout "" + set runerr "" + + #return [shellfilter::run [lrange $args 1 end] -teehandle punksh -inbuffering none -outbuffering none -stdinhandler ::repl::repl_handler] + puts stdout ">>runraw got: $commandline" + + #run always echoes anyway.. as we aren't diverting stdout/stderr off for capturing + #for consistency with other runxxx commands - we'll just consume it. (review) + + set reallyraw 1 + if {$reallyraw} { + set wordparts [regexp -inline -all {\S+} $commandline] + set runwords $wordparts + } else { + #shell style args parsing not suitable for windows where we can't assume matched quotes etc. + package require string::token::shell + set parts [string token shell -indices -- $commandline] + puts stdout ">>shellparts: $parts" + set runwords [list] + foreach p $parts { + set ptype [lindex $p 0] + set pval [lindex $p 3] + if {$ptype eq "PLAIN"} { + lappend runwords [lindex $p 3] + } elseif {$ptype eq "D:QUOTED"} { + set v {"} + append v $pval + append v {"} + lappend runwords $v + } elseif {$ptype eq "S:QUOTED"} { + set v {'} + append v $pval + append v {'} + lappend runwords $v + } + } + } + + puts stdout ">>runraw runwords: $runwords" + set runwords [lrange $runwords 1 end] + + puts stdout ">>runraw runwords: $runwords" + #set args [lrange $args 1 end] + #set runwords [lrange $wordparts 1 end] + + set known_runopts [list "-echo" "-e" "-terminal" "-t"] + set aliases [list "-e" "-echo" "-echo" "-echo" "-t" "-terminal" "-terminal" "-terminal"] ;#include map to self + set runopts [list] + set cmdwords [list] + set idx_first_cmdarg [lsearch -not $runwords "-*"] + set runopts [lrange $runwords 0 $idx_first_cmdarg-1] + set cmdwords [lrange $runwords $idx_first_cmdarg end] + + foreach o $runopts { + if {$o ni $known_runopts} { + error "runraw: Unknown runoption $o" + } + } + set runopts [lmap o $runopts {dict get $aliases $o}] + + set cmd_as_string [join $cmdwords " "] + puts stdout ">>cmd_as_string: $cmd_as_string" + + if {"-terminal" in $runopts} { + #fake terminal using 'script' command. + #not ideal: smushes stdout & stderr together amongst other problems + set tcmd [shellfilter::get_scriptrun_from_cmdlist_dquote_if_not $cmdwords] + puts stdout ">>tcmd: $tcmd" + set exitinfo [shellfilter::run $tcmd -teehandle punksh -inbuffering line -outbuffering none ] + set exitinfo "exitcode not-implemented" + } else { + set exitinfo [shellfilter::run $cmdwords -teehandle punksh -inbuffering line -outbuffering none ] + } + + if {[dict exists $exitinfo error]} { + #todo - check errorInfo makes sense.. return -code? tailcall? + error [dict get $exitinfo error] + } + set code [dict get $exitinfo exitcode] + if {$code == 0} { + set c [a+ green] + } else { + set c [a+ white bold] + } + puts stderr $c + return $exitinfo + } + + proc sh_run {args} { + set splitargs [get_run_opts $args] + set runopts [dict get $splitargs runopts] + set cmdargs [dict get $splitargs cmdargs] + #e.g sh -c "ls -l *" + #we pass cmdargs to sh -c as a list, not individually + tailcall shellrun::run {*}$runopts sh -c $cmdargs + } + proc sh_runout {args} { + set splitargs [get_run_opts $args] + set runopts [dict get $splitargs runopts] + set cmdargs [dict get $splitargs cmdargs] + tailcall shellrun::runout {*}$runopts sh -c $cmdargs + } + proc sh_runerr {args} { + set splitargs [get_run_opts $args] + set runopts [dict get $splitargs runopts] + set cmdargs [dict get $splitargs cmdargs] + tailcall shellrun::runerr {*}$runopts sh -c $cmdargs + } + proc sh_runx {args} { + set splitargs [get_run_opts $args] + set runopts [dict get $splitargs runopts] + set cmdargs [dict get $splitargs cmdargs] + tailcall shellrun::runx {*}$runopts sh -c $cmdargs + } +} + +namespace eval shellrun { + interp alias {} run {} shellrun::run + interp alias {} sh_run {} shellrun::sh_run + interp alias {} runout {} shellrun::runout + interp alias {} sh_runout {} shellrun::sh_runout + interp alias {} runerr {} shellrun::runerr + interp alias {} sh_runerr {} shellrun::sh_runerr + interp alias {} runx {} shellrun::runx + interp alias {} sh_runx {} shellrun::sh_runx + + interp alias {} runc {} shellrun::runconsole + interp alias {} runraw {} shellrun::runraw + + + #the shortened versions deliberately don't get pretty output from the repl + interp alias {} r {} shellrun::run + interp alias {} ro {} shellrun::runout + interp alias {} re {} shellrun::runerr + interp alias {} rx {} shellrun::runx + + +} + +namespace eval shellrun { + proc test_cffi {} { + package require test_cffi + cffi::Wrapper create ::shellrun::kernel32 [file join $env(windir) system32 Kernel32.dll] + ::shellrun::kernel32 stdcall CreateProcessA + #todo - stuff. + return ::shellrun::kernel32 + } + +} +namespace eval ::punk::args::register { + #use fully qualified so 8.6 doesn't find existing var in global namespace + lappend ::punk::args::register::NAMESPACES ::shellrun +} + + +package provide shellrun [namespace eval shellrun { + variable version + set version 0.1.2 +}] diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/zipper-0.14.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/zipper-0.14.tm index 7f7817f1ddce7fa6abfdea66e3c84636d1fe44cd..f1e5eeaed33aed457f26c1fe55bdad783c7406eb 100644 GIT binary patch delta 2479 zcmV;g2~hUNO~_5K6&ew1hr(P@d(l3$2><}W9RL6#lRPFRlS>*{e>jN!xiSksP^6ZA zM4$9xp;B5O5U$$0`$dvwq+^|FKhmER`C+KyEPdb)p-w?MmKO)xJDKXz5#(#>r`jJw zj!D>lHujBbKh2Ur9&Rl0Lp`CDstYq#lO$ENO7SF~k{>^0Gyaez;6go0@>EEZHk8ej z#i8VNh!t8f$*Ib)Q<;u+oT(K0&>~g-93mW-j5WYhe)yP|Ge1S4pZSiHlcSRCaf`Ld zd;pnD?MlQ`QWi@M(}%eNX7Qd;>B6ky#dN$;?CoM&W`xne_7lZ6{2f89lgv2*+rMzC5I9Z@%%>+#e?QnB%1rdVIE&LqolRxW*`3a;ux^_l{+z?fLi><8 zT5pc@owaN4ue6%!UF+8RLrS}apJthPA?)Zf9@DDC{uYI z6gm@FgcZAUJ(sK};ii_ZnE3MLO9Z!9OIYry#L_TRQN(XY+pm$gXuT<)9tJZ6D$?&n zPjdk4ac;^|KQ@t{v0!85P-N7eis8Y6Tc z7^xR0v06ns26?BpX>AS@f0Jq0XKfS|oX#`qZ?-X;&@hOS;ErQx?q?u_wLN#UKKe*U zb2%G0Yf4byP-kVL+nxb#9 z&zoIc4F-0{-0kRk=IgHqC!4zTS)Rr;j5M6q6UH8s8MW{%Yw22&B`geAg)!E7tncT- zy3+x`&=VE4i8VZX?N#g4FLtR2T|IWTfDMv3G$X1xW#k*9r;xL-suguGvRKKZzZ`zJ zevJ~tNg5K5Q3@V7e_PJE+8GWj4ttv+!C?vM*&pkP75x23h`oGLGH>&)MDEuFXnI!U zPpRLu&cgy5ASUV1&Ad)mP;19=+Pne>-sYi{M@`#kTg(S$k=Wj$xAp1Ir13fAhs08P;&F3$F%0~SBZ@vndQ3qYJUy>urVT%7OP&TbyKG2BMhPS$;Hy{g-0dAwQHH|9 zNwmu{BG5K|ymdrZzYo}wVWEND-+sT_SA2> z#6F!$keu31e`1Ed18qn*Ma-rlEEz<(Bz1XfO=-(3G^$z!3iCyz16vT#&k4ff1}VH? zf$(Peg{|dD#_WDO)4zd9Fa$e^T-xSL7%3T@7Cb4)DC@1dL_` zM;XN@qX)8QB-Ghz_q!i&1~=yftorx;^ZwvseA%xj(gk-tMd9xZT{(6&&p!{I8C+Ux zV=lC&cR$j4K<9McN3P&MaM;t$x`vEIktg}i#*kM_&>n}ISI-vsCt0d??IO5le!^~W z{+t@1e~l!gb*dfXTqEVPHMi{Nl0AGnOyXm1?BJpqal_cGx5=$EUT6kyS$Lc?<_j7$ zLi>@obJceIegS-&cvP8+{t(K0i8hh;_IvO)?lyPs$X`Gy^-Hv`4`1+a$cU`s4a3LG~*IWXD2MM&Fa6dBWke$kbglSWo`;_WI;EE!(4O ze^Krgy};)S{J-4gCfgy`iWU=S`fyE`aL}sjY8E*caMn6ro9GT%cYExv-br4J{^tlc zPxpj4{Yg>&>x4@+*Pj#dc3WpxxA1Fav08QdlkFI!qJ3{OGpf|n8}hH$ zFu+fOL!J)B3AuTw*Zj)$pGsS-#qCw+jZIAI5pWL;@$((p7YWdKCbk4oC*4$ec@`FFMjDGPF z+Ag0v8b;-L)Kd~&`o8U=8D-W!>BN*HPfgy>$opo!E3ENfA=*f zZ4RKe<$(ErOA7HV+g5wE9X&n_ReIE0YaCEgk~Kx+y~Q?lsn4>mXjiDzT6P3Ss+L-< zDhA*F{q-B-(DS(~=QMYD^US8XXZ_1YFTTec&aF3CU$~@a8}Tns5O;rBZ*NQ1ehnKp z)UlX3>jPjpp-RJ`?zKV7u(+FMe<+e883MQ)>k%?$>%# zoog1!JM!~5nDJQE4t?i7PA;~2YfIp#(`8@y7dc`sM|%4WPw$k5(#~hTh6~uma%8si z*Yp1Q1*|P6b2puzs#u}M*~t$d3^E;`*?E64ELix#oj+AT>6aV_DZAbIf1l<1@?~w* zI!qRl7ltcEju|ovp%+(v9#+dFnGy`=PcWS7V<_kD))9xJ#cHJQ$L<6 zw_-r>?{gmrsFz9Tu_|>D;-dja}D%TLI+8x$vk{twMrR0p+oL zU$ZP%SUPruqau}+dpQRb;e$%D@6aWAKlLjOd0SA+gCL#y_ t{{sL30Rpo_B-#NDYlp&IQG3xova$!P!p delta 2469 zcmV;W30n5ZO~y^I6&exR2)tY<;pJen2><}V9RL6#lRhRTlS>*{e^~gzoj+ByNRy=w z6@Ai+g-WS^Hn=!Ai2b=TSfNNQ{it}iJ|JARclV1V%}B>O(|)8sDe}Wm#aa5mA3~ji zZ7eSiws$hsr6b7K(oeNNhK!T2{cP+T)qa{Kfjrz;;)i-dD^(X}tR_jSXqDngJS9JV z$Y%T@OTdMCl;o+9Vd->o`*>^Z{hbpF@P>lCcJ`$`2p& za^|Nf^fTXaa&lCXJ#Mi!nGYb7iQM>UFw;xbV-jb3WKs9KW%*WvLP{(DfdZ^sCFvdZ zj`NI6G8ZFLlXV*-f4fnjjMb(koYUfmiV(X3&3wE5jK$(jvC&Bkd6_)8&yqZ1_$W@= zG%d+4Yh!2*eJ4p2B`fkN)RPJJ#~B_Dg`Sir;e+Sz`nTfs^XL0(dv#IPk zyVIE!)@}2{pK~}_Xdg01>&=nAvv%$Ml~ywy%mBunvcMKtQR%vnh+km6(-+ia8ZA zPMnw6=|#lFe;p$RWh$?OLT3Vtuwr+v=aTg#+|<$)6JNf3iQx8X3Clf|SQ=(3iumnl z`!(_wtvBVFE82dQ8W|p9;oQO-(+go)3K2)bHMeCmU#u z&o_e&P0DqgbbW-w`XjxiH-xw#BMZlPe%BBSE)0ty9iql{yWYp%;KlR)$<@`16Z#Kz zy|-6af0z8pd$Va;Q}iwNd9$ml!NBgAyB%H6eEs#{WK)+u%hQ;Kk%rTH!q{UnqZXcJ zEnQ2pgoWX%FvdEM_5EB}cRBzVdZMB>v4&@_y=tBM#V!@0tH;h3ut5@sW<)iojC^DC z6mk|;wW1D27Atx5m%|U&uTf$+Nkif>O2GqXf6F;nJHuhcVQ(`eI4mJO`(r(^g1;XL zv6oLu=55}U$o-lCP0xz_DfOGyd01cr#6%r~NXJD6U^xMB zf4-O_!y3+&oWCEF&W;U*3NU6hq&7`8hJl}PMA4^6k10rlr{|T-wBaXh$v^x-oUs|rNRTA-YqgsMP+8`IJ z@f%l)xoP6tHpd#niZ1nf_}Tf}@D;)4mPy>EiVNOS-8zmgFS|l4Wotw|&lTuee@Z^& ziu{DWtKrMQ0iM^KfYFTLD5Ln)^g#CfggRU8e)r?e;O3lwRsX(!-XC0yFZ=aGy5O#- zDEytFE61+p`RBnigG*~|%!StU?nhb==$y{`$QAqt4tu&;*N~AY@+9Bc81iZf+T(EZ z>e&MSBumwO zHo29?3(epy3y*Wgd_jXoXg~6HuG)^@FMw|ok1A8qA3}LA(I(Q~eh=Qp-R906`3oqe zJ}P|U#bF~>N=rAdfBI3b%DeZhh`Zh>6Qp{f1VKHyHcqXv^eAG2Zs)^w=VZ4y*LC5WG?R=&m@}SOs-!QJcT@Wgb~okY zZyvIew2mj}Tr`RWa`1#t!N_=GLl*;&_6XR0n}pX^e_TH$$bN-@>{v+3=zB6WPdJ&f5VUZ4D?WqWijf6Be07x;XE|ChVmWIN7Ed$KPk$8op7n<`g0=QZtLvo7JjWPR;x~bvK@m|wC`37BJMpf?Kv-f;p0kw z$C;r2`6rU9EkF2E%jg#`q3!ayvr+lKaM`+V7GrQ)x6eAaGGx6)1Km`nX|9;9GK>m? zS~HDWvyS`X6};BUe{)}R(&hkaTMn52x1RubP42!#Ie}*DCk|BV*u^u5~woaT7 zKa#n1hbbIZ_cT^K-cIw_*tuqrydyu4gBg!i?a+7b#s;u?dzL?kir;lxHasgKn|=Il)ISq|?!8wAHMO zIb@MG^3R*J1`@Rq=lb6_XHV>Gvp(2t_L{J6k7%5iTCT%F_9C4-*R-+g+HWg> z+&C8=b*fcJa4MiYmhWqpZ $pkgname $cond] { if {![catch {package require } returnver]} { - tsv::set zzzload_pkg $returnver + tsv::set zzzload_pkg $returnver } else { tsv::set zzzload_pkg "failed" } @@ -85,7 +88,7 @@ namespace eval zzzload { } } proc pkg_wait {pkgname} { - if {[set ver [package provide twapi]] ne ""} { + if {[set ver [package provide $pkgname]] ne ""} { return $ver } @@ -116,22 +119,10 @@ namespace eval zzzload { } - - - - - - - - - - - - # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready +## Ready package provide zzzload [namespace eval zzzload { variable version - set version 0.1.0 + set version 0.1.0 }] return \ No newline at end of file diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/make.tcl b/src/project_layouts/custom/_project/punk.project-0.1/src/make.tcl index 25ba66ae..917cd4d7 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/make.tcl +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/make.tcl @@ -2093,12 +2093,16 @@ if {$::punkboot::command in {project packages modules}} { #install .tm *and other files* puts stdout "VENDORMODULES$which: copying from $sourcefolder/$vf to $target_module_folder (if source file changed)" - set resultdict [punkcheck::install $sourcefolder/$vf $target_module_folder\ - -installer make.tcl\ - -overwrite installedsourcechanged-targets\ - -antiglob_paths {README.md AGENTS.md **/AGENTS.md include_modules.config}\ - -progresschannel stdout\ - ] + set resultdict [punkcheck::install $sourcefolder/$vf $target_module_folder {*}{ + -installer make.tcl + -overwrite installedsourcechanged-targets + -progresschannel stdout + -exclude-filetails {AGENTS.md include_modules.config} + -antiglob_paths {README.md} + }] + # -antiglob_paths {README.md AGENTS.md **/AGENTS.md include_modules.config} + #-exclude-filetails {AGENTS.md include_modules.config} + #-antiglob_paths {README.md} puts stdout [punkcheck::summarize_install_resultdict $resultdict] } if {![llength $vendormodulefolders]} { diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/fauxlink-0.1.1.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/fauxlink-0.1.1.tm index 970e47da..2fc9c5fb 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/fauxlink-0.1.1.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/fauxlink-0.1.1.tm @@ -205,7 +205,7 @@ namespace eval fauxlink { # %2F "/" # %2f "/" # %7f (del) - #we exlude the forward slash because we already have + for that - and multiple ways to specify it obscure intention. + #we exclude the forward slash because we already have + for that - and multiple ways to specify it obscure intention. # set decode_map [dict merge $decode_map [dict create\ %09 \t\ diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/funcl-0.1.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/funcl-0.1.tm index e8430fb0..f36a1f64 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/funcl-0.1.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/funcl-0.1.tm @@ -1,3 +1,6 @@ + +#experimental. + package provide funcl [namespace eval funcl { variable version set version 0.1 @@ -210,7 +213,7 @@ namespace eval funcl { } append body [join [lreverse $tails] " "] #puts stdout "tails: $tails" - + return $body } @@ -225,7 +228,7 @@ namespace eval funcl { # _fn 0 indicates next item is an unwrapped commandlist (terminal command) # #o_of is equivalent to o_of_n 1 (1 argument o combinator) - #last n args are passed to the prior function + #last n args are passed to the prior function #e.g for n=1 f a b = f(a(b)) #e.g for n=2, e f a b = e(f(a b)) proc o_of_n {n args} { @@ -235,7 +238,7 @@ namespace eval funcl { } set comp [list] ;#composition list set end [lindex $args end] - if {[lindex $end 0] in {_fn _call}]} { + if {[lindex $end 0] in {_fn _call}} { #is_funcl set endfunc [lindex $args end] } else { @@ -246,7 +249,7 @@ namespace eval funcl { set endfunc [list _call 1 3 [list {*}$end]] } } - + if {[llength $args] == 1} { return $endfunc } diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/metaface-1.2.9.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/metaface-1.2.9.tm new file mode 100644 index 00000000..aabb5435 --- /dev/null +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/metaface-1.2.9.tm @@ -0,0 +1,6364 @@ +package provide metaface [namespace eval metaface { + variable version + set version 1.2.9 +}] + +# 2025-09-29 - update outdated 'trace vinfo' to 'trace info variable' - both work for 8.6, but vinfo deprecated for tcl 9+ +# 2023-07 - add .. MetaMethods + + +#example datastructure: +#$_ID_ +#{ +#i +# { +# this +# { +# {16 ::p::16 item ::>x {}} +# } +# role2 +# { +# {17 ::p::17 item ::>y {}} +# {18 ::p::18 item ::>z {}} +# } +# } +#context {} +#} + +#$MAP +#invocantdata {16 ::p::16 item ::>x {}} +#interfaces {level0 +# { +# api0 {stack {123 999}} +# api1 {stack {333}} +# } +# level0_default api0 +# level1 +# { +# } +# level1_default {} +# } +#patterndata {patterndefaultmethod {}} + + +namespace eval ::p::predator {} +#temporary alternative to ::p::internals namespace. +# - place predator functions here until ready to replace internals. + + +namespace eval ::p::snap { + variable id 0 ;#ever-increasing non-reused snapshot-id to identify ::p::snapshot namespaces used to allow overlay-rollbacks. +} + + + + +# not called directly. Retrieved using 'info body ::p::predator::getprop_template' +#review - why use a proc instead of storing it as a string? +proc ::p::predator::getprop_template {_ID_ args} { + set OID [lindex [dict get $_ID_ i this] 0 0] + if {"%varspace%" eq ""} { + set ns ::p::${OID} + } else { + if {[string match "::*" "%varspace%"]} { + set ns "%varspace%" + } else { + set ns ::p::${OID}::%varspace% + } + } + + + if {[llength $args]} { + #lassign [lindex $invocant 0] OID alias itemCmd cmd + if {[array exists ${ns}::o_%prop%]} { + #return [set ${ns}::o_%prop%($args)] + if {[llength $args] == 1} { + return [set ::p::${OID}::o_%prop%([lindex $args 0])] + } else { + return [lindex [set ::p::${OID}::o_%prop%([lindex $args 0])] {*}[lrange $args 1 end]] + } + } else { + set val [set ${ns}::o_%prop%] + + set rType [expr {[scan [namespace tail $val] >%s rType] ? {object} : {unknown}}] + if {$rType eq "object"} { + #return [$val . item {*}$args] + return [$val {*}$args] + } else { + #treat as list? + return [lindex $val $args] + } + } + } else { + return [set ${ns}::o_%prop%] + } +} + + +proc ::p::predator::getprop_template_immediate {_ID_ args} { + if {[llength $args]} { + if {[array exists %ns%::o_%prop%]} { + return [set %ns%::o_%prop%($args)] + } else { + set val [set %ns%::o_%prop%] + set rType [expr {[scan [namespace tail $val] >%s rType] ? {object} : {unknown}}] + if {$rType eq "object"} { + #return [$val . item {*}$args] + #don't assume defaultmethod named 'item'! + return [$val {*}$args] + } else { + #treat as list? + return [lindex $val $args] + } + } + } else { + return [set %ns%::o_%prop%] + } +} + + + + + + + + +proc ::p::predator::getprop_array {_ID_ prop args} { + set OID [lindex [dict get $_ID_ i this] 0 0] + + #upvar 0 ::p::${OID}::o_${prop} prop + #1st try: assume array + if {[catch {array get ::p::${OID}::o_${prop}} result]} { + #treat as list (why?) + #!review + if {[info exists ::p::${OID}::o_${prop}]} { + array set temp [::list] + set i 0 + foreach element ::p::${OID}::o_${prop} { + set temp($i) $element + incr i + } + set result [array get temp] + } else { + error "unable to retrieve [set ::p::${OID}::o_${prop}] contents in 'array get' format" + } + } + return $result +} + +proc ::p::predator::setprop_template {prop _ID_ args} { + set OID [lindex [dict get $_ID_ i this] 0 0] + if {"%varspace%" eq ""} { + set ns ::p::${OID} + } else { + if {[string match "::*" "%varspace%"]} { + set ns "%varspace%" + } else { + set ns ::p::${OID}::%varspace% + } + } + + + if {[llength $args] == 1} { + #return [set ::p::${OID}::o_%prop% [lindex $args 0]] + return [set ${ns}::o_%prop% [lindex $args 0]] + + } else { + if {[array exists ${ns}::o_%prop%] || ![info exists ${ns}::o_%prop%]} { + #treat attempt to perform indexed write to nonexistant var, same as indexed write to array + + #2 args - single index followed by a value + if {[llength $args] == 2} { + return [set ${ns}::o_%prop%([lindex $args 0]) [lindex $args 1]] + } else { + #multiple indices + #return [set ::p::${OID}::o_%prop%([lrange $args 0 end-1]) [lindex $args end]] + return [lset ${ns}::o_%prop%([lindex $args 0]) {*}[lrange $args 1 end-1] [lindex $args end] ] + } + } else { + #treat as list + return [lset ${ns}::o_%prop% [lrange $args 0 end-1] [lindex $args end]] + } + } +} + +#-------------------------------------- +#property read & write traces +#-------------------------------------- + + +proc ::p::predator::propref_trace_read {get_cmd _ID_ refname prop indices vtraced idx op} { + + #puts stderr "\t-->propref_trace_read get_cmd:'$get_cmd' refname:'$refname' prop:'$prop' indices:'$indices' $vtraced idx:'$idx' " + + #set cmd ::p::${OID}::(GET)$prop ;#this is an interp alias to the head of the implementation command-chain. + + if {[llength $idx]} { + if {[llength $idx] == 1} { + set ${refname}($idx) [$get_cmd $_ID_ {*}$indices $idx] + } else { + lset ${refname}([lindex $idx 0]) [lrange $idx 1 end] [$get_cmd $_ID_ {*}$indices {*}$idx] + } + return ;#return value ignored - in a trace we can only return the value by setting the traced variable to a value + } else { + if {![info exists $refname]} { + set $refname [$get_cmd $_ID_ {*}$indices] + } else { + set newval [$get_cmd $_ID_ {*}$indices] + if {[set $refname] ne $newval} { + set $refname $newval + } + } + return + } +} + + + + +proc ::p::predator::propref_trace_write {_ID_ OID full_varspace refname vname idx op} { + #note 'vname' may be upvar-ed local - we need the fully qualified name so must use passed in $refname + #puts stdout "\t-->propref_trace_write $OID ref:'$refname' var:'$vname' idx:'$idx'" + + + #derive the name of the write command from the ref var. + set indices [lassign [split [namespace tail $refname] +] prop] + + + #assert - we will never have both a list in indices and an idx value + if {[llength $indices] && ($idx ne "")} { + #since Tcl has no nested arrays - we can't write to an idx within something like ${prop}+x + #review - are there any datastructures which would/should allow this? + #this assertion is really just here as a sanity check for now + error "propref_trace_write unexpected values. Didn't expect a refname of the form ${prop}+* as well as an idx value" + } + + #upvar #0 ::p::${OID}::_meta::map MAP + #puts "-->propref_trace_write map: $MAP" + + #temporarily deactivate refsync trace + #puts stderr -->1>--removing_trace_o_${field} +### trace remove variable ::p::${OID}::o_${prop} [::list write] [::list ::p::predator::propvar_write_TraceHandler $OID $prop] + + #we need to catch, and re-raise any error that we may receive when writing the property + # because we have to reinstate the propvar_write_TraceHandler after the call. + #(e.g there may be a propertywrite handler that deliberately raises an error) + + set excludesync_refs $refname + set cmd ::p::${OID}::(SET)$prop + + + set f_error 0 + if {[catch { + + if {![llength $indices]} { + if {[string length $idx]} { + $cmd $_ID_ $idx [set ${refname}($idx)] + #::p::predator::refsyncvar_write_manualupdate $OID $excludesync_refs $prop ::p::${OID}::o_${prop}($idx) [list] + ### ::p::predator::refsyncvar_write_manualupdate $OID $excludesync_refs $prop ::p::${OID}::o_${prop} [list $idx] + + } else { + $cmd $_ID_ [set $refname] + ### ::p::predator::refsyncvar_write_manualupdate $OID $excludesync_refs $prop ::p::${OID}::o_${prop} [list] + } + } else { + #puts " ++>> cmd:$cmd indices:'$indices' refname:'$refname'\n" + $cmd $_ID_ {*}$indices [set $refname] + ### ::p::predator::refsyncvar_write_manualupdate $OID $excludesync_refs $prop ::p::${OID}::o_${prop} $indices + } + + } result]} { + set f_error 1 + } + + + + + #::p::predator::propvar_write_TraceHandler $OID $prop ::p::${OID}::o_${prop} $indices write + #reactivate refsync trace + #puts stderr "****** reactivating refsync trace on o_$field" + #puts stderr -->2>--reactivating_trace_o_${field} + ### trace add variable ::p::${OID}::o_${prop} [::list write] [::list ::p::predator::propvar_write_TraceHandler $OID $prop] + + + if {$f_error} { + #!todo - review error & 'return' functions for proper way to throw error, preserving callstack info for debugging. + # ? return -code error $errMsg ? -errorinfo + + #!quick n dirty + #error $errorMsg + return -code error -errorinfo $::errorInfo $result + } else { + return $result + } +} + + + + + +proc ::p::predator::propref_trace_array {_ID_ OID refname vref idx op} { + #puts stderr "\t-->propref_trace_array OID:$OID refname:'$refname' var:'$vref' index:'$idx' operation:'$op'" + #NOTE - do not rely on $vref !!!! (can be upvared - so could be anything. e.g during 'parray' calls it is set to 'array') + + set indices [lassign [split [namespace tail $refname] +] prop] ;#make sure 'prop' is set + + #set updated_value [::p::predator::getprop_array $prop $_ID_] + #puts stderr "-->array_Trace updated_value:$updated_value" + if {[catch {array set $refname [::p::predator::getprop_array $_ID_ $prop ]} errm]} { + puts stderr "-->propref_trace_array error $errm" + array set $refname {} + } + + #return value ignored for +} + + +#-------------------------------------- +# +proc ::p::predator::object_array_trace {OID _ID_ vref idx op} { + upvar #0 ::p::${OID}::_meta::map MAP + lassign [dict get $MAP invocantdata] OID alias itemCmd + + + #don't rely on variable name passed by trace - may have been 'upvar'ed + set refvar ::p::${OID}::_ref::__OBJECT + + #puts "+=====>object_array_trace $map '$vref' '$idx' '$op' refvar: $refvar" + + set iflist [dict get $MAP interfaces level0] + + set plist [list] + + #!todo - get propertylist from cache on object(?) + foreach IFID [lreverse $iflist] { + dict for {prop pdef} [set ::p::${IFID}::_iface::o_properties] { + #lassign $pdef v + if {[catch {lappend plist $prop [set ::p::${OID}::o_${prop}]}]} { + if {[array exists ::p::${OID}::o_${prop}]} { + lappend plist $prop [array get ::p::${OID}::o_${prop}] + } else { + #ignore - array only represents properties that have been set. + #error "property $v is not set" + #!todo - unset corresponding items in $refvar if needed? + } + } + } + } + array set $refvar $plist +} + + +proc ::p::predator::object_read_trace {OID _ID_ vref idx op} { + upvar #0 ::p::${OID}::_meta::map MAP + lassign [dict get $MAP invocantdata] OID alias itemCmd + #don't rely on variable name passed by trace. + set refvar ::p::${OID}::_ref::__OBJECT + + #puts "\n\n+=====>object_read_trace map:'$MAP' '$vref' '$idx' '$op' refvar: $refvar\n\n" + + #!todo? - build a list of all interface properties (cache it on object??) + set iflist [dict get $MAP interfaces level0] + set IID "" + foreach id [lreverse $iflist] { + if {$idx in [dict keys [set ::p::${id}::_iface::o_properties]]} { + set IID $id + break + } + } + + if {[string length $IID]} { + #property + if {[catch {set ${refvar}($idx) [::p::${id}::_iface::(GET)$idx $_ID_]} errmsg]} { + puts stderr "\twarning: ::p::${id}::_iface::(GET)$idx retrieval failed (array?) errmsg:$errmsg" + } + } else { + #method + error "property '$idx' not found" + } +} + + +proc ::p::predator::object_unset_trace {OID _ID_ vref idx op} { + upvar #0 ::p::${OID}::_meta::map MAP + + lassign [dict get $MAP invocantdata] OID alias itemCmd + + #!todo - ??? + + if {![llength [info commands ::p::${OID}::$idx]]} { + error "no such method or property: '$idx'" + } else { + #!todo? - build a list of all interface properties (cache it on object??) + set iflist [dict get $MAP interfaces level0] + set found 0 + foreach id [lreverse $iflist] { + if {$idx in [dict keys [set ::p::${id}::_iface::o_properties]]} { + set found 1 + break + } + } + + if {$found} { + unset ::p::${OID}::o_$idx + } else { + puts stderr "\tWARNING: UNIMPLEMENTED CASE! (unset) object_unset_trace id:$OID objectcmd:[lindex [dict get $MAP invocantdata] 3] var:$vref prop:$idx" + } + } +} + + +proc ::p::predator::object_write_trace {OID _ID_ vref idx op} { + upvar #0 ::p::${OID}::_meta::map MAP + lassign [dict get $MAP invocantdata] OID alias itemCmd + #don't rely on variable name passed by trace. + set refvar ::p::${OID}::_ref::__OBJECT + #puts "+=====>object_write_trace $MAP '$vref' '$idx' '$op' refvar: $refvar" + + + if {![llength [info commands ::p::${OID}::$idx]]} { + #!todo - create new property in interface upon attempt to write to non-existant? + # - or should we require some different kind of object-reference for that? + array unset $refvar $idx ;#make sure 'array names' on the ref doesn't include this $idx + error "no such method or property: '$idx'" + } else { + #!todo? - build a list of all interface properties (cache it on object??) + set iflist [dict get $MAP interfaces level0] + set IID "" + foreach id [lreverse $iflist] { + if {$idx in [dict keys [set ::p::${id}::_iface::o_properties]]} { + set IID $id + break + } + } + + #$IID is now topmost interface in default iStack which has this property + + if {[string length $IID]} { + #write to defined property + + ::p::${IID}::_iface::(SET)$idx $_ID_ [set ${refvar}($idx)] + } else { + #!todo - allow write of method body back to underlying object? + #attempted write to 'method' ..undo(?) + array unset $refvar $idx ;#make sure 'array names' on the ref doesn't include this $idx + error "cannot write to method '$idx'" + #for now - disallow + } + } + +} + + + +proc ::p::predator::propref_trace_unset {_ID_ OID refname vref idx op} { + #note 'vref' may be upvar-ed local - we need the fully qualified name so must use passed in $refname + + set refindices [lassign [split [namespace tail $refname] +] prop] + #derive the name of any potential PropertyUnset command from the refname. i.e (UNSET)$prop + #if there is no PropertyUnset command - we unset the underlying variable directly + + trace remove variable ::p::${OID}::o_${prop} [::list unset] [::list ::p::predator::propvar_unset_TraceHandler $OID $prop] + + + if {[catch { + + #assert if refname is complex (prop+idx etc), we will not get a reference trace with an $idx value + #i.e + if {[llength $refindices] && [string length $idx]} { + puts stderr "\t !!!!! unexpected call to propref_trace_unset oid:'$OID' refname:'$refname' vref:'$vref' idx:'$idx' op:'$op'" + error "unexpected call to propref_trace_unset" + } + + + upvar #0 ::p::${OID}::_meta::map MAP + + set iflist [dict get $MAP interfaces level0] + #find topmost interface containing this $prop + set IID "" + foreach id [lreverse $iflist] { + if {$prop in [dict keys [set ::p::${id}::_iface::o_properties]]} { + set IID $id + break + } + } + if {![string length $IID]} { + error "propref_trace_unset failed to find property '$prop' on objectid $OID ([lindex [dict get $_ID_ i this] 0 3])" + } + + + + if {[string length $idx]} { + #eval "$_alias ${unset_}$field $idx" + #what happens to $refindices??? + + + #!todo varspace + + if {![llength $refindices]} { + #puts stdout "\t 1a@@@@ propref_trace_unset $OID ref:'$refname' var:'$vref' idx:'$idx'" + + if {![llength [info commands ::p::${IID}::_iface::(UNSET)$prop]]} { + unset ::p::${OID}::o_${prop}($idx) + } else { + ::p::${IID}::_iface::(UNSET)$prop $_ID_ $idx + } + + + #manually call refsync, passing it this refvar as an exclusion + ::p::predator::refsyncvar_unset_manualupdate $OID $refname $prop ::p::${OID}::o_${prop} $idx + } else { + #assert - won't get here + error 1a + + } + + } else { + if {[llength $refindices]} { + #error 2a + #puts stdout "\t 2a@@@@ propref_trace_unset $OID ref:'$refname' var:'$vref' idx:'$idx'" + + if {![llength [info commands ::p::${IID}::_iface::(UNSET)$prop]]} { + #review - what about list-type property? + #if {[array exists ::p::${OID}::o_${prop}]} ??? + unset ::p::${OID}::o_${prop}($refindices) + } else { + ::p::${IID}::_iface::(UNSET)$prop $_ID_ $refindices + } + + + + #manually call refsync, passing it this refvar as an exclusion + ::p::predator::refsyncvar_unset_manualupdate $OID $refname $prop ::p::${OID}::o_${prop} $refindices + + + } else { + #puts stdout "\t 2b@@@@ propref_trace_unset $OID ref:'$refname' var:'$vref' idx:'$idx'" + + #ref is not of form prop+x etc and no idx in the trace - this is a plain unset + if {![llength [info commands ::p::${IID}::_iface::(UNSET)$prop]]} { + unset ::p::${OID}::o_${prop} + } else { + ::p::${IID}::_iface::(UNSET)$prop $_ID_ "" + } + #manually call refsync, passing it this refvar as an exclusion + ::p::predator::refsyncvar_unset_manualupdate $OID $refname $prop ::p::${OID}::o_${prop} {} + + } + } + + + } errM]} { + #set ::LAST_UNSET_ERROR "$errM\n[set ::errorInfo]" + set ruler [string repeat - 80] + puts stderr "\t$ruler" + puts stdout "\t @@@@ERROR propref_trace_unset $OID ref:'$refname' var:'$vref' idx:'$idx'" + puts stderr "\t$ruler" + puts stderr $errM + puts stderr "\t$ruler" + + } else { + #puts stdout "\t @@@@ propref_trace_unset $OID ref:'$refname' var:'$vref' idx:'$idx'" + #puts stderr "*@*@*@*@ end propref_trace_unset - no error" + } + + trace add variable ::p::${OID}::o_${prop} [::list unset] [::list ::p::predator::propvar_unset_TraceHandler $OID $prop] + + +} + + + + +proc ::p::predator::refsyncvar_unset_manualupdate {OID triggeringRef prop vtraced vidx} { + #Do not use 'info exists' (avoid triggering read trace) - use info vars + if {[info vars ::p::${OID}::_ref::$prop] eq "::p::${OID}::_ref::$prop"} { + #puts " **> lappending '::p::REF::${OID}::$prop'" + lappend refvars ::p::${OID}::_ref::$prop + } + lappend refvars {*}[info vars ::p::${OID}::_ref::${prop}+*] + + if {[string length $triggeringRef]} { + set idx [lsearch -exact $refvars $triggeringRef] + if {$idx >= 0} { + set refvars [lreplace $refvars[set refvars {}] $idx $idx] ;#note inline K combinator [set refvars {}] + } + } + if {![llength $refvars]} { + #puts stderr " %%%%%%%%%% no refvars for propvar_unset_TraceHandler to update - short circuiting . $OID $triggeringRef $prop $vtraced $vidx" + return + } + + + #*usually* triggeringRef is not in the reflist because the triggeringRef is being unset + # - but this is not the case when we do an array unset of an element using a reference to the whole array e.g "array unset [>obj . arr .] b" + if {([string length $triggeringRef]) && ($triggeringRef in $refvars)} { + #puts stderr "\t@@@@@@@@@@ propvar_unset_TraceHandler unexpected situation. triggeringRef $triggeringRef in refvars:$refvars during unset ???" + puts stderr "\t@@@@@ propvar_unset_TraceHandler triggeringRef $triggeringRef is in refvars list - probably a call of form 'array unset \[>obj .arr .\] someindex'" + } + + + puts stderr "\t refsyncvar_unset_manualupdate OID:'$OID' triggeringRef:'$triggeringRef' prop:'$prop' vtraced:'$vtraced' vidx:'$vidx' " + + + + upvar $vtraced SYNCVARIABLE + + + #We are only interested in suppressing the 'setGet_TraceHandler' traces on refvars + array set traces [::list] + + #puts stderr "*-*-*-*-*-* refvars \n- [join $refvars "\n- "]" + + + foreach rv $refvars { + #puts "--refvar $rv" + foreach tinfo [trace info variable $rv] { + #puts "##trace $tinfo" + set ops {}; set cmd {} + lassign $tinfo ops cmd + #!warning - assumes traces with single operation per handler. + #write & unset traces on refvars need to be suppressed + #we also need to be able to read certain refvars without triggering retrieval of underlying value in order to detect if changed. + if {$ops in {read write unset array}} { + if {[string match "::p::predator::propref_trace_*" $cmd]} { + lappend traces($rv) $tinfo + trace remove variable $rv $ops $cmd + #puts stderr "*-*-*-*-*-* removing $ops trace on $rv -> $cmd" + } + } + } + } + + + if {[array exists SYNCVARIABLE]} { + #underlying variable is an array - we are presumably unsetting just an element + set vtracedIsArray 1 + } else { + #!? maybe the var was an array - but it's been unset? + set vtracedIsArray 0 + } + + #puts stderr "--------------------------------------------------\n\n" + #some things we don't want to repeat for each refvar in case there are lots of them.. + + #set triggeringRefIdx $vidx + + if {[string match "${prop}+*" [namespace tail $triggeringRef]]} { + set triggering_indices [lrange [split [namespace tail $triggeringRef] +] 1 end] + } else { + set triggering_indices [list] + } + + + #puts stderr ">>>...----refsync-trace = $vtraced $op refvars:$refvars" + #puts stderr ">>> [trace info variable $vtraced]" + #puts "--- unset branch refvar:$refvar" + + if {[llength $vidx]} { + #trace called with an index - must be an array + foreach refvar $refvars { + set reftail [namespace tail $refvar] + + if {[string match "${prop}+*" $reftail]} { + #!todo - add test + if {$vidx eq [lrange [split $reftail +] 1 end]} { + #unset if indices match + error "untested, possibly unused branch spuds1" + #puts "1111111111111111111111111" + unset $refvar + } + } else { + #test exists - #!todo - document which one + + #see if we succeeded in unsetting this element in the underlying variables + #(may have been blocked by a PropertyUnset body) + set element_exists [uplevel 1 [::list info exists ${vtraced}($vidx)]] + #puts "JJJJJJ vtraced:$vtraced vidx:$vidx element_exists:$element_exists" + if {$element_exists} { + #do nothing it wasn't actually unset + } else { + #puts "JJJJJ unsetting ${refvar}($vidx)" + unset ${refvar}($vidx) + } + } + } + + } else { + + foreach refvar $refvars { + set reftail [namespace tail $refvar] + + if {[string match "${prop}+*" $reftail]} { + #check indices of triggering refvar match this refvars indices + + if {$reftail eq [namespace tail $triggeringRef]} { + #!todo - add test + error "untested, possibly unused branch spuds2" + #puts "222222222222222222" + unset $refvar + } else { + + #error "untested - branch spuds2a" + + } + + } else { + #!todo -add test + #reference is directly to property var + error "untested, possibly unused branch spuds3" + #theoretically no other non-indexed ref.. so $triggeringRefIdx must contain non-zero-len string? + puts "\t33333333333333333333" + + if {[string length $triggeringRefIdx]} { + unset $refvar($triggeringRefIdx) + } + } + } + + } + + #!todo - understand. + #puts stderr "\n*****\n propvar_unset_TraceHandler $refvar unset $prop $args \n*****\n" + #catch {unset $refvar} ;#oops - Tcl_EventuallyFree called twice - abnormal program termination (tcl8.4?) + + + #reinstall the traces we stored at the beginning of this proc. + foreach rv [array names traces] { + foreach tinfo $traces($rv) { + set ops {}; set cmd {} + lassign $tinfo ops cmd + + #puts stderr "****** re-installing setGet trace '$ops' on variable $rv" + trace add variable $rv $ops $cmd + } + } + + + + + +} + + +proc ::p::predator::propvar_unset_TraceHandler {OID prop vtraced vidx op} { + + upvar $vtraced SYNCVARIABLE + + set refvars [::list] + #Do not use 'info exists' (avoid triggering read trace) - use info vars + if {[info vars ::p::${OID}::_ref::$prop] eq "::p::${OID}::_ref::$prop"} { + lappend refvars ::p::${OID}::_ref::$prop + } + lappend refvars {*}[info vars ::p::${OID}::_ref::${prop}+*] + + #short_circuit breaks unset traces for array elements (why?) + + + if {![llength $refvars]} { + #puts stderr "\t%%%%%%%%%% no refvars for propvar_unset_TraceHandler to update - short circuiting . OID:'$OID' prop:'$prop' vtraced:'$vtraced' vidx:'$vidx'" + return + } else { + puts stderr "\t****** [llength $refvars] refvars for propvar_unset_TraceHandler to update. OID:'$OID' prop:'$prop' vtraced:'$vtraced' vidx:'$vidx'" + } + + if {[catch { + + + + #We are only interested in suppressing the 'setGet_TraceHandler' traces on refvars + array set traces [::list] + + #puts stderr "*-*-*-*-*-* refvars \n- [join $refvars "\n- "]" + + + foreach rv $refvars { + #puts "--refvar $rv" + foreach tinfo [trace info variable $rv] { + #puts "##trace $tinfo" + set ops {}; set cmd {} + lassign $tinfo ops cmd + #!warning - assumes traces with single operation per handler. + #write & unset traces on refvars need to be suppressed + #we also need to be able to read certain refvars without triggering retrieval of underlying value in order to detect if changed. + if {$ops in {read write unset array}} { + if {[string match "::p::predator::propref_trace_*" $cmd]} { + lappend traces($rv) $tinfo + trace remove variable $rv $ops $cmd + #puts stderr "*-*-*-*-*-* removing $ops trace on $rv -> $cmd" + } + } + } + } + + + + + if {[array exists SYNCVARIABLE]} { + + #underlying variable is an array - we are presumably unsetting just an element + set vtracedIsArray 1 + } else { + #!? maybe the var was an array - but it's been unset? + set vtracedIsArray 0 + } + + #puts stderr "--------------------------------------------------\n\n" + #some things we don't want to repeat for each refvar in case there are lots of them.. + set triggeringRefIdx $vidx + + + #puts stderr ">>>...----refsync-trace = $vtraced $op refvars:$refvars" + #puts stderr ">>> [trace info variable $vtraced]" + #puts "--- unset branch refvar:$refvar" + + + if {[llength $vidx]} { + #trace called with an index - must be an array + foreach refvar $refvars { + set reftail [namespace tail $refvar] + + if {[string match "${prop}+*" $reftail]} { + #!todo - add test + if {$vidx eq [lrange [split $reftail +] 1 end]} { + #unset if indices match + error "untested, possibly unused branch spuds1" + #puts "1111111111111111111111111" + unset $refvar + } + } else { + #test exists - #!todo - document which one + + #see if we succeeded in unsetting this element in the underlying variables + #(may have been blocked by a PropertyUnset body) + set element_exists [uplevel 1 [::list info exists ${vtraced}($vidx)]] + #puts "JJJJJJ vtraced:$vtraced vidx:$vidx element_exists:$element_exists" + if {$element_exists} { + #do nothing it wasn't actually unset + } else { + #puts "JJJJJ unsetting ${refvar}($vidx)" + unset ${refvar}($vidx) + } + } + } + + + } else { + + foreach refvar $refvars { + set reftail [namespace tail $refvar] + unset $refvar + + } + + } + + + #!todo - understand. + #puts stderr "\n*****\n propvar_unset_TraceHandler $refvar unset $prop $args \n*****\n" + #catch {unset $refvar} ;#oops - Tcl_EventuallyFree called twice - abnormal program termination (tcl8.4?) + + + #reinstall the traces we stored at the beginning of this proc. + foreach rv [array names traces] { + foreach tinfo $traces($rv) { + set ops {}; set cmd {} + lassign $tinfo ops cmd + + #puts stderr "****** re-installing setGet trace '$ops' on variable $rv" + trace add variable $rv $ops $cmd + } + } + + } errM]} { + set ruler [string repeat * 80] + puts stderr "\t$ruler" + puts stderr "\t>>>>>>>$ propvar_unset_TraceHandler OID:'$OID' prop:'$prop' vtraced:'$vtraced' vidx:'$vidx' $op" + puts stderr "\t$ruler" + puts stderr $::errorInfo + puts stderr "\t$ruler" + + } + +} + +proc ::p::predator::refsyncvar_write_manualupdate {OID triggeringRef prop vtraced indices} { + error hmmmmm + upvar $vtraced SYNCVARIABLE + #puts stderr "\t>>>>>>>$ refsyncvar_write_manualupdate $OID '$triggeringRef' '$prop' vtraced:'$vtraced' indices:'$indices' " + set refvars [::list] + + #avoid info exists ::p::${OID}::_ref::$prop (info exists triggers read unnecessary read trace ) + if {[info vars ::p::${OID}::_ref::$prop] eq "::p::${OID}::_ref::$prop"} { + lappend refvars ::p::${OID}::_ref::$prop ;#this is the basic unindexed reference we normally get when getting a standard property ref (e.g set ref [>obj . prop .]) + } + lappend refvars {*}[info vars ::p::${OID}::_ref::${prop}+*] ;#add any indexed references + #assert triggeringRef is in the list + if {([string length $triggeringRef]) && ($triggeringRef ni $refvars)} { + error "@@@@@@@@@@ refsyncvar_write_manualupdate unexpected situation. triggeringRef $triggeringRef ni refvars:$refvars" + } + set refposn [lsearch -exact $refvars $triggeringRef] + #assert - due to test above, we know $triggeringRef is in the list so refposn > 0 + set refvars [lreplace $refvars[set refvars {}] $refposn $refposn] ;#note inline K combinator [set refvars {}] + if {![llength $refvars]} { + #puts stderr " %%%%%%%%%% no refvars for refsyncvar_write_manualupdate to update - short circuiting . OID:$OID prop:$prop" + return [list refs_updates [list]] + } + + #suppress the propref_trace_* traces on all refvars + array set traces [::list] + array set external_traces [::list] ;#e.g application/3rd party traces on "">obj . prop ." + #we do not support tracing of modifications to refs which occur from inside the pattern system. ie we disable them during refsync + #todo - after finished refsyncing - consider manually firing the external_traces in such a way that writes/unsets raise an error? + #(since an external trace should not be able to affect a change which occured from inside the object - but can affect values from application writes/unsets to the ref) + + foreach rv $refvars { + #puts "--refvar $rv" + foreach tinfo [trace info variable $rv] { + #puts "##trace $tinfo" + set ops {}; set cmd {} + lassign $tinfo ops cmd + #!warning - assumes traces with single operation per handler. + #write & unset traces on refvars need to be suppressed + #we also need to be able to read certain refvars without triggering retrieval of underlying value in order to detect if changed. + + if {[string match "::p::predator::propref_trace_*" $cmd]} { + lappend traces($rv) $tinfo + trace remove variable $rv $ops $cmd + #puts stderr "*-*-*-*-*-* removing $ops trace on $rv -> $cmd" + } else { + #all other traces are 'external' + lappend external_traces($rv) $tinfo + #trace remove variable $rv $ops $cmd + } + + } + } + #-------------------------------------------------------------------------------------------------------------------------- + if {([array exists SYNCVARIABLE]) || (![info exists SYNCVARIABLE])} { + if {![info exists SYNCVARIABLE]} { + error "WARNING: REVIEW why does $vartraced not exist here?" + } + #either the underlying variable is an array + # OR - underlying variable doesn't exist - so we treat the property as an array because of the indexed access pattern + set treat_vtraced_as_array 1 + } else { + set treat_vtraced_as_array 0 + } + + set refs_updated [list] + set refs_deleted [list] ;#unset due to index no longer being relevant + if {$treat_vtraced_as_array} { + foreach refvar $refvars { + #puts stdout "\n\n \tarrayvariable:'$vtraced' examining REFVAR:'$refvar'" + set refvar_tail [namespace tail $refvar] + if {[string match "${prop}+*" $refvar_tail]} { + #refvar to update is curried e.g ::p::${OID}::_ref::${prop}+x+y + set ref_indices [lrange [split $refvar_tail +] 1 end] + if {[llength $indices]} { + if {[llength $indices] == 1} { + if {[lindex $ref_indices 0] eq [lindex $indices 0]} { + #error "untested xxx-a" + set ${refvar} [set SYNCVARIABLE([lindex $indices 0])] + lappend refs_updated $refvar + } else { + #test exists + #error "xxx-ok single index" + #updating a different part of the property - nothing to do + } + } else { + #nested index + if {[lindex $ref_indices 0] eq [lindex $indices 0]} { + if {[llength $ref_indices] == 1} { + #error "untested xxx-b1" + set ${refvar} [lindex [set SYNCVARIABLE([lindex $indices 0])] [lrange $indices 1 end] ] + } else { + #assert llength $ref_indices > 1 + #NOTE - we cannot test index equivalence reliably/simply just by comparing indices + #compare by value + + if {![catch {lindex [set SYNCVARIABLE([lindex $indices 0])] [lrange $indices 1 end]} possiblyNewVal]} { + #puts stderr "\tYYYYYYYYY $refvar:'[set $refvar]'' / possiblyNewVal:'$possiblyNewVal'" + if {[set $refvar] ne $possiblyNewVal} { + set $refvar $possiblyNewVal + } + } else { + #fail to retrieve underlying value corrsponding to these $indices + unset $refvar + } + } + } else { + #test exists + #error "untested xxx-ok deepindex" + #updating a different part of the property - nothing to do + } + } + } else { + error "untested xxx-c" + + } + + } else { + #refvar to update is plain e.g ::p::${OID}::_ref::${prop} + if {[llength $indices]} { + if {[llength $indices] == 1} { + set ${refvar}([lindex $indices 0]) [set SYNCVARIABLE([lindex $indices 0])] + } else { + lset ${refvar}([lindex $indices 0]) {*}[lrange $indices 1 end] [lindex [set SYNCVARIABLE([lindex $indices 0])] {*}[lrange $indices 1 end]] + } + lappend refs_updated $refvar + } else { + error "untested yyy" + set $refvar $SYNCVARIABLE + } + } + } + } else { + #vtraced non array, but could be an array element e.g ::p::${OID}::_ref::ARR(x) + # + foreach refvar $refvars { + #puts stdout "\n\n \tsimplevariable:'$vtraced' examining REFVAR:'$refvar'" + set refvar_tail [namespace tail $refvar] + if {[string match "${prop}+*" $refvar_tail]} { + #refvar to update is curried e.g ::p::${OID}::_ref::${prop}+x+y + set ref_indices [lrange [split $refvar_tail +] 1 end] + + if {[llength $indices]} { + #see if this update would affect this curried ref + #1st see if we can short-circuit our comparison based on numeric-indices + if {[string is digit -strict [join [concat $ref_indices $indices] ""]]} { + #both sets of indices are purely numeric (no end end-1 etc) + set rlen [llength $ref_indices] + set ilen [llength $indices] + set minlen [expr {min($rlen,$ilen)}] + set matched_firstfew_indices 1 ;#assume the best + for {set i 0} {$i < $minlen} {incr i} { + if {[lindex $ref_indices $i] ne [lindex $indices $i]} { + break ;# + } + } + if {!$matched_firstfew_indices} { + #update of this refvar not required + #puts stderr "\t@@@1 SKIPPING refvar $refvar - indices don't match $ref_indices vs $indices" + break ;#break to next refvar in the foreach loop + } + } + #failed to short-circuit + + #just do a simple value comparison - some optimisations are possible, but perhaps unnecessary here + set newval [lindex $SYNCVARIABLE $ref_indices] + if {[set $refvar] ne $newval} { + set $refvar $newval + lappend refs_updated $refvar + } + + } else { + #we must be updating the entire variable - so this curried ref will either need to be updated or unset + set newval [lindex $SYNCVARIABLE $ref_indices] + if {[set ${refvar}] ne $newval} { + set ${refvar} $newval + lappend refs_updated $refvar + } + } + } else { + #refvar to update is plain e.g ::p::${OID}::_ref::${prop} + if {[llength $indices]} { + #error "untested zzz-a" + set newval [lindex $SYNCVARIABLE $indices] + if {[lindex [set $refvar] $indices] ne $newval} { + lset ${refvar} $indices $newval + lappend refs_updated $refvar + } + } else { + if {[set ${refvar}] ne $SYNCVARIABLE} { + set ${refvar} $SYNCVARIABLE + lappend refs_updated $refvar + } + } + + } + + } + } + #-------------------------------------------------------------------------------------------------------------------------- + + #!todo - manually fire $external_traces as appropriate - but somehow raise error if attempt to write/unset + + #reinstall the traces we stored at the beginning of this proc. + foreach rv [array names traces] { + if {$rv ni $refs_deleted} { + foreach tinfo $traces($rv) { + set ops {}; set cmd {} + lassign $tinfo ops cmd + + #puts stderr "****** re-installing trace '$ops' on variable $rv cmd:$cmd" + trace add variable $rv $ops $cmd + } + } + } + foreach rv [array names external_traces] { + if {$rv ni $refs_deleted} { + foreach tinfo $external_traces($rv) { + set ops {}; set cmd {} + lassign $tinfo ops cmd + #trace add variable $rv $ops $cmd + } + } + } + + + return [list updated_refs $refs_updated] +} + +#purpose: update all relevant references when context variable changed directly +proc ::p::predator::propvar_write_TraceHandler {OID prop vtraced vidx op} { + #note that $vtraced may have been upvared in calling scope - so could have any name! only use it for getting/setting values - don't rely on it's name in any other way. + #we upvar it here instead of using uplevel - as presumably upvar is more efficient (don't have to wory about whether uplevelled script is bytecompiled etc) and also makes code simpler + + upvar $vtraced SYNCVARIABLE + #puts stderr "\t>>>>>>>$ propvar_write_TraceHandler OID:$OID propertyname:'$prop' vtraced:'$vtraced' index:'$vidx' operation:$op" + #set t_info [trace info variable $vtraced] + #foreach t_spec $t_info { + # set t_ops [lindex $t_spec 0] + # if {$op in $t_ops} { + # puts stderr "\t!!!!!!!! propvar_write_Tracehandler [lindex $t_spec 1]" + # } + #} + + #puts stderr -*-*-[info vars ::p::_ref::${OID}::[lindex $prop 0]+*]-*-*- + #vtype = array | array-item | list | simple + + set refvars [::list] + + ############################ + #!!!NOTE!!! do not call 'info exists' on a propref here as it will trigger a read trace -which then pulls in the value from the (GET)prop function etc!!! + #This would be extra cpu work - and sets the propref prematurely (breaking proper property-trace functionality plus vwaits on proprefs) + #The alternative 'info vars' does not trigger traces + if {[info vars ::p::${OID}::_ref::$prop] eq "::p::${OID}::_ref::$prop"} { + #puts " **> lappending '::p::REF::${OID}::$prop'" + lappend refvars ::p::${OID}::_ref::$prop ;#this is the basic unindexed reference we normally get when getting a standard property ref (e.g set ref [>obj . prop .]) + } + ############################ + + #lappend refvars ::p::${OID}::_ref::$prop ;#this is the basic unindexed reference we normally get when getting a standard property ref (e.g set ref [>obj . prop .]) + lappend refvars {*}[info vars ::p::${OID}::_ref::${prop}+*] ;#add any indexed references + + + if {![llength $refvars]} { + #puts stderr "\t%%%%%%%%%% no refvars for propvar_write_TraceHandler to update - short circuiting . OID:$OID prop:$prop" + return + } + + + #puts stderr "*-*-*-*-*-* refvars \n- [join $refvars "\n- "]" + + #We are only interested in suppressing the pattern library's 'propref_trace_*' traces and 3rd party 'read' traces on refvars + array set predator_traces [::list] + #maintain two lists of external traces - as we need to temporarily deactivate all non-pattern read traces even if they are part of a more comprehensive trace.. + #ie for something like 'trace add variable someref {write read array} somefunc' + # we need to remove and immediately reinstall it as a {write array} trace - and at the end of this procedure - reinstall it as the original {write read array} trace + array set external_read_traces [::list] ;#pure read traces the library user may have added + array set external_readetc_traces [::list] ;#read + something else traces the library user may have added + foreach rv $refvars { + #puts "--refvar $rv" + foreach tinfo [trace info variable $rv] { + #puts "##trace $tinfo" + set ops {}; set cmd {} + lassign $tinfo ops cmd + #!warning - assumes traces with single operation per handler. + #write & unset traces on refvars need to be suppressed + #we also need to be able to read certain refvars without triggering retrieval of underlying value in order to detect if changed. + #if {$ops in {read write unset array}} {} + + if {[string match "::p::predator::propref_trace_*" $cmd]} { + lappend predator_traces($rv) $tinfo + trace remove variable $rv $ops $cmd + #puts stderr "*-*-*-*-*-* removing $ops trace on $rv -> $cmd" + } else { + #other traces + # puts "##trace $tinfo" + if {"read" in $ops} { + if {[llength $ops] == 1} { + #pure read - + lappend external_read_traces($rv) $tinfo + trace remove variable $rv $ops $cmd + } else { + #mixed operation trace - remove and reinstall without the 'read' + lappend external_readetc_traces($rv) $tinfo + set other_ops [lsearch -all -inline -not $ops "read"] + trace remove variable $rv $ops $cmd + #reinstall trace for non-read operations only + trace add variable $rv $other_ops $cmd + } + } + } + } + } + + + if {([array exists SYNCVARIABLE]) || (![info exists SYNCVARIABLE])} { + #either the underlying variable is an array + # OR - underlying variable doesn't exist - so we treat the property as an array because of the indexed access pattern + set vtracedIsArray 1 + } else { + set vtracedIsArray 0 + } + + #puts stderr "--------------------------------------------------\n\n" + + #puts stderr ">>>...----refsync-trace = $vtraced $op refvars:$refvars" + #puts stderr ">>> [trace info variable $vtraced]" + #puts "**write*********** propvar_write_TraceHandler $prop $vtraced $vidx $op" + #puts "**write*********** refvars: $refvars" + + #!todo? unroll foreach into multiple foreaches within ifs? + #foreach refvar $refvars {} + + + #puts stdout "propvar_write_TraceHandler examining REFVAR $refvar" + if {[string length $vidx]} { + #indexable + if {$vtracedIsArray} { + + foreach refvar $refvars { + #puts stderr " - - a refvar $refvar vidx: $vidx" + set tail [namespace tail $refvar] + if {[string match "${prop}+*" $tail]} { + #refvar is curried + #only set if vidx matches curried index + #!todo -review + set idx [lrange [split $tail +] 1 end] + if {$idx eq $vidx} { + set newval [set SYNCVARIABLE($vidx)] + if {[set $refvar] ne $newval} { + set ${refvar} $newval + } + #puts stderr "=a.1=> updated $refvar" + } + } else { + #refvar is simple + set newval [set SYNCVARIABLE($vidx)] + if {![info exists ${refvar}($vidx)]} { + #new key for this array + #puts stderr "\npropvar_write_TraceHandler------ about to call 'array set $refvar [::list $vidx [set SYNCVARIABLE($vidx)] ]' " + array set ${refvar} [::list $vidx [set SYNCVARIABLE($vidx)] ] + } else { + set oldval [set ${refvar}($vidx)] + if {$oldval ne $newval} { + #puts stderr "\npropvar_write_TraceHandler------ about to call 'array set $refvar [::list $vidx [set SYNCVARIABLE($vidx)] ]' " + array set ${refvar} [::list $vidx [set SYNCVARIABLE($vidx)] ] + } + } + #puts stderr "=a.2=> updated ${refvar} $vidx" + } + } + + } else { + + foreach refvar $refvars { + upvar $refvar internal_property_reference + #puts stderr " - - b vidx: $vidx" + + #!? could be object not list?? + #!!but what is the difference between an object, and a list of object names which happens to only contain one object?? + #For predictability - we probably need to autodetect type on 1st write to o_prop either list, array or object (and maintain after unset operations) + #There would still be an edge case of an initial write of a list of objects of length 1. + if {([llength [set $SYNCVARIABLE]] ==1) && ([string range [set $SYNCVARIABLE] 0 0] eq ">")} { + error "untested review!" + #the o_prop is object-shaped + #assumes object has a defaultmethod which accepts indices + set newval [[set $SYNCVARIABLE] {*}$vidx] + + } else { + set newval [lindex $SYNCVARIABLE {*}$vidx] + #if {[set $refvar] ne $newval} { + # set $refvar $newval + #} + if {$internal_property_reference ne $newval} { + set internal_property_reference $newval + } + + } + #puts stderr "=b=> updated $refvar" + } + + } + + } else { + #no vidx + + if {$vtracedIsArray} { + + foreach refvar $refvars { + set targetref_tail [namespace tail $refvar] + set targetref_is_indexed [string match "${prop}+*" $targetref_tail] + + + #puts stderr " - - c traced: $vtraced refvar:$refvar triggeringRef: $triggeringRef" + if {$targetref_is_indexed} { + #curried array item ref of the form ${prop}+x or ${prop}+x+y etc + + #unindexed write on a property that is acting as an array.. + + #case a) If the underlying variable is actually an array - it will error upon attempt to write it like this - that's ok. + + #case b) If the underlying variable doesn't exist - perhaps a PropertyWrite will accept the unindexed write (e.g by asigning a default for the missing index). + # we can't know here how this write affects other indexed traces on this property... hence we warn but do nothing. + puts stderr "\tc.1 WARNING: write to property without 'array set'. op:'$op' refvar:'$refvar' prop:'$prop' \n\traw: propvar_write_TraceHandler $OID $prop $vtraced $vidx $op" + } else { + #How do we know what to write to array ref? + puts stderr "\tc.2 WARNING: unimplemented/unused?" + #error no_tests_for_branch + + #warning - this would trigger 3rd party unset traces which is undesirable for what is really a 'bookkeeping' operation + #if this branch is actually useful - we probably need to step through the array and unset and set elements as appropriate + array unset ${refvar} + array set ${refvar} [array get SYNCVARIABLE] + } + } + + } else { + foreach refvar $refvars { + #puts stderr "\t\t_________________[namespace current]" + set targetref_tail [namespace tail $refvar] + upvar $refvar INTERNAL_REFERENCE_TO_PROPERTY__$targetref_tail + set targetref_is_indexed [string match "${prop}+*" $targetref_tail] + + if {$targetref_is_indexed} { + #puts "XXXXXXXXX vtraced:$vtraced" + #reference curried with index(es) + #we only set indexed refs if value has changed + # - this not required to be consistent with standard list-containing variable traces, + # as normally list elements can't be traced seperately anyway. + # + + #only bother checking a ref if no setVia index + # i.e some operation on entire variable so need to test synchronisation for each element-ref + set targetref_indices [lrange [split $targetref_tail +] 1 end] + set possiblyNewVal [lindex $SYNCVARIABLE {*}$targetref_indices] + #puts stderr "YYYYYYYYY \[set \$refvar\]: [set $refvar] / possiblyNewVal: $possiblyNewVal" + if {[set INTERNAL_REFERENCE_TO_PROPERTY__$targetref_tail] ne $possiblyNewVal} { + set INTERNAL_REFERENCE_TO_PROPERTY__$targetref_tail $possiblyNewVal + #puts stderr "=d1=> updated $refvar -> [uplevel 1 "lindex \[set $vtraced] $idx"]" + } + + } else { + #for consistency with standard traces on a list-containing variable, we perform the set even if the list value has not changed! + + #puts stderr "- d2 set" + #puts "refvar: [set $refvar]" + #puts "SYNCVARIABLE: $SYNCVARIABLE" + + #if {[set $refvar] ne $SYNCVARIABLE} { + # set $refvar $SYNCVARIABLE + #} + if {[set INTERNAL_REFERENCE_TO_PROPERTY__$targetref_tail] ne $SYNCVARIABLE} { + set INTERNAL_REFERENCE_TO_PROPERTY__$targetref_tail $SYNCVARIABLE + } + + } + } + + } + + } + + + + #reinstall the traces we stored at the beginning of this proc. + foreach rv [array names predator_traces] { + foreach tinfo $predator_traces($rv) { + set ops {}; set cmd {} + lassign $tinfo ops cmd + + #puts stderr "****** re-installing trace '$ops' on variable $rv cmd:$cmd" + trace add variable $rv $ops $cmd + } + } + + foreach rv [array names external_traces] { + foreach tinfo $external_traces($rv) { + set ops {}; set cmd {} + lassign $tinfo ops cmd + + #puts stderr "****** re-installing trace '$ops' on variable $rv cmd:$cmd" + trace add variable $rv $ops $cmd + } + } + + + +} + +# end propvar_write_TraceHandler + + + + + + + + + + + + + + + + +# + +#returns 0 if method implementation not present for interface +proc ::p::predator::method_chainhead {iid method} { + #Interface proc + # examine the existing command-chain + set candidates [info commands ::p::${iid}::_iface::$method.*] ;#rough grab (info commands only allows basic pattern globbing - not a regex) + set cmdchain [list] + + set re [string map [list %m% [string map {( \\( ) \\) . \\.} $method]] {^%m%.([0-9]+)$}] + set maxversion 0 + #loop and test because it is possible there are unrelated commands (having a matching prefix with . character) which were caught in the glob. + foreach test [lsort -dictionary $candidates] { + set c [namespace tail $test] + if {[regexp $re $c _match version]} { + lappend cmdchain $c + if {$version > $maxversion} { + set maxversion $version + } + } + } + return $maxversion +} + + + + + +#this returns a script that upvars vars for all interfaces on the calling object - +# - must be called at runtime from a method +proc ::p::predator::upvar_all {_ID_} { + #::set OID [lindex $_ID_ 0 0] + ::set OID [::lindex [::dict get $_ID_ i this] 0 0] + ::set decl {} + #[set ::p::${OID}::_meta::map] + #[dict get [lindex [dict get $_ID_ i this] 0 1] map] + + ::upvar #0 ::p::${OID}::_meta::map MAP + #puts stdout "\n\n -->-->-->--> _meta::map '$MAP' <-<-<-\n\n" + #set iflist [::lindex [dict get [lindex [dict get $_ID_ i this] 0 1] map] 1 0] + + ::foreach ifid [dict get $MAP interfaces level0] { + if {[::dict size [::set ::p::${ifid}::_iface::o_variables]]} { + ::array unset nsvars + ::array set nsvars [::list] + ::dict for {vname vinfo} [::set ::p::${ifid}::_iface::o_variables] { + ::set varspace [::dict get $vinfo varspace] + ::lappend nsvars($varspace) $vname + } + #nsvars now contains vars grouped by varspace. + + ::foreach varspace [::array names nsvars] { + if {$varspace eq ""} { + ::set ns ::p::${OID} + } else { + if {[::string match "::*" $varspace]} { + ::set ns $varspace + } else { + ::set ns ::p::${OID}::$varspace + } + } + + ::append decl "namespace upvar $ns " + ::foreach vname [::set nsvars($varspace)] { + ::append decl "$vname $vname " + } + ::append decl " ;\n" + } + ::array unset nsvars + } + } + ::return $decl +} + +#we need to use eval because it is potentially a multiline script returned by upvar_all (so can't just use {*} operator) +proc ::p::predator::runtime_vardecls {} { + set result "::eval \[::p::predator::upvar_all \$_ID_\]" + #set result "::apply { {_ID_} ::p::predator::upvar_all } \$_ID_" + + #set result "::apply \[::list {} \[::p::predator::upvar_all \$_ID_\] \[namespace current\]\]" + #set result "::interp eval {} \[::p::predator::upvar_all \$_ID_\]" + #puts stdout "\t>>>[info level -1]\n\t>>>>>>>>>>>>>>>>>>>>> '$result'" + return $result +} + + + + + + +#OBSOLETE!(?) - todo - move stuff out of here. +proc ::p::predator::compile_interface {IFID caller_ID_} { + upvar 0 ::p::${IFID}:: IFACE + + #namespace eval ::p::${IFID} { + # namespace ensemble create + #} + + #'namespace upvar' - from tip.tcl.tk #250: Efficient Access to Namespace Variables + + namespace upvar ::p::${IFID}::_iface o_propertyunset_handlers o_propertyunset_handlers o_variables o_variables o_properties o_properties o_methods o_methods o_unknown o_unknown o_varspace o_varspace o_varspaces o_varspaces + + #set varDecls {} + #if {[llength $o_variables]} { + # #puts "*********!!!! $vlist" + # append varDecls "namespace upvar ::p::\[lindex \$_ID_ 0 0 \] " + # foreach vdef $o_variables { + # append varDecls "[lindex $vdef 0] [lindex $vdef 0] " + # } + # append varDecls \n + #} + + #runtime gathering of vars from other interfaces. + #append varDecls [runtime_vardecls] + + set varDecls [runtime_vardecls] + + + + #implement methods + + #!todo - avoid globs on iface array? maintain list of methods in another slot? + #foreach {n mname} [array get IFACE m-1,name,*] {} + + + #namespace eval ::p::${IFID}::_iface "namespace export {*}$o_methods" ;#make methods available as interface ensemble. + + + + #implement property getters/setters/unsetters + #'setter' overrides + #pw short for propertywrite + foreach {n property} [array get IFACE pw,name,*] { + if {[string length $property]} { + #set property [lindex [split $n ,] end] + + #!todo - next_script + #set next [::p::next_script "\[set ::p::\${_ID_}::(self)]" $IFID $property] + + set maxversion [::p::predator::method_chainhead $IFID (SET)$property] + set chainhead [expr {$maxversion + 1}] + set THISNAME (SET)$property.$chainhead ;#first version will be (SET)$property.1 + + set next [::p::predator::next_script $IFID (SET)$property $THISNAME $caller_ID_] ;#?! caller_ID_ ?? + + set body $IFACE(pw,body,$property) + + + set processed [dict create {*}[::p::predator::expand_var_statements $body $o_varspace]] + if {[llength [dict get $processed varspaces_with_explicit_vars]]} { + foreach vs [dict get $processed varspaces_with_explicit_vars] { + if {[string length $vs] && ($vs ni $o_varspaces)} { + lappend o_varspaces $vs + } + } + set body [dict get $processed body] + } else { + set body $varDecls\n[dict get $processed body] + #puts stderr "\t\timplicit vardecls used for propertywrite $property on interface $IFID ##### \n $body" + } + + #set body [string map [::list @this@ "\[lindex \${_ID_} 0 3 \]" @next@ $next] $body\n] + set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata \] 3\]" @next@ $next] $body\n] + + + + set maxversion [::p::predator::method_chainhead $IFID $property] + set headid [expr {$maxversion + 1}] + + proc ::p::${IFID}::_iface::(SET)$property.$headid [concat _ID_ $IFACE(pw,arg,$property)] $body + + interp alias {} ::p::${IFID}::_iface::(SET)$property {} ::p::${IFID}::_iface::(SET)$property.$headid + + #proc ::p::${IFID}::___system___write_$property [concat _ID_ $IFACE(pw,arg,$property)] $body + } + } + #'unset' overrides + + dict for {property handler_info} $o_propertyunset_handlers { + + set body [dict get $handler_info body] + set arraykeypattern [dict get $handler_info arraykeypattern] ;#array element pattern for unsetting individual elements in an array + + set maxversion [::p::predator::method_chainhead $IFID (UNSET)$property] + set headid [expr {$maxversion + 1}] + + set THISNAME (UNSET)$property.$headid + + set next [::p::predator::next_script $IFID (UNSET)$property $THISNAME $caller_ID_] ;#?! caller_ID_ ??? + + + + + + set processed [dict create {*}[::p::predator::expand_var_statements $body $o_varspace]] + if {[llength [dict get $processed varspaces_with_explicit_vars]]} { + foreach vs [dict get $processed varspaces_with_explicit_vars] { + if {[string length $vs] && ($vs ni $o_varspaces)} { + lappend o_varspaces $vs + } + } + set body [dict get $processed body] + } else { + set body $varDecls\n[dict get $processed body] + #puts stderr "\t\timplicit vardecls used for property unset $property on interface $IFID ##### \n $body" + + } + #set body [string map [::list @this@ "\[lindex \$_ID_ 0 3 \]" @next@ $next] $body\n] + set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata \] 3\]" @next@ $next] $body\n] + + + + + #implement + #always take arraykeypattern argument even though usually empty string (only used for unsetting individual array elements) + if {[string trim $arraykeypattern] eq ""} { + set arraykeypattern "_dontcare_" + } + proc ::p::${IFID}::_iface::(UNSET)$property.$headid [concat _ID_ $arraykeypattern] $body + + + #chainhead pointer + interp alias {} ::p::${IFID}::_iface::(UNSET)$property {} ::p::${IFID}::_iface::(UNSET)$property.$headid + } + + + + interp alias {} ::p::${IFID}::(VIOLATE) {} ::p::internals::(VIOLATE) + + #the usual case will have no destructor - so use info exists to check. + + if {[info exists ::p::${IFID}::_iface::o_destructor_body]} { + #!todo - chained destructors (support @next@). + #set next [::p::next_script_destructor "\[lindex \$_ID_ 0 1\]" $IFID] + set next NEXT + + set body [set ::p::${IFID}::_iface::o_destructor_body] + + + set processed [dict create {*}[::p::predator::expand_var_statements $body $o_varspace]] + if {[llength [dict get $processed varspaces_with_explicit_vars]]} { + foreach vs [dict get $processed varspaces_with_explicit_vars] { + if {[string length $vs] && ($vs ni $o_varspaces)} { + lappend o_varspaces $vs + } + } + set body [dict get $processed body] + } else { + set body $varDecls\n[dict get $processed body] + #puts stderr "\t\t**********************implicit vardecls used for destructor on interface $IFID ##### \n $body" + } + #set body [::p::fixed_var_statements \n@IMPLICITDECLS@\n$body] + #set body [string map [::list @this@ "\[lindex \$_ID_ 0 3 \]" @next@ $next] $body\n] + set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata \] 3\]" @next@ $next] $body\n] + + + proc ::p::${IFID}::___system___destructor _ID_ $body + } + + + if {[info exists o_unknown]} { + #use 'apply' somehow? + interp alias {} ::p::${IFID}::_iface::(UNKNOWN) {} ::p::${IFID}::_iface::$o_unknown + + #namespace eval ::p::${IFID}::_iface [list namespace unknown $o_unknown] + } + + + return +} + + + + + + + +#'info args' - assuming arbitrary chain of 'interp aliases' +proc ::p::predator::command_info_args {cmd} { + if {[llength [set next [interp alias {} $cmd]]]} { + set curriedargs [lrange $next 1 end] + + if {[catch {set arglist [info args [lindex $next 0]]}]} { + set arglist [command_info_args [lindex $next 0]] + } + #trim curriedargs + return [lrange $arglist [llength $curriedargs] end] + } else { + info args $cmd + } +} + + +proc ::p::predator::do_next {_ID_ IFID mname nextArgs args} { + if {[llength $args]} { + tailcall ::p::${IFID}::_iface::$mname $_ID_ {*}$args + } else { + if {[llength $nextArgs] > 1} { + set argVals [::list] + set i 0 + foreach arg [lrange $nextArgs 1 end] { + upvar 1 $arg $i + if {$arg eq "args"} { + #need to check if 'args' is actually available in caller + if {[info exists $i]} { + set argVals [concat $argVals [set $i]] + } + } else { + lappend argVals [set $i] + } + } + tailcall ::p::${IFID}::_iface::$mname $_ID_ {*}$argVals + } else { + tailcall ::p::${IFID}::_iface::$mname $_ID_ + } + } +} + +#---------------------------------------------------------------------------------------------- +proc ::p::predator::next_script {IFID method caller caller_ID_} { + + if {$caller eq "(CONSTRUCTOR).1"} { + return [string map [list %cID% [list $caller_ID_] %ifid% $IFID %m% $method] {::p::predator::do_next_pattern_if $_ID_ %cID% %ifid% %m%}] + } elseif {$caller eq "$method.1"} { + #delegate to next interface lower down the stack which has a member named $method + return [string map [list %ifid% $IFID %m% $method] {::p::predator::do_next_if $_ID_ %ifid% %m%}] + } elseif {[string match "(GET)*.2" $caller]} { + # .1 is the getprop procedure, .2 is the bottom-most PropertyRead. + + #jmn + set prop [string trimright $caller 1234567890] + set prop [string range $prop 5 end-1] ;#string leading (GET) and trailing . + + if {$prop in [dict keys [set ::p::${IFID}::_iface::o_properties]]} { + #return [string map [list %ifid% $IFID %p% $prop ] {::p::%ifid%::_iface::(GET)%p%.1 $_ID_}] + return [string map [list %ifid% $IFID %m% (GET)$prop.1 %nargs% [list]] {::p::predator::do_next $_ID_ %ifid% %m% [list %nargs%]}] + } else { + #we can actually have a property read without a property or a method of that name - but it could also match the name of a method. + # (in which case it could return a different value depending on whether called via set [>obj . something .] vs >obj . something) + return [string map [list %ifid% $IFID %m% $method] {::p::predator::do_next_if $_ID_ %ifid% %m%}] + } + } elseif {[string match "(SET)*.2" $caller]} { + return [string map [list %ifid% $IFID %m% $method] {::p::predator::do_next_if $_ID_ %ifid% %m%}] + } else { + #this branch will also handle (SET)*.x and (GET)*.x where x >2 + + #puts stdout "............next_script IFID:$IFID method:$method caller:$caller" + set callerid [string range $caller [string length "$method."] end] + set nextid [expr {$callerid - 1}] + + if {[catch {set nextArgs [info args ::p::${IFID}::_iface::$method.$nextid]} errMsg]} { + #not a proc directly on this interface - presumably an alias made by something like linkcopy_interface. + #puts ">>>>>>>>::p::predator::next_script IFID:$IFID caller:$caller aaaa@ $method.$nextid" + set nextArgs [command_info_args ::p::${IFID}::_iface::$method.$nextid] + } + + return [string map [list %ifid% $IFID %m% $method.$nextid %nargs% $nextArgs] {::p::predator::do_next $_ID_ %ifid% %m% [list %nargs%]}] + } +} + +proc ::p::predator::do_next_if {_ID_ IFID method args} { + #puts "<>(::p::predator::do_next_if)<> '$_ID_' '$IFID' '$method' '$args' (((" + + #set invocants [dict get $_ID_ i] + #set this_invocantdata [lindex [dict get $invocants this] 0] + #lassign $this_invocantdata OID this_info + set OID [::p::obj_get_this_oid $_ID_] + ::p::map $OID MAP + lassign [dict get $MAP invocantdata] OID alias itemCmd cmd + set interfaces [dict get $MAP interfaces level0] + set patterninterfaces [dict get $MAP interfaces level1] + + set L0_posn [lsearch $interfaces $IFID] + if {$L0_posn == -1} { + error "(::p::predator::do_next_if) called with interface not present at level0 for this object" + } elseif {$L0_posn > 0} { + #set ifid_next [lindex $interfaces $L0_posn-1] ;#1 lower in the iStack + set lower_interfaces [lrange $interfaces 0 $L0_posn-1] + + foreach if_sub [lreverse $lower_interfaces] { + if {[string match "(GET)*" $method]} { + #do not test o_properties here! We need to call even if there is no underlying property on this interface + #(PropertyRead without Property is legal. It results in dispatch to subsequent interface rather than property variable for this interface) + # relevant test: higher_order_propertyread_chaining + return [::p::${if_sub}::_iface::$method $_ID_ {*}$args] + } elseif {[string match "(SET)*" $method]} { + #must be called even if there is no matching $method in o_properties + return [::p::${if_sub}::_iface::$method $_ID_ {*}$args] + } elseif {[string match "(UNSET)*" $method]} { + #review untested + #error "do_next_if (UNSET) untested" + #puts stderr "<>(::p::predator::do_next_if)<> (UNSET) called - dispatching to ::p::${if_sub}::_iface::$method with args:'$args'" + return [::p::${if_sub}::_iface::$method $_ID_ {*}$args] + + } elseif {$method in [dict keys [set ::p::${if_sub}::_iface::o_methods]]} { + if {[llength $args]} { + #puts stdout "<>(::p::predator::do_next_if)<> - - - calling ::p::${if_sub}::_iface::$method on sub interface $if_sub with $args" + + #return [::p::${if_sub}::_iface::$method $_ID_ {*}$args] + #tailcall ::p::${if_sub}::_iface::$method $_ID_ {*}$args + + #!todo - handle case where llength $args is less than number of args for subinterface command + #i.e remaining args will need to be upvared to get values from calling scope (auto-set any values not explicitly set) + + #handle case where next interface has different arguments (masking of sub interfaces in the stack with function with different arity/signature) + set head [interp alias {} ::p::${if_sub}::_iface::$method] + set nextArgs [info args $head] ;#!todo - fix... head not necessarily a proc + set argx [list] + foreach a $nextArgs { + lappend argx "\$a" + } + + #todo - handle func a b args called with func "x" ie short on named vars so b needs to be upvared + + if {([llength $args] == [llength $nextArgs]) || ([lindex $nextArgs end] eq "args")} { + tailcall apply [list $nextArgs [list ::p::${if_sub}::_iface::$method {*}$argx ]] $_ID_ {*}$args + } else { + #todo - upvars required for tail end of arglist + tailcall apply [list $nextArgs [list ::p::${if_sub}::_iface::$method {*}$argx ]] $_ID_ {*}$args + } + + } else { + #auto-set: upvar vars from calling scope + #!todo - robustify? alias not necessarily matching command name.. + set head [interp alias {} ::p::${if_sub}::_iface::$method] + + + set nextArgs [info args $head] ;#!todo - fix... head not necessarily a proc + if {[llength $nextArgs] > 1} { + set argVals [::list] + set i 0 + foreach arg [lrange $nextArgs 1 end] { + upvar 1 $arg $i + if {$arg eq "args"} { + #need to check if 'args' is actually available in caller + if {[info exists $i]} { + set argVals [concat $argVals [set $i]] + } + } else { + lappend argVals [set $i] + } + } + #return [$head $_ID_ {*}$argVals] + tailcall $head $_ID_ {*}$argVals + } else { + #return [$head $_ID_] + tailcall $head $_ID_ + } + } + } elseif {$method eq "(CONSTRUCTOR)"} { + #chained constructors will only get args if the @next@ caller explicitly provided them. + puts stdout "!!!<>(::p::predator::do_next_if)<> CONSTRUCTOR CHAINED CALL via do_next_if _ID_:$_ID_ IFID:$IFID method:$method args:$args!!!" + #return [::p::${if_sub}::_iface::(CONSTRUCTOR) $_ID_ {*}$args] + xtailcall ::p::${if_sub}::_iface::(CONSTRUCTOR) $_ID_ {*}$args + } + } + #no interfaces in the iStack contained a matching method. + return + } else { + #no further interfaces in this iStack + return + } +} + + +#only really makes sense for (CONSTRUCTOR) calls. +#_ID_ is the invocant data for the target. caller_ID_ is the invocant data for the calling(creating,cloning etc) pattern/class. +proc ::p::predator::do_next_pattern_if {_ID_ caller_ID_ IFID method args} { + #puts ")))) do_next_pattern_if _ID_:'$_ID_' IFID:'$IFID' method:'$method' args:'$args' (((" + + #set invocants [dict get $_ID_ i] + #set this_invocant [lindex [dict get $invocants this] 0] + #lassign $this_invocant OID this_info + #set OID [lindex [dict get $invocants this] 0 0] + #upvar #0 ::p::${OID}::_meta::map map + #lassign [lindex $map 0] OID alias itemCmd cmd + + + set caller_OID [lindex [dict get $caller_ID_ i this] 0 0] + upvar #0 ::p::${caller_OID}::_meta::map callermap + + #set interfaces [lindex $map 1 0] + set patterninterfaces [dict get $callermap interfaces level1] + + set L0_posn [lsearch $patterninterfaces $IFID] + if {$L0_posn == -1} { + error "do_next_pattern_if called with interface not present at level1 for this object" + } elseif {$L0_posn > 0} { + + set lower_interfaces [lrange $patterninterfaces 0 $L0_posn-1] + + foreach if_sub [lreverse $lower_interfaces] { + if {$method eq "(CONSTRUCTOR)"} { + #chained constructors will only get args if the @next@ caller explicitly provided them. + #puts stdout "!!! CONSTRUCTOR CHAINED CALL via do_next_pattern_if _ID_:$_ID_ IFID:$IFID method:$method args:$args!!!" + tailcall ::p::${if_sub}::_iface::(CONSTRUCTOR) $_ID_ {*}$args + } + } + #no interfaces in the iStack contained a matching method. + return + } else { + #no further interfaces in this iStack + return + } +} + + + + + +#------------------------------------------------------------------------------------------------ + + + + + +#------------------------------------------------------------------------------------- +####################################################### +####################################################### +####################################################### +####################################################### +####################################################### +####################################################### +####################################################### + + +#!todo - can we just call new_object somehow to create this? + + #until we have a version of Tcl that doesn't have 'creative writing' scope issues - + # - we should either explicity specify the whole namespace when setting variables or make sure we use the 'variable' keyword. + # (see http://mini.net/tcl/1030 'Dangers of creative writing') +namespace eval ::p::-1 { + #namespace ensemble create + + namespace eval _ref {} + namespace eval _meta {} + + namespace eval _iface { + variable o_usedby + variable o_open + variable o_constructor + variable o_variables + variable o_properties + variable o_methods + variable o_definition + variable o_varspace + variable o_varspaces + + array set o_usedby [list i0 1] ;#!todo - review + #'usedby' array the metaface is an exception. All objects use it - so we should list none of them rather than pointless updating of this value? + + set o_open 1 + set o_constructor [list] + set o_variables [list] + set o_properties [dict create] + set o_methods [dict create] + array set o_definition [list] + set o_varspace "" + set o_varspaces [list] + } +} + + +# + +#interp alias {} ::p::internals::>metaface {} ::p::internals::predator [list [list -1 ::p::internals::>metaface item {}] {{} {}}] +interp alias {} ::p::internals::>metaface {} ::p::internals::predator [list i [list this [list [list -1 ::p::internals::>metaface item {}]]] context {}] + + +upvar #0 ::p::-1::_iface::o_definition def + + +#! concatenate -> compose ?? +dict set ::p::-1::_iface::o_methods Concatenate {arglist {target args}} +proc ::p::-1::Concatenate {_ID_ target args} { + set invocants [dict get $_ID_ i] + #set invocant_alias [lindex [dict get $invocants this] 0] + #set invocant [lindex [interp alias {} $invocant_alias] 1] + set OID [lindex [dict get $invocants this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + + lassign [dict get $MAP invocantdata] OID alias itemCmd cmd + + if {![string match "::*" $target]} { + if {[set ns [uplevel 1 {namespace current}]] eq "::"} { + set target ::$target + } else { + set target ${ns}::$target + } + } + #add > character if not already present + set target [namespace qualifiers $target]::>[string trimleft [namespace tail $target] >] + set _target [string map {::> ::} $target] + + set ns [namespace qualifiers $target] + if {$ns eq ""} { + set ns "::" + } else { + namespace eval $ns {} + } + + if {![llength [info commands $target]]} { + #degenerate case - target does not exist + #Probably just 1st of a set of Concatenate calls - so simply delegate to 'Clone' + #review - should be 'Copy' so it has object state from namespaces and variables? + return [::p::-1::Clone $_ID_ $target {*}$args] + + #set TARGETMAP [::p::predator::new_object $target] + #lassign [lindex $TARGETMAP 0] target_ID target_cmd itemCmd + + } else { + #set TARGETMAP [lindex [interp alias {} [namespace origin $target]] 1] + set TARGETMAP [$target --] + + lassign [dict get $TARGETMAP invocantdata] target_ID target_cmd itemCmd + + #Merge lastmodified(?) level0 and level1 interfaces. + + } + + return $target +} + + + +#Object's Base-Interface proc with itself as curried invocant. +#interp alias {} ::p::-1::Create {} ::p::-1::_iface::Create $invocant +#namespace eval ::p::-1 {namespace export Create} +dict set ::p::-1::_iface::o_methods Define {arglist definitions} +#define objects in one step +proc ::p::-1::Define {_ID_ definitions} { + set invocants [dict get $_ID_ i] + #set invocant_alias [lindex [dict get $invocants this] 0] + #set invocant [lindex [interp alias {} $invocant_alias] 1] + set OID [lindex [dict get $invocants this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + + lassign [dict get $MAP invocantdata] OID alias default_method cmd + set interfaces [dict get $MAP interfaces level0] ;#level-0 interfaces + set patterns [dict get $MAP interfaces level1] ;#level-1 interfaces + + #!todo - change these to dicts; key=interface stack name value= a list of interfaces in the stack + #set IFID0 [lindex $interfaces 0] + #set IFID1 [lindex $patterns 0] ;#1st pattern + + #set IFID_TOP [lindex $interfaces end] + set IFID_TOP [::p::predator::get_possibly_new_open_interface $OID] + + #set ns ::p::${OID} + + #set script [string map [list %definitions% $definitions] { + # if {[lindex [namespace path] 0] ne "::p::-1"} { + # namespace path [list ::p::-1 {*}[namespace path]] + # } + # %definitions% + # namespace path [lrange [namespace path] 1 end] + # + #}] + + set script [string map [list %id% $_ID_ %definitions% $definitions] { + set ::p::-1::temp_unknown [namespace unknown] + + namespace unknown [list ::apply {{funcname args} {::p::predator::redirect $funcname [list %id%] {*}$args}}] + + #namespace unknown [list ::apply { {funcname args} {if {![llength [info commands ::p::-1::$funcname]]} {::unknown $funcname {*}$args } else {::p::-1::$funcname [list %id%] {*}$args} }} ] + + %definitions% + + + namespace unknown ${::p::-1::temp_unknown} + return + }] + + + + #uplevel 1 $script ;#this would run the script in the global namespace + #run script in the namespace of the open interface, this allows creating of private helper procs + #namespace inscope ::p::${IFID_TOP}::_iface $script ;#do not use tailcall here! Define belongs on the callstack + #namespace inscope ::p::${OID} $script + namespace eval ::p::${OID} $script + #return $cmd +} + + +proc ::p::predator::redirect {func args} { + #todo - review tailcall - tests? + if {![llength [info commands ::p::-1::$func]]} { + #error "invalid command name \"$func\"" + tailcall uplevel 1 [list ::unknown $func {*}$args] + } else { + tailcall uplevel 1 [list ::p::-1::$func {*}$args] + } +} + + +#'immediate' constructor - this is really like a (VIOLATE) call.. todo - review. +dict set ::p::-1::_iface::o_methods Construct {arglist {argpairs body args}} +proc ::p::-1::Construct {_ID_ argpairs body args} { + set OID [::p::obj_get_this_oid $_ID_] + ::p::map $OID MAP + + set interfaces [dict get $MAP interfaces level0] + set iid_top [lindex $interfaces end] + namespace upvar ::p::${iid_top}::_iface o_varspaces o_varspaces o_varspace o_varspace + + set ARGSETTER {} + foreach {argname argval} $argpairs { + append ARGSETTER "set $argname $argval\n" + } + #$_self (VIOLATE) $ARGSETTER$body + + set body $ARGSETTER\n$body + + + set processed [dict create {*}[::p::predator::expand_var_statements $body $o_varspace]] + if {[llength [dict get $processed varspaces_with_explicit_vars]]} { + foreach vs [dict get $processed varspaces_with_explicit_vars] { + if {[string length $vs] && ($vs ni $o_varspaces)} { + lappend o_varspaces $vs + } + } + set body [dict get $processed body] + } else { + set varDecls [::p::predator::runtime_vardecls] ;#dynamic vardecls can access vars from all interfaces of invocant object. + set body $varDecls\n[dict get $processed body] + # puts stderr "\t runtime_vardecls in Construct $varDecls" + } + + set next "\[error {next not implemented}\]" + #set body [string map [::list @this@ "\[lindex \$_ID_ 0 3 \]"] $body\n] + set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata \] 3\]" @next@ $next] $body\n] + + + #namespace eval ::p::${iid_top} $body + + #return [apply [list {_ID_ args} $body ::p::${iid_top}::_iface] $_ID_] + #does this handle Varspace before constructor? + return [apply [list {_ID_ args} $body ::p::${OID} ] $_ID_ {*}$args] +} + + + + + +#hacked optimized version of ::p::-1::Create for creating ::p::ifaces::>* objects +namespace eval ::p::3 {} +proc ::p::3::_create {child {OID "-2"}} { + #puts stderr "::p::3::_create $child $OID" + set _child [string map {::> ::} $child] + if {$OID eq "-2"} { + #set childmapdata [::p::internals::new_object $child] + #set child_ID [lindex [dict get $childmapdata invocantdata] 0 ] + set child_ID [lindex [dict get [::p::internals::new_object $child] invocantdata] 0] + upvar #0 ::p::${child_ID}::_meta::map CHILDMAP + } else { + set child_ID $OID + #set _childmap [::p::internals::new_object $child "" $child_ID] + ::p::internals::new_object $child "" $child_ID + upvar #0 ::p::${child_ID}::_meta::map CHILDMAP + } + + #-------------- + + set oldinterfaces [dict get $CHILDMAP interfaces] + dict set oldinterfaces level0 [list 2] + set modifiedinterfaces $oldinterfaces + dict set CHILDMAP interfaces $modifiedinterfaces + + #-------------- + + + + + #puts stderr ">>>> creating alias for ::p::$child_ID" + #puts stderr ">>>::p::3::_create $child $OID >>>[interp alias {} ::p::$child_ID]" + + #interp alias ::p::$child_ID already exists at this point - so calling here will do nothing! + #interp alias {} ::p::$child_ID {} ::p::internals::predator [dict create i [dict create this [list [list $child_ID {} ]]]] + #puts stderr ">>>[interp alias {} ::p::$child_ID]" + + + + #--------------- + namespace upvar ::p::2::_iface o_methods o_methods o_properties o_properties + foreach method [dict keys $o_methods] { + #todo - change from interp alias to context proc + interp alias {} ::p::${child_ID}::$method {} ::p::2::_iface::$method + } + #namespace eval ::p::${child_ID} [list namespace export {*}$o_methods] + #implement property even if interface already compiled because we need to create defaults for each new child obj. + # also need to add alias on base interface + #make sure we are only implementing properties from the current CREATOR + dict for {prop pdef} $o_properties { + #lassign $pdef prop default + interp alias {} ::p::${child_ID}::$prop {} ::p::2::_iface::(GET)$prop + interp alias {} ::p::${child_ID}::(GET)$prop {} ::p::2::_iface::(GET)$prop + + } + ::p::2::_iface::(CONSTRUCTOR) [dict create i [dict create this [list [dict get $CHILDMAP invocantdata]]] context {}] + #--------------- + #namespace eval ::p::${child_ID} "namespace ensemble create -command $_child" + return $child +} + +#configure -prop1 val1 -prop2 val2 ... +dict set ::p::-1::_iface::o_methods Configure {arglist args} +proc ::p::-1::Configure {_ID_ args} { + + #!todo - add tests. + set OID [::p::obj_get_this_oid $_ID_] + ::p::map $OID MAP + + lassign [dict get $MAP invocantdata] OID alias itemCmd this + + if {![expr {([llength $args] % 2) == 0}]} { + error "expected even number of Configure args e.g '-property1 value1 -property2 value2'" + } + + #Do a separate loop to check all the arguments before we run the property setting loop + set properties_to_configure [list] + foreach {argprop val} $args { + if {!([string range $argprop 0 0] eq "-") || ([string length $argprop] < 2)} { + error "expected Configure args in the form: '-property1 value1 -property2 value2'" + } + lappend properties_to_configure [string range $argprop 1 end] + } + + #gather all valid property names for all level0 interfaces in the relevant interface stack + set valid_property_names [list] + set iflist [dict get $MAP interfaces level0] + foreach id [lreverse $iflist] { + set interface_property_names [dict keys [set ::p::${id}::_iface::o_properties]] + foreach if_prop $interface_property_names { + if {$if_prop ni $valid_property_names} { + lappend valid_property_names $if_prop + } + } + } + + foreach argprop $properties_to_configure { + if {$argprop ni $valid_property_names} { + error "Configure failed - no changes made. Unable to find property '$argprop' on object $this OID:'$OID' valid properties: $valid_property_names" + } + } + + set top_IID [lindex $iflist end] + #args ok - go ahead and set all properties + foreach {prop val} $args { + set property [string range $prop 1 end] + #------------ + #don't use property ref unnecessarily - leaves property refs hanging around which traces need to update + #ie don't do this here: set [$this . $property .] $val + #------------- + ::p::${top_IID}::_iface::(SET)$property $_ID_ $val ;#equivalent to [$this . (SET)$property $val] + } + return +} + + + + + + +dict set ::p::-1::_iface::o_methods AddPatternInterface {arglist iid} +proc ::p::-1::AddPatternInterface {_ID_ iid} { + #puts stderr "!!!!!!!!!!!!!!! ::p::-1::AddPatternInterface $_ID_ $iid" + if {![string is integer -strict $iid]} { + error "adding interface by name not yet supported. Please use integer id" + } + + set invocants [dict get $_ID_ i] + #set invocant_alias [lindex [dict get $invocants this] 0] + #set invocant [lindex [interp alias {} $invocant_alias] 1] + #lassign [lindex $invocant 0] OID alias itemCmd cmd + + set OID [lindex [dict get $invocants this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + set existing_ifaces [dict get $MAP interfaces level1] ;#pattern interfaces + + + + #it is theoretically possible to have the same interface present multiple times in an iStack. + # #!todo -review why/whether this is useful. should we disallow it and treat as an error? + + lappend existing_ifaces $iid + #lset map {1 1} $existing_ifaces + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level1 $existing_ifaces + dict set MAP interfaces $extracted_sub_dict + + #lset invocant {1 1} $existing_ifaces + +} + + +#!todo - update usedby ?? +dict set ::p::-1::_iface::o_methods AddInterface {arglist iid} +proc ::p::-1::AddInterface {_ID_ iid} { + #puts stderr "::p::-1::AddInterface _ID_:$_ID_ iid:$iid" + if {![string is integer -strict $iid]} { + error "adding interface by name not yet supported. Please use integer id" + } + + + lassign [dict get $_ID_ i this] list_of_invocants_for_role_this ;#Although there is normally only 1 'this' element - it is a 'role' and the structure is nonetheless a list. + set this_invocant [lindex $list_of_invocants_for_role_this 0] + + lassign $this_invocant OID _etc + + upvar #0 ::p::${OID}::_meta::map MAP + set existing_ifaces [dict get $MAP interfaces level0] + + lappend existing_ifaces $iid + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level0 $existing_ifaces + dict set MAP interfaces $extracted_sub_dict + return [dict get $extracted_sub_dict level0] +} + + + +# The 'Create' method on the meta-interface has 2 variants (CreateNew & CreateOverlay) provided to enhance code clarity for the application using the pattern module. +# The 'Create' method could be used in all instances - but 'CreateNew' is designed for the case where the target/child object does not yet exist +# and 'CreateOverlay' for the case where the target/child object already exists. +# If the application writer follows the convention of using 'CreateNew' & 'CreateOverlay' instead of 'Create' - it should be more obvious where a particular object first comes into existence, +# and it should reduce errors where the author was expecting to overlay an existing object, but accidentally created a new object. +# 'CreateNew' will raise an error if the target already exists +# 'CreateOverlay' will raise an error if the target object does not exist. +# 'Create' will work in either case. Creating the target if necessary. + + +#simple form: +# >somepattern .. Create >child +#simple form with arguments to the constructor: +# >somepattern .. Create >child arg1 arg2 etc +#complex form - specify more info about the target (dict keyed on childobject name): +# >somepattern .. Create {>child {-id 1}} +#or +# >somepattern .. Create [list >child {-id 1 -somethingelse etc} >child2 {}] +#complex form - with arguments to the contructor: +# >somepattern .. Create [list >child {-id 1}] arg1 arg2 etc +dict set ::p::-1::_iface::o_methods Create {arglist {target_spec args}} +proc ::p::-1::Create {_ID_ target_spec args} { + #$args are passed to constructor + if {[llength $target_spec] ==1} { + set child $target_spec + set targets [list $child {}] + } else { + set targets $target_spec + } + + set OID [::p::obj_get_this_oid $_ID_] + ::p::map $OID MAP + set invocants [dict get $_ID_ i] + set invocant_roles [dict keys $invocants] ;#usually the only invocant role present will be 'this' (single dispatch case) + + foreach {child target_spec_dict} $targets { + #puts ">>>::p::-1::Create $_ID_ $child $args <<<" + + + + #set invocant_alias [lindex [dict get $invocants this] 0] + #set invocant [lindex [interp alias {} $invocant_alias] 1] + + + #puts ">>Create _ID_:$_ID_ child:$child args:$args map:$map OID:$OID" + + #child should already be fully ns qualified (?) + #ensure it is has a pattern-object marker > + #puts stderr ".... $child (nsqual: [namespace qualifiers $child])" + + + lassign [dict get $MAP invocantdata] OID alias parent_defaultmethod cmd + set interfaces [dict get $MAP interfaces level0] ;#level-0 interfaces + set patterns [dict get $MAP interfaces level1] ;#level-1 interfaces + #puts "parent: $OID -> child:$child Patterns $patterns" + + #todo - change to dict of interface stacks + set IFID0 [lindex $interfaces 0] + set IFID1 [lindex $patterns 0] ;#1st pattern + + #upvar ::p::${OID}:: INFO + + if {![string match {::*} $child]} { + if {[set ns [uplevel 1 {namespace current}]] eq "::"} { + set child ::$child + } else { + set child ${ns}::$child + } + } + + + #add > character if not already present + set child [namespace qualifiers $child]::>[string trimleft [namespace tail $child] >] + set _child [string map {::> ::} $child] + + set ns [namespace qualifiers $child] + if {$ns eq ""} { + set ns "::" + } else { + namespace eval $ns {} + } + + + #maintain a record of interfaces created so that we can clean-up if we get an error during any of the Constructor calls. + set new_interfaces [list] + + if {![llength $patterns]} { + ##puts stderr "===> WARNING: no level-1 interfaces (patterns) on object $cmd when creating $child" + #lappend patterns [::p::internals::new_interface $OID] + + #lset invocant {1 1} $patterns + ##update our command because we changed the interface list. + #set IFID1 [lindex $patterns 0] + + #set patterns [list [::p::internals::new_interface $OID]] + + #set patterns [list [::p::internals::new_interface]] + + #set patterns [list [set iid [expr {$::p::ID + 1}]]] ;#PREDICT the next object's id + #set patterns [list [set iid [incr ::p::ID]]] + set patterns [list [set iid [::p::get_new_object_id]]] + + #--------- + #set iface [::p::>interface .. Create ::p::ifaces::>$iid] + #::p::-1::Create [list {caller ::p::3}] ::p::ifaces::>$iid + + #lappend new_interfaces [::p::3::_create ::p::ifaces::>$iid] ;#interface creation + lappend new_interfaces [::p::3::_create ::p::ifaces::>$iid $iid] + + #--------- + + #puts "??> p::>interface .. Create ::p::ifaces::>$iid" + #puts "??> [::p::ifaces::>$iid --]" + #set [$iface . UsedBy .] + } + set parent_patterndefaultmethod [dict get $MAP patterndata patterndefaultmethod] + + #if {![llength [info commands $child]]} {} + + if {[namespace which $child] eq ""} { + #normal case - target/child does not exist + set is_new_object 1 + + if {[dict exists $target_spec_dict -id]} { + set childmapdata [::p::internals::new_object $child "" [dict get $target_spec_dict -id]] + } else { + set childmapdata [::p::internals::new_object $child] + } + lassign [dict get $childmapdata invocantdata] child_ID child_alias child_defaultmethod + upvar #0 ::p::${child_ID}::_meta::map CHILDMAP + + #child initially uses parent's level1 interface as it's level0 interface + # child has no level1 interface until PatternMethods or PatternProperties are added + # (or applied via clone; or via create with a parent with level2 interface) + #set child_IFID $IFID1 + + #lset CHILDMAP {1 0} [list $IFID1] + #lset CHILDMAP {1 0} $patterns + + set extracted_sub_dict [dict get $CHILDMAP interfaces] + dict set extracted_sub_dict level0 $patterns + dict set CHILDMAP interfaces $extracted_sub_dict + + #why write back when upvared??? + #review + set ::p::${child_ID}::_meta::map $CHILDMAP + + #::p::predator::remap $CHILDMAP + + #interp alias {} $child {} ::p::internals::predator $CHILDMAP + + #set child_IFID $IFID1 + + #upvar ::p::${child_ID}:: child_INFO + + #!todo review + #set n ::p::${child_ID} + #if {![info exists ${n}::-->PATTERN_ANCHOR]} { + # #puts stdout "### target:'$child' Creating ${n}::-->PATTERN_ANCHOR (unset trace to delete namespace '$n'" + # #!todo - keep an eye on tip.tcl.tk #140 - 'Tracing Namespace Modification' - may be able to do away with this hack + # set ${n}::-->PATTERN_ANCHOR "objects within this namespace will be deleted when this var is unset" + # trace add variable ${n}::-->PATTERN_ANCHOR {unset} [list ::p::meta::clear_ns $n] + #} + + set ifaces_added $patterns + + } else { + #overlay/mixin case - target/child already exists + set is_new_object 0 + + #set CHILDMAP [lindex [interp alias {} [namespace origin $child]] 1] + set childmapdata [$child --] + + + #puts stderr " *** $cmd .. Create -> target $child already exists!!!" + #puts " **** CHILDMAP: $CHILDMAP" + #puts " ****" + + #puts stderr " ---> Properties: [$child .. Properties . names]" + #puts stderr " ---> Methods: [$child .. Properties . names]" + + lassign [dict get $childmapdata invocantdata] child_ID child_alias child_default child_cmd + upvar #0 ::p::${child_ID}::_meta::map CHILDMAP + + #set child_IFID [lindex $CHILDMAP 1 0 end] + #if {$child_IFID != [set child_IFID [::p::internals::expand_interface $child_IFID]]} { + # lset CHILDMAP {1 0} [concat [lindex $CHILDMAP 1 0] $child_IFID] + # interp alias {} $child_cmd {} ::p::internals::predator $CHILDMAP + #} + ##!todo? - merge only 'open' parent interfaces onto 'open' target interfaces + #::p::merge_interface $IFID1 $child_IFID + + + set existing_interfaces [dict get $CHILDMAP interfaces level0] + set ifaces_added [list] + foreach p $patterns { + if {$p ni $existing_interfaces} { + lappend ifaces_added $p + } + } + + if {[llength $ifaces_added]} { + #lset CHILDMAP {1 0} [concat [lindex $CHILDMAP 1 0] $ifaces_added] + set extracted_sub_dict [dict get $CHILDMAP interfaces] + dict set extracted_sub_dict level0 [concat $existing_interfaces $ifaces_added] + dict set CHILDMAP interfaces $extracted_sub_dict + #set ::p::${child_ID}::_meta::map $CHILDMAP ;#why? + #::p::predator::remap $CHILDMAP + } + } + + #do not overwrite the child's defaultmethod value if the parent_patterndefaultmethod is empty + if {$parent_patterndefaultmethod ne ""} { + set child_defaultmethod $parent_patterndefaultmethod + set CHILD_INVOCANTDATA [dict get $CHILDMAP invocantdata] + lset CHILD_INVOCANTDATA 2 $child_defaultmethod + dict set CHILDMAP invocantdata $CHILD_INVOCANTDATA + #update the child's _ID_ + interp alias {} $child_alias {} ;#first we must delete it + interp alias {} $child_alias {} ::p::internals::predator [list i [list this [list $CHILD_INVOCANTDATA] ] context {}] + + #! object_command was initially created as the renamed alias - so we have to do it again + rename $child_alias $child + trace add command $child rename [list $child .. Rename] + } + #!todo - review - dont we already have interp alias entries for every method/prop? + #namespace eval ::p::${child_ID} "namespace ensemble create -command $_child" + + + + + + set constructor_failure 0 ;#flag to indicate abortion due to error during a constructor call. + + + + #------------------------------------------------------------------------------------ + #create snapshot of the object-namespaces variables to allow object state to be rolledback if any Constructor calls fail. + # - All variables under the namespace - not just those declared as Variables or Properties + # - use a namespace. For the usual case of success, we just namespace delete, and remove the COW traces. + # - presumably this snapshot should be reasonably efficient even if variables hold large amounts of data, as Tcl implements Copy-On-Write. + + #NOTE - do not use the objectID as the sole identifier for the snapshot namespace. + # - there may be multiple active snapshots for a single object if it overlays itself during a constructor, + # and it may be that a failure of an inner overlay is deliberately caught and not considered reason to raise an error for the initial constructor call. + # - we will use an ever-increasing snapshotid to form part of ns_snap + set ns_snap "::p::snap::[incr ::p::snap::id]_$child_ID" ;#unique snapshot namespace for this call to Create. + + #!todo - this should look at child namespaces (recursively?) + #!todo - this should examine any namespaces implied by the default 'varspace' value for all interfaces. + # (some of these namespaces might not be descendants of the object's ::p::${child_ID} namespace) + + namespace eval $ns_snap {} + foreach vname [info vars ::p::${child_ID}::*] { + set shortname [namespace tail $vname] + if {[array exists $vname]} { + array set ${ns_snap}::${shortname} [array get $vname] + } elseif {[info exists $vname]} { + set ${ns_snap}::${shortname} [set $vname] + } else { + #variable exists without value (e.g created by 'variable' command) + namespace eval $ns_snap [list variable $shortname] ;#create the variable without value, such that it is present, but does not 'info exist' + } + } + #------------------------------------------------------------------------------------ + + + + + + + + + + #puts "====>>> ifaces_added $ifaces_added" + set idx 0 + set idx_count [llength $ifaces_added] + set highest_constructor_IFID "" + foreach IFID $ifaces_added { + incr idx + #puts "--> adding iface $IFID " + namespace upvar ::p::${IFID}::_iface o_usedby o_usedby o_open o_open o_methods o_methods o_properties o_properties o_variables o_variables o_unknown o_unknown o_varspace o_varspace o_varspaces o_varspaces + + if {[llength $o_varspaces]} { + foreach vs $o_varspaces { + #ensure all varspaces for the interface exists so that the 'namespace upvar' entries in methods etc will work. + if {[string match "::*" $vs]} { + namespace eval $vs {} ;#an absolute path to a namespace which may not be under the object's namespace at all. + } else { + namespace eval ::p::${child_ID}::$vs {} + } + } + } + + if {$IFID != 2} { + #>ifinfo interface always has id 2 and is used by all interfaces - no need to add everything to its usedby list. + if {![info exists o_usedby(i$child_ID)]} { + set o_usedby(i$child_ID) $child_alias + } + + #compile and close the interface only if it is shared + if {$o_open} { + ::p::predator::compile_interface $IFID $_ID_ ;#params: IFID , caller_ID_ + set o_open 0 + } + } + + + package require struct::set + + set propcmds [list] + foreach cmd [info commands ::p::${IFID}::_iface::(GET)*] { + set cmd [namespace tail $cmd] + #may contain multiple results for same prop e.g (GET)x.3 + set cmd [string trimright $cmd 0123456789] + set cmd [string trimright $cmd .] ;#do separately in case cmd name also contains numerals + lappend propcmds [string range $cmd 5 end] ;#don't worry about dupes here. + } + set propcmds [struct::set union $propcmds] ;#a way to get rid of dupes. + #$propcmds now holds all Properties as well as PropertyReads with no corresponding Property on this interface. + foreach property $propcmds { + #puts "\n\n ::p::${child_ID}::$property --->>>>>>>>>>>> ::p::${IFID}::_iface::(GET)$property \n" + interp alias {} ::p::${child_ID}::(GET)$property {} ::p::${IFID}::_iface::(GET)$property ;#used by property reference traces + interp alias {} ::p::${child_ID}::$property {} ::p::${IFID}::_iface::(GET)$property + } + + set propcmds [list] + foreach cmd [info commands ::p::${IFID}::_iface::(SET)*] { + set cmd [namespace tail $cmd] + #may contain multiple results for same prop e.g (GET)x.3 + set cmd [string trimright $cmd 0123456789] + set cmd [string trimright $cmd .] ;#do separately in case cmd name also contains numerals + lappend propcmds [string range $cmd 5 end] ;#don't worry about dupes here. + } + set propcmds [struct::set union $propcmds] ;#a way to get rid of dupes. + #$propcmds now holds all Properties as well as PropertyReads with no corresponding Property on this interface. + foreach property $propcmds { + interp alias {} ::p::${child_ID}::(SET)$property {} ::p::${IFID}::_iface::(SET)$property ;#used by property reference traces + } + + + foreach method [dict keys $o_methods] { + set arglist [dict get $o_methods $method arglist] + set argvals "" + foreach argspec $arglist { + if {[llength $argspec] == 2} { + set a [lindex $argspec 0] + } else { + set a $argspec + } + + if {$a eq "args"} { + append argvals " \{*\}\$args" + } else { + append argvals " \$$a" + } + } + set argvals [string trimleft $argvals] + + #interp alias {} ::p::${child_ID}::$method {} ::p::${IFID}::_iface::$method + + #this proc directly on the object is not *just* a forwarding proc + # - it provides a context in which the 'uplevel 1' from the running interface proc runs + #This (in 2018) is faster than a namespace alias forward to an interface proc which used apply to run in the dynamically calculated namespace (it seems the dynamic namespace stopped it from byte-compiling?) + + #proc calls the method in the interface - which is an interp alias to the head of the implementation chain + + proc ::p::${child_ID}::$method [list _ID_ {*}$arglist] [subst { + ::p::${IFID}::_iface::$method \$_ID_ $argvals + }] + + #proc ::p::${child_ID}::$method [list _ID_ {*}$arglist] [string map [list @m@ $method @ID@ $IFID @argvals@ $argvals] { + # ::p::@ID@::_iface::@m@ $_ID_ @argvals@ + #}] + + } + + #namespace eval ::p::${child_ID} [list namespace export {*}$o_methods] + + #implement property even if interface already compiled because we need to create defaults for each new child obj. + # also need to add alias on base interface + #make sure we are only implementing properties from the current CREATOR + dict for {prop pdef} $o_properties { + set varspace [dict get $pdef varspace] + if {![string length $varspace]} { + set ns ::p::${child_ID} + } else { + if {[string match "::*" $varspace]} { + set ns $varspace + } else { + set ns ::p::${child_ID}::$varspace + } + } + if {[dict exists $pdef default]} { + if {![info exists ${ns}::o_$prop]} { + #apply CREATORS defaults - don't trash existing state for matching property (only apply if var unset) + set ${ns}::o_$prop [dict get $pdef default] + } + } + #! May be replaced by a method with the same name + if {$prop ni [dict keys $o_methods]} { + interp alias {} ::p::${child_ID}::$prop {} ::p::${IFID}::_iface::(GET)$prop + } + interp alias {} ::p::${child_ID}::(GET)$prop {} ::p::${IFID}::_iface::(GET)$prop + interp alias {} ::p::${child_ID}::(SET)$prop {} ::p::${IFID}::_iface::(SET)$prop + } + + + + #variables + #foreach vdef $o_variables { + # if {[llength $vdef] == 2} { + # #there is a default value defined. + # lassign $vdef v default + # if {![info exists ::p::${child_ID}::$v]} { + # set ::p::${child_ID}::$v $default + # } + # } + #} + dict for {vname vdef} $o_variables { + if {[dict exists $vdef default]} { + #there is a default value defined. + set varspace [dict get $vdef varspace] + if {$varspace eq ""} { + set ns ::p::${child_ID} + } else { + if {[string match "::*" $varspace]} { + set ns $varspace + } else { + set ns ::p::${child_ID}::$varspace + } + } + set ${ns}::$vname [dict get $vdef default] + } + } + + #!todo - review. Write tests for cases of multiple constructors! + + #We don't want to the run constructor for each added interface with the same set of args! + #run for last one - rely on constructor authors to use @next@ properly? + if {[llength [set ::p::${IFID}::_iface::o_constructor]]} { + set highest_constructor_IFID $IFID + } + + if {$idx == $idx_count} { + #we are processing the last interface that was added - now run the latest constructor found + if {$highest_constructor_IFID ne ""} { + #at least one interface has a constructor + if {[llength [set ::p::${highest_constructor_IFID}::_iface::o_constructor]]} { + #puts ">>!! running constructor ifid:$highest_constructor_IFID child: $CHILDMAP" + if {[catch {::p::${highest_constructor_IFID}::_iface::(CONSTRUCTOR) [dict create i [dict create this [list [dict get $CHILDMAP invocantdata] ] ]] {*}$args} constructor_error]} { + set constructor_failure 1 + set constructor_errorInfo $::errorInfo ;#cache it immediately. + break + } + } + } + } + + if {[info exists o_unknown]} { + interp alias {} ::p::${IFID}::_iface::(UNKNOWN) {} ::p::${IFID}::_iface::$o_unknown + interp alias {} ::p::${child_ID}::(UNKNOWN) {} ::p::${child_ID}::$o_unknown + + #interp alias {} ::p::${IFID}::_iface::(UNKNOWN) {} ::p::${child_ID}::$o_unknown + #namespace eval ::p::${IFID}::_iface [list namespace unknown $o_unknown] + #namespace eval ::p::${child_ID} [list namespace unknown $o_unknown] + } + } + + if {$constructor_failure} { + if {$is_new_object} { + #is Destroy enough to ensure that no new interfaces or objects were left dangling? + $child .. Destroy + } else { + #object needs to be returned to a sensible state.. + #attempt to rollback all interface additions and object state changes! + puts "!!!!!!!!!!!!!!!!>>>constructor rollback object $child_ID \n\n\n\n" + #remove variables from the object's namespace - which don't exist in the snapshot. + set snap_vars [info vars ${ns_snap}::*] + puts "ns_snap '$ns_snap' vars'${snap_vars}'" + foreach vname [info vars ::p::${child_ID}::*] { + set shortname [namespace tail $vname] + if {"${ns_snap}::$shortname" ni "$snap_vars"} { + #puts "--- >>>>> unsetting $shortname " + unset -nocomplain $vname + } + } + + #restore variables from snapshot - but try to do so with minimal writes (don't want to trigger any unnecessary traces) + #values of vars may also have Changed + #todo - consider traces? what is the correct behaviour? + # - some application traces may have fired before the constructor error occurred. + # Should the rollback now also trigger traces? + #probably yes. + + #we need to test both source and dest var for arrayness - as the failed constructor could have changed the variable type, not just the value + foreach vname $snap_vars { + #puts stdout "@@@@@@@@@@@ restoring $vname" + #flush stdout + + + set shortname [namespace tail $vname] + set target ::p::${child_ID}::$shortname + if {$target in [info vars ::p::${child_ID}::*]} { + set present 1 ;#variable exists in one of 3 forms; array, simple, or 'declared only' + } else { + set present 0 + } + + if {[array exists $vname]} { + #restore 'array' variable + if {!$present} { + array set $target [array get $vname] + } else { + if {[array exists $target]} { + #unset superfluous elements + foreach key [array names $target] { + if {$key ni [array names $vname]} { + array unset $target $key + } + } + #.. and write only elements that have changed. + foreach key [array names $vname] { + if {[set ${target}($key)] ne [set ${vname}($key)]} { + set ${target}($key) [set ${vname}($key)] + } + } + } else { + #target has been changed to a simple variable - unset it and recreate the array. + unset $target + array set $target [array get $vname] + } + } + } elseif {[info exists $vname]} { + #restore 'simple' variable + if {!$present} { + set $target [set $vname] + } else { + if {[array exists $target]} { + #target has been changed to array - unset it and recreate the simple variable. + unset $target + set $target [set $vname] + } else { + if {[set $target] ne [set $vname]} { + set $target [set $vname] + } + } + } + } else { + #restore 'declared' variable + if {[array exists $target] || [info exists $target]} { + unset -nocomplain $target + } + namespace eval ::p::${child_ID} [list variable $shortname] + } + } + } + namespace delete $ns_snap + return -code error -errorinfo "oid:${child_ID} constructor_failure for IFID:${IFID}\n$constructor_errorInfo" $constructor_error + } + namespace delete $ns_snap + + } + + return $child +} + +dict set ::p::-1::_iface::o_methods Clone {arglist {clone args}} +#A cloned individual doesn't have the scars of its parent. i.e values (state) not *copied* +# (new 'clean' object with same structure. values as set by constructor or *specified by defaults*) +# Also: Any 'open' interfaces on the parent become closed on clone! +proc ::p::-1::Clone {_ID_ clone args} { + set OID [::p::obj_get_this_oid $_ID_] + ::p::map $OID MAP + + set invocants [dict get $_ID_ i] + lassign [dict get $MAP invocantdata] OID alias parent_defaultmethod cmd + + set _cmd [string map {::> ::} $cmd] + set tail [namespace tail $_cmd] + + + #obsolete? + ##set IFID0 [lindex $map 1 0 end] + #set IFID0 [lindex [dict get $MAP interfaces level0] end] + ##set IFID1 [lindex $map 1 1 end] + #set IFID1 [lindex [dict get $MAP interfaces level1] end] + + + if {![string match "::*" $clone]} { + if {[set ns [uplevel 1 {namespace current}]] eq "::"} { + set clone ::$clone + } else { + set clone ${ns}::$clone + } + } + + + set clone [namespace qualifiers $clone]::>[string trimleft [namespace tail $clone] >] + set _clone [string map {::> ::} $clone] + + + set cTail [namespace tail $_clone] + + set ns [namespace qualifiers $clone] + if {$ns eq ""} { + set ns "::" + } + + namespace eval $ns {} + + + #if {![llength [info commands $clone]]} {} + if {[namespace which $clone] eq ""} { + set clonemapdata [::p::internals::new_object $clone] + } else { + #overlay/mixin case - target/clone already exists + #set CLONEMAP [lindex [interp alias {} [namespace origin $clone]] 1] + set clonemapdata [$clone --] + } + set clone_ID [lindex [dict get $clonemapdata invocantdata] 0] + + upvar #0 ::p::${clone_ID}::_meta::map CLONEMAP + + + #copy patterndata element of MAP straight across + dict set CLONEMAP patterndata [dict get $MAP patterndata] + set CLONE_INVOCANTDATA [dict get $CLONEMAP invocantdata] + lset CLONE_INVOCANTDATA 2 $parent_defaultmethod + dict set CLONEMAP invocantdata $CLONE_INVOCANTDATA + lassign $CLONE_INVOCANTDATA clone_ID clone_alias clone_defaultmethod clone + + #update the clone's _ID_ + interp alias {} $clone_alias {} ;#first we must delete it + interp alias {} $clone_alias {} ::p::internals::predator [list i [list this [list $CLONE_INVOCANTDATA] ] context {}] + + #! object_command was initially created as the renamed alias - so we have to do it again + rename $clone_alias $clone + trace add command $clone rename [list $clone .. Rename] + + + + + #obsolete? + #upvar ::p::${clone_ID}:: clone_INFO + #upvar ::p::${IFID0}:: IFACE ;#same interface on predecessor(self) and clone. + #upvar ::p::${OID}:: INFO + + + array set clone_INFO [array get INFO] + + array set ::p::${clone_ID}::_iface::o_usedby [list] ;#'usedby' + + + #!review! + #if {![catch {set itemCmd $IFACE(m-1,name,item)}]} { + #puts "***************" + #puts "clone" + #parray IFINFO + #puts "***************" + #} + + #we need the parent(s) in order to 'clone'??? - probably, as the defs are usually there unless the object was created with ad-hoc methods/props directly from ::>pattern + + + #clone's interface maps must be a superset of original's + foreach lev {0 1} { + #set parent_ifaces [lindex $map 1 $lev] + set parent_ifaces [dict get $MAP interfaces level$lev] + + #set existing_ifaces [lindex $CLONEMAP 1 $lev] + set existing_ifaces [dict get $CLONEMAP interfaces level$lev] + + set added_ifaces_$lev [list] + foreach ifid $parent_ifaces { + if {$ifid ni $existing_ifaces} { + + #interface must not remain extensible after cloning. + if {[set ::p::${ifid}::_iface::o_open]} { + ::p::predator::compile_interface $ifid $_ID_ + set ::p::${ifid}::_iface::o_open 0 + } + + + + lappend added_ifaces_$lev $ifid + #clone 'uses' all it's predecessor's interfaces, so update each interface's 'usedby' list. + set ::p::${ifid}::_iface::o_usedby(i$clone_ID) $clone + } + } + set extracted_sub_dict [dict get $CLONEMAP interfaces] + dict set extracted_sub_dict level$lev [concat $existing_ifaces [set added_ifaces_$lev]] + dict set CLONEMAP interfaces $extracted_sub_dict + #lset CLONEMAP 1 $lev [concat $existing_ifaces [set added_ifaces_$lev]] + } + + #interp alias {} ::p::${IFID0}::(VIOLATE) {} ::p::internals::(VIOLATE) + + + #foreach *added* level0 interface.. + foreach ifid $added_ifaces_0 { + namespace upvar ::p::${ifid}::_iface o_methods o_methods o_properties o_properties o_variables o_variables o_constructor o_constructor o_unknown o_unknown + + + dict for {prop pdef} $o_properties { + #lassign $pdef prop default + if {[dict exists $pdef default]} { + set varspace [dict get $pdef varspace] + if {$varspace eq ""} { + set ns ::p::${clone_ID} + } else { + if {[string match "::*" $varspace]} { + set ns $varspace + } else { + set ns ::p::${clone_ID}::$varspace + } + } + + if {![info exists ${ns}::o_$prop]} { + #apply CREATORS defaults - don't trash existing state for matching property (only apply if var unset) + set ${ns}::o_$prop [dict get $pdef default] + } + } + + #! May be replaced by method of same name + if {[namespace which ::p::${clone_ID}::$prop] eq ""} { + interp alias {} ::p::${clone_ID}::$prop {} ::p::${ifid}::_iface::(GET)$prop + } + interp alias {} ::p::${clone_ID}::(GET)$prop {} ::p::${ifid}::_iface::(GET)$prop + interp alias {} ::p::${clone_ID}::(SET)$prop {} ::p::${ifid}::_iface::(SET)$prop + } + + #variables + dict for {vname vdef} $o_variables { + if {[dict exists $vdef default]} { + set varspace [dict get $vdef varspace] + if {$varspace eq ""} { + set ns ::p::${clone_ID} + } else { + if {[string match "::*" $varspace]} { + set ns $varspace + } else { + set ns ::p::${clone_ID}::$varspace + } + } + if {![info exists ${ns}::$vname]} { + set ::p::${clone_ID}::$vname [dict get $vdef default] + } + } + } + + + #update the clone object's base interface to reflect the new methods. + #upvar 0 ::p::${ifid}:: IFACE + #set methods [list] + #foreach {key mname} [array get IFACE m-1,name,*] { + # set method [lindex [split $key ,] end] + # interp alias {} ::p::${clone_ID}::$method {} ::p::${ifid}::_iface::$method $CLONEMAP + # lappend methods $method + #} + #namespace eval ::p::${clone_ID} [list namespace export {*}$methods] + + + foreach method [dict keys $o_methods] { + + set arglist [dict get $o_methods $method arglist] + set argvals "" + foreach argspec $arglist { + if {[llength $argspec] == 2} { + set a [lindex $argspec 0] + } else { + set a $argspec + } + + if {$a eq "args"} { + append argvals " \{*\}\$args" + } else { + append argvals " \$$a" + } + } + set argvals [string trimleft $argvals] + #interp alias {} ::p::${clone_ID}::$method {} ::p::${ifid}::_iface::$method + + #this proc directly on the object is not *just* a forwarding proc + # - it provides a context in which the 'uplevel 1' from the running interface proc runs + #This (in 2018) is faster than a namespace alias forward to an interface proc which used apply to run in the dynamically calculated namespace (it seems the dynamic namespace stopped it from byte-compiling?) + + #proc calls the method in the interface - which is an interp alias to the head of the implementation chain + proc ::p::${clone_ID}::$method [list _ID_ {*}$arglist] [subst { + ::p::${ifid}::_iface::$method \$_ID_ $argvals + }] + + } + #namespace eval ::p::${clone_ID} [list namespace export {*}$o_methods] + + + if {[info exists o_unknown]} { + #interp alias {} ::p::${IID}::_iface::(UNKNOWN) {} ::p::${clone_ID}::$o_unknown + interp alias {} ::p::${IID}::_iface::(UNKNOWN) {} ::p::${IID}::_iface::$o_unknown + interp alias {} ::p::${clone_ID}::(UNKNOWN) {} ::p::${clone_ID}::$o_unknown + + #namespace eval ::p::${IID}::_iface [list namespace unknown $o_unknown] + #namespace eval ::p::${clone_ID} [list namespace unknown $o_unknown] + + } + + + #2021 + #Consider >parent with constructor that sets height + #.eg >parent .. Constructor height { + # set o_height $height + #} + #>parent .. Create >child 5 + # - >child has height 5 + # now when we peform a clone operation - it is the >parent's constructor that will run. + # A clone will get default property and var values - but not other variable values unless the constructor sets them. + #>child .. Clone >fakesibling 6 + # - >sibling has height 6 + # Consider if >child had it's own constructor created with .. Construct prior to the clone operation. + # The >child's constructor didn't run - even though we created a >fakesibling - because the paren'ts one ran instead. + # If we now add a constructor to >fakesibling - and put @next@ for constructor chaining... + # when we now do >sibling .. Create >grandchild + # - The constructor on >sibling runs first but chains to >child - the cloner aunt/uncle of the >grandchild + # (while the calling order can't be changed - the positioning of @next@ tag in the contructor can allow code to run before and/or after the chained constructors and chaining can be disabled by providing a constructor without this tag.) + # However - the args supplied in the >clone operation don't get either constructor running on the >grandchild + #(though other arguments can be manually passed) + # #!review - does this make sense? What if we add + # + #constructor for each interface called after properties initialised. + #run each interface's constructor against child object, using the args passed into this clone method. + if {[llength [set constructordef [set o_constructor]]]} { + #error + puts "!!!!!> running constructor for ifid:$ifid on clone:$clone_ID" + ::p::${ifid}::_iface::(CONSTRUCTOR) [dict create i [dict create this [list [dict get $CLONEMAP invocantdata]] ]] {*}$args + + } + + } + + + return $clone + +} + + + +interp alias {} ::p::-1::constructor {} ::p::-1::Constructor ;#for Define compatibility (snit?) +dict set ::p::-1::_iface::o_methods Constructor {arglist {arglist body}} +proc ::p::-1::Constructor {_ID_ arglist body} { + set invocants [dict get $_ID_ i] + #set invocant_alias [lindex [dict get $invocants this] 0] + #set invocant [lindex [interp alias {} $invocant_alias] 1] + #lassign [lindex $invocant 0 ] OID alias itemCmd cmd + + set OID [lindex [dict get $_ID_ i this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + + set patterns [dict get $MAP interfaces level1] + set iid_top [lindex $patterns end] ;#!todo - choose 'open' interface to expand. + set iface ::p::ifaces::>$iid_top + + if {(![string length $iid_top]) || ([$iface . isClosed])} { + #no existing pattern - create a new interface + set iid_top [expr {$::p::ID + 1}] ;#PREDICT the next object's id + #set iid_top [::p::get_new_object_id] + + #the >interface constructor takes a list of IDs for o_usedby + set iface [::p::>interface .. Create ::p::ifaces::>$iid_top [list $OID]] + + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level1 [concat $patterns $iid_top] + dict set MAP interfaces $extracted_sub_dict + #lset map {1 1} [concat $patterns $iid_top] + + #::p::predator::remap $invocant + } + set IID $iid_top + + namespace upvar ::p::${IID}::_iface o_open o_open o_constructor o_constructor o_varspace o_varspace o_varspaces o_varspaces + + + # examine the existing command-chain + set maxversion [::p::predator::method_chainhead $IID (CONSTRUCTOR)] + set headid [expr {$maxversion + 1}] + set THISNAME (CONSTRUCTOR).$headid ;#first version will be $method.1 + + set next [::p::predator::next_script $IID (CONSTRUCTOR) $THISNAME $_ID_] + + #set varspaces [::pattern::varspace_list] + set processed [dict create {*}[::p::predator::expand_var_statements $body $o_varspace]] + + if {[llength [dict get $processed varspaces_with_explicit_vars]]} { + foreach vs [dict get $processed varspaces_with_explicit_vars] { + if {[string length $vs] && ($vs ni $o_varspaces)} { + lappend o_varspaces $vs + } + } + set body [dict get $processed body] + } else { + set varDecls [::p::predator::runtime_vardecls] + set body $varDecls\n[dict get $processed body] + #puts stderr "\t runtime_vardecls in Constructor $varDecls" + } + + #set body [string map [::list @this@ "\[lindex \$_ID_ 0 3]" @next@ $next] $body\n] + set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata \] 3\]" @next@ $next] $body\n] + + #puts stderr ---- + #puts stderr $body + #puts stderr ---- + + proc ::p::${IID}::_iface::(CONSTRUCTOR).$headid [concat _ID_ $arglist] $body + interp alias {} ::p::${IID}::_iface::(CONSTRUCTOR) {} ::p::${IID}::_iface::(CONSTRUCTOR).$headid + + + + set o_constructor [list $arglist $body] + set o_open 1 + + return +} + + + +dict set ::p::-1::_iface::o_methods UsedBy {arglist {}} +proc ::p::-1::UsedBy {_ID_} { + return [array get ::p::[lindex [dict get $_ID_ i this] 0 0]::_iface::o_usedby] +} + + +dict set ::p::-1::_iface::o_methods Ready {arglist {}} +proc ::p::-1::Ready {_ID_} { + return [expr {![set ::p::[lindex [dict get $_ID_ i this] 0 0]::_iface::o_open]}] +} + + + +dict set ::p::-1::_iface::o_methods Destroy {arglist {{force 1}}} + +#'force' 1 indicates object command & variable will also be removed. +#'force' 0 is used when the containing namespace is being destroyed anyway - so no need to destroy cmd & var. +#this is necessary for versions of Tcl that have problems with 'unset' being called multiple times. (e.g Tcl 8.5a4) +# +proc ::p::-1::Destroy {_ID_ {force 1}} { + #puts stdout "\t\tDestroy called with _ID_:$_ID_ force:$force caller:[info level 1]" + set invocants [dict get $_ID_ i] + set OID [lindex [dict get $invocants this] 0 0] + + if {$OID eq "null"} { + puts stderr "warning - review code. Destroy called on object with null OID. _ID_:$_ID_" + return + } + + upvar #0 ::p::${OID}::_meta::map MAP + + lassign [dict get $MAP invocantdata] OID alias itemCmd cmd + + + #puts ">>>>>Explicit Destroy $cmd [clock format [clock seconds] -format %H:%M:%S] info-level-1'[info level 1]'<<<<<" ;flush stdout + + #explicit Destroy - remove traces + #puts ">>TRACES: [trace info variable $cmd]" + #foreach tinfo [trace info variable $cmd] { + # trace remove variable $cmd {*}$tinfo + #} + #foreach tinfo [trace info command $cmd] { + # trace remove command $cmd {*}$tinfo + #} + + + set _cmd [string map {::> ::} $cmd] + + #set ifaces [lindex $map 1] + set iface_stacks [dict get $MAP interfaces level0] + #set patterns [lindex $map 2] + set pattern_stacks [dict get $MAP interfaces level1] + + + + set ifaces $iface_stacks + + + set patterns $pattern_stacks + + + #set i 0 + #foreach iflist $ifaces { + # set IFID$i [lindex $iflist 0] + # incr i + #} + + + set IFTOP [lindex $ifaces end] + + set DESTRUCTOR ::p::${IFTOP}::___system___destructor + #may be a proc, or may be an alias + if {[namespace which $DESTRUCTOR] ne ""} { + set temp_ID_ [dict create i [dict create this [list [dict get $MAP invocantdata]]] context {}] + + if {[catch {$DESTRUCTOR $temp_ID_} prob]} { + #!todo - ensure correct calling order of interfaces referencing the destructor proc + + + #!todo - emit destructor errors somewhere - logger? + #puts stderr "underlying proc already removed??? ---> $prob" + #puts stderr "--------Destructor Error on interface $IFID0 of Object $OID-------------" + #puts stderr $::errorInfo + #puts stderr "---------------------" + } + } + + + #remove ourself from each interfaces list of referencers + #puts stderr "--- $ifaces" + + foreach var {ifaces patterns} { + + foreach i [set $var] { + + if {[string length $i]} { + if {$i == 2} { + #skip the >ifinfo interface which doesn't maintain a usedby list anyway. + continue + } + + if {[catch { + + upvar #0 ::p::${i}::_iface::o_usedby usedby + + array unset usedby i$OID + + #puts "\n***>>***" + #puts "IFACE: $i usedby: $usedby" + #puts "***>>***\n" + + #remove interface if no more referencers + if {![array size usedby]} { + #puts " **************** DESTROYING unused interface $i *****" + #catch {namespace delete ::p::$i} + + #we happen to know where 'interface' object commands are kept: + + ::p::ifaces::>$i .. Destroy + + } + + } errMsg]} { + #warning + puts stderr "warning: error during destruction of object:$OID (removing usedby reference for interface $i) ([lindex [dict get $MAP invocantdata] 3]) \n $errMsg" + } + } + + } + + } + + set ns ::p::${OID} + #puts "-- destroying objects below namespace:'$ns'" + ::p::internals::DestroyObjectsBelowNamespace $ns + #puts "--.destroyed objects below '$ns'" + + + #set ns ::p::${OID}::_sub + #call .. Destroy on each thing that looks like a pattern object anywhere below our 'user-area' namespace + #( ::p::OBJECT::$OID ) + #puts "\n******** [clock format [clock seconds] -format %H:%M:%S] destroyingobjectsbelownamespace ns: $ns *****\n" + #::p::internals::DestroyObjectsBelowNamespace $ns + + #same for _meta objects (e.g Methods,Properties collections) + #set ns ::p::${OID}::_meta + #::p::internals::DestroyObjectsBelowNamespace $ns + + + + #foreach obj [info commands ${ns}::>*] { + # #Assume it's one of ours, and ask it to die. + # catch {::p::meta::Destroy $obj} + # #catch {$cmd .. Destroy} + #} + #just in case the user created subnamespaces.. kill objects there too. + #foreach sub [namespace children $ns] { + # ::p::internals::DestroyObjectsBelowNamespace $sub + #} + + + #!todo - fix. info vars on the namespace is not enough to detect references which were never set to a value! + #use info commands ::p::${OID}::_ref::* to find all references - including variables never set + #remove variable traces on REF vars + #foreach rv [info vars ::p::${OID}::_ref::*] { + # foreach tinfo [trace info variable $rv] { + # #puts "-->removing traces on $rv: $tinfo" + # trace remove variable $rv {*}$tinfo + # } + #} + + #!todo - write tests + #refs create aliases and variables at the same place + #- but variable may not exist if it was never set e.g if it was only used with info exists + foreach rv [info commands ::p::${OID}::_ref::*] { + foreach tinfo [trace info variable $rv] { + #puts "-->removing traces on $rv: $tinfo" + trace remove variable $rv {*}$tinfo + } + } + + + + + + + + #if {[catch {namespace delete $nsMeta} msg]} { + # puts stderr "-----&&&&&&&&&&&&&& ERROR deleting NS $nsMeta : $msg " + #} else { + # #puts stderr "------ -- -- -- -- deleted $nsMeta " + #} + + + #!todo - remove + #temp + #catch {interp alias "" ::>$OID ""} + + if {$force} { + #rename $cmd {} + + #removing the alias will remove the command - even if it's been renamed + interp alias {} $alias {} + + #if {[catch {rename $_cmd {} } why]} { + # #!todo - work out why some objects don't have matching command. + # #puts stderr "\t rename $_cmd {} failed" + #} else { + # puts stderr "\t rename $_cmd {} SUCCEEDED!!!!!!!!!!" + #} + + } + + set refns ::p::${OID}::_ref + #puts "[clock format [clock seconds] -format %H:%M:%S] - tidying up namespace $refns" + #puts "- children: [llength [namespace children $refns]]" + #puts "- vars : [llength [info vars ${refns}::*]]" + #puts "- commands: [llength [info commands ${refns}::*]]" + #puts "- procs : [llength [info procs ${refns}::*]]" + #puts "- aliases : [llength [lsearch -all -inline [interp aliases {}] ${refns}::*]]" + #puts "- matching command: [llength [info commands ${refns}]]" + #puts "[clock format [clock seconds] -format %H:%M:%S] - tidyup DONE $refns" + + + #foreach v [info vars ${refns}::*] { + # unset $v + #} + #foreach p [info procs ${refns}::*] { + # rename $p {} + #} + #foreach a [lsearch -all -inline [interp aliases {}] ${refns}::*] { + # interp alias {} $a {} + #} + + + #set ts1 [clock seconds] + #puts "[clock format $ts1 -format %H:%M:%S] $cmd about to delete $refns." + #puts "- children: [llength [namespace children $refns]]" + #puts "- vars : [llength [info vars ${refns}::*]]" + + #puts "- commands: [llength [info commands ${refns}::*]]" + #puts "- procs : [llength [info procs ${refns}::*]]" + #puts "- aliases : [llength [lsearch -all -inline [interp aliases {}] ${refns}::*]]" + #puts "- exact command: [info commands ${refns}]" + + + + + #puts "--delete ::p::${OID}::_ref" + if {[namespace exists ::p::${OID}::_ref]} { + #could just catch.. but would rather know if there's some other weird reason the namespace can't be deleted. + namespace delete ::p::${OID}::_ref:: + } + set ts2 [clock seconds] + #puts "[clock format $ts2 -format %H:%M:%S] $cmd deleted $refns. ELAPSED: [expr {$ts2 - $ts1}]" + + + #delete namespace where instance variables reside + #catch {namespace delete ::p::$OID} + namespace delete ::p::$OID + + #puts "...... destroyed $cmd [clock format [clock seconds] -format %H:%M:%S] <<<<<" ;flush stdout + return +} + + +interp alias {} ::p::-1::destructor {} ::p::-1::Destructor ;#for Define compatibility + + +dict set ::p::-1::_iface::o_methods Destructor {arglist {args}} +#!todo - destructor arguments? e.g to be able to mark for destruction on next sweep of some collector as opposed to immediate destruction? +#install a Destructor on the invocant's open level1 interface. +proc ::p::-1::Destructor {_ID_ args} { + set OID [::p::obj_get_this_oid $_ID_] + ::p::map $OID MAP + + #lassign [lindex $map 0] OID alias itemCmd cmd + + set patterns [dict get $MAP interfaces level1] + + if {[llength $args] > 2} { + error "too many arguments to 'Destructor' - expected at most 2 (arglist body)" + } + + set existing_IID [lindex $patterns end] ;#!todo - get 'open' interface. + + if {$existing_IID != [set IID [::p::internals::expand_interface $existing_IID]]} { + array unset ::p::${existing_IID}::_iface::o_usedby i$OID + error "NOT TESTED" + set ::p::${IID}::_iface::o_usedby(i$OID) $cmd + + set posn [lsearch $patterns $existing_IID] + + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level1 [concat [lreplace $patterns $posn $posn] $IID] + dict set MAP interfaces $extracted_sub_dict + #lset map {1 1} [concat [lreplace $patterns $posn $posn] $IID] + + #::p::predator::remap $invocant + } + + + set ::p::${IID}::_iface::o_destructor_body [lindex $args end] + + if {[llength $args] > 1} { + #!todo - allow destructor args(?) + set arglist [lindex $args 0] + } else { + set arglist [list] + } + + set ::p::${IID}::_iface::o_destructor_args $arglist + + return +} + + + + + +interp alias {} ::p::-1::method {} ::p::-1::PatternMethod ;#for Define compatibility (with snit) + + +dict set ::p::-1::_iface::o_methods PatternMethod {arglist {method arglist body}} +proc ::p::-1::PatternMethod {_ID_ method arglist body} { + set OID [::p::obj_get_this_oid $_ID_] + ::p::map $OID MAP + lassign [dict get $MAP invocantdata] OID alias default_method object_command _wrapped + + set patterns [dict get $MAP interfaces level1] + set iid_top [lindex $patterns end] ;#!todo - get 'open' interface. + set iface ::p::ifaces::>$iid_top + + if {(![string length $iid_top]) || ([$iface . isClosed])} { + #no existing pattern - create a new interface + set iid_top [expr {$::p::ID + 1}] ;#PREDICT the next object's id + set iface [::p::>interface .. Create ::p::ifaces::>$iid_top $OID] + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level1 [concat $patterns $iid_top] + dict set MAP interfaces $extracted_sub_dict + } + set IID $iid_top + + + namespace upvar ::p::${IID}::_iface o_methods o_methods o_definition o_definition o_varspace o_varspace o_varspaces o_varspaces + + + # examine the existing command-chain + set maxversion [::p::predator::method_chainhead $IID $method] + set headid [expr {$maxversion + 1}] + set THISNAME $method.$headid ;#first version will be $method.1 + + set next [::p::predator::next_script $IID $method $THISNAME $_ID_] + + + set processed [dict create {*}[::p::predator::expand_var_statements $body $o_varspace]] + if {[llength [dict get $processed varspaces_with_explicit_vars]]} { + foreach vs [dict get $processed varspaces_with_explicit_vars] { + if {[string length $vs] && ($vs ni $o_varspaces)} { + lappend o_varspaces $vs + } + } + set body [dict get $processed body] + } else { + set varDecls [::p::predator::runtime_vardecls] ;#dynamic vardecls can access vars from all interfaces of invocant object. + #puts stdout "!!!>!>>>>>$THISNAME VarDecls: $varDecls" + set body $varDecls\n[dict get $processed body] + #puts stderr "\t object $OID runtime_vardecls in PatternMethod $method $varDecls" + } + + + set body [::p::predator::wrap_script_in_apply_object_namespace $o_varspace $body[set body {}] $arglist] + + #set body [string map [::list @this@ "\[lindex \${_ID_} 0 3]" @next@ $next] $body\n] + set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata\] 3\]" @next@ $next] $body[set body {}]\n] + #puts "\t\t--------------------" + #puts "\n" + #puts $body + #puts "\n" + #puts "\t\t--------------------" + proc ::p::${IID}::_iface::$THISNAME [concat _ID_ $arglist] $body + + + + #pointer from method-name to head of the interface's command-chain + interp alias {} ::p::${IID}::_iface::$method {} ::p::${IID}::_iface::$THISNAME + + + + if {$method in [dict keys $o_methods]} { + #error "patternmethod '$method' already present in interface $IID" + set msg "WARNING: patternmethod '$method' already exists on objectid $OID ($object_command). Replacing previous version. (no chaining support here yet...)" + if {[string match "*@next@*" $body]} { + append msg "\n EXTRA-WARNING: method contains @next@" + } + + puts stdout $msg + } else { + dict set o_methods $method [list arglist $arglist] + } + + #::p::-1::update_invocant_aliases $_ID_ + return +} + +#MultiMethod +#invocant_signature records the rolenames and aritys as a dispatch signature to support multimethods which act on any number of invocants +# e.g1 $obj .. MultiMethod add {these 2} $arglist $body +# e.g2 $obj .. MultiMethod add {these n} $arglist $body +# +# e.g3 $collidabletemplate .. MultiMethod collision {vehicles 2 cameras 0..n} $arglist $body +# +# for e.g3 - all vehicles & cameras involved would need to have the interface containing the method named 'collision', with the matching invocant_signature. +# (it is possible for the object, or even the same interface to contain another method named 'collision' with a different signature) +# !todo - review rules for when invocants participating in a multimethod with a particular signature, have different implementations (method from different interfaces) +# - can we avoid the overhead of checking for this at dispatch-time, and simply use which ever implementation we first encounter? +# - should we warn about or enforce a same-implementation rule for all multimethod conflicts found at the time an object-conglomeration is formed? +# - should there be before and after hooks for all invocants involved in a multimethod so they can each add behaviour independent of the shared multimethod code? +# (and how would we define the call order? - presumably as it appears in the conglomerate) +# (or could that be done with a more general method-wrapping mechanism?) +#...should multimethods use some sort of event mechanism, and/or message-passing system? +# +dict set ::p::-1::_iface::o_methods MultiMethod {arglist {method invocant_signature arglist body args}} +proc ::p::-1::MultiMethod {_ID_ method invocant_signature arglist body args} { + set invocants [dict get $_ID_ i] + + error "not implemented" +} + +dict set ::p::-1::_iface::o_methods DefaultMethod {arglist {{methodname "noargsupplied--9e40ec8b-bc31-4400-98b8-d48ee23746c4"}}} +# we could use . to indicate no methodname - as this is one of a few highly confusing names for a method (also for example .. , # -- ) +#we can create a method named "." by using the argprotect operator -- +# e.g >x .. Method -- . {args} $body +#It can then be called like so: >x . . +#This is not guaranteed to work and is not in the test suite +#for now we'll just use a highly unlikely string to indicate no argument was supplied +proc ::p::-1::DefaultMethod {_ID_ {methodname "noargsupplied--9e40ec8b-bc31-4400-98b8-d48ee23746c4"} } { + set non_argument_magicstring "noargsupplied--9e40ec8b-bc31-4400-98b8-d48ee23746c4" + set OID [lindex [dict get $_ID_ i this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + lassign [dict get $MAP invocantdata] OID alias default_method object_command _wrapped + if {$methodname eq $non_argument_magicstring} { + return $default_method + } else { + set extracted_value [dict get $MAP invocantdata] + lset extracted_value 2 $methodname + dict set MAP invocantdata $extracted_value ;#write modified value back + #update the object's command alias to match + interp alias {} $alias {} ;#first we must delete it + interp alias {} $alias {} ::p::internals::predator [list i [list this [list $extracted_value ] ] context {}] + + #! $object_command was initially created as the renamed alias - so we have to do it again + rename $alias $object_command + trace add command $object_command rename [list $object_command .. Rename] + return $methodname + } +} + +dict set ::p::-1::_iface::o_methods PatternDefaultMethod {arglist {{methodname "noargsupplied--9e40ec8b-bc31-4400-98b8-d48ee23746c4"}}} +proc ::p::-1::PatternDefaultMethod {_ID_ {methodname "noargsupplied--9e40ec8b-bc31-4400-98b8-d48ee23746c4"} } { + set non_argument_magicstring "noargsupplied--9e40ec8b-bc31-4400-98b8-d48ee23746c4" + set OID [lindex [dict get $_ID_ i this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + set extracted_patterndata [dict get $MAP patterndata] + set pattern_default_method [dict get $extracted_patterndata patterndefaultmethod] + if {$methodname eq $non_argument_magicstring} { + return $pattern_default_method + } else { + dict set extracted_patterndata patterndefaultmethod $methodname + dict set MAP patterndata $extracted_patterndata + return $methodname + } +} + + +dict set ::p::-1::_iface::o_methods Method {arglist {method arglist bodydef args}} +proc ::p::-1::Method {_ID_ method arglist bodydef args} { + set invocants [dict get $_ID_ i] + + set OID [lindex [dict get $_ID_ i this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + + + set invocant_signature [list] ; + ;# we sort when calculating the sig.. so a different key order will produce the same signature - !todo - this is probably desirable but review anyway. + foreach role [lsort [dict keys $invocants]] { + lappend invocant_signature $role [llength [dict get $invocants $role]] + } + #note: it's expected that by far the most common 'invocant signature' will be {this 1} - which corresponds to a standard method dispatch on a single invocant object - the 'subject' (aka 'this') + + + + lassign [dict get $MAP invocantdata] OID alias default_method object_command + set interfaces [dict get $MAP interfaces level0] + + + + ################################################################################# + if 0 { + set iid_top [lindex $interfaces end] ;#!todo - get 'open' interface + set prev_open [set ::p::${iid_top}::_iface::o_open] + + set iface ::p::ifaces::>$iid_top + + set f_new 0 + if {![string length $iid_top]} { + set f_new 1 + } else { + if {[$iface . isClosed]} { + set f_new 1 + } + } + if {$f_new} { + #create a new interface + set iid_top [expr {$::p::ID + 1}] ;#PREDICT the next object's id + set iface [::p::>interface .. Create ::p::ifaces::>$iid_top $OID] + + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level0 [concat $interfaces $iid_top] + dict set MAP interfaces $extracted_sub_dict + + } + set IID $iid_top + + } + ################################################################################# + + set IID [::p::predator::get_possibly_new_open_interface $OID] + + #upvar 0 ::p::${IID}:: IFACE + + namespace upvar ::p::${IID}::_iface o_methods o_methods o_definition o_definition o_varspace o_varspace o_varspaces o_varspaces + + + #Interface proc + # examine the existing command-chain + set maxversion [::p::predator::method_chainhead $IID $method] + set headid [expr {$maxversion + 1}] + set THISNAME $method.$headid ;#first version will be $method.1 + + if {$method ni [dict keys $o_methods]} { + dict set o_methods $method [list arglist $arglist] + } + + #next_script will call to lower interface in iStack if we are $method.1 + set next [::p::predator::next_script $IID $method $THISNAME $_ID_] ;#last parameter is caller_ID_ + #puts ">!>>$THISNAME>>>>> next: '$next'<<<<<<" + + + #implement + #----------------------------------- + set processed [dict create {*}[::p::predator::expand_var_statements $bodydef $o_varspace]] + if {[llength [dict get $processed varspaces_with_explicit_vars]]} { + foreach vs [dict get $processed varspaces_with_explicit_vars] { + if {[string length $vs] && ($vs ni $o_varspaces)} { + lappend o_varspaces $vs + } + } + set body [dict get $processed body] + set varDecls "" + } else { + set varDecls [::p::predator::runtime_vardecls] ;#dynamic vardecls can access vars from all interfaces of invocant object. + set body $varDecls\n[dict get $processed body] + } + + + set body [::p::predator::wrap_script_in_apply_object_namespace $o_varspace $body $arglist] + + + + #set body [string map [::list @this@ "\[lindex \$_ID_ 0 3 \]" @next@ $next] $body\n] + set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata \] 3\]" @next@ $next] $body\n] + + #if {[string length $varDecls]} { + # puts stdout "\t---------------------------------------------------------------" + # puts stdout "\t----- efficiency warning - implicit var declarations used -----" + # puts stdout "\t-------- $object_command .. Method $method $arglist ---------" + # puts stdout "\t[string map [list \n \t\t\n] $body]" + # puts stdout "\t--------------------------" + #} + #invocants are stored as a nested dict in the Invocant Data parameter (_ID_) under the key 'i', and then the invocant_role + # while 'dict get $_ID_ i this' should always return a single invocant, all roles theoretically return a list of invocants fulfilling that position. + #(as specified by the @ operator during object conglomeration) + #set body [string map [::list @this@ "\[dict get \$_ID_ i this \]" @next@ $next] $body\n] + + #puts stdout "\t\t----------------------------" + #puts stdout "$body" + #puts stdout "\t\t----------------------------" + + proc ::p::${IID}::_iface::$THISNAME [concat _ID_ $arglist] $body + + #----------------------------------- + + #pointer from method-name to head of override-chain + interp alias {} ::p::${IID}::_iface::$method {} ::p::${IID}::_iface::$THISNAME + + + #point to the interface command only. The dispatcher will supply the invocant data + #interp alias {} ::p::${OID}::$method {} ::p::${IID}::_iface::$method + set argvals "" + foreach argspec $arglist { + if {[llength $argspec] == 2} { + set a [lindex $argspec 0] + } else { + set a $argspec + } + if {$a eq "args"} { + append argvals " \{*\}\$args" + } else { + append argvals " \$$a" + } + } + set argvals [string trimleft $argvals] + #this proc directly on the object is not *just* a forwarding proc + # - it provides a context in which the 'uplevel 1' from the running interface proc runs + #This (in 2018) is faster than a namespace alias forward to an interface proc which used apply to run in the dynamically calculated namespace (it seems the dynamic namespace stopped it from byte-compiling?) + + #we point to the method of the same name in the interface - which is an interp alias to the head of the implementation chain + + proc ::p::${OID}::$method [list _ID_ {*}$arglist] [subst { + ::p::${IID}::_iface::$method \$_ID_ $argvals + }] + + if 0 { + if {[llength $argvals]} { + proc ::p::${OID}::$method [list _ID_ {*}$arglist] [string map [list @ID@ [list $_ID_] @iid@ $IID @m@ $method @argl@ $arglist @argv@ $argvals] { + apply {{_ID_ @argl@} {::p::@iid@::_iface::@m@ $_ID_ @argl@}} @ID@ @argv@ + }] + } else { + + proc ::p::${OID}::$method [list _ID_ {*}$arglist] [string map [list @ID@ [list $_ID_] @iid@ $IID @m@ $method @argl@ $arglist] { + apply [list {_ID_ @argl@} {::p::@iid@::_iface::@m@ $_ID_ @argl@} [namespace current]] @ID@ + }] + + } + } + + + #proc ::p::${OID}::$method [list _ID_ {*}$arglist] [subst { + # ::p::${IID}::_iface::$method \$_ID_ $argvals + #}] + + #todo - for o_varspaces + #install ::p::${OID}::${varspace}::$method with interp alias from ::p::${OID}::$method + #- this should work correctly with the 'uplevel 1' procs in the interfaces + + + if {[string length $o_varspace]} { + if {[string match "::*" $o_varspace]} { + namespace eval $o_varspace {} + } else { + namespace eval ::p::${OID}::$o_varspace {} + } + } + + + #if the metainfo collection exists, update it. Don't worry if nonexistant as it will be created if needed. + set colMethods ::p::${OID}::_meta::>colMethods + + if {[namespace which $colMethods] ne ""} { + if {![$colMethods . hasKey $method]} { + $colMethods . add [::p::internals::predator $_ID_ . $method .] $method + } + } + + #::p::-1::update_invocant_aliases $_ID_ + return + #::>pattern .. Create [::>pattern .. Namespace]::>method_??? + #return $method_object +} + + +dict set ::p::-1::_iface::o_methods V {arglist {{glob *}}} +proc ::p::-1::V {_ID_ {glob *}} { + set invocants [dict get $_ID_ i] + #set invocant_alias [lindex [dict get $invocants this] 0] + #set invocant [lindex [interp alias {} $invocant_alias] 1] + + set OID [lindex [dict get $invocants this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + + lassign [dict get $MAP invocantdata] OID alias itemCmd cmd + set ifaces [dict get $MAP interfaces level0] ;#level 0 interfaces + + + + set vlist [list] + foreach IID $ifaces { + dict for {vname vdef} [set ::p::${IID}::_iface::o_variables] { + if {[string match $glob $vname]} { + lappend vlist $vname + } + } + } + return $vlist +} + +#experiment from http://wiki.tcl.tk/4884 +proc p::predator::pipeline {args} { + set lambda {return -level 0} + foreach arg $args { + set lambda [list apply [dict get { + toupper {{lambda input} {string toupper [{*}$lambda $input]}} + tolower {{lambda input} {string tolower [{*}$lambda $input]}} + totitle {{lambda input} {string totitle [{*}$lambda $input]}} + prefix {{lambda pre input} {string cat $pre [{*}$lambda $input]}} + suffix {{lambda suf input} {string cat [{*}$lambda $input] $suf}} + } [lindex $arg 0]] $lambda[set lambda {}] {*}[lrange $arg 1 end]] + } + return $lambda +} + +proc ::p::predator::get_apply_arg_0_oid {} { + set apply_args [lrange [info level 0] 2 end] + puts stderr ">>>>> apply_args:'$apply_args'<<<<" + set invocant [lindex $apply_args 0] + return [lindex [dict get $invocant i this] 0 0] +} +proc ::p::predator::get_oid {} { + #puts stderr "---->> [info level 1] <<-----" + set _ID_ [lindex [info level 1] 1] ;#something like ::p::17::_iface::method.1 {i {this { {16 ::p::16 item ::>thing {} } } }} arg1 arg2 + tailcall lindex [dict get $_ID_ i this] 0 0 +} + +#todo - make sure this is called for all script installations - e.g propertyread etc etc +#Add tests to check code runs in correct namespace +#review - how does 'Varspace' command affect this? +proc ::p::predator::wrap_script_in_apply_object_namespace {varspace body arglist} { + #use 'lindex $a 0' to make sure we only get the variable name. (arglist may have defaultvalues) + set arglist_apply "" + append arglist_apply "\$_ID_ " + foreach a $arglist { + if {$a eq "args"} { + append arglist_apply "{*}\$args" + } else { + append arglist_apply "\$[lindex $a 0] " + } + } + #!todo - allow fully qualified varspaces + if {[string length $varspace]} { + if {[string match ::* $varspace]} { + return "tailcall apply \[list \[list _ID_ $arglist\] \{$body\} $varspace \] $arglist_apply" + } else { + #return "uplevel 1 \[list apply \[list \[list _ID_ $arglist\] \{$body\} ::p::@OID@::$varspace \] $arglist_apply \]\n" + return "tailcall apply \[list \[list _ID_ $arglist\] \{$body\} ::p::@OID@::$varspace \] $arglist_apply" + } + } else { + #return "uplevel 1 \[list apply \[list \[list _ID_ $arglist\] \{$body\} ::p::@OID@ \] $arglist_apply \]\n" + #return "tailcall try \[list apply \[list \[list _ID_ $arglist\] \{$body\} ::p::@OID@ \] $arglist_apply \]" + + set script "tailcall apply \[list \{_ID_" + + if {[llength $arglist]} { + append script " $arglist" + } + append script "\} \{" + append script $body + append script "\} ::p::@OID@\] " + append script $arglist_apply + #puts stderr "\n88888888888888888888888888\n\t$script\n" + #puts stderr "\n77777777777777777777777777\n\ttailcall apply \[list \[list _ID_ $arglist\] \{$body\} ::p::@OID@ \] $arglist_apply" + #return $script + + + #----------------------------------------------------------------------------- + # 2018 candidates + # + #return "tailcall apply \[list \[list _ID_ $arglist\] \{$body\} ::p::@OID@ \] $arglist_apply" ;#ok - but doesn't seem to be bytecompiled + #return "tailcall apply \[list {_ID_ $arglist} {$body} ::p::@OID@ \] $arglist_apply" ;#ok - but doesn't seem to be bytecompiled + + #this has problems with @next@ arguments! (also script variables will possibly interfere with each other) + #faster though. + #return "uplevel 1 \{$body\}" + return "uplevel 1 [list $body]" + #----------------------------------------------------------------------------- + + #set script "apply \[list \[list _ID_ $arglist\] \{$body\}\] $arglist_apply" + #return "uplevel 1 \{$script\}" + + #return "puts stderr --\[info locals\]-- ;apply \[list {_ID_ $arglist} {$body} ::p::\[p::predator::get_oid\] \] $arglist_apply" ;#fail + #return "apply \[list {_ID_ $arglist} {$body} ::p::\[p::predator::get_oid\] \] $arglist_apply" ;#fail + + + + #return "tailcall apply { {_ID_ $arglist} {$body} ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\] } $arglist_apply" ;#wrong + + #return "tailcall apply \[list {_ID_ $arglist} {apply { {_ID_ $arglist} {$body}} $arglist_apply } ::p::@OID@ \] $arglist_apply" ;#wrong ns + + + #experiment with different dispatch mechanism (interp alias with 'namespace inscope') + #----------- + #return "apply { {_ID_ $arglist} {$body}} $arglist_apply" + + + #return "uplevel 1 \{$body\}" ;#do nothing + + #---------- + + #return "tailcall namespace inscope ::p::@OID@ \{apply \{\{_ID_ $arglist\} \{$body\}\}\} $arglist_apply" ;#wrong! doesn't evaluate in the correct namespace (wrong _ID_ ??) + + #return "tailcall apply \{\{_ID_ $arglist\} \{namespace inscope ::p::@OID@ \{$body\}\} \} $arglist_apply" ;#wrong - _ID_ now not available in $body + + #return "tailcall apply \{\{ns _ID_ $arglist\} \{ apply \[list {_ID_ $arglist} \{$body\} \$ns \] $arglist_apply \} \} ::p::@OID@ $arglist_apply" ;#no quicker + + #return "tailcall " + + } +} + + +#Handle 'var' and 'varspace' declarations in method/constructor/destructor/propertyread etc bodies. +#expand 'var' statements inline in method bodies +#The presence of a var statement in any code-branch will cause the processor to NOT insert the implicit default var statements. +# +#concept of 'varspace' to allow separation and/or sharing of contexts for cooperating interfaces +#WARNING: within methods etc, varspace statements affect all following var statements.. i.e varspace not affected by runtime code-branches! +# e.g if 1 {varspace x} else {varspace y} will always leave 'varspace y' in effect for following statements. +#Think of var & varspace statments as a form of compile-time 'macro' +# +#caters for 2-element lists as arguments to var statement to allow 'aliasing' +#e.g var o_thing {o_data mydata} +# this will upvar o_thing as o_thing & o_data as mydata +# +proc ::p::predator::expand_var_statements {rawbody {varspace ""}} { + set body {} + + #keep count of any explicit var statments per varspace in 'numDeclared' array + # don't initialise numDeclared. We use numDeclared keys to see which varspaces have var statements. + + #default varspace is "" + #varspace should only have leading :: if it is an absolute namespace path. + + + foreach ln [split $rawbody \n] { + set trimline [string trim $ln] + + if {$trimline eq "var"} { + #plain var statement alone indicates we don't have any explicit declarations in this branch + # and we don't want implicit declarations for the current varspace either. + #!todo - implement test + + incr numDeclared($varspace) + + #may be further var statements e.g - in other code branches + #return [list body $rawbody varspaces_with_explicit_vars 1] + } elseif {([string range $trimline 0 2] eq "var") && ([string is space [string index $trimline 3]])} { + + #append body " upvar #0 " + #append body " namespace upvar ::p::\[lindex \$_ID_ 0 0 \]${varspace} " + #append body " namespace upvar ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]${varspace} " + + if {$varspace eq ""} { + append body " namespace upvar ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\] " + } else { + if {[string match "::*" $varspace]} { + append body " namespace upvar $varspace " + } else { + append body " namespace upvar ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::${varspace} " + } + } + + #any whitespace before or betw var names doesn't matter - about to use as list. + foreach varspec [string range $trimline 4 end] { + lassign [concat $varspec $varspec] var alias ;#var == alias if varspec only 1 element. + ##append body "::p::\[lindex \$_ID_ 0 0 \]::${varspace}$var $alias " + #append body "::p::\[lindex \$_ID_ 0 0 \]${varspace}$var $alias " + + append body "$var $alias " + + } + append body \n + + incr numDeclared($varspace) + } elseif {([string range $trimline 0 7] eq "varspace") && ([string is space -strict [string index $trimline 8]])} { + # 2021 REVIEW - why do we even need 'varspace x' commands in bodies? - just use 'namespace eval x' ??? + #it is assumed there is a single word following the 'varspace' keyword. + set varspace [string trim [string range $trimline 9 end]] + + if {$varspace in [list {{}} {""}]} { + set varspace "" + } + if {[string length $varspace]} { + #set varspace ::${varspace}:: + #no need to initialize numDeclared($varspace) incr will work anyway. + #if {![info exists numDeclared($varspace)]} { + # set numDeclared($varspace) 0 + #} + + if {[string match "::*" $varspace]} { + append body "namespace eval $varspace {} \n" + } else { + append body "namespace eval ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::$varspace {} \n" + } + + #puts "!!!! here~! namespace eval ::p::\[lindex \$_ID_ 0 0\]$varspace {} " + #append body "namespace eval ::p::\[lindex \$_ID_ 0 0\]$varspace {} \n" + #append body "namespace eval ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]$varspace {} \n" + + #append body "puts \"varspace: created ns ::p::\[lindex \$_ID_ 0 0\]$varspace \"\n" + } + #!review - why? why do we need the magic 'default' name instead of just using the empty string? + #if varspace argument was empty string - leave it alone + } else { + append body $ln\n + } + } + + + + set varspaces [array names numDeclared] + return [list body $body varspaces_with_explicit_vars $varspaces] +} + + + + +#Interface Variables +dict set ::p::-1::_iface::o_methods IV {arglist {{glob *}}} +proc ::p::-1::IV {_ID_ {glob *}} { + set invocants [dict get $_ID_ i] + + set OID [lindex [dict get $invocants this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + lassign [dict get $MAP invocantdata] OID alias itemCmd cmd + set ifaces [dict get $MAP interfaces level0] ;#level 0 interfaces + + + #!todo - test + #return [dict keys ::p::${OID}::_iface::o_variables $glob] + + set members [list] + foreach vname [dict keys [set ::p::${OID}::_iface::o_variables]] { + if {[string match $glob $vname]} { + lappend members $vname + } + } + return $members +} + +dict set ::p::-1::_iface::o_methods MetaMethods {arglist {{glob *}}} +proc ::p::-1::MetaMethods {_ID_ {glob *}} { + upvar ::p::-1::_iface::o_methods metaface_methods + set metamethod_names [lsort [dict keys $metaface_methods]] + if {$glob ne "*"} { + set metamethod_names [lsearch -all -inline $metamethod_names $glob] + } + return $metamethod_names +} + + +dict set ::p::-1::_iface::o_methods Methods {arglist {{idx ""}}} +proc ::p::-1::Methods {_ID_ {idx ""}} { + set invocants [dict get $_ID_ i] + set this_invocant [lindex [dict get $invocants this] 0] + lassign $this_invocant OID _etc + #set map [dict get $this_info map] + set OID [lindex [dict get $_ID_ i this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + + + lassign [dict get $MAP invocantdata] OID alias itemCmd cmd + set ifaces [dict get $MAP interfaces level0] ;#level 0 interfaces + + set col ::p::${OID}::_meta::>colMethods + + if {[namespace which $col] eq ""} { + patternlib::>collection .. Create $col + foreach IID $ifaces { + foreach m [dict keys [set ::p::${IID}::_iface::o_methods]] { + if {![$col . hasIndex $m]} { + #todo - create some sort of lazy-evaluating method object? + #set arglist [dict get [set ::p::${IID}::iface::o_methods] $m arglist] + $col . add [::p::internals::predator $_ID_ . $m .] $m + } + } + } + } + if {[string length $idx]} { + return [$col . item $idx] + } else { + return $col + } +} + +dict set ::p::-1::_iface::o_methods M {arglist {{glob *}}} +proc ::p::-1::M {_ID_ {glob *}} { + set invocants [dict get $_ID_ i] + set this_invocant [lindex [dict get $invocants this] 0] + lassign $this_invocant OID _etc + #set map [dict get $this_info map] + set OID [lindex [dict get $_ID_ i this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + lassign [dict get $MAP invocantdata] OID alias itemCmd cmd + set ifaces [dict get $MAP interfaces level0] ;#level 0 interfaces + set members [list] + foreach IID $ifaces { + lappend members {*}[dict keys [set ::p::${IID}::_iface::o_methods] $glob] + } + return $members +} + +#PatternMethods +dict set ::p::-1::_iface::o_methods PM {arglist {{glob *}}} +proc ::p::-1::PM {_ID_ {glob *}} { + set invocants [dict get $_ID_ i] + set this_invocant [lindex [dict get $invocants this] 0] + lassign $this_invocant OID _etc + #set OID [lindex [dict get $_ID_ i this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + #lassign [dict get $MAP invocantdata] OID alias itemCmd cmd + set ifaces [dict get $MAP interfaces level1] ;#level 1 interfaces + set members [list] + foreach IID $ifaces { + lappend members {*}[dict keys [set ::p::${IID}::_iface::o_methods] $glob] + } + return [lsort $members] +} + + +#review +#Interface Methods +dict set ::p::-1::_iface::o_methods IM {arglist {{glob *}}} +proc ::p::-1::IM {_ID_ {glob *}} { + set invocants [dict get $_ID_ i] + set this_invocant [lindex [dict get $invocants this] 0] + lassign $this_invocant OID _etc + #set map [dict get $this_info map] + set OID [lindex [dict get $_ID_ i this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + + lassign [dict get $MAP invocantdata] OID alias itemCmd cmd + set ifaces [dict get $MAP interfaces level0] ;#level 0 interfaces + + return [dict keys [set ::p::${OID}::_iface::o_methods] $glob] + +} + + + +dict set ::p::-1::_iface::o_methods InterfaceStacks {arglist {}} +proc ::p::-1::InterfaceStacks {_ID_} { + upvar #0 ::p::[lindex [dict get $_ID_ i this] 0 0]::_meta::map MAP + return [dict get $MAP interfaces level0] +} + + +dict set ::p::-1::_iface::o_methods PatternStacks {arglist {}} +proc ::p::-1::PatternStacks {_ID_} { + set OID [lindex [dict get $_ID_ i this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + return [dict get $MAP interfaces level1] +} + + +#!todo fix. need to account for references which were never set to a value +dict set ::p::-1::_iface::o_methods DeletePropertyReferences {arglist {}} +proc ::p::-1::DeletePropertyReferences {_ID_} { + set OID [lindex [dict get $_ID_ i this] 0 0] + set cleared_references [list] + set refvars [info vars ::p::${OID}::_ref::*] + #unsetting vars will clear traces anyway - but we wish to avoid triggering the 'unset' traces - so we will explicitly remove all traces 1st. + foreach rv $refvars { + foreach tinfo [trace info variable $rv] { + set ops {}; set cmd {} + lassign $tinfo ops cmd + trace remove variable $rv $ops $cmd + } + unset $rv + lappend cleared_references $rv + } + + + return [list deleted_property_references $cleared_references] +} + +dict set ::p::-1::_iface::o_methods DeleteMethodReferences {arglist {}} +proc ::p::-1::DeleteMethodReferences {_ID_} { + set OID [lindex [dict get $_ID_ i this] 0 0] + set cleared_references [list] + + set iflist [dict get $MAP interfaces level0] + set iflist_reverse [lreferse $iflist] + #set iflist [dict get $MAP interfaces level0] + + + set refcommands [info commands ::p::${OID}::_ref::*] + foreach c $refcommands { + set reftail [namespace tail $c] + set field [lindex [split $c +] 0] + set field_is_a_method 0 + foreach IFID $iflist_reverse { + if {$field in [dict keys [set ::p::${IFID}::_iface::o_methods]]} { + set field_is_a_method 1 + break + } + } + if {$field_is_a_method} { + #what if it's also a property? + interp alias {} $c {} + lappend cleared_references $c + } + } + + + return [list deleted_method_references $cleared_references] +} + + +dict set ::p::-1::_iface::o_methods DeleteReferences {arglist {}} +proc ::p::-1::DeleteReferences {_ID_} { + set OID [lindex [dict get $_ID_ i this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + lassign [dict get $MAP invocantdata] OID alias default_method this + + set result [dict create] + dict set result {*}[$this .. DeletePropertyReferences] + dict set result {*}[$this .. DeleteMethodReferences] + + return $result +} + +## +#Digest +# +#!todo - review +# -> a variable containing empty string is the same as a non existant variable as far as digest is concerned.. is that bad? (probably!) +# +#!todo - write tests - check that digest changes when properties of contained objects change value +# +#!todo - include method/property/interfaces in digest calc, or provide a separate more comprehensive digest method? +# +dict set ::p::-1::_iface::o_methods Digest {arglist {args}} +proc ::p::-1::Digest {_ID_ args} { + set invocants [dict get $_ID_ i] + # md5 c-version is faster than md4 tcl version... and more likely to be required in the interp for some other purpose anyway. + #set this_invocant [lindex [dict get $invocants this] 0] + #lassign $this_invocant OID _etc + set OID [lindex [dict get $_ID_ i this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + lassign [dict get $MAP invocantdata] _OID alias default_method this + + + set interface_ids [dict get $MAP interfaces level0] + set IFID0 [lindex $interface_ids end] + + set known_flags {-recursive -algorithm -a -indent} + set defaults {-recursive 1 -algorithm md5 -indent ""} + if {[dict exists $args -a] && ![dict exists $args -algorithm]} { + dict set args -algorithm [dict get $args -a] + } + + set opts [dict merge $defaults $args] + foreach key [dict keys $opts] { + if {$key ni $known_flags} { + error "unknown option $key. Expected only: $known_flags" + } + } + + set known_algos {"" raw RAW none NONE md5 MD5 sha256 SHA256} + if {[dict get $opts -algorithm] ni $known_algos} { + error "call to Digest with unknown -algorithm [dict get $opts -algorithm]. Expected one of: $known_algos" + } + set algo [string tolower [dict get $opts -algorithm]] + + # append comma for each var so that all changes in adjacent vars detectable. + # i.e set x 34; set y 5 + # must be distinguishable from: + # set x 3; set y 45 + + if {[dict get $opts -indent] ne ""} { + set state "" + set indent "[dict get $opts -indent]" + } else { + set state "---\n" + set indent " " + } + append state "${indent}object_command: $this\n" + set indent "${indent} " + + #append state "[lindex [interp alias {} $alias] 1]\n" ;#at the very least, include the object's interface state. + append state "${indent}interfaces: [dict get $MAP interfaces]\n";#at the very least, include the object's interface state. + + + #!todo - recurse into 'varspaces' + set varspaces_found [list] + append state "${indent}interfaces:\n" + foreach IID $interface_ids { + append state "${indent} - interface: $IID\n" + namespace upvar ::p::${IID}::_iface o_varspace local_o_varspace o_varspaces local_o_varspaces + append state "${indent} varspaces:\n" + foreach vs $local_o_varspaces { + if {$vs ni $varspaces_found} { + lappend varspaces_found $vs + append state "${indent} - varspace: $vs\n" + } + } + } + + append state "${indent}vars:\n" + foreach var [info vars ::p::${OID}::*] { + append state "${indent} - [namespace tail $var] : \"" + if {[catch {append state "[set $var]"}]} { + append state "[array get $var]" + } + append state "\"\n" + } + + if {[dict get $opts -recursive]} { + append state "${indent}sub-objects:\n" + set subargs $args + dict set subargs -indent "$indent " + foreach obj [info commands ::p::${OID}::>*] { + append state "[$obj .. Digest {*}$subargs]\n" + } + + append state "${indent}sub-namespaces:\n" + set subargs $args + dict set subargs -indent "$indent " + foreach ns [namespace children ::p::${OID}] { + append state "${indent} - namespace: $ns\n" + foreach obj [info commands ${ns}::>*] { + append state "[$obj .. Digest {*}$subargs]\n" + } + } + } + + if {$algo in {"" raw none}} { + return $state + } else { + if {$algo eq "md5"} { + package require md5 + return [::md5::md5 -hex $state] + } elseif {$algo eq "sha256"} { + package require sha256 + return [::sha2::sha256 -hex $state] + } elseif {$algo eq "blowfish"} { + package require patterncipher + patterncipher::>blowfish .. Create >b1 + set [>b1 . key .] 12341234 + >b1 . encrypt $state -final 1 + set result [>b1 . ciphertext] + >b1 .. Destroy + + } elseif {$algo eq "blowfish-binary"} { + + } else { + error "can't get here" + } + + } +} + + +dict set ::p::-1::_iface::o_methods Variable {arglist {varname args}} +proc ::p::-1::Variable {_ID_ varname args} { + set invocants [dict get $_ID_ i] + + #set invocant_alias [lindex [dict get $invocants this] 0] + #set invocant [lindex [interp alias {} $invocant_alias] 1] + + set OID [lindex [dict get $invocants this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + #this interface itself is always a co-invocant + lassign [dict get $MAP invocantdata] OID alias itemCmd cmd + set interfaces [dict get $MAP interfaces level0] + + #set existing_IID [lindex $map 1 0 end] + set existing_IID [lindex $interfaces end] + + set prev_openstate [set ::p::${existing_IID}::_iface::o_open] + + if {$existing_IID != [set IID [::p::internals::expand_interface $existing_IID]]} { + #IID changed + #remove ourself from the usedby list of the previous interface + array unset ::p::${existing_IID}::_iface::o_usedby i$OID + set ::p::${IID}::_iface::o_usedby(i$OID) $cmd + + set posn [lsearch $interfaces $existing_IID] + + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level0 [concat [lreplace $interfaces $posn $posn] $IID] + dict set MAP interfaces $extracted_sub_dict + #lset map {1 0} [concat [lreplace $interfaces $posn $posn] $IID] + + + #update original object command + set ::p::${IID}::_iface::o_open 0 + } else { + set ::p::${IID}::_iface::o_open $prev_openstate + } + + set varspace [set ::p::${IID}::_iface::o_varspace] ;#varspace at the time this Variable was added (may differ from default for interface) + + if {[llength $args]} { + #!assume var not already present on interface - it is an error to define twice (?) + #lappend ::p::${IID}::_iface::o_variables [list $varname [lindex $args 0]] + dict set ::p::${IID}::_iface::o_variables $varname [list default [lindex $args 0] varspace $varspace] + + + #Implement if there is a default + #!todo - correct behaviour when overlaying on existing object with existing var of this name? + #if {[string length $varspace]} { + # set ::p::${OID}::${varspace}::$varname [lindex $args 0] + #} else { + set ::p::${OID}::$varname [lindex $args 0] + #} + } else { + #lappend ::p::${IID}::_iface::o_variables [list $varname] + dict set ::p::${IID}::_iface::o_variables $varname [list varspace $varspace] + } + + #varspace '_iface' + + return +} + + +#interp alias {} ::p::-1::variable {} ::p::-1::PatternVariable ;#for Define compatibility + +dict set ::p::-1::_iface::o_methods PatternVariable {arglist {varname args}} +proc ::p::-1::PatternVariable {_ID_ varname args} { + set invocants [dict get $_ID_ i] + + #set invocant_alias [lindex [dict get $invocants this] 0] + #set invocant [lindex [interp alias {} $invocant_alias] 1] + ##this interface itself is always a co-invocant + #lassign [lindex $invocant 0 ] OID alias itemCmd cmd + + set OID [lindex [dict get $invocants this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + + + + set patterns [dict get $MAP interfaces level1] + set iid_top [lindex $patterns end] ;#!todo - get 'open' interface. + set iface ::p::ifaces::>$iid_top + + if {(![string length $iid_top]) || ([$iface . isClosed])} { + #no existing pattern - create a new interface + set iid_top [expr {$::p::ID + 1}] ;#PREDICT the next object's id + set iface [::p::>interface .. Create ::p::ifaces::>$iid_top $OID] + + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level1 [concat $patterns $iid_top] + dict set MAP interfaces $extracted_sub_dict + #lset map {1 1} [concat $patterns $iid_top] + } + set IID $iid_top + + set varspace [set ::p::${IID}::_iface::o_varspace] ;#record varspace against each variable, because default varspace for interface can be modified. + + + if {[llength $args]} { + #lappend ::p::${IID}::_iface::o_variables [list $varname [lindex $args 0]] + dict set ::p::${IID}::_iface::o_variables $varname [list default [lindex $args 0] varspace $varspace] + } else { + dict set ::p::${IID}::_iface::o_variables $varname [list varspace $varspace] + } + + return +} + +dict set ::p::-1::_iface::o_methods Varspaces {arglist args} +proc ::p::-1::Varspaces {_ID_ args} { + set invocants [dict get $_ID_ i] + set OID [lindex [dict get $_ID_ i this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + + if {![llength $args]} { + #query + set iid_top [lindex [dict get $MAP interfaces level0] end] + set iface ::p::ifaces::>$iid_top + if {![string length $iid_top]} { + error "Cannot query Varspaces because no top level interface on object:[lindex [dict get $MAP invocantdata] 3] " + } elseif {[$iface . isClosed]} { + error "Cannot query Varspaces because top level interface (id:$iid_top) is closed on object:[lindex [dict get $MAP invocantdata] 3] " + } + return [set ::p::${iid_top}::_iface::o_varspaces] + } + set IID [::p::predator::get_possibly_new_open_interface $OID] + namespace upvar ::p::${IID}::_iface o_varspace o_varspace o_varspaces o_varspaces + + set varspaces $args + foreach vs $varspaces { + if {[string length $vs] && ($vs ni $o_varspaces)} { + if {[string match ::* $vs]} { + namespace eval $vs {} + } else { + namespace eval ::p::${OID}::$vs {} + } + lappend o_varspaces $vs + } + } + return $o_varspaces +} + +#set or query Varspace. Error to query a closed interface, but if interface closed when writing, itwill create a new open interface +dict set ::p::-1::_iface::o_methods Varspace {arglist args} +# set the default varspace for the interface, so that new methods/properties refer to it. +# varspace may be switched in between various additions of methods/properties so that different methods/properties are using different varspaces. +proc ::p::-1::Varspace {_ID_ args} { + set OID [::p::obj_get_this_oid $_ID_] + ::p::map $OID MAP + + if {![llength $args]} { + #query + set iid_top [lindex [dict get $MAP interfaces level0] end] + set iface ::p::ifaces::>$iid_top + if {![string length $iid_top]} { + error "Cannot query Varspace because no top level interface on object:[lindex [dict get $MAP invocantdata] 3] " + } elseif {[$iface . isClosed]} { + error "Cannot query Varspace because top level interface (id:$iid_top) is closed on object:[lindex [dict get $MAP invocantdata] 3] " + } + return [set ::p::${iid_top}::_iface::o_varspace] + } + set varspace [lindex $args 0] + + #set interfaces [dict get $MAP interfaces level0] + #set iid_top [lindex $interfaces end] + + set IID [::p::predator::get_possibly_new_open_interface $OID] + + + #namespace upvar ::p::${IID}::_iface o_variables o_variables o_properties o_properties o_methods o_methods o_varspace o_varspace + namespace upvar ::p::${IID}::_iface o_varspace o_varspace o_varspaces o_varspaces + + if {[string length $varspace]} { + #ensure namespace exists !? do after list test? + if {[string match ::* $varspace]} { + namespace eval $varspace {} + } else { + namespace eval ::p::${OID}::$varspace {} + } + if {$varspace ni $o_varspaces} { + lappend o_varspaces $varspace + } + } + set o_varspace $varspace +} + + +proc ::p::predator::get_possibly_new_open_interface {OID} { + #we need to re-upvar MAP rather than using a parameter - as we need to write back to it + upvar #0 ::p::${OID}::_meta::map MAP + set interfaces [dict get $MAP interfaces level0] + set iid_top [lindex $interfaces end] + + + set iface ::p::ifaces::>$iid_top + if {(![string length $iid_top]) || ([$iface . isClosed])} { + #no existing pattern - create a new interface + set iid_top [expr {$::p::ID + 1}] ;#PREDICT the next object's id + #puts stderr ">>>>creating new interface $iid_top" + set iface [::p::>interface .. Create ::p::ifaces::>$iid_top $OID] + + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level0 [concat $interfaces $iid_top] + dict set MAP interfaces $extracted_sub_dict + } + + return $iid_top +} + + + + + + + + + + +################################################################################################################################################### + +################################################################################################################################################### +dict set ::p::-1::_iface::o_methods PatternVarspace {arglist {varspace args}} +# set the default varspace for the interface, so that new methods/properties refer to it. +# varspace may be switched in between various additions of methods/properties so that different methods/properties are using different varspaces. +proc ::p::-1::PatternVarspace {_ID_ varspace args} { + set invocants [dict get $_ID_ i] + set OID [lindex [dict get $_ID_ i this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + + set patterns [dict get $MAP interfaces level1] + set iid_top [lindex $patterns end] + + set iface ::p::ifaces::>$iid_top + if {(![string length $iid_top]) || ([$iface . isClosed])} { + #no existing pattern - create a new interface + set iid_top [expr {$::p::ID + 1}] ;#PREDICT the next object's id + set iface [::p::>interface .. Create ::p::ifaces::>$iid_top $OID] + + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level1 [concat $patterns $iid_top] + dict set MAP interfaces $extracted_sub_dict + } + set IID $iid_top + + namespace upvar ::p::${IID}::_iface o_varspace o_varspace o_varspaces o_varspaces + if {[string length $varspace]} { + if {$varspace ni $o_varspaces} { + lappend o_varspaces $varspace + } + } + #o_varspace is the currently active varspace + set o_varspace $varspace +} +################################################################################################################################################### + +#get varspace and default from highest interface - return all interface ids which define it +dict set ::p::-1::_iface::o_methods GetPropertyInfo {arglist {{propnamepattern *}}} +proc ::p::-1::GetPropertyInfo {_ID_ {propnamepattern *}} { + set OID [lindex [dict get $_ID_ i this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + set interfaces [dict get $MAP interfaces level0] + + array set propinfo {} + set found_property_names [list] + #start at the lowest and work up (normal storage order of $interfaces) + foreach iid $interfaces { + set propinfodict [set ::p::${iid}::_iface::o_properties] + set matching_propnames [dict keys $propinfodict $propnamepattern] + foreach propname $matching_propnames { + if {$propname ni $found_property_names} { + lappend found_property_names $propname + } + lappend propinfo($propname,interfaces) $iid + ;#These 2 values for this $propname are overwritten for each iid in the outer loop - we are only interested in the last one + if {[dict exists $propinfodict $propname default]} { + set propinfo($propname,default) [dict get $propinfodict $propname default] + } + set propinfo($propname,varspace) [dict get $propinfodict $propname varspace] + } + } + + set resultdict [dict create] + foreach propname $found_property_names { + set fields [list varspace $propinfo($propname,varspace)] + if {[array exists propinfo($propname,default)]} { + lappend fields default [set propinfo($propname,default)] + } + lappend fields interfaces $propinfo($propname,interfaces) + dict set resultdict $propname $fields + } + return $resultdict +} + + +dict set ::p::-1::_iface::o_methods GetTopPattern {arglist args} +proc ::p::-1::GetTopPattern {_ID_ args} { + set OID [::p::obj_get_this_oid $_ID_] + ::p::map $OID MAP + + set interfaces [dict get $MAP interfaces level1] + set iid_top [lindex $interfaces end] + if {![string length $iid_top]} { + lassign [dict get $MAP invocantdata] OID _alias _default_method object_command + error "No installed level1 interfaces (patterns) for object $object_command" + } + return ::p::ifaces::>$iid_top +} + + + +dict set ::p::-1::_iface::o_methods GetTopInterface {arglist args} +proc ::p::-1::GetTopInterface {_ID_ args} { + set OID [::p::obj_get_this_oid $_ID_] + ::p::map $OID MAP + + set iid_top [lindex [dict get $MAP interfaces level0] end] + if {![string length $iid_top]} { + lassign [dict get $MAP invocantdata] OID _alias _default_method object_command + error "No installed level0 interfaces for object $object_command" + } + return ::p::ifaces::>$iid_top +} + + +dict set ::p::-1::_iface::o_methods GetExpandableInterface {arglist args} +proc ::p::-1::GetExpandableInterface {_ID_ args} { + +} + + + + + +################################################################################################################################################### + +################################################################################################################################################### +dict set ::p::-1::_iface::o_methods Property {arglist {property args}} +proc ::p::-1::Property {_ID_ property args} { + #puts stderr "::p::-1::Property called with _ID_: '$_ID_' property:$property args:$args" + #set invocants [dict get $_ID_ i] + #set invocant_roles [dict keys $invocants] + if {[llength $args] > 1} { + error ".. Property expects 1 or 2 arguments only. (>object .. Property propertyname ?default?)" + } + set OID [::p::obj_get_this_oid $_ID_] + ::p::map $OID MAP + + set interfaces [dict get $MAP interfaces level0] + set iid_top [lindex $interfaces end] + + set prev_openstate [set ::p::${iid_top}::_iface::o_open] + + set iface ::p::ifaces::>$iid_top + + + if {(![string length $iid_top]) || ([$iface . isClosed])} { + #create a new interface + set iid_top [expr {$::p::ID + 1}] ;#PREDICT the next object's id + set iface [::p::>interface .. Create ::p::ifaces::>$iid_top $OID] + + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level0 [concat $interfaces $iid_top] + dict set MAP interfaces $extracted_sub_dict + } + set IID $iid_top + + + namespace upvar ::p::${IID}::_iface o_variables o_variables o_properties o_properties o_methods o_methods o_varspace o_varspace + + + set maxversion [::p::predator::method_chainhead $IID (GET)$property] + set headid [expr {$maxversion + 1}] + set THISNAME (GET)$property.$headid ;#first version will be (GET)$property.1 + + + if {$headid == 1} { + #implementation + #interp alias {} ::p::${IID}::_iface::(GET)$property.1 {} ::p::predator::getprop $property + + #if {$o_varspace eq ""} { + # set ns ::p::${OID} + #} else { + # if {[string match "::*" $o_varspace]} { + # set ns $o_varspace + # } else { + # set ns ::p::${OID}::$o_varspace + # } + #} + #proc ::p::${IID}::_iface::(GET)$property.1 {_ID_ args} [string map [list %prop% $property %varspace% $o_varspace %ns% $ns] [info body ::p::predator::getprop_template_immediate]] + + proc ::p::${IID}::_iface::(GET)$property.1 {_ID_ args} [string map [list %prop% $property %varspace% $o_varspace ] [info body ::p::predator::getprop_template]] + + + #interp alias {} ::p::${IID}::_iface::(SET)$property.1 {} ::p::predator::setprop $property + proc ::p::${IID}::_iface::(SET)$property.1 {_ID_ args} [string map [list %prop% $property %varspace% $o_varspace] [info body ::p::predator::setprop_template]] + + + #chainhead pointers + interp alias {} ::p::${IID}::_iface::(GET)$property {} ::p::${IID}::_iface::(GET)$property.1 + interp alias {} ::p::${IID}::_iface::(SET)$property {} ::p::${IID}::_iface::(SET)$property.1 + + + } + + if {($property ni [dict keys $o_methods])} { + interp alias {} ::p::${IID}::_iface::$property {} ::p::${IID}::_iface::(GET)$property + } + + + + #installation on object + + #namespace eval ::p::${OID} [list namespace export $property] + + + + #obsolete? + #if {$property ni [P $_ID_]} { + #only link objects (GET)/(SET) for this property if property not present on any of our other interfaces + #interp alias {} ::p::${OID}::(GET)$property {} ::p::${IID}::_iface::(GET)$property $invocant + #interp alias {} ::p::${OID}::(SET)$property {} ::p::${IID}::_iface::(SET)$property $invocant + #} + + #link main (GET)/(SET) to this interface + interp alias {} ::p::${OID}::(GET)$property {} ::p::${IID}::_iface::(GET)$property + interp alias {} ::p::${OID}::(SET)$property {} ::p::${IID}::_iface::(SET)$property + + #Only install property if no method of same name already installed here. + #(Method takes precedence over property because property always accessible via 'set' reference) + #convenience pointer to chainhead pointer. + if {$property ni [M $_ID_]} { + interp alias {} ::p::${OID}::$property {} ::p::${IID}::_iface::(GET)$property + } else { + #property with same name as method - we need to make sure the refMisuse_traceHandler is fixed + + + } + + + set varspace [set ::p::${IID}::_iface::o_varspace] + + + + #Install the matching Variable + #!todo - which should take preference if Variable also given a default? + #if {[set posn [lsearch -index 0 $o_variables o_$property]] >= 0} { + # set o_variables [lreplace $o_variables $posn $posn o_$property] + #} else { + # lappend o_variables [list o_$property] + #} + dict set o_variables o_$property [list varspace $varspace] + + + + + if {[llength $args]} { + #should store default once only! + #set IFINFO(v,default,o_$property) $default + + set default [lindex $args end] + + dict set o_properties $property [list default $default varspace $varspace] + + #if {[set posn [lsearch -index 0 $o_properties $property]] >= 0} { + # set o_properties [lreplace $o_properties $posn $posn [list $property $default]] + #} else { + # lappend o_properties [list $property $default] + #} + + if {$varspace eq ""} { + set ns ::p::${OID} + } else { + if {[string match "::*" $varspace]} { + set ns $varspace + } else { + set ns ::p::${OID}::$o_varspace + } + } + + set ${ns}::o_$property $default + #set ::p::${OID}::o_$property $default + } else { + + #if {[set posn [lsearch -index 0 $o_properties $property]] >= 0} { + # set o_properties [lreplace $o_properties $posn $posn [list $property]] + #} else { + # lappend o_properties [list $property] + #} + dict set o_properties $property [list varspace $varspace] + + + #variable ::p::${OID}::o_$property + } + + + + + + #if the metainfo collection exists, update it. Don't worry if nonexistant as it will be created if needed. + #!todo - mark interface dirty (not ready?) instead? - would need all colProperties methods to respect dirty flag & synchronize as needed. (object filter?) + #catch {::p::OBJECT::${OID}::colProperties add [::p::internals::predator $invocant . $property .] $property} + + set colProperties ::p::${OID}::_meta::>colProperties + if {[namespace which $colProperties] ne ""} { + if {![$colProperties . hasKey $property]} { + $colProperties . add [::p::internals::predator $_ID_ . $property .] $property + } + } + + return +} +################################################################################################################################################### + + + +################################################################################################################################################### + +################################################################################################################################################### +interp alias {} ::p::-1::option {} ::p::-1::PatternProperty ;#for Define compatibility +dict set ::p::-1::_iface::o_methods PatternProperty {arglist {property args}} +proc ::p::-1::PatternProperty {_ID_ property args} { + set OID [::p::obj_get_this_oid $_ID_] + ::p::map $OID MAP + + set patterns [dict get $MAP interfaces level1] + set iid_top [lindex $patterns end] + + set iface ::p::ifaces::>$iid_top + + if {(![string length $iid_top]) || ([$iface . isClosed])} { + set iid_top [expr {$::p::ID + 1}] ;#PREDICT the next object's id + set iface [::p::>interface .. Create ::p::ifaces::>$iid_top $OID] + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level1 [concat $patterns $iid_top] + dict set MAP interfaces $extracted_sub_dict + #lset map {1 1} [concat $patterns $iid_top] + } + set IID $iid_top + + namespace upvar ::p::${IID}::_iface o_properties o_properties o_variables o_variables o_varspace o_varspace + + + set maxversion [::p::predator::method_chainhead $IID (GET)$property] + set headid [expr {$maxversion + 1}] + set THISNAME (GET)$property.$headid ;#first version will be (GET)$property.1 + + + + if {$headid == 1} { + #implementation + #interp alias {} ::p::${IID}::_iface::(GET)$property.1 {} ::p::predator::getprop $property + proc ::p::${IID}::_iface::(GET)$property.1 {_ID_ args} [string map [list %prop% $property %varspace% $o_varspace] [info body ::p::predator::getprop_template]] + #interp alias {} ::p::${IID}::_iface::(SET)$property.1 {} ::p::predator::setprop $property + proc ::p::${IID}::_iface::(SET)$property.1 {_ID_ args} [string map [list %prop% $property %varspace% $o_varspace] [info body ::p::predator::setprop_template]] + + + #chainhead pointers + interp alias {} ::p::${IID}::_iface::(GET)$property {} ::p::${IID}::_iface::(GET)$property.1 + interp alias {} ::p::${IID}::_iface::(SET)$property {} ::p::${IID}::_iface::(SET)$property.1 + + } + + if {($property ni [dict keys [set ::p::${IID}::_iface::o_methods]])} { + interp alias {} ::p::${IID}::_iface::$property {} ::p::${IID}::_iface::(GET)$property + } + + set varspace [set ::p::${IID}::_iface::o_varspace] + + #Install the matching Variable + #!todo - which should take preference if Variable also given a default? + #if {[set posn [lsearch -index 0 $o_variables o_$property]] >= 0} { + # set o_variables [lreplace $o_variables $posn $posn o_$property] + #} else { + # lappend o_variables [list o_$property] + #} + dict set o_variables o_$property [list varspace $varspace] + + set argc [llength $args] + + if {$argc} { + if {$argc == 1} { + set default [lindex $args 0] + dict set o_properties $property [list default $default varspace $varspace] + } else { + #if more than one arg - treat as a dict of options. + if {[dict exists $args -default]} { + set default [dict get $args -default] + dict set o_properties $property [list default $default varspace $varspace] + } else { + #no default value + dict set o_properties $property [list varspace $varspace] + } + } + #! only set default for property... not underlying variable. + #lappend ::p::${IID}::_iface::o_variables [list o_$property [lindex $args 0]] + } else { + dict set o_properties $property [list varspace $varspace] + } + return +} +################################################################################################################################################### + + + + + + + + + + + + + + + + + +################################################################################################################################################### + +################################################################################################################################################### +dict set ::p::-1::_iface::o_methods PatternPropertyRead {arglist {property args}} +proc ::p::-1::PatternPropertyRead {_ID_ property args} { + set invocants [dict get $_ID_ i] + + set this_invocant [lindex [dict get $_ID_ i this] 0] ;#assume only one 'this' + set OID [lindex $this_invocant 0] + #set OID [lindex [dict get $_ID_ i this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + lassign [dict get $MAP invocantdata] OID alias defaut_command cmd + + set patterns [dict get $MAP interfaces level1] + set existing_IID [lindex $patterns end] + + set idxlist [::list] + if {[llength $args] == 1} { + set body [lindex $args 0] + } elseif {[llength $args] == 2} { + lassign $args idxlist body + } else { + error "wrong # args: should be \"property body\" or \"property idxlist body\"" + } + + + if {$existing_IID != [set IID [::p::internals::expand_interface $existing_IID]]} { + #remove ourself from the usedby list of the previous interface + array unset ::p::${existing_IID}::_iface::o_usedby i$OID + set ::p::${IID}::_iface::o_usedby(i$OID) $cmd + + set posn [lsearch $patterns $existing_IID] + + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level1 [concat [lreplace $patterns $posn $posn] $IID] + dict set MAP interfaces $extracted_sub_dict + #lset map {1 1} [concat [lreplace $patterns $posn $posn] $IID] + + } else { + set prev_open [set ::p::${existing_IID}::_iface::o_open] + set ::p::${IID}::_iface::o_open $prev_open + } + + namespace upvar ::p::${IID}::_iface o_varspaces o_varspaces o_varspace o_varspace + + set maxversion [::p::predator::method_chainhead $IID (GET)$property] + set headid [expr {$maxversion + 1}] + if {$headid == 1} { + set headid 2 ;#reserve 1 for the getprop of the underlying property + } + + set THISNAME (GET)$property.$headid ;#first version will be (GET)$property.1 + set next [::p::predator::next_script $IID (GET)$property $THISNAME $_ID_] ;#last parameter is caller_ID_ + + + #implement + #----------------------------------- + + + set processed [dict create {*}[::p::predator::expand_var_statements $body $o_varspace]] + if {[llength [dict get $processed varspaces_with_explicit_vars]]} { + foreach vs [dict get $processed varspaces_with_explicit_vars] { + if {[string length $vs] && ($vs ni $o_varspaces)} { + lappend o_varspaces $vs + } + } + set body [dict get $processed body] + } else { + + set varDecls [::p::predator::runtime_vardecls] ;#dynamic vardecls can access vars from all interfaces of invocant object. + set body $varDecls[dict get $processed body] + } + #set body [string map [::list @this@ "\[lindex \$_ID_ 0 3 \]" @next@ $next] $body\n] + set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata \] 3\]" @next@ $next] $body\n] + + + #implementation + if {![llength $idxlist]} { + proc ::p::${IID}::_iface::(GET)$property.$headid {_ID_ args} $body + } else { + #what are we trying to achieve here? .. + proc ::p::${IID}::_iface::(GET)$property.$headid [linsert $idxlist 0 _ID_] $body + } + + + #----------------------------------- + + + #adjust chain-head pointer to point to new head. + interp alias {} ::p::${IID}::_iface::(GET)$property {} ::p::${IID}::_iface::(GET)$property.$headid + + return +} +################################################################################################################################################### + + + + + + + + + + + + +################################################################################################################################################### + +################################################################################################################################################### +dict set ::p::-1::_iface::o_methods PropertyRead {arglist {property args}} +proc ::p::-1::PropertyRead {_ID_ property args} { + set OID [::p::obj_get_this_oid $_ID_] + ::p::map $OID MAP + + #assert $OID ne "null" - dispatcher won't call PropertyRead on a non-object(?) (presumably the call would be to 'Method' instead) + lassign [dict get $MAP invocantdata] OID alias default_command cmd + + set interfaces [dict get $MAP interfaces level0] + set existing_IID [lindex $interfaces end] + + + set idxlist [::list] + if {[llength $args] == 1} { + set body [lindex $args 0] + } elseif {[llength $args] == 2} { + lassign $args idxlist body + } else { + error "wrong # args: should be \"property body\" or \"property idxlist body\"" + } + + + if {$existing_IID != [set IID [::p::internals::expand_interface $existing_IID]]} { + #remove ourself from the usedby list of the previous interface + array unset ::p::${existing_IID}::_iface::o_usedby i$OID + set ::p::${IID}::_iface::o_usedby(i$OID) $cmd + + set posn [lsearch $interfaces $existing_IID] + + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level0 [concat [lreplace $interfaces $posn $posn] $IID] + dict set MAP interfaces $extracted_sub_dict + + set ::p::${IID}::_iface::o_open 0 + } else { + set prev_open [set ::p::${existing_IID}::_iface::o_open] + set ::p::${IID}::_iface::o_open $prev_open + } + namespace upvar ::p::${IID}::_iface o_varspaces o_varspaces o_varspace o_varspace + + #array set ::p::${IID}:: [::list pr,body,$property $body pr,arg,$property $idxlist pr,name,$property $property pr,iface,$property $cmd] + + + set maxversion [::p::predator::method_chainhead $IID (GET)$property] + set headid [expr {$maxversion + 1}] + if {$headid == 1} { + set headid 2 + } + set THISNAME (GET)$property.$headid ;#first version will be (GET)$property.2 - even if corresponding property is missing (we reserve $property.1 for the property itself) + + set next [::p::predator::next_script $IID (GET)$property $THISNAME $_ID_] + + #implement + #----------------------------------- + + set processed [dict create {*}[::p::predator::expand_var_statements $body $o_varspace]] + if {[llength [dict get $processed varspaces_with_explicit_vars]]} { + foreach vs [dict get $processed varspaces_with_explicit_vars] { + if {[string length $vs] && ($vs ni $o_varspaces)} { + lappend o_varspaces $vs + } + } + set body [dict get $processed body] + } else { + set varDecls [::p::predator::runtime_vardecls] ;#dynamic vardecls can access vars from all interfaces of invocant object. + set body $varDecls[dict get $processed body] + } + #set body [string map [::list @this@ "\[lindex \$_ID_ 0 3 \]" @next@ $next] $body\n] + set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata \] 3\]" @next@ $next] $body\n] + + proc ::p::${IID}::_iface::$THISNAME [concat _ID_ $idxlist] $body + + #----------------------------------- + + + + #pointer from prop-name to head of override-chain + interp alias {} ::p::${IID}::_iface::(GET)$property {} ::p::${IID}::_iface::(GET)$property.$headid + + + interp alias {} ::p::${OID}::(GET)$property {} ::p::${IID}::_iface::(GET)$property ;#the reference traces will call this one - in case there is both a property and a method with this name. + if {$property ni [M $_ID_]} { + interp alias {} ::p::${OID}::$property {} ::p::${IID}::_iface::(GET)$property + } +} +################################################################################################################################################### + + + + + + + + + + + + + + +################################################################################################################################################### + +################################################################################################################################################### +dict set ::p::-1::_iface::o_methods PropertyWrite {arglist {property argname body}} +proc ::p::-1::PropertyWrite {_ID_ property argname body} { + set invocants [dict get $_ID_ i] + set OID [lindex [dict get $invocants this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + lassign [dict get $MAP invocantdata] OID alias default_command cmd + + set interfaces [dict get $MAP interfaces level0] + set existing_IID [lindex $interfaces end] ;#!todo - get 'open' interface. + + + + if {$existing_IID != [set IID [::p::internals::expand_interface $existing_IID]]} { + #remove ourself from the usedby list of the previous interface + array unset ::p::${existing_IID}::_iface::o_usedby i$OID + set ::p::${IID}::_iface::o_usedby(i$OID) $cmd + + set posn [lsearch $interfaces $existing_IID] + + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level0 [concat [lreplace $interfaces $posn $posn] $IID] + dict set MAP interfaces $extracted_sub_dict + #lset map {1 0} [concat [lreplace $interfaces $posn $posn] $IID] + + set ::p::${IID}::_iface::o_open 0 + } else { + set prev_open [set ::p::${existing_IID}::_iface::o_open] + set ::p::${IID}::_iface::o_open $prev_open + } + namespace upvar ::p::${IID}::_iface o_varspaces o_varspaces o_varspace o_varspace + + #pw short for propertywrite + #array set ::p::${IID}:: [::list pw,body,$property $body pw,arg,$property $argname pw,name,$property $property pw,iface,$property $cmd] + array set ::p::${IID}:: [::list pw,body,$property $body pw,arg,$property $argname pw,name,$property $property] + + + set maxversion [::p::predator::method_chainhead $IID (SET)$property] + set headid [expr {$maxversion + 1}] + + set THISNAME (SET)$property.$headid + + set next [::p::predator::next_script $IID (SET)$property $THISNAME $_ID_] + + #implement + #----------------------------------- + + set processed [dict create {*}[::p::predator::expand_var_statements $body $o_varspace]] + if {[llength [dict get $processed varspaces_with_explicit_vars]]} { + foreach vs [dict get $processed varspaces_with_explicit_vars] { + if {[string length $vs] && ($vs ni $o_varspaces)} { + lappend o_varspaces $vs + } + } + set body [dict get $processed body] + } else { + set varDecls [::p::predator::runtime_vardecls] ;#dynamic vardecls can access vars from all interfaces of invocant object. + set body $varDecls[dict get $processed body] + } + #set body [string map [::list @this@ "\[lindex \$_ID_ 0 3 \]" @next@ $next] $body\n] + set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata \] 3\]" @next@ $next] $body\n] + + + proc ::p::${IID}::_iface::$THISNAME [list _ID_ $argname] $body + + #----------------------------------- + + + + #pointer from method-name to head of override-chain + interp alias {} ::p::${IID}::_iface::(SET)$property {} ::p::${IID}::_iface::(SET)$property.$headid +} +################################################################################################################################################### + + + + + + + + + + + + + + +################################################################################################################################################### + +################################################################################################################################################### +dict set ::p::-1::_iface::o_methods PatternPropertyWrite {arglist {property argname body}} +proc ::p::-1::PatternPropertyWrite {_ID_ property argname body} { + set invocants [dict get $_ID_ i] + set OID [lindex [dict get $invocants this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + lassign [dict get $MAP invocantdata] OID alias default_command cmd + + + set patterns [dict get $MAP interfaces level1] + set existing_IID [lindex $patterns end] ;#!todo - get 'open' interface. + + + if {$existing_IID != [set IID [::p::internals::expand_interface $existing_IID]]} { + #remove ourself from the usedby list of the previous interface + array unset ::p::${existing_IID}::_iface::o_usedby i$OID + set ::p::${IID}::_iface::o_usedby(i$OID) $cmd + + set existing_ifaces [lindex $map 1 1] + set posn [lsearch $existing_ifaces $existing_IID] + + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level1 [concat [lreplace $existing_ifaces $posn $posn] $IID] + dict set MAP interfaces $extracted_sub_dict + #lset map {1 1} [concat [lreplace $existing_ifaces $posn $posn] $IID] + + #set ::p::${IID}::_iface::o_open 0 + } else { + } + + #pw short for propertywrite + array set ::p::${IID}:: [::list pw,body,$property $body pw,arg,$property $argname pw,name,$property $property pw,iface,$property $cmd] + + + return + +} +################################################################################################################################################### + + + + + + + +################################################################################################################################################### + +################################################################################################################################################### +dict set ::p::-1::_iface::o_methods PropertyUnset {arglist {property arraykeypattern body}} +proc ::p::-1::PropertyUnset {_ID_ property arraykeypattern body} { + set invocants [dict get $_ID_ i] + set OID [lindex [dict get $invocants this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + lassign [dict get $MAP invocantdata] OID alias default_command cmd + + + set interfaces [dict get $MAP interfaces level0] + set existing_IID [lindex $interfaces end] ;#!todo - choose 'open' interface to expand. + + + + if {$existing_IID != [set IID [::p::internals::expand_interface $existing_IID]]} { + #remove ourself from the usedby list of the previous interface + array unset ::p::${existing_IID}::_iface::o_usedby i$OID + set ::p::${IID}::_iface::o_usedby(i$OID) $cmd + + set posn [lsearch $interfaces $existing_IID] + + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level0 [concat [lreplace $interfaces $posn $posn] $IID] + dict set MAP interfaces $extracted_sub_dict + } else { + set prev_open [set ::p::${existing_IID}::_iface::o_open] + set ::p::${IID}::_iface::o_open $prev_open + } + namespace upvar ::p::${IID}::_iface o_varspaces o_varspaces o_varspace o_varspace o_propertyunset_handlers propertyunset_handlers + #upvar ::p::${IID}::_iface::o_propertyunset_handlers propertyunset_handlers + dict set propertyunset_handlers $property [list body $body arraykeypattern $arraykeypattern] + + set maxversion [::p::predator::method_chainhead $IID (UNSET)$property] + set headid [expr {$maxversion + 1}] + + set THISNAME (UNSET)$property.$headid + + set next [::p::predator::next_script $IID (UNSET)$property $THISNAME $_ID_] + + + set processed [dict create {*}[::p::predator::expand_var_statements $body $o_varspace]] + if {[llength [dict get $processed varspaces_with_explicit_vars]]} { + foreach vs [dict get $processed varspaces_with_explicit_vars] { + if {[string length $vs] && ($vs ni $o_varspaces)} { + lappend o_varspaces $vs + } + } + set body [dict get $processed body] + } else { + set varDecls [::p::predator::runtime_vardecls] ;#dynamic vardecls can access vars from all interfaces of invocant object. + set body $varDecls[dict get $processed body] + } + #set body [string map [::list @this@ "\[lindex \$_ID_ 0 3 \]" @next@ $next] $body\n] + set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata \] 3\]" @next@ $next] $body\n] + + #note $arraykeypattern actually contains the name of the argument + if {[string trim $arraykeypattern] eq ""} { + set arraykeypattern _dontcare_ ;# + } + proc ::p::${IID}::_iface::(UNSET)$property.$headid [list _ID_ $arraykeypattern] $body + +#----------------------------------- + + +#pointer from method-name to head of override-chain +interp alias {} ::p::${IID}::_iface::(UNSET)$property {} ::p::${IID}::_iface::(UNSET)$property.$headid + +} +################################################################################################################################################### + + + + + + + + +################################################################################################################################################### + +################################################################################################################################################### +dict set ::p::-1::_iface::o_methods PatternPropertyUnset {arglist {property arraykeypattern body}} +proc ::p::-1::PatternPropertyUnset {_ID_ property arraykeypattern body} { + set invocants [dict get $_ID_ i] + set OID [lindex [dict get $invocants this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + lassign [dict get $MAP invocantdata] OID alias itemCmd cmd + + + set patterns [dict get $MAP interfaces level1] + set existing_IID [lindex $patterns end] ;#!todo - choose 'open' interface to expand. + + + if {$existing_IID != [set IID [::p::internals::expand_interface $existing_IID]]} { + #remove ourself from the usedby list of the previous interface + array unset ::p::${existing_IID}::_iface::o_usedby i$OID + set ::p::${IID}::_iface::o_usedby(i$OID) $cmd + + set posn [lsearch $patterns $existing_IID] + + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level1 [concat [lreplace $patterns $posn $posn] $IID] + dict set MAP interfaces $extracted_sub_dict + #set ::p::${IID}::_iface::o_open 0 + } + + + upvar ::p::${IID}::_iface::o_propertyunset_handlers propertyunset_handlers + dict set propertyunset_handlers $property [list body $body arraykeypattern $arraykeypattern] + + return +} +################################################################################################################################################### + + + +#lappend ::p::-1::_iface::o_methods Implements +#!todo - some way to force overriding of any abstract (empty) methods from the source object +#e.g leave interface open and raise an error when closing it if there are unoverridden methods? + + + + + +#implementation reuse - sugar for >object .. Clone >target +dict set ::p::-1::_iface::o_methods Extends {arglist {pattern}} +proc ::p::-1::Extends {_ID_ pattern} { + if {!([string range [namespace tail $pattern] 0 0] eq ">")} { + error "'Extends' expected a pattern object" + } + set invocants [dict get $_ID_ i] + set OID [lindex [dict get $invocants this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + lassign [dict get $MAP invocantdata] OID alias itemCmd object_command + + + tailcall $pattern .. Clone $object_command +} +#implementation reuse - sugar for >pattern .. Create >target +dict set ::p::-1::_iface::o_methods PatternExtends {arglist {pattern}} +proc ::p::-1::PatternExtends {_ID_ pattern} { + if {!([string range [namespace tail $pattern] 0 0] eq ">")} { + error "'PatternExtends' expected a pattern object" + } + set invocants [dict get $_ID_ i] + set OID [lindex [dict get $invocants this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + lassign [dict get $MAP invocantdata] OID alias itemCmd object_command + + + tailcall $pattern .. Create $object_command +} + + +dict set ::p::-1::_iface::o_methods Extend {arglist {{idx ""}}} +proc ::p::-1::Extend {_ID_ {idx ""}} { + puts stderr "Extend is DEPRECATED - use Expand instead" + tailcall ::p::-1::Expand $_ID_ $idx +} + +#set the topmost interface on the iStack to be 'open' +dict set ::p::-1::_iface::o_methods Expand {arglist {{idx ""}}} +proc ::p::-1::Expand {_ID_ {idx ""}} { + set invocants [dict get $_ID_ i] + set OID [lindex [dict get $invocants this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + set interfaces [dict get $MAP interfaces level0] ;#level 0 interfaces + set iid_top [lindex $interfaces end] + set iface ::p::ifaces::>$iid_top + + if {![string length $iid_top]} { + #no existing interface - create a new one + set iid_top [expr {$::p::ID + 1}] ;#PREDICT the next object's id + set iface [::p::>interface .. Create ::p::ifaces::>$iid_top $OID] + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level0 [list $iid_top] + dict set MAP interfaces $extracted_sub_dict ;#write new interface into map + $iface . open + return $iid_top + } else { + if {[$iface . isOpen]} { + #already open.. + #assume ready to expand.. shared or not! + return $iid_top + } + lassign [dict get $MAP invocantdata] OID alias itemCmd cmd + + if {[$iface . refCount] > 1} { + if {$iid_top != [set IID [::p::internals::expand_interface $iid_top ]]} { + #!warning! not exercised by test suites! + + #remove ourself from the usedby list of the previous interface + array unset ::p::${iid_top}::_iface::o_usedby i$OID + set ::p::${IID}::_iface::o_usedby(i$OID) $cmd + + #remove existing interface & add + set posn [lsearch $interfaces $iid_top] + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level0 [concat [lreplace $interfaces $posn $posn] $IID] + dict set MAP interfaces $extracted_sub_dict + #lset map {1 0} [concat [lreplace $interfaces $posn $posn] $IID] + + + set iid_top $IID + set iface ::p::ifaces::>$iid_top + } + } + } + + $iface . open + return $iid_top +} + +dict set ::p::-1::_iface::o_methods PatternExtend {arglist {{idx ""}}} +proc ::p::-1::PatternExtend {_ID_ {idx ""}} { + puts stderr "PatternExtend is DEPRECATED - use PatternExpand instead" + tailcall ::p::-1::PatternExpand $_ID_ $idx +} + + + +#set the topmost interface on the pStack to be 'open' if it's not shared +# if shared - 'copylink' to new interface before opening for extension +dict set ::p::-1::_iface::o_methods PatternExpand {arglist {{idx ""}}} +proc ::p::-1::PatternExpand {_ID_ {idx ""}} { + set OID [::p::obj_get_this_oid $_ID_] + ::p::map $OID MAP + #puts stderr "no tests written for PatternExpand " + lassign [dict get $MAP invocantdata] OID alias itemCmd cmd + + set ifaces [dict get $MAP interfaces level1] ;#level 1 interfaces + set iid_top [lindex $ifaces end] + set iface ::p::ifaces::>$iid_top + + if {![string length $iid_top]} { + #no existing interface - create a new one + set iid_top [expr {$::p::ID + 1}] ;#PREDICT the next object's id + set iface [::p::>interface .. Create ::p::ifaces::>$iid_top $OID] + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level1 [list $iid_top] + dict set MAP interfaces $extracted_sub_dict + #lset map {1 1} [list $iid_top] + $iface . open + return $iid_top + } else { + if {[$iface . isOpen]} { + #already open.. + #assume ready to expand.. shared or not! + return $iid_top + } + + if {[$iface . refCount] > 1} { + if {$iid_top != [set IID [::p::internals::expand_interface $iid_top]]} { + #!WARNING! not exercised by test suite! + #remove ourself from the usedby list of the previous interface + array unset ::p::${iid_top}::_iface::o_usedby i$OID + set ::p::${IID}::_iface::o_usedby(i$OID) $cmd + + set posn [lsearch $ifaces $iid_top] + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level1 [concat [lreplace $ifaces $posn $posn] $IID] + dict set MAP interfaces $extracted_sub_dict + #lset map {1 1} [concat [lreplace $ifaces $posn $posn] $IID] + + set iid_top $IID + set iface ::p::ifaces::>$iid_top + } + } + } + + $iface . open + return $iid_top +} + + + + + +dict set ::p::-1::_iface::o_methods Properties {arglist {{idx ""}}} +proc ::p::-1::Properties {_ID_ {idx ""}} { + set OID [lindex [dict get $_ID_ i this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + set ifaces [dict get $MAP interfaces level0] ;#level 0 interfaces + + set col ::p::${OID}::_meta::>colProperties + + if {[namespace which $col] eq ""} { + patternlib::>collection .. Create $col + foreach IID $ifaces { + dict for {prop pdef} [set ::p::${IID}::_iface::o_properties] { + if {![$col . hasIndex $prop]} { + $col . add [::p::internals::predator $_ID_ . $prop .] $prop + } + } + } + } + + if {[string length $idx]} { + return [$col . item $idx] + } else { + return $col + } +} + +dict set ::p::-1::_iface::o_methods P {arglist {{glob *}}} +proc ::p::-1::P {_ID_ {glob *}} { + set invocants [dict get $_ID_ i] + set this_invocant [lindex [dict get $invocants this] 0] + lassign $this_invocant OID _etc + set OID [lindex [dict get $_ID_ i this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + set interfaces [dict get $MAP interfaces level0] ;#level 0 interfaces + + set members [list] + foreach IID $interfaces { + lappend members {*}[dict keys [set ::p::${IID}::_iface::o_properties] $glob] + } + return [lsort $members] +} + +#PatternProperties +dict set ::p::-1::_iface::o_methods PP {arglist {{glob *}}} +proc ::p::-1::PP {_ID_ {glob *}} { + set invocants [dict get $_ID_ i] + set this_invocant [lindex [dict get $invocants this] 0] + lassign $this_invocant OID _etc + set OID [lindex [dict get $_ID_ i this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + set interfaces [dict get $MAP interfaces level1] ;#level 1 interfaces + + set members [list] + foreach IID $interfaces { + lappend members {*}[dict keys [set ::p::${IID}::_iface::o_properties] $glob] + } + return [lsort $members] +} + + + +#Interface Properties +dict set ::p::-1::_iface::o_methods IP {arglist {{glob *}}} +proc ::p::-1::IP {_ID_ {glob *}} { + set invocants [dict get $_ID_ i] + set OID [lindex [dict get $invocants this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + set ifaces [dict get $MAP interfaces level0] ;#level 0 interfaces + set members [list] + + foreach m [dict keys [set ::p::${OID}::_iface::o_properties]] { + if {[string match $glob [lindex $m 0]]} { + lappend members [lindex $m 0] + } + } + return $members +} + + +#used by rename.test - theoretically should be on a separate interface! +dict set ::p::-1::_iface::o_methods CheckInvocants {arglist {args}} +proc ::p::-1::CheckInvocants {_ID_ args} { + #check all invocants in the _ID_ are consistent with data stored in their MAP variable + set status "ok" ;#default to optimistic assumption + set problems [list] + + set invocant_dict [dict get $_ID_ i] + set invocant_roles [dict keys $invocant_dict] + + foreach role $invocant_roles { + set invocant_list [dict get $invocant_dict $role] + foreach aliased_invocantdata $invocant_list { + set OID [lindex $aliased_invocantdata 0] + set map_invocantdata [dict get [set ::p::${OID}::_meta::map] invocantdata] + #we use lrange to make sure the lists are in canonical form + if {[lrange $map_invocantdata 0 end] ne [lrange $aliased_invocantdata 0 end]} { + set status "not-ok" + lappend problems [list type "invocant_data_mismatch" invocant_role $role oid $OID command_invocantdata $aliased_invocantdata map_invocantdata $map_invocantdata] + } + } + + } + + + set result [dict create] + dict set result status $status + dict set result problems $problems + + return $result +} + + +#get or set t +dict set ::p::-1::_iface::o_methods Namespace {arglist {args}} +proc ::p::-1::Namespace {_ID_ args} { + #set invocants [dict get $_ID_ i] + #set this_invocant [lindex [dict get $invocants this] 0] + #lassign $this_invocant OID this_info + set OID [lindex [dict get $_ID_ i this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + set IID [lindex [dict get $MAP interfaces level0] end] + + namespace upvar ::p::${IID}::_iface o_varspace active_varspace + + if {[string length $active_varspace]} { + set ns ::p::${OID}::$active_varspace + } else { + set ns ::p::${OID} + } + + #!todo - review.. 'eval' & 'code' subcommands make it too easy to violate the object? + # - should .. Namespace be usable at all from outside the object? + + + if {[llength $args]} { + #special case some of the namespace subcommands. + + #delete + if {[string match "d*" [lindex $args 0]]} { + error "Don't destroy an object's namespace like this. Use '>object .. Destroy' to remove an object." + } + #upvar,ensemble,which,code,origin,expor,import,forget + if {[string range [lindex $args 0] 0 1] in [list "up" "en" "wh" "co" "or" "ex" "im" "fo"]} { + return [namespace eval $ns [list namespace {*}$args]] + } + #current + if {[string match "cu*" [lindex $args 0]]} { + return $ns + } + + #children,eval,exists,inscope,parent,qualifiers,tail + return [namespace {*}[linsert $args 1 $ns]] + } else { + return $ns + } +} + + + + + + + + + + +dict set ::p::-1::_iface::o_methods PatternUnknown {arglist {args}} +proc ::p::-1::PatternUnknown {_ID_ args} { + set invocants [dict get $_ID_ i] + set OID [lindex [dict get $invocants this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + lassign [dict get $MAP invocantdata] OID alias itemCmd cmd + set patterns [dict get $MAP interfaces level1] + set existing_IID [lindex $patterns end] ;#!todo - choose 'open' interface to expand. + + if {$existing_IID != [set IID [::p::internals::expand_interface $existing_IID]]} { + #remove ourself from the usedby list of the previous interface + array unset ::p::${existing_IID}::_iface::o_usedby i$OID + set ::p::${IID}::_iface::o_usedby(i$OID) $cmd + + set posn [lsearch $patterns $existing_IID] + + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level1 [concat [lreplace $patterns $posn $posn] $IID] + dict set MAP interfaces $extracted_sub_dict + #lset map {1 1} [concat [lreplace $patterns $posn $posn] $IID] + #::p::predator::remap $invocant + } + + set handlermethod [lindex $args 0] + + + if {[llength $args]} { + set ::p::${IID}::_iface::o_unknown $handlermethod + return + } else { + set ::p::${IID}::_iface::o_unknown $handlermethod + } + +} + + + +dict set ::p::-1::_iface::o_methods Unknown {arglist {args}} +proc ::p::-1::Unknown {_ID_ args} { + set invocants [dict get $_ID_ i] + set OID [lindex [dict get $invocants this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + + set interfaces [dict get $MAP interfaces level0] + set existing_IID [lindex $interfaces end] ;#!todo - choose 'open' interface to expand. + + set prev_open [set ::p::${existing_IID}::_iface::o_open] + + if {$existing_IID != [set IID [::p::internals::expand_interface $existing_IID]]} { + #remove ourself from the usedby list of the previous interface + array unset ::p::${existing_IID}::_iface::o_usedby i$OID + set ::p::${IID}::_iface::o_usedby(i$OID) $cmd + + set posn [lsearch $interfaces $existing_IID] + + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level0 [concat [lreplace $interfaces $posn $posn] $IID] + dict set MAP interfaces $extracted_sub_dict + #lset map {1 0} [concat [lreplace $interfaces $posn $posn] $IID] + + set ::p::${IID}::_iface::o_open 0 + } else { + set ::p::${IID}::_iface::o_open $prev_open + } + + set handlermethod [lindex $args 0] + + if {[llength $args]} { + set ::p::${IID}::_iface::o_unknown $handlermethod + #set ::p::${IID}::(unknown) $handlermethod + + + #interp alias {} ::p::${IID}::_iface::(UNKNOWN) {} ::p::${OID}::$handlermethod + interp alias {} ::p::${IID}::_iface::(UNKNOWN) {} ::p::${IID}::_iface::$handlermethod + interp alias {} ::p::${OID}::(UNKNOWN) {} ::p::${OID}::$handlermethod + + #namespace eval ::p::${IID}::_iface [list namespace unknown $handlermethod] + #namespace eval ::p::${OID} [list namespace unknown $handlermethod] + + return + } else { + set ::p::${IID}::_iface::o_unknown $handlermethod + } + +} + + +#useful on commandline - can just uparrow and add to it to become ' .. As varname' instead of editing start and end of commandline to make it 'set varname []' +# should also work for non-object results +dict set ::p::-1::_iface::o_methods As {arglist {varname}} +proc ::p::-1::As {_ID_ varname} { + set invocants [dict get $_ID_ i] + #puts stdout "invocants: $invocants" + #!todo - handle multiple invocants with other roles, not just 'this' + + set OID [lindex [dict get $_ID_ i this] 0 0] + if {$OID ne "null"} { + upvar #0 ::p::${OID}::_meta::map MAP + lassign [dict get $MAP invocantdata] OID alias itemCmd cmd + tailcall set $varname $cmd + } else { + #puts stdout "info level 1 [info level 1]" + set role_members [dict get $_ID_ i this] + if {[llength $role_members] == 1} { + set member [lindex $role_members 0] + lassign $member _OID namespace default_method stackvalue _wrapped + tailcall set $varname $stackvalue + } else { + #multiple invocants - return all results as a list + set resultlist [list] + foreach member $role_members { + lassign $member _OID namespace default_method stackvalue _wrapped + lappend resultlist $stackvalue + } + tailcall set $varname $resultlist + } + } +} + +#!todo - AsFileStream ?? +dict set ::p::-1::_iface::o_methods AsFile {arglist {filename args}} +proc ::p::-1::AsFile {_ID_ filename args} { + dict set default -force 0 + dict set default -dumpmethod ".. Digest -algorithm raw" ;#how to serialize/persist an object + set opts [dict merge $default $args] + set force [dict get $opts -force] + set dumpmethod [dict get $opts -dumpmethod] + + + if {[file pathtype $filename] eq "relative"} { + set filename [pwd]/$filename + } + set filedir [file dirname $filename] + if {![sf::file_writable $filedir]} { + error "(method AsFile) ERROR folder $filedir is not writable" + } + if {[file exists $filename]} { + if {!$force} { + error "(method AsFile) ERROR file $filename already exists. Use -force 1 to overwrite" + } + if {![sf::file_writable $filename]} { + error "(method AsFile) ERROR file $filename is not writable - check permissions" + } + } + set fd [open $filename w] + fconfigure $fd -translation binary + + set invocants [dict get $_ID_ i] + set OID [lindex [dict get $_ID_ i this] 0 0] + if {$OID ne "null"} { + upvar #0 ::p::${OID}::_meta::map MAP + lassign [dict get $MAP invocantdata] OID alias itemCmd cmd + #tailcall set $varname $cmd + set object_data [$cmd {*}$dumpmethod] + puts -nonewline $fd $object_data + close $fd + return [list status 1 bytes [string length $object_data] filename $filename] + } else { + #puts stdout "info level 1 [info level 1]" + set role_members [dict get $_ID_ i this] + if {[llength $role_members] == 1} { + set member [lindex $role_members 0] + lassign $member _OID namespace default_method stackvalue _wrapped + puts -nonewline $fd $stackvalue + close $fd + #tailcall set $varname $stackvalue + return [list status 1 bytes [string length $stackvalue] filename $filename] + } else { + #multiple invocants - return all results as a list + set resultlist [list] + foreach member $role_members { + lassign $member _OID namespace default_method stackvalue _wrapped + lappend resultlist $stackvalue + } + puts -nonewline $fd $resultset + close $fd + return [list status 1 bytes [string length $resultset] filename $filename] + #tailcall set $varname $resultlist + } + } + +} + + + +dict set ::p::-1::_iface::o_methods Object {arglist {}} +proc ::p::-1::Object {_ID_} { + set invocants [dict get $_ID_ i] + set OID [lindex [dict get $invocants this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + lassign [dict get $MAP invocantdata] OID alias itemCmd cmd + + set result [string map [list ::> ::] $cmd] + if {![catch {info level -1} prev_level]} { + set called_by "(called by: $prev_level)" + } else { + set called_by "(called by: interp?)" + + } + + puts stdout "\n\nWARNING: '.. Object' calls are now obsolete. Please adjust your code. $called_by ( [info level 1])\n\n" + puts stdout " (returning $result)" + + return $result +} + +#todo: make equivalent to >pattern = cmdname, >pattern . x = cmdname , >pattern # apiname = cmdname +dict set ::p::-1::_iface::o_methods MakeAlias {arglist {cmdname}} +proc ::p::-1::MakeAlias {_ID_cmdname } { + set OID [::p::obj_get_this_oid $_ID_] + upvar #0 ::p::${OID}::_meta::map MAP + lassign [dict get $MAP invocantdata] OID alias itemCmd cmd + + error "concept probably won't work - try making dispatcher understand trailing '= cmdname' " +} +dict set ::p::-1::_iface::o_methods ID {arglist {}} +proc ::p::-1::ID {_ID_} { + set OID [lindex [dict get $_ID_ i this] 0 0] + return $OID +} + +dict set ::p::-1::_iface::o_methods IFINFO {arglist {}} +proc ::p::-1::IFINFO {_ID_} { + puts stderr "--_ID_: $_ID_--" + set OID [::p::obj_get_this_oid $_ID_] + upvar #0 ::p::${OID}::_meta::map MAP + + puts stderr "-- MAP: $MAP--" + + set interfaces [dict get $MAP interfaces level0] + set IFID [lindex $interfaces 0] + + if {![llength $interfaces]} { + puts stderr "No interfaces present at level 0" + } else { + foreach IFID $interfaces { + set iface ::p::ifaces::>$IFID + puts stderr "$iface : [$iface --]" + puts stderr "\tis open: [set ::p::${IFID}::_iface::o_open]" + set variables [set ::p::${IFID}::_iface::o_variables] + puts stderr "\tvariables: $variables" + } + } + +} + + + + +dict set ::p::-1::_iface::o_methods INVOCANTDATA {arglist {}} +proc ::p::-1::INVOCANTDATA {_ID_} { + #same as a call to: >object .. + return $_ID_ +} + +#obsolete? +dict set ::p::-1::_iface::o_methods UPDATEDINVOCANTDATA {arglist {}} +proc ::p::-1::UPDATEDINVOCANTDATA {_ID_} { + #package require dictutils + set updated_ID_ $_ID_ + array set updated_roles [list] + + set invocants [dict get $_ID_ i] + set invocant_roles [dict keys $invocants] + foreach role $invocant_roles { + + set role_members [dict get $invocants $role] + foreach member [dict get $invocants $role] { + #each member is a 2-element list consisting of the OID and a dictionary + #each member is a 5-element list + #set OID [lindex $member 0] + #set object_dict [lindex $member 1] + lassign $member OID alias itemcmd cmd wrapped + + set MAP [set ::p::${OID}::_meta::map] + #if {[dictutils::equal {apply {{key v1 v2} {expr {$v1 eq $v2}}}} $mapvalue [dict get $object_dict map]]} {} + + if {[dict get $MAP invocantdata] eq $member} + #same - nothing to do + + } else { + package require overtype + puts stderr "---------------------------------------------------------" + puts stderr "UPDATEDINVOCANTDATA WARNING: invocantdata in _ID_ not equal to invocantdata in _meta::map - returning updated version" + set col1 [string repeat " " [expr {[string length [dict get $MAP invocantdata]] + 2}]] + puts stderr "[overtype::left $col1 {_ID_ map value}]: $member" + puts stderr "[overtype::left $col1 ::p::${OID}::_meta::map]: [dict get $MAP invocantdata]" + puts stderr "---------------------------------------------------------" + #take _meta::map version + lappend updated_roles($role) [dict get $MAP invocantdata] + } + + } + + #overwrite changed roles only + foreach role [array names updated_roles] { + dict set updated_ID_ i $role [set updated_roles($role)] + } + + return $updated_ID_ +} + + + +dict set ::p::-1::_iface::o_methods INFO {arglist {}} +proc ::p::-1::INFO {_ID_} { + set result "" + append result "_ID_: $_ID_\n" + + set invocants [dict get $_ID_ i] + set invocant_roles [dict keys $invocants] + append result "invocant roles: $invocant_roles\n" + set total_invocants 0 + foreach key $invocant_roles { + incr total_invocants [llength [dict get $invocants $key]] + } + + append result "invocants: ($total_invocants invocant(s) in [llength $invocant_roles] role(s)) \n" + foreach key $invocant_roles { + append result "\t-------------------------------\n" + append result "\trole: $key\n" + set role_members [dict get $invocants $key] ;#usually the role 'this' will have 1 member - but roles can have any number of invocants + append result "\t Raw data for this role: $role_members\n" + append result "\t Number of invocants in this role: [llength $role_members]\n" + foreach member $role_members { + #set OID [lindex [dict get $invocants $key] 0 0] + set OID [lindex $member 0] + append result "\t\tOID: $OID\n" + if {$OID ne "null"} { + upvar #0 ::p::${OID}::_meta::map MAP + append result "\t\tmap:\n" + foreach key [dict keys $MAP] { + append result "\t\t\t$key\n" + append result "\t\t\t\t [dict get $MAP $key]\n" + append result "\t\t\t----\n" + } + lassign [dict get $MAP invocantdata] _OID namespace default_method cmd _wrapped + append result "\t\tNamespace: $namespace\n" + append result "\t\tDefault method: $default_method\n" + append result "\t\tCommand: $cmd\n" + append result "\t\tCommand Alias: [::pattern::which_alias $cmd]\n" + append result "\t\tLevel0 interfaces: [dict get $MAP interfaces level0]\n" + append result "\t\tLevel1 interfaces: [dict get $MAP interfaces level1]\n" + } else { + lassign $member _OID namespace default_method stackvalue _wrapped + append result "\t\t last item on the predator stack is a value not an object" + append result "\t\t Value is: $stackvalue" + + } + } + append result "\n" + append result "\t-------------------------------\n" + } + + + + return $result +} + + + + +dict set ::p::-1::_iface::o_methods Rename {arglist {args}} +proc ::p::-1::Rename {_ID_ args} { + set OID [::p::obj_get_this_oid $_ID_] + if {![llength $args]} { + error "Rename expected \$newname argument" + } + + #Rename operates only on the 'this' invocant? What if there is more than one 'this'? should we raise an error if there is anything other than a single invocant? + upvar #0 ::p::${OID}::_meta::map MAP + + + + #puts ">>.>> Rename. _ID_: $_ID_" + + if {[catch { + + if {([llength $args] == 3) && [lindex $args 2] eq "rename"} { + + #appears to be a 'trace command rename' firing + #puts "\t>>>> rename trace fired $MAP $args <<<" + + lassign $args oldcmd newcmd + set extracted_invocantdata [dict get $MAP invocantdata] + lset extracted_invocantdata 3 $newcmd + dict set MAP invocantdata $extracted_invocantdata + + + lassign $extracted_invocantdata _oid alias _default_method object_command _wrapped + + #Write the same info into the _ID_ value of the alias + interp alias {} $alias {} ;#first we must delete it + interp alias {} $alias {} ::p::internals::predator [list i [list this [list $extracted_invocantdata ] ] context {}] + + + + #! $object_command was initially created as the renamed alias - so we have to do it again + uplevel 1 [list rename $alias $object_command] + trace add command $object_command rename [list $object_command .. Rename] + + } elseif {[llength $args] == 1} { + #let the rename trace fire and we will be called again to do the remap! + uplevel 1 [list rename [lindex [dict get $MAP invocantdata] 3] [lindex $args 0]] + } else { + error "Rename expected \$newname argument ." + } + + } errM]} { + puts stderr "\t@@@@@@ rename error" + set ruler "\t[string repeat - 80]" + puts stderr $ruler + puts stderr $errM + puts stderr $ruler + + } + + return + + +} + +proc ::p::obj_get_invocants {_ID_} { + return [dict get $_ID_ i] +} +#The invocant role 'this' is special and should always have only one member. +# dict get $_ID_ i XXX will always return a list of invocants that are playing role XXX +proc ::p::obj_get_this_oid {_ID_} { + return [lindex [dict get $_ID_ i this] 0 0] +} +proc ::p::obj_get_this_ns {_ID_} { + return [lindex [dict get $_ID_ i this] 0 1] +} + +proc ::p::obj_get_this_cmd {_ID_} { + return [lindex [dict get $_ID_ i this] 0 3] +} +proc ::p::obj_get_this_data {_ID_} { + lassign [dict get [set ::p::[lindex [dict get $_ID_ i this] 0 0]::_meta::map] invocantdata] OID ns _unknown cmd + #set this_invocant_data {*}[dict get $_ID_ i this] + return [list oid $OID ns $ns cmd $cmd] +} +proc ::p::map {OID varname} { + tailcall upvar #0 ::p::${OID}::_meta::map $varname +} + + + diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/oolib-0.1.3.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/oolib-0.1.3.tm new file mode 100644 index 00000000..e44e2a8d --- /dev/null +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/oolib-0.1.3.tm @@ -0,0 +1,200 @@ +#JMN - api should be kept in sync with package patternlib where possible +# + +namespace eval oolib { + oo::class create collection { + variable o_data ;#dict + #variable o_alias + constructor {} { + set o_data [dict create] + } + method info {} { + return [dict info $o_data] + } + method count {} { + return [dict size $o_data] + } + method isEmpty {} { + expr {[dict size $o_data] == 0} + } + method names {{globOrIdx {}}} { + if {[llength $globOrIdx]} { + if {[string is integer -strict $globOrIdx]} { + set idx $globOrIdx + if {$idx < 0} { + set idx "end-[expr {abs($idx + 1)}]" + } + if {[catch {lindex [dict keys $o_data] $idx} result]} { + error "[self object] no such index : '$idx'" + } else { + return $result + } + } else { + #glob + return [lsearch -glob -all -inline [dict keys $o_data] $globOrIdx] + } + } else { + return [dict keys $o_data] + } + } + #like names but without globbing + method keys {} { + dict keys $o_data + } + method key {{posn 0}} { + if {$posn < 0} { + set posn "end-[expr {abs($posn + 1)}]" + } + if {[catch {lindex [dict keys $o_data] $posn} result]} { + error "[self object] no such index : '$posn'" + } else { + return $result + } + } + method hasKey {key} { + dict exists $o_data $key + } + method get {} { + return $o_data + } + method items {} { + return [dict values $o_data] + } + method item {key} { + if {[string is integer -strict $key]} { + if {$key >= 0} { + set valposn [expr {(2*$key) +1}] + return [lindex $o_data $valposn] + } else { + set key "end-[expr {abs($key + 1)}]" + return [lindex $o_data $key] + #return [lindex [dict keys $o_data] $key] + } + } + if {[dict exists $o_data $key]} { + return [dict get $o_data $key] + } + } + #inverse lookup + method itemKeys {value} { + set value_indices [lsearch -all [dict values $o_data] $value] + set keylist [list] + foreach i $value_indices { + set idx [expr {(($i + 1) *2) -2}] + lappend keylist [lindex $o_data $idx] + } + return $keylist + } + method search {value args} { + set matches [lsearch {*}$args [dict values $o_data] $value] + if {"-inline" in $args} { + return $matches + } else { + set keylist [list] + foreach i $matches { + set idx [expr {(($i + 1) *2) -2}] + lappend keylist [lindex $o_data $idx] + } + return $keylist + } + } + #review - see patternlib. Is the intention for aliases to be configurable independent of whether the target exists? + #review - what is the point of alias anyway? - why slow down other operations when a variable can hold a keyname perfectly well? + #method alias {newAlias existingKeyOrAlias} { + # if {[string is integer -strict $newAlias]} { + # error "[self object] collection key alias cannot be integer" + # } + # if {[string length $existingKeyOrAlias]} { + # set o_alias($newAlias) $existingKeyOrAlias + # } else { + # unset o_alias($newAlias) + # } + #} + #method aliases {{key ""}} { + # if {[string length $key]} { + # set result [list] + # foreach {n v} [array get o_alias] { + # if {$v eq $key} { + # lappend result $n $v + # } + # } + # return $result + # } else { + # return [array get o_alias] + # } + #} + ##if the supplied index is an alias, return the underlying key; else return the index supplied. + #method realKey {idx} { + # if {[catch {set o_alias($idx)} key]} { + # return $idx + # } else { + # return $key + # } + #} + method add {value key} { + if {[string is integer -strict $key]} { + error "[self object] collection key must not be an integer. Use another structure if integer keys required" + } + if {[dict exists $o_data $key]} { + error "[self object] col_processors object error: key '$key' already exists in collection" + } + dict set o_data $key $value + return [expr {[dict size $o_data] - 1}] ;#return index of item + } + method remove {idx {endRange ""}} { + if {[string length $endRange]} { + error "[self object] collection error: ranged removal not yet implemented.. remove one item at a time" + } + if {[string is integer -strict $idx]} { + if {$idx < 0} { + set idx "end-[expr {abs($idx+1)}]" + } + set key [lindex [dict keys $o_data] $idx] + set posn $idx + } else { + set key $idx + set posn [lsearch -exact [dict keys $o_data] $key] + if {$posn < 0} { + error "[self object] no such index: '$idx' in this collection" + } + } + dict unset o_data $key + return + } + method clear {} { + set o_data [dict create] + return + } + method reverse_the_collection {} { + #named slightly obtusely because reversing the data when there may be references held is a potential source of bugs + #the name reverse_the_collection should make it clear that the object is being modified in place as opposed to simply 'reverse' which may imply a view/copy. + #todo - consider implementing a get_reverse which provides an interface to the same collection without affecting original references, yet both allowing delete/edit operations. + set dictnew [dict create] + foreach k [lreverse [dict keys $o_data]] { + dict set dictnew $k [dict get $o_data $k] + } + set o_data $dictnew + return + } + #review - cmd as list vs cmd as script? + method map {cmd} { + set seed [list] + dict for {k v} $o_data { + lappend seed [uplevel #0 [list {*}$cmd $v]] + } + return $seed + } + method objectmap {cmd} { + set seed [list] + dict for {k v} $o_data { + lappend seed [uplevel #0 [list $v {*}$cmd]] + } + return $seed + } + } +} + +package provide oolib [namespace eval oolib { + variable version + set version 0.1.3 +}] diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/overtype-1.7.4.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/overtype-1.7.4.tm index 04d0e96b..1ca40672 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/overtype-1.7.4.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/overtype-1.7.4.tm @@ -253,7 +253,6 @@ tcl::namespace::eval overtype { coloured as this doesn't affect the display width. Default is \uFFFD - the unicode replacement char.} - -experimental -default 0 -cp437 -default 0 -type boolean -looplimit -default \uFFEF\ -type integer -help\ "internal failsafe - experimental" @@ -263,7 +262,8 @@ tcl::namespace::eval overtype { -wrap -default 0 -type boolean -info -default 0 -type boolean -help\ "When set to 1, return a dictionary (experimental)" - -binarytext -default "" -type string -choices {"" bios ice} + -format -default ansi -type string -choices {ansi binarytext-bios binarytext-ice xbin} -help\ + "Format of new data being applied as an overlay" -console -default {stdin stdout stderr} -type list @values -min 1 -max 2 @@ -328,7 +328,6 @@ tcl::namespace::eval overtype { -transparent 0 -exposed1 \uFFFD -exposed2 \uFFFD - -experimental 0 -cp437 0 -looplimit \uFFEF -crm_mode 0 @@ -336,7 +335,7 @@ tcl::namespace::eval overtype { -insert_mode 0 -wrap 0 -info 0 - -binarytext "" + -format ansi -console {stdin stdout stderr} }] #expand_right is perhaps consistent with the idea of the page_size being allowed to grow horizontally.. @@ -353,11 +352,11 @@ tcl::namespace::eval overtype { foreach {k v} $argsflags { switch -- $k { -looplimit - -width - -height - -startcolumn - -startrow - -bias - -ellipsis - -ellipsistext - -ellipsiswhitespace - - -transparent - -exposed1 - -exposed2 - -experimental + - -transparent - -exposed1 - -exposed2 - -expand_right - -appendlines - -reverse_mode - -crm_mode - -insert_mode - -cp437 - - -info - -binarytext - -console { + - -info - -format - -console { tcl::dict::set opts $k $v } -wrap - -autowrap_mode { @@ -379,6 +378,7 @@ tcl::namespace::eval overtype { set opt_height [tcl::dict::get $opts -height] set opt_startcolumn [tcl::dict::get $opts -startcolumn] set opt_startrow [tcl::dict::get $opts -startrow] + #review -appendlines - this needs thought regarding interaction with terminal height concept and scrolling set opt_appendlines [tcl::dict::get $opts -appendlines] set opt_transparent [tcl::dict::get $opts -transparent] set opt_ellipsistext [tcl::dict::get $opts -ellipsistext] @@ -397,7 +397,7 @@ tcl::namespace::eval overtype { # -- --- --- --- --- --- set opt_cp437 [tcl::dict::get $opts -cp437] set opt_info [tcl::dict::get $opts -info] - set opt_binarytext [tcl::dict::get $opts -binarytext] + set opt_format [tcl::dict::get $opts -format] set opt_console [tcl::dict::get $opts -console] @@ -416,26 +416,18 @@ tcl::namespace::eval overtype { #} #-------------------------------------------------------------------------- - # ---------------------------- - # -experimental dev flag to set flags etc - # ---------------------------- - set data_mode 0 - set edit_mode 0 - set opt_experimental [tcl::dict::get $opts -experimental] - foreach o $opt_experimental { - switch -- $o { - data_mode { - set data_mode 1 - } - edit_mode { - set edit_mode 1 - } - } - } - # ---------------------------- + #--------------------------------------------------------- + #underblock is expected to be pre-rendered - ie any ANSI codes have already been processed and rendered into the text. + #This is because the underblock is used as the basis for calculating the layout of the output + #- so it needs to be in a form where we can determine the width of each line and how many lines there are. set underblock [tcl::string::map {\r\n \n} $underblock] - set overblock [tcl::string::map {\r\n \n} $overblock] + + #do not split the overblock into lines at this stage - it may contain binary data. + #REVIEW - xbin (or binarytext?) may contain binary data which could be corrupted by mapping \r\n to \n. + #set overblock [tcl::string::map {\r\n \n} $overblock] + #--------------------------------------------------------- + if {$opt_startrow > 1} { set down [expr {$opt_startrow -1}] #when vt52? @@ -471,12 +463,17 @@ tcl::namespace::eval overtype { } insert_mode $opt_insert_mode {*}{ } autowrap_mode $opt_autowrap_mode {*}{ } cp437 $opt_cp437 {*}{ + } row 1 {*}{ + } col 1 {*}{ + } topmargin 1 {*}{ + } bottommargin $renderheight {*}{ } ] #modes #e.g insert_mode can be toggled by insert key or ansi IRM sequence CSI 4 h|l #opt_startcolumn ?? - DECSLRM ? set vtstate $initial_state + dict set vtstate col $opt_startcolumn # -- --- --- --- #REVIEW - do we need ansi resets in the underblock? @@ -484,7 +481,6 @@ tcl::namespace::eval overtype { set blankline [string repeat \u0000 $renderwidth] set underlines [lrepeat $renderheight $blankline] } else { - #---- #this splits into lines - only to rejoin - which is inefficient. #It also has code to handle joining multiple blocks - but we only have one in this case. @@ -498,16 +494,8 @@ tcl::namespace::eval overtype { } else { set underlines [split $underblock \n] } - } - #if {$underblock eq ""} { - # set blank "\x1b\[0m\x1b\[0m" - # #set underlines [list "\x1b\[0m\x1b\[0m"] - # set underlines [lrepeat $renderheight $blank] - #} else { - # #lines_as_list -ansiresets 1 will do nothing if -ansiresets 1 isn't specified - REVIEW - # set underlines [lines_as_list -ansiresets 1 $underblock] - #} + #underlines are not necessarily processed in order - depending on cursor-moves applied from overtext # -- --- --- --- #todo - reconsider the 'line' as the natural chunking mechanism for the overlay. @@ -529,95 +517,82 @@ tcl::namespace::eval overtype { #overblock height/width isn't useful in the presence of an ansi input overlay with movements. The number of lines may bear little relationship to the output height #lassign [blocksize $overblock] _w overblock_width _h overblock_height - set scheme 4 - switch -- $scheme { - 0 { - #one big chunk - set inputchunks [list mixed $overblock] - } - 1 { - #todo - set inputchunks [punk::ansi::ta::split_codes $overblock] - } - 2 { - #todo - #split into lines if possible first - then into plaintext/ansi-sequence chunks ? - set inputchunks [list ""] ;#put an empty plaintext split in for starters - set i 1 - set lines [split $overblock \n] - foreach ln $lines { - if {$i < [llength $lines]} { - append ln \n - } - set sequence_split [punk::ansi::ta::split_codes_single $ln] ;#use split_codes Not split_codes_single? - set lastpt [lindex $inputchunks end] - lset inputchunks end [tcl::string::cat $lastpt [lindex $sequence_split 0]] - lappend inputchunks {*}[lrange $sequence_split 1 end] - incr i - } - } - 3 { - #todo - #it turns out line based chunks are faster than the above.. probably because some of those end up doing the regex splitting twice - set lflines [list] - set inputchunks [split $overblock \n] - foreach ln $inputchunks { - append ln \n - lappend lflines $ln + set inputchunks [list] + switch -- $opt_format { + ansi { + #ansi is commonly but not always line-based. + #some ansi is a string of data with ansi movements and no linefeeds. + set overblock [tcl::string::map {\r\n \n} $overblock] + foreach ln [split $overblock \n] { + lappend inputchunks [list mixed $ln\n] } - if {[llength $lflines]} { - lset lflines end [tcl::string::range [lindex $lflines end] 0 end-1] + if {[llength $inputchunks]} { + #strip trailing newline from last line. + lset inputchunks end 1 [tcl::string::range [lindex $inputchunks end 1] 0 end-1] } - #set inputchunks $lflines[unset lflines] - set inputchunks [lindex [list $lflines [unset lflines]] 0] - } - 4 { - set inputchunks [list] - switch -- $opt_binarytext { - "" { - foreach ln [split $overblock \n] { - lappend inputchunks [list mixed $ln\n] - } - if {[llength $inputchunks]} { - lset inputchunks end 1 [tcl::string::range [lindex $inputchunks end 1] 0 end-1] - } + binarytext-bios { + #16 fg, 8 fg + possible blink + set input "" + set ansisplit [list ""] + set charpair 0 + foreach {ch at} [split $overblock ""] { + #review - does binarytext only apply to cp437??? we need to know the original encoding + if {[catch {punk::ansi::colour::byteAnsi $at} code]} { + puts stderr "renderspace err at charpair: $charpair [punk::ansi::ansistring VIEW ${ch}${at}]" + #append input [punk::ansi::a+ brightred White] \uFFef + set code [punk::ansi::a+ brightred White] } - bios { - #16 fg, 8 fg + possible blink - set input "" - set ansisplit [list ""] - set charpair 0 - foreach {ch at} [split $overblock ""] { - #review - does binarytext only apply to cp437??? we need to know the original encoding - set at [encoding convertto cp437 $at] - if {[catch {punk::ansi::colour::byteAnsi $at} code]} { - puts stderr "renderspace err at charpair: $charpair [punk::ansi::ansistring VIEW ${ch}${at}]" - #append input [punk::ansi::a+ brightred White] \uFFef - set code [punk::ansi::a+ brightred White] - set ch \uFFeF - } - append input $code $ch - lappend ansisplit $code $ch - incr charpair - } - #lappend inputchunks [list mixed $input] - lappend inputchunks [list ansisplit $ansisplit] + if {[catch {encoding convertfrom cp437 $ch} ch]} { + puts stderr "renderspace err at charpair: $charpair [punk::ansi::ansistring VIEW ${ch}${at}]" + set ch \uFFeF } - ice { - #16 fg, 16 bg (no blink) - set input "" - foreach {ch at} [split $overblock ""] { - set at [encoding convertto cp437 $at] - append input [punk::ansi::colour::byteAnsiIce $at]$ch - } - lappend inputchunks [list mixed $input] + append input $code $ch + lappend ansisplit $code $ch + incr charpair + } + #lappend inputchunks [list mixed $input] + lappend inputchunks [list ansisplit $ansisplit] + } + binarytext-ice { + #16 fg, 16 bg (no blink) + set input "" + foreach {ch at} [split $overblock ""] { + if {$at ne ""} { + append input [punk::ansi::colour::byteAnsiIce $at] } + set ch [encoding convertfrom cp437 $ch] + append input $ch } + lappend inputchunks [list mixed $input] } - } + xbin { + set parse_dict [punk::ansi::xbin::parse $overblock] + set ansisplit [dict get $parse_dict ansisplit] + set xbin_header_info [dict get $parse_dict header] + set flags [dict get $xbin_header_info flags] + set xbin_width [dict get $xbin_header_info width] + set xbin_height [dict get $xbin_header_info height] + puts stdout "xbin dimensions ${xbin_width}x${xbin_height} decoded [dict get $parse_dict decoded_cells] of [dict get $parse_dict expected_cells] expected cells" + puts stdout "xbin flags $flags" + set warnings [dict get $parse_dict warnings] + foreach w $warnings { + puts stderr "xbin warning: $w" + } + puts stdout "xbin decoded" + flush stdout + lappend inputchunks [list ansisplit $ansisplit] + } + } + #we have a list of 2 element input chunks {overtext_type overtext} in $inputchunks + #- each chunk is either a string of text with embedded ANSI codes (type 'mixed') + #- or a list of alternating ANSI code and text segments (type 'ansisplit') + #For ansi files each chunk may commonly correspond to a line of text - but this is not necessarily the case, as ANSI cursor movements and other codes may be present which affect the layout in ways that can't be determined until processing. + #for binary files - there may be no newlines at all - just a stream of bytes with ANSI codes interspersed to control the layout and colours. + #The chunks are processed in order, with the output of each chunk being rendered onto the current 'underlay' of the output, + #and then becoming the new 'underlay' for the next chunk to render onto. set replay_codes_underlay [tcl::dict::create 1 ""] @@ -631,13 +606,6 @@ tcl::namespace::eval overtype { set outputlines $underlines set overidx 0 - #underlines are not necessarily processed in order - depending on cursor-moves applied from overtext - set row 1 - #if {$data_mode} { - # set col [_get_row_append_column $row] - #} else { - set col $opt_startcolumn - #} set instruction_stats [tcl::dict::create] @@ -655,7 +623,10 @@ tcl::namespace::eval overtype { continue } #puts "----->[ansistring VIEW -lf 1 -vt 1 -nul 1 $overtext]<----" - set undertext [lindex $outputlines [expr {$row -1}]] + set undertext [lindex $outputlines [dict get $vtstate row]-1] + if {[tcl::dict::exists $replay_codes_underlay [dict get $vtstate row]]} { + set undertext [tcl::dict::get $replay_codes_underlay [dict get $vtstate row]]$undertext + } #renderline pads each underly line to width with spaces and should track where end of data is @@ -690,19 +661,17 @@ tcl::namespace::eval overtype { #} ###################### - set renderedrow $row + #remember the row we are just about to render. + set renderedrow [dict get $vtstate row] if {$renderedrow > $renderedrow_max} { set renderedrow_max $renderedrow } - if {[tcl::dict::exists $replay_codes_underlay $row]} { - set undertext [tcl::dict::get $replay_codes_underlay $row]$undertext - } #review insert_mode. As an 'overtype' function whose main function is not interactive keystrokes - insert is secondary - #but even if we didn't want it as an option to the function call - to process ansi adequately we need to support IRM (insertion-replacement mode) ESC [ 4 h|l - set renderopts [list -experimental $opt_experimental {*}{ + set renderopts [list {*}{ } -cp437 $opt_cp437 {*}{ } -info 1 {*}{ } -crm_mode [tcl::dict::get $vtstate crm_mode] {*}{ @@ -715,8 +684,8 @@ tcl::namespace::eval overtype { } -exposed1 $opt_exposed1 {*}{ } -exposed2 $opt_exposed2 {*}{ } -expand_right $opt_expand_right {*}{ - } -cursor_column $col {*}{ - } -cursor_row $row {*}{ + } -cursor_column [tcl::dict::get $vtstate col] {*}{ + } -cursor_row [tcl::dict::get $vtstate row] {*}{ } -overtext_type $overtext_type {*}{ } ] @@ -747,6 +716,8 @@ tcl::namespace::eval overtype { set visualwidth [tcl::dict::get $rinfo visualwidth] ;#column width of what is 'rendered' for the line set insert_lines_above [tcl::dict::get $rinfo insert_lines_above] set insert_lines_below [tcl::dict::get $rinfo insert_lines_below] + + #review - this assumes lines are rendered in order - but this isn't always true. tcl::dict::set replay_codes_underlay [expr {$renderedrow+1}] [tcl::dict::get $rinfo replay_codes_underlay] #lset replay_codes_overlay [expr $overidx+1] [tcl::dict::get $rinfo replay_codes_overlay] @@ -785,7 +756,7 @@ tcl::namespace::eval overtype { #-- todo - detect looping properly - if {$row > 1 && $overtext ne "" && $unapplied eq $overtext && $post_render_row == $row && $instruction eq ""} { + if {[dict get $vtstate row] > 1 && $overtext ne "" && $unapplied eq $overtext && $post_render_row == [dict get $vtstate row] && $instruction eq ""} { puts stderr "overtype::renderspace loop?" puts [ansistring VIEW $rinfo] break @@ -811,25 +782,23 @@ tcl::namespace::eval overtype { tcl::dict::incr instruction_stats $instruction_type switch -- $instruction_type { reset { - #reset the 'renderspace terminal' (not underlying terminal) - set row 1 - set col 1 + #reset the 'renderspace virtual terminal' (not underlying terminal) set vtstate [tcl::dict::merge $vtstate $initial_state] #todo - clear screen } {} { #end of supplied line input #lf included in data - set row $post_render_row - set col $post_render_col + dict set vtstate row $post_render_row + #dict set vtstate col $post_render_col if {![llength $unapplied_list]} { if {$overflow_right ne ""} { - incr row + dict incr vtstate row } } else { puts stderr "renderspace end of input line - has unapplied: [ansistring VIEW $unapplied] (review)" } - set col $opt_startcolumn + dict set vtstate col $opt_startcolumn } up { @@ -843,87 +812,42 @@ tcl::namespace::eval overtype { #puts stderr "up $post_render_row" #puts stderr "$rinfo" - #puts stdout "1 row:$row col $col" - set row $post_render_row - #data_mode (naming?) determines if we move to end of existing data or not. - #data_mode 0 means ignore existing line length and go to exact column - #set by -experimental flag - if {$data_mode == 0} { - set col $post_render_col - } else { - #This doesn't really work if columns are pre-filled with spaces..we can't distinguish them from data - #we need renderline to return the number of the maximum column filled (or min if we ever do r-to-l) - set existingdata [lindex $outputlines [expr {$post_render_row -1}]] - set lastdatacol [punk::ansi::printing_length $existingdata] - if {$lastdatacol < $renderwidth} { - set col [expr {$lastdatacol+1}] - } else { - set col $renderwidth - } - } - - #puts stdout "2 row:$row col $col" - #puts stdout "-----------------------" - #puts stdout $rinfo - #flush stdout + dict set vtstate row $post_render_row + dict set vtstate col $post_render_col } down { - if {$data_mode == 0} { + #cursor down. Will not force scroll if at bottom of screen. + if {$post_render_row > [llength $outputlines]} { #renderline doesn't know how far down we can go.. - if {$post_render_row > [llength $outputlines]} { - if {$opt_appendlines} { - set diff [expr {$post_render_row - [llength $outputlines]}] - set bce_line \x1b\[0m$replay_codes_overlay[string repeat \u0000 $renderwidth] - if {$diff > 0} { - lappend outputlines {*}[lrepeat $diff $bce_line] - #lappend outputlines {*}[lrepeat $diff ""] - } - lappend outputlines $bce_line - #lappend outputlines "" - } - } - set row $post_render_row - set col $post_render_col - } else { - puts stderr "renderspace down - data_mode 1 - review" - if {$post_render_row > [llength $outputlines]} { - if {$opt_appendlines} { - set diff [expr {$post_render_row - [llength $outputlines]}] - set bce_line \x1b\[0m$replay_codes_overlay[string repeat \u0000 $renderwidth] - if {$diff > 0} { - lappend outputlines {*}[lrepeat $diff $bce_line] - #lappend outputlines {*}[lrepeat $diff ""] - } - lappend outputlines $bce_line - #lappend outputlines "" + set post_render_row [llength $outputlines] + } + dict set vtstate row $post_render_row + dict set vtstate col $post_render_col + } + down_scrolling { + #todo - scrolling region. take account of decstbm. + + #renderline doesn't know how far down we can go.. + if {$post_render_row > [llength $outputlines]} { + if {$opt_appendlines} { + set diff [expr {$post_render_row - [llength $outputlines]}] + set bce_line \x1b\[0m$replay_codes_overlay[string repeat \u0000 $renderwidth] + if {$diff > 0} { + lappend outputlines {*}[lrepeat $diff $bce_line] } + lappend outputlines $bce_line } - # ---- - # review - set col $post_render_col - #just because it's out of range of the renderwidth - doesn't mean a move down should jump to within the range - 2025 - #---- - - #set existingdata [lindex $outputlines [expr {$post_render_row -1}]] - #set lastdatacol [punk::ansi::printing_length $existingdata] - - #set col [expr {$lastdatacol+1}] - - #if {$lastdatacol < $renderwidth} { - # set col [expr {$lastdatacol+1}] - #} else { - # set col $renderwidth - #} - } + dict set vtstate row $post_render_row + dict set vtstate col $post_render_col } restore_cursor { #testfile belinda.ans uses this #puts stdout "[a+ blue bold]CURSOR_RESTORE[a]" if {[tcl::dict::exists $cursor_saved_position row]} { - set row [tcl::dict::get $cursor_saved_position row] - set col [tcl::dict::get $cursor_saved_position column] + dict set vtstate row [tcl::dict::get $cursor_saved_position row] + dict set vtstate col [tcl::dict::get $cursor_saved_position column] #puts stdout "restoring: row $row col $col [ansistring VIEW $cursor_saved_attributes] [a] unapplied [ansistring VIEWCODES $unapplied]" #set nextprefix $cursor_saved_attributes #lset replay_codes_overlay [expr $overidx+1] $cursor_saved_attributes @@ -971,6 +895,47 @@ tcl::namespace::eval overtype { set overflow_handled 1 } + decstbm { + #scrolling region - CSI r + #renderline will have rendered the line based on the current vtstate row/col + #- but the scrolling region change may have caused a move to be rendered to the output which changes the row/col for the next line + #- so we need to update our vtstate cursor position. + lassign $instruction _ margin_top margin_bottom + + set margins_valid 1 ;#default assumption + #todo - validate margins. A valid scrolling region requires at least two lines. + if {$margin_top eq ""} {set margin_top 1} + if {$margin_bottom eq ""} {set margin_bottom $screen_rows} + if {![string is integer -strict $margin_top] || $margin_top < 1} { + puts stderr "DECSTBM invalid margin_top '$margin_top' [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + set margins_valid 0 + } + if {![string is integer -strict $margin_bottom] || $margin_bottom < 1} { + puts stderr "DECSTBM invalid margin_bottom '$margin_bottom' [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + set margins_valid 0 + } + if {$margin_bottom - $margin_top < 1} { + puts stderr "DECSTBM invalid margins - bottom '$margin_bottom' must be greater than top '$margin_top' [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + set margins_valid 0 + } + if {$margins_valid} { + #todo - return these for the caller to process.. + puts stderr "overtype::renderspace DECSTBM set top and bottom margin not implemented" + #Also moves the cursor to col 1 line 1 of the page + #review - examine DECOM state to determine new cursor position? + dict set vtstate row 1 + dict set vtstate col 1 + + #incr idx_over + #priv::render_to_unapplied $overlay_grapheme_control_list $gci + #set instruction [list decstbm $margin_top $margin_bottom] + dict set vtstate topmargin $margin_top + dict set vtstate bottommargin $margin_bottom + } else { + puts stderr "overtype::renderspace DECSTBM invalid margins - ignoring [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + #don't update the vtstate margins. + } + } move { ######## if {$post_render_row > [llength $outputlines]} { @@ -982,67 +947,95 @@ tcl::namespace::eval overtype { if {$diff > 0} { lappend outputlines {*}[lrepeat $diff $bce_line] } - set row $post_render_row + dict set vtstate row $post_render_row } else { - set row [llength $outputlines] + dict set vtstate row [llength $outputlines] } } else { - set row $post_render_row + dict set vtstate row $post_render_row } ####### - set col $post_render_col + dict set vtstate col $post_render_col #overflow + unapplied? } + clear_to_end_display { + #ED 0 + #review - needs to operate within top and bottom margins if set (decstbm) - but for now we assume full screen clear + #Current row already partially erased by renderline. + if {$post_render_row > [llength $outputlines]} { + dict set vtstate row [llength $outputlines] + } else { + dict set vtstate row $post_render_row + } + dict set vtstate col $post_render_col + set overflow_right "" + + set start_idx [expr {[dict get $vtstate row]}] + if {$start_idx < 0} {set start_idx 0} + for {set i $start_idx} {$i < [llength $outputlines]} {incr i} { + lset outputlines $i \x1b\[0m$replay_codes_overlay[string repeat \u0000 $renderwidth]\x1b\[0m + } + } + clear_to_start_display { + #ED 1 + #Current row already partially erased by renderline. + if {$post_render_row > [llength $outputlines]} { + dict set vtstate row [llength $outputlines] + } else { + dict set vtstate row $post_render_row + } + dict set vtstate col $post_render_col + set overflow_right "" + + set stop_idx [expr {[dict get $vtstate row] - 1}] + if {$stop_idx >= [llength $outputlines]} { + set stop_idx [expr {[llength $outputlines] - 1}] + } + for {set i 0} {$i < $stop_idx} {incr i} { + lset outputlines $i \x1b\[0m$replay_codes_overlay[string repeat \u0000 $renderwidth]\x1b\[0m + } + } clear_and_move { - #e.g 2J + #ED 2J if {$post_render_row > [llength $outputlines]} { - set row [llength $outputlines] + dict set vtstate row [llength $outputlines] } else { - set row $post_render_row + dict set vtstate row $post_render_row } - set col $post_render_col + dict set vtstate col $post_render_col set overflow_right "" ;#if we're clearing - any overflow due to insert_mode is irrelevant - set clearedlines [list] - foreach ln $outputlines { - lappend clearedlines \x1b\[0m$replay_codes_overlay[string repeat \u0000 $renderwidth]\x1b\[0m - - #set lineparts [punk::ansi::ta::split_codes $ln] - #set numcells 0 - #foreach {pt _code} $lineparts { - # if {$pt ne ""} { - # foreach grapheme [punk::char::grapheme_split $pt] { - # switch -- $grapheme { - # " " - - - _ - ! - @ - # - $ - % - ^ - & - * - = - + - : - . - , - / - | - ? - - # a - b - c - d - e - f - g - h - i - j - k - l - m - n - o - p - q - r - s - t - u - v - w - x - y - - # z - A - B - C - D - E - F - G - H - I - J - K - L - M - N - O - P - Q - R - S - T - U - V - W - X - Y - Z - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 { - # incr numcells 1 - # } - # default { - # if {$grapheme eq "\u0000"} { - # #review - # incr numcells 1 - # } elseif {$grapheme eq "\t"} { - # #set tstops [lsort -integer -unique [punk::console::get_tabstops]] - # puts stderr "tab at numcells: $numcells - REVIEW renderspace" - # set nexttabstop [expr {((int($numcells / 8) + 1) * 8)}] - # incr numcells [expr {$nexttabstop - $numcells}] - # } else { - # incr numcells [grapheme_width_cached $grapheme] - # } - # } - # } - - # } - # } - #} - ##replays/resets each line - #lappend clearedlines \x1b\[0m$replay_codes_overlay[string repeat \u0000 $numcells]\x1b\[0m + for {set i 0} {$i < [llength $outputlines]} {incr i} { + lset outputlines $i \x1b\[0m$replay_codes_overlay[string repeat \u0000 $renderwidth]\x1b\[0m } - set outputlines $clearedlines #todo - determine background/default to be in effect - DECECM ? puts stderr "replay_codes_overlay: [ansistring VIEW $replay_codes_overlay]" - #lset outputlines 0 $replay_codes_overlay[lindex $outputlines 0] - + } + delete_lines { + #DL n + set delete_count [lindex $instruction 1] + set r $renderedrow + puts stderr "delete_lines $delete_count at row $r" + if {$delete_count > 0} { + #set outputlines [lreplace $outputlines [dict get $vtstate row] [expr {[dict get $vtstate row] + $delete_count - 1}]] + set delidx_first [expr {$r - 1}] ;#convert to 0-based index + set delidx_last [expr {$delidx_first + ($delete_count - 1)}] ;#inclusive index of last line to delete + #if delete_count is 1 - we are only deleting the current line. + ledit outputlines $delidx_first $delidx_last + } + dict set vtstate row $renderedrow + if {[llength $outputlines] < [dict get $vtstate row]} { + dict set vtstate row [llength $outputlines] + } + #we need to ensure 'unapplied' data is still applied to the current line after deletion. + #Any overflow on the current line should be abandoned. + if {[llength $unapplied_ansisplit]} { + #set inputchunks [linsert $inputchunks 0 $nextprefix] + #JMN - assume backwards compat ledit available from punk::lib (for tcl <9) + ledit inputchunks -1 -1 [list ansisplit $unapplied_ansisplit] + } + incr overidx + incr loop + continue } lf_start { #raw newlines @@ -1051,9 +1044,9 @@ tcl::namespace::eval overtype { #test - treating as newline below... #append rendered $overflow_right #set overflow_right "" - set row $renderedrow - incr row - if {$row > [llength $outputlines]} { + + dict set vtstate row [expr {$renderedrow + 1}] + if {[dict get $vtstate row] > [llength $outputlines]} { #lappend outputlines "" # BCE lappend outputlines \x1b\[0m$replay_codes_overlay[string repeat \u0000 $renderwidth] @@ -1062,137 +1055,88 @@ tcl::namespace::eval overtype { # ---------------------- } lf_mid { - set edit_mode 0 - if {$edit_mode} { - #set inputchunks [linsert $inputchunks 0 $overflow_right$unapplied] - #JMN - #ledit inputchunks -1 -1 $overflow_right$unapplied - - set pt_ansi_pt [punk::ansi::ta::split_codes_single $overflow_right] - #join the trailing and leading pt parts of the 2 lists - ledit pt_ansi_pt end end "[lindex $pt_ansi_pt end][lindex $unapplied_ansisplit 0]" - lappend pt_ansi_pt [lrange $unapplied_ansisplit 1 end] - - ledit inputchunks -1 -1 [list ansisplit $pt_ansi_pt] ;#combined overflow_right and unapplied - in ansisplit form - + if {$overflow_right ne ""} { + if {$opt_expand_right} { + append rendered $overflow_right set overflow_right "" - set unapplied "" - set unapplied_list [list] - set unapplied_ansisplit [list] - - set row $post_render_row - #set col $post_render_col - set col $opt_startcolumn - if {$row > [llength $outputlines]} { - #lappend outputlines {*}[lrepeat 1 ""] - lappend outputlines \x1b\[0m$replay_codes_overlay[string repeat \u0000 $renderwidth] - } } else { - if 1 { - if {$overflow_right ne ""} { - if {$opt_expand_right} { - append rendered $overflow_right - set overflow_right "" - } else { - #review - we should really make renderline do the work...? - set overflow_width [punk::ansi::printing_length $overflow_right] - if {$visualwidth + $overflow_width <= $renderwidth} { - append rendered $overflow_right - set overflow_right "" - } else { - if {[tcl::dict::get $vtstate autowrap_mode]} { - #set outputlines [linsert $outputlines $renderedrow $overflow_right] - #ledit outputlines $renderedrow $renderedrow-1 $overflow_right - puts stderr "REVIEW wrap overflow_right to next line: $overflow_right" - #this looks wrong - ledit outputlines $renderedrow -1 $overflow_right - set overflow_right "" - set row [expr {$renderedrow + 2}] - } else { - set overflow_right "" ;#abandon - } + #review - we should really make renderline do the work...? + set overflow_width [punk::ansi::printing_length $overflow_right] + if {$visualwidth + $overflow_width <= $renderwidth} { + append rendered $overflow_right + set overflow_right "" + } else { + if {[tcl::dict::get $vtstate autowrap_mode]} { + #set outputlines [linsert $outputlines $renderedrow $overflow_right] + #ledit outputlines $renderedrow $renderedrow-1 $overflow_right + puts stderr "REVIEW wrap overflow_right to next line: $overflow_right" + #this looks wrong + ledit outputlines $renderedrow -1 $overflow_right + set overflow_right "" + #review - why are we setting this here when we override it below? + dict set vtstate row [expr {$renderedrow + 2}] + } else { + set overflow_right "" ;#abandon + } - if {0 && $visualwidth < $renderwidth} { - puts stderr "visualwidth: $visualwidth < renderwidth:$renderwidth" - error "incomplete - abandon?" - set overflowparts [punk::ansi::ta::split_codes $overflow_right] - set remaining_overflow $overflowparts - set filled 0 - foreach {pt code} $overflowparts { - lpop remaining_overflow 0 - if {$pt ne ""} { - set graphemes [punk::char::grapheme_split $pt] - set add "" - set addlen $visualwidth - foreach g $graphemes { - set w [overtype::grapheme_width_cached $g] - if {$addlen + $w <= $renderwidth} { - append add $g - incr addlen $w - } else { - set filled 1 - break - } - } - append rendered $add - } - if {!$filled} { - lpop remaining_overflow 0 ;#pop code - } + if {0 && $visualwidth < $renderwidth} { + puts stderr "visualwidth: $visualwidth < renderwidth:$renderwidth" + error "incomplete - abandon?" + set overflowparts [punk::ansi::ta::split_codes $overflow_right] + set remaining_overflow $overflowparts + set filled 0 + foreach {pt code} $overflowparts { + lpop remaining_overflow 0 + if {$pt ne ""} { + set graphemes [punk::char::grapheme_split $pt] + set add "" + set addlen $visualwidth + foreach g $graphemes { + set w [overtype::grapheme_width_cached $g] + if {$addlen + $w <= $renderwidth} { + append add $g + incr addlen $w + } else { + set filled 1 + break } - set overflow_right [join $remaining_overflow ""] } + append rendered $add + } + if {!$filled} { + lpop remaining_overflow 0 ;#pop code } } - } - set row $post_render_row - set col $opt_startcolumn - if {$row > [llength $outputlines]} { - #lappend outputlines {*}[lrepeat 1 ""] - # BCE - #puts "row: $row > outputlines: [llength $outputlines] overlay replay:[ansistring VIEW $replay_codes_overlay]" - lappend outputlines \x1b\[0m$replay_codes_overlay[string repeat \u0000 $renderwidth] - } - } else { - #old version - known to work with various ansi graphics - e.g fruit.ans - # - but fails to limit lines to renderwidth when expand_right == 0 - append rendered $overflow_right - set overflow_right "" - set row $post_render_row - set col $opt_startcolumn - if {$row > [llength $outputlines]} { - lappend outputlines {*}[lrepeat 1 ""] + set overflow_right [join $remaining_overflow ""] } } } + } + dict set vtstate row $post_render_row + dict set vtstate col $opt_startcolumn + if {[dict get $vtstate row] > [llength $outputlines]} { + #lappend outputlines {*}[lrepeat 1 ""] + # BCE + #puts "row: $row > outputlines: [llength $outputlines] overlay replay:[ansistring VIEW $replay_codes_overlay]" + lappend outputlines \x1b\[0m$replay_codes_overlay[string repeat \u0000 $renderwidth] + } } lf_overflow { - #linefeed after renderwidth e.g at column 81 for an 80 col width - #we may also have other control sequences that came after col 80 e.g cursor save - - if 0 { - set lhs [overtype::left -width 40 -wrap 1 "" [ansistring VIEWSTYLE -nul 1 -lf 1 -vt 1 $rendered]] - set lhs [textblock::frame -title "rendered $visualwidth cols" -subtitle "row-$renderedrow" $lhs] - set rhs "" - - #assertion - there should be no overflow.. - puts $lhs - } - if {![tcl::dict::get $vtstate insert_mode]} { - assert {$overflow_right eq ""} lf_overflow should not get data in overflow_right when not insert_mode - } + #linefeed after renderwidth e.g at column 81 for an 80 col width + #we may also have other control sequences that came after col 80 e.g cursor save - set row $post_render_row - #set row $renderedrow - #incr row - #only add newline if we're at the bottom - if {$row > [llength $outputlines]} { - #lappend outputlines {*}[lrepeat 1 ""] - # BCE - lappend outputlines \x1b\[0m$replay_codes_overlay[string repeat \u0000 $renderwidth] - } - set col $opt_startcolumn + if {![tcl::dict::get $vtstate insert_mode]} { + assert {$overflow_right eq ""} lf_overflow should not get data in overflow_right when not insert_mode + } + dict set vtstate row $post_render_row + #only add newline if we're at the bottom + if {[dict get $vtstate row] > [llength $outputlines]} { + #lappend outputlines {*}[lrepeat 1 ""] + # BCE + lappend outputlines \x1b\[0m$replay_codes_overlay[string repeat \u0000 $renderwidth] + } + dict set vtstate col $opt_startcolumn } newlines_above { #we get a newlines_above instruction when received at column 1 @@ -1202,76 +1146,53 @@ tcl::namespace::eval overtype { puts "--->newlines_above" puts "rinfo: $rinfo" #renderline doesn't advance the row for us - the caller has the choice to implement or not - set row $post_render_row - set col $post_render_col + set temp_row $post_render_row if {$insert_lines_above > 0} { - set row $renderedrow + set temp_row $renderedrow #set outputlines [linsert $outputlines $renderedrow-1 {*}[lrepeat $insert_lines_above ""]] #ledit outputlines $renderedrow-1 $renderedrow-2 {*}[lrepeat $insert_lines_above ""] # BCE (background color erase) set bce_line \x1b\[0m$replay_codes_overlay[string repeat \u0000 $renderwidth] ledit outputlines $renderedrow-1 -1 {*}[lrepeat $insert_lines_above $bce_line] #ledit outputlines $renderedrow-1 -1 {*}[lrepeat $insert_lines_above ""] - incr row [expr {$insert_lines_above -1}] ;#we should end up on the same line of text (at a different index), with new empties inserted above + incr temp_row [expr {$insert_lines_above -1}] ;#we should end up on the same line of text (at a different index), with new empties inserted above #? set row $post_render_row #can renderline tell us? } + dict set vtstate row $temp_row + dict set vtstate col $post_render_col } newlines_below { #obsolete? - use for ANSI insert lines sequence - if {$data_mode == 0} { - puts --->nl_below - set row $post_render_row - set col $post_render_col - if {$insert_lines_below == 1} { - #set lhs [overtype::left -width 40 -wrap 1 "" [ansistring VIEWSTYLE -lf 1 -vt 1 $rendered]] - #set lhs [textblock::frame -title rendered -subtitle "row-$renderedrow" $lhs] - #set rhs "" - #if {$overflow_right ne ""} { - # set rhs [overtype::left -width 40 -wrap 1 "" [ansistring VIEWSTYLE -lf 1 -vt 1 $overflow_right]] - # set rhs [textblock::frame -title overflow_right $rhs] - #} - #puts [textblock::join $lhs $rhs] - - #rendered - append rendered $overflow_right - # + puts --->nl_below + set temp_row $post_render_row + set temp_col $post_render_col + if {$insert_lines_below == 1} { + #set lhs [overtype::left -width 40 -wrap 1 "" [ansistring VIEWSTYLE -lf 1 -vt 1 $rendered]] + #set lhs [textblock::frame -title rendered -subtitle "row-$renderedrow" $lhs] + #set rhs "" + #if {$overflow_right ne ""} { + # set rhs [overtype::left -width 40 -wrap 1 "" [ansistring VIEWSTYLE -lf 1 -vt 1 $overflow_right]] + # set rhs [textblock::frame -title overflow_right $rhs] + #} + #puts [textblock::join $lhs $rhs] + #rendered + append rendered $overflow_right + # - set overflow_right "" - set row $renderedrow - #only add newline if we're at the bottom - if {$row > [llength $outputlines]} { - set bce_line \x1b\[0m$replay_codes_overlay[string repeat \u0000 $renderwidth] - lappend outputlines {*}[lrepeat $insert_lines_below $bce_line] - #lappend outputlines {*}[lrepeat $insert_lines_below ""] - } - incr row $insert_lines_below - set col $opt_startcolumn - } - } else { - set row $post_render_row - if {$post_render_row > [llength $outputlines]} { - if {$opt_appendlines} { - set diff [expr {$post_render_row - [llength $outputlines]}] - set bce_line \x1b\[0m$replay_codes_overlay[string repeat \u0000 $renderwidth] - - if {$diff > 0} { - lappend outputlines {*}[lrepeat $diff $bce_line] - #lappend outputlines {*}[lrepeat $diff ""] - } - lappend outputlines $bce_line - #lappend outputlines "" - } - } else { - set existingdata [lindex $outputlines [expr {$post_render_row -1}]] - set lastdatacol [punk::ansi::printing_length $existingdata] - if {$lastdatacol < $renderwidth} { - set col [expr {$lastdatacol+1}] - } else { - set col $renderwidth - } + set overflow_right "" + set temp_row $renderedrow + #only add newline if we're at the bottom + if {$temp_row > [llength $outputlines]} { + set bce_line \x1b\[0m$replay_codes_overlay[string repeat \u0000 $renderwidth] + lappend outputlines {*}[lrepeat $insert_lines_below $bce_line] + #lappend outputlines {*}[lrepeat $insert_lines_below ""] } + incr temp_row $insert_lines_below + set temp_col $opt_startcolumn } + dict set vtstate row $temp_row + dict set vtstate col $temp_col } wrapmoveforward { #doesn't seem to be used by fruit.ans testfile @@ -1305,8 +1226,8 @@ tcl::namespace::eval overtype { set c $post_render_col } #puts stderr "wrapmoveforward - moving from row $row col $col to row $r col $c" - set row $r - set col $c + dict set vtstate row $r + dict set vtstate col $c } wrapmovebackward { set c $renderwidth @@ -1334,8 +1255,8 @@ tcl::namespace::eval overtype { } else { puts stderr "Wrapmovebackward - but postrendercol >= 1???" } - set row $r - set col $c + dict set vtstate row $r + dict set vtstate col $c } overflow { #normal single-width grapheme overflow @@ -1351,13 +1272,13 @@ tcl::namespace::eval overtype { #example trigger: textblock::frame -width 80 [ansicat us-pump_up_the_jam-355.ans 355x100] - set row $post_render_row ;#renderline will not advance row when reporting overflow char + set r $post_render_row ;#renderline will not advance row when reporting overflow char #puts stderr "overflow autowrap - wrap to next line row: $row autowrap: [tcl::dict::get $vtstate autowrap_mode] renderwidth: $renderwidth visualwidth: $visualwidth [ansistring VIEW $unapplied]" if {[tcl::dict::get $vtstate autowrap_mode]} { - incr row - set col $opt_startcolumn ;#whether wrap or not - next data is at column 1 ?? + incr r + set c $opt_startcolumn ;#whether wrap or not - next data is at column 1 ?? } else { - set col $post_render_col + set c $post_render_col #The overflow can only be triggered by a grapheme (todo cluster?) - but our unapplied could contain SGR codes prior to the grapheme that triggered overflow - so we need to skip beyond any SGRs #There may be more than one, because although the stack leading up to overflow may have been merged - codes between the last column and the overflowing grapheme will remain separate #We don't expect any movement or other ANSI codes - as if they came before the grapheme, they would have triggered a different instruction to 'overflow' @@ -1410,9 +1331,12 @@ tcl::namespace::eval overtype { set overflow_handled 1 #handled by dropping overflow if any } + dict set vtstate row $r + dict set vtstate col $c } overflow_splitchar { - set row $post_render_row ;#renderline will not advance row when reporting overflow char + set r $post_render_row ;#renderline will not advance row when reporting overflow char + set c $post_render_col #2nd half of grapheme would overflow - treggering grapheme is returned in unapplied. There may also be overflow_right from earlier inserts #todo - consider various options .. re-render a single trailing space or placeholder on same output line, etc @@ -1434,8 +1358,8 @@ tcl::namespace::eval overtype { #review - inefficient to re-split (return unapplied_tagged instead of unapplied_ansisplit?) set unapplied_ansisplit [punk::ansi::ta::split_codes_single $unapplied] } else { - set col $opt_startcolumn - incr row + set c $opt_startcolumn + incr r } } else { set overflow_handled 1 @@ -1458,13 +1382,14 @@ tcl::namespace::eval overtype { set unapplied_ansisplit [punk::ansi::ta::split_codes_single $unapplied] } } - + dict set vtstate row $r + dict set vtstate col $c } vt { #can vt add a line like a linefeed can? - set row $post_render_row - set col $post_render_col + dict set vtstate row $post_render_row + dict set vtstate col $post_render_col } set_window_title { set newtitle [lindex $instruction 1] @@ -1547,19 +1472,6 @@ tcl::namespace::eval overtype { lappend nextprefix_list {*}[lrange $unapplied_ansisplit 1 end] } - if 0 { - if {$nextprefix ne ""} { - set nextoveridx [expr {$overidx+1}] - if {$nextoveridx >= [llength $inputchunks]} { - lappend inputchunks $nextprefix - } else { - #lset overlines $nextoveridx $nextprefix[lindex $overlines $nextoveridx] - #set inputchunks [linsert $inputchunks $nextoveridx $nextprefix] - ledit inputchunks $nextoveridx -1 $nextprefix - } - } - } - if {[llength $nextprefix_list]} { #set inputchunks [linsert $inputchunks 0 $nextprefix] #JMN - assume backwards compat ledit available from punk::lib (for tcl <9) @@ -1578,7 +1490,6 @@ tcl::namespace::eval overtype { set debugmsg "" append debugmsg "${Y}${sep_header}${RST}" \n append debugmsg "looplimit $looplimit reached\n" - append debugmsg "data_mode:$data_mode\n" append debugmsg "opt_appendlines:$opt_appendlines\n" append debugmsg "prev_row :[tcl::dict::get $renderopts -cursor_row]\n" append debugmsg "prev_col :[tcl::dict::get $renderopts -cursor_column]\n" @@ -2258,7 +2169,6 @@ tcl::namespace::eval overtype { Default is \uFFFD - the unicode replacement char.} -cursor_restore_attributes -default "" -cp437 -default 0 -type boolean - -experimental -default {} -overtext_type -type string -choices {mixed plain ansisplit} -default mixed @values -min 2 -max 2 undertext -type string -help\ @@ -2303,8 +2213,10 @@ tcl::namespace::eval overtype { #At the moment we return a reset at the end of the renderline result instead of the replay codes. proc renderline {args} { - #todo - fix 'unapplied' mechanism.This is particularly inefficient for long lines, or data such as binarytext which is not line-based. - #All unapplied data is re-split/reprocessed repeatedly for each line! This is very wasteful and slow. + #------------------------------------------------------------------------------------------------------------------------------------- + #todo - fix 'unapplied' mechanism.This is particularly inefficient for long lines, or data such as binarytext/xbin which is not line-based. + #All unapplied data is re-split/reprocessed repeatedly for each line! This is very wasteful and very slow. + #------------------------------------------------------------------------------------------------------------------------------------- # ## ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### # renderline written from a left-right line orientation perspective as a first-shot at getting something useful. @@ -2374,7 +2286,6 @@ tcl::namespace::eval overtype { -exposed2 \uFFFD -cursor_restore_attributes "" -cp437 0 - -experimental {} -overtext_type mixed }] #-overtext_type plain|mixed|ansisplit @@ -2390,7 +2301,7 @@ tcl::namespace::eval overtype { set argsflags [lrange $args 0 end-2] tcl::dict::for {k v} $argsflags { switch -- $k { - -experimental - -cp437 - -width - -expand_right - -transparent - -startcolumn - -cursor_column - -cursor_row + -cp437 - -width - -expand_right - -transparent - -startcolumn - -cursor_column - -cursor_row - -crm_mode - -insert_mode - -autowrap_mode - -reverse_mode - -etabs - -info - -exposed1 - -exposed2 - -cursor_restore_attributes - -overtext_type { tcl::dict::set opts $k $v @@ -3863,6 +3774,7 @@ tcl::namespace::eval overtype { } B { #CUD - Cursor Down + #CSI n B #Row move - down lassign [split $param {;}] num modifierkey set replay_codes_overlay [punk::ansi::codetype::sgr_merge [lindex $overlay_grapheme_control_stacks $gci]] @@ -4189,10 +4101,34 @@ tcl::namespace::eval overtype { if {$param eq ""} {set param 0} switch -exact -- $param { 0 { - #clear from cursor to end of screen + #ED 0 - clear from cursor to end of screen (including cursor position) + #Current-line part can be done here; remaining lines are handled by caller. + set replay_codes_overlay [punk::ansi::codetype::sgr_merge [lindex $overlay_grapheme_control_stacks $gci]] + incr idx_over + if {[llength $outcols] && $idx < [llength $outcols]} { + priv::render_erasechar $idx [expr {[llength $outcols] - $idx}] + } + priv::render_to_unapplied $overlay_grapheme_control_list $gci + set instruction clear_to_end_display + break } 1 { - #clear from cursor to beginning of screen + #ED 1 - clear from start of screen to cursor + #Current-line part can be done here; previous lines are handled by caller. + set replay_codes_overlay [punk::ansi::codetype::sgr_merge [lindex $overlay_grapheme_control_stacks $gci]] + incr idx_over + if {[llength $outcols] && $idx >= 0} { + set count [expr {$idx + 1}] + if {$count > [llength $outcols]} { + set count [llength $outcols] + } + if {$count > 0} { + priv::render_erasechar 0 $count + } + } + priv::render_to_unapplied $overlay_grapheme_control_list $gci + set instruction clear_to_start_display + break } 2 { #clear entire screen CSI 2J @@ -4210,7 +4146,8 @@ tcl::namespace::eval overtype { break } 3 { - #clear entire screen. presumably cursor doesn't move - otherwise it would be same as 2J ? + #clear entire screen. As well as scrollback buffer if supported (unimplemented) + puts stderr "overtype::renderline ED 3 - clear entire screen and scrollback buffer if supported (unimplemented) [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" } default { @@ -4271,8 +4208,79 @@ tcl::namespace::eval overtype { } M { #CSI Pn M - DL - Delete Line - puts stderr "overtype::renderline DL - Delete Line - not implemented [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + if {$param eq "" || $param eq "0"} {set param 1}; #param=number of chars to delete + if {![string is integer -strict $param] || $param < 0} { + puts stderr "overtype::renderline DCH bad param '$param' - assuming 1 [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + set param 1 + } + priv::render_to_unapplied $overlay_grapheme_control_list $gci + #The current line will be deleted by the calling function - along with more below if param > 1 + #we clear the outcols so that the result for this line is empty. + ledit outcols 0 end + ledit understacks 0 end + ledit understacks_gx 0 end + #puts stderr "overtype::renderline DL - Delete Line - not implemented [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + #todo - rename insert_lines_below to affect_lines_below or something equally generic (use for multiple instructions) + set instruction [list delete_lines $param] + break + } + P { + #DCH - Delete Character(s) + #Deletes Pn characters from cursor position, shifts line left, + #and fills vacated rightmost cells with erased cells. + if {$param eq "" || $param eq "0"} {set param 1}; #param=number of chars to delete + if {![string is integer -strict $param] || $param < 0} { + puts stderr "overtype::renderline DCH bad param '$param' - assuming 1 [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + set param 1 + } + set orig_len [llength $outcols] + for {set di 0} {$di < $param} {incr di} { + priv::render_delchar $idx + } + #Maintain line width by padding erased cells at right edge. + set removed [expr {$orig_len - [llength $outcols]}] + for {set fi 0} {$fi < $removed} {incr fi} { + lappend outcols \u0000 + lappend understacks [list $replay_codes_overlay] + lappend understacks_gx [list] + #review - should we be appending gx0state here? or just empty list? + #- presumably we should be appending gx0state from the end of the line - which may be different from current gx0state if there are codes in the line that change it - but we don't want to track those changes as we delete chars - so maybe we should be appending the gx0state from the end of the line before deletion started? + #lappend understacks_gx [list $gx0state] + } + #cursor position doesn't change. + } + @ { + #ICH - Insert Character(s) + #Inserts Pn blank characters at the cursor position, shifts line right, + #and fills vacated leftmost cells with erased cells. + #The characters shifted beyond the right margin are lost. + if {$param eq "" || $param eq "0"} {set param 1}; #param=number of chars to insert + if {![string is integer -strict $param] || $param < 1} { + puts stderr "overtype::renderline ICH bad param '$param' - assuming 1 [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + set param 1 + } + set orig_len [llength $outcols] + if {$overflow_idx != -1 && $param > [llength $outcols]} { + #since characters at rhs are lost, we can't insert more than the width. + set param $orig_len + } + set this_sgrstack [lindex $overlay_grapheme_control_stacks $gci] + set this_gxstack [lindex $overstacks_gx $idx_over] + + #use space for inserted blanks; helper handles tab reflow + priv::render_insertgraphemes $idx [lrepeat $param " "] $this_sgrstack $this_gxstack + #Keep line width fixed unless expand-right mode is active. + if {$overflow_idx != -1} { + if {[llength $outcols] > $orig_len} { + #truncate + ledit outcols $orig_len end + ledit understacks $orig_len end + ledit understacks_gx $orig_len end + } + } + + #cursor position doesn't change. } T { #CSI Pn T - SD Pan Up (empty lines introduced at top) @@ -4328,16 +4336,36 @@ tcl::namespace::eval overtype { #This control function sets the top and bottom margins for the current page. You cannot perform scrolling outside the margins lassign [split $param {;}] margin_top margin_bottom - #todo - return these for the caller to process.. - puts stderr "overtype::renderline DECSTBM set top and bottom margin not implemented" - #Also moves the cursor to col 1 line 1 of the page - set cursor_column 1 - set cursor_row 1 + set margins_valid 1 ;#default assumption + #todo - validate margins. A valid scrolling region requires at least two lines. + if {$margin_top eq ""} {set margin_top 1} + if {$margin_bottom eq ""} {set margin_bottom $screen_rows} + if {![string is integer -strict $margin_top] || $margin_top < 1} { + puts stderr "DECSTBM invalid margin_top '$margin_top' [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + set margins_valid 0 + } + if {![string is integer -strict $margin_bottom] || $margin_bottom < 1} { + puts stderr "DECSTBM invalid margin_bottom '$margin_bottom' [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + set margins_valid 0 + } + if {$margin_bottom - $margin_top < 1} { + puts stderr "DECSTBM invalid margins - bottom '$margin_bottom' must be greater than top '$margin_top' [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + set margins_valid 0 + } + if {$margins_valid} { + #todo - return these for the caller to process.. + puts stderr "overtype::renderline DECSTBM set top and bottom margin not implemented" + #Also moves the cursor to col 1 line 1 of the page + set cursor_column 1 + set cursor_row 1 - incr idx_over - priv::render_to_unapplied $overlay_grapheme_control_list $gci - set instruction move ;#own instruction? decstbm? - break + incr idx_over + priv::render_to_unapplied $overlay_grapheme_control_list $gci + set instruction [list decstbm $margin_top $margin_bottom] + break + } else { + puts stderr "overtype::renderline DECSTBM invalid margins - ignoring [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + } } s { #code conflict between ansi emulation and DECSLRM - REVIEW @@ -4833,12 +4861,12 @@ tcl::namespace::eval overtype { } D { #\x84 - #index (IND) + #index (IND) ESC D #vt102-docs: "Moves cursor down one line in same column. If cursor is at bottom margin, screen performs a scroll-up" puts stderr "renderline ESC D not fully implemented" incr cursor_row priv::render_to_unapplied $overlay_grapheme_control_list $gci - set instruction down + set instruction down_scrolling #retain cursor_column break } @@ -4872,7 +4900,7 @@ tcl::namespace::eval overtype { } #ensure rest of *overlay* is emitted to remainder priv::render_to_unapplied $overlay_grapheme_control_list $gci - set instruction up ;#need instruction for scroll-down? + set instruction up ;#need instruction for screen to scroll-down? #retain cursor_column break } @@ -5398,17 +5426,9 @@ tcl::namespace::eval overtype { set in_tab_expansion [dict create idx $i remaining [expr {$this_tab_width -1}]] set this_char \t } elseif {$ch eq "\u0000"} { - if {$cp437_glyphs} { - #map all nulls including at tail to space - set this_char " " - } else { - set this_char " " - #if {$trailing_nulls && $i < $first_tail_null_posn} { - # append outstring " " ;#map inner nulls to space - #} else { - # append outstring \u0000 - #} - } + #map all nulls including at tail to space + set this_char " " + #review } else { set this_char $ch } diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/packagetest-0.1.8.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/packagetest-0.1.8.tm new file mode 100644 index 0000000000000000000000000000000000000000..5ab00010b2b5f414f3b827e86433879339478f1c GIT binary patch literal 12718 zcmch6cRZEh|F>Ns8QG)TNGV&x&WLOxlzp7R;W&pgtdLcdnM%^2B9xJ`A{mvDk+eu9 zGl?iA4LsL34@-83_91Z) zj(|X+iI6uD?TyBx&?s5R67565644|G4c35Ht`sbejKxD>FNP!y5r~j4hNP+riy{*s zF9HQmhWy-Nq2Q4>kifj?L`Ym4M@AFz2r||ejSGM%cz7R)0Fm7hWC-m~CL)kzGzt>; zBA~npC>d`A(i7o^mhnXsNmv3N!Vqwx&t*Kb?_eck|v~1 z_M-l=#3U>RI%tnXkdf}tL8>$H1fmxLhYdtS_E2{t_tTIG+GiA@g;yq8ccIGc_GZXe1d#SR2w=DY~%hs2PmIq49121thc` zAq@>k9xNuJ$rK_UIvBj%+sn7<{MXwwA^Sy#|4m8wL^xnD6iH|=vlxC2f8ZtBkc7@Z z7wA9|K+K9uRyK9v;Dal_#t?{T1gL+1pc!-!Uc6btU+S-pTeMtf1xT1PWIilZ1evcg zSm<9XY+)A;lr(_uIY0TYXd}FIWkXheI-dtC`fP>V5MPE>aPE@;mIIU`Kz?WliNJ#_ zhC2mNmPqg>VgW$o0+uNYdlH94kkHO^!0SvxyLqAU0C4PKfWx~1WW*8te%0CUdI2^4 zm+G982Wk|6D2$;bs^gZ)BO`IDs$?&?O_0bdh+2pt4(aR#i-9DT3to=)@L8}?)Gdpw zpU?#Khh&ac!R((xtVg3{Kqz1~ z1$V-QMzZXTUjA&Rve9hQ+K`@lT_!p@xm^uUfv*K$nbMG3sx2a*eL)=MR`Rf8F>{|XsM9- zopY#36}GYv6al}94CfWJX%Ro$1QaghBJSMkK%>Nd!QW7IcR|a^cVj5*c!X zsjnBzM8G!+jY9;GAi%)=uy_=~j|6$+5M+RXfN}%+iYMS@s67e+OpsbxvwiL`YX=)a z=cRZ7{uBUO6c94!eK|Q009dy<1`9e4cn&HA0pdyaBM?2Qe0MnyT#{^5zkuF=0@N4s zL<5EGmnX>IVO2~{ZZ4JNKzh#=nizz~!UYX}%?bZoVo}oo1)3a|jE1x=4CgazQG)&| z@_AQ7elP%l`vH+m0rw&JHiRdD(0QY%K9QMkm2(00#1s6$ePl`Q!YN9ikRdWLfa*B% z%HDxBqgKxR6=lWfz>DCI_%eU};;GOt@BFKd0ocK}IJ6gR4+->U_-yig=n;?~kpN=s zMnRKE&}IaYjKzTa9t1!U0ryk5Fu|1tM1E23f}9~y(9o`x(`rs_ptv^$umZ7vsQ){r z|Mb9rBH{0j1|Ui#n*Ozq{L&W03<6hKK!33R)CLZm=)&c4xoW>c^2@ki;ad5&xuC$p zH`Qw-GJwM0cTf_ze`;!KE=t{bY=zX}uz*|e?|RULFrdwWOTGi%6{O<4NvbRDUA$>t z5Q&0BqS0W=-~g}*=39%A{CB?nE=TB>c}wrK3+62TUSgUqjO;MrQ@q`X2o#k$f@ud4 z)HN2MAAo<5c5|SQ!Gas%9QeY8{O^O7(~AWa{{Chzri(Ltc^Ki=y{u)!e)!eD!L;Ll zOtU2}m=g#sM3)*4814Vd!{-AJB1a9{Tu%Y5&wkNQ$A3F-3D{8Za~iFn&p#_5`TxEp{9Tp(2| zYAbH0BMaFAzCooiNI>*KJB58ir3GGKR0BT%jwC@cU=j(MA9y#HIDpy!k_}S@611E< z!ezO<@FeD@KfeLypCtwFU%=u&82c}){=)`9<;Ns9NbGms!jsouVt$bY;I}#R7BUum zFC;eTpdbt8>J6q22w#B3)Oq3DsP>P+-vTl%e9zAbynq^@ip2~ufNIT+c;`eep6nus zAU%JHmzj4vwT9q4o%21&R_gc|1-S+Q=7^_&;LneEy{U)`VnwaMU!@3NeQ;nbAp7^? zgSGub(|te=b#M%(%Mf5ofL6ev2dB*!47hs1BmziBEX;>t+WmX1yckFqs*gHN_6CN6 zf}9^S1A?}o>c17710f0E$`!L3w&9<30xy6+)O#ihvR|l?g)78@7SQs9{p*3Sy#FBM z|KD^P_^{tfThC*;1O_1SpC$HBg<(1W9}pcrW@S|W`5{{>!`S^b~6d6{pP9vU1x zKVkWEGClu4432*QAN>D2ziI^JGyve=Lr(zNXJpm2&sk$erOFyam+g3>lE2H%hH_laDbF7=JJF9%) zX`R^vqVFz?%{;4F4Rgm`#uInnoa!#9cpFA5Ph+Tet2~?Y1Oq0p{NQ(u1P)TGu+0=l z2%G-Md0t6I^V|2{j%;a+$^9H7Z+b<#_qDLw{nVRP?cM!7J%~@$x6d6`nMevfrQ+sx zRyoL}(68y?{?tPC3Ayolh8|w2tvkbPy-S+gQz~D+%y&|YQH%{&yD%VMm*KyeNxZs; zmyad%8#XD5_8|>1B{!vhCS+PeC)n@H@qzn0dZn3zFK9JwRCh!Rxx8g0$Lw_CkgeS; zT{5C6{Vej!9<8t+*gGvOBIYh9$J#@U+s?+y1tfnAwKL3CnW&7EQSRGY#>{)1PtxRP z_HJB{U`c%KeWl5dJetvKl-sYE;5+Lk2$kG!{M{J=`!hOu>VFPzof^xYz4(#0JGjwF z{m@6}dnX80=rMm<^*7h#!@3DO1gjt4y|ov~@#W#B(ASQ>w1MH0WR&M!S{a3v1e2^!{i<+Xg}Yp`M3vrvqe3X6G6v z_ieuLll4I$@24NkzFX2(yKbxP$a2WWcW1g-?9g+fC}pw9tlr9Uu`s+$XwfI{# zJ~l>&-ADAZmakAqZ&|L003hd0|z>aveY`zPMt6!fV2crjwH72V^Es4~_QeVS*8 zp?W^%rDqQ9aXTH_(@2XAu_MS2KhF7}cK(x^oa^J99ES>8JF!Kr@L6r*von|Z+4Xa6v$z(8 zsa@O(>pQmHA%Zhy_an=pHb1QXj&m|ik>vyZ>87TfEo;4)rxZu1lB-$y*9qkW$y? zeT(*Fmlge>HJcvmGI`7*lYk%HlS{Wb;Vu zw>X)tHp#?3mQsi^4ydUj+zr(fp2}@}LO!-vc>IpXaQ%~K+WPYLR)e_#MYs4_uITdkf=(XblZc_1(K4^S@i*5BMf$VFUz0$FxM-2vP z-JK#*3UA6ExRSKiEuB&C%*HPt44D%q6t`#@M^n)Hy=w{^WNut{jcwH9^mccmw{}CF ze}mX)!oirJLUPrb@|+qM>3IHqyXBgD_Kd^4Qrt(|!gH^XAKTg2O`+~*#NyE>5Tuj0 zQ2CUiLydlh{BkbgsePsbeU&G;hW6gsDCpSW(z;EUX^at-sKZ$<#47nNif2~M$WJlE z1|jR*l2h*>sMCvMR!Er{n8Kb+=0_Pr4Q7R}LPcpKnrm(-yRfRC`(#}4I-C=|aa9=m z`MuJY)i$?rAAr>h?+jX7ym%zUIbQ0~;BIb5)w^PvDl{Aeey-6Y!|u43d@_Jk1n zBatJbn?-;fI<{xE9$!pz$GMJD924AlItNr@llx|7{#_vXQw7sj>flBdq`ZDI1!Y0NyL!7DI%?)8Vm z&JC7nQcabY4Vt}KRiefrdq#E){|x;-_M(F(q7s1@%nEv*(MVD92TZkxcv;Ii%0i_g zpso_y%`zICq3y$}=_S2ndXLh)yNcG=SfuvVrE->^>J#uX@;}3?ZKuQISw|Xs{c~b? zIw4)6dwQZJfzVlB`h0^FD;+{;tCN8AnRwHgHj_u|t#8mI-8p;aqv$>3TSo>`x#V=1 z!uTHE5O6(}WxIc${B~ETleF}u#6;$(${7qK=6c}OX|a2k!s6Hr59T^O{29NF{P>Mj zBdgL6;~vrv=NR0p*U;7zClx2ZACzmVc83P7=}Wpwhb&Kcwvz968p&E`$DC577b};c zu}YNV#q4rx_tjDI+BLf)+gSPVdXn^Di+131oDE(qq+WcSUrjt)o?XjOu=M-K?hfyc zlZro9pZ!s-VZ;|^wAy}H`*q~B(NoP?O|2-SLIakw2o{#a>htSsrpa3d(q9$2f?n1t z)89ecB0qUIC0Zw$Xa94H;{rbnvj@etowMr3*j?J*ai%!RmZ^6P@hDSoSU>>giiY?J{=v@z(ux4?A((nJfmUEn~aIOqhi@ zuQAJUBr=X0iZ@(*uYCL+Q<$Mmx^N%!?Ix#6*N10EG;-xX=Ut$%|7g(PEVgMR?*X>? zc83^KN^ARWi{p-;%=U&i8tCC2$8uFOHcC7we4^Eumlc;59dTDZkCjJ2!2qjgJ)>NB z>3d~$frjs$qdL}s`kw|TQyiO%L-9Kz4C^f;yFA#M2QF0YC{H0_d*~3zq9Yc{=13>@ zw9Df>bX77YCrK&+3g60&Ayd@h>4q3qT9gxA&-;$hS)rJxtpk}&clgojW@E}~Ojk1m zuViYq*WA_2j#gmiO%%IFso36hU zXYyy8iV6D>UY3l8_7^x8HfhF$M#zTJ*Gg83hZiYI>n$O+S>8)glDCfrC+Dj2W@K?s?dIQmj6+@T1~s*H>(VV z%Vv^S)$=8#3cfRWSbKcAaYg#V4c-&87k)m?F?xhC-9GEIY40={``vMGVD|GYEf-#F zs}y3D)s-lkx8sO|se3XbSJL&Q>>$EL$F_m$VUsY~T z-)1(gcz{9D7RKk9PrCcLKbpKY7%_d^V%yHvufiiDg7;e`w)K!EV(q(Xb}}o09uayEY7d|IYv5<@40!qp4o?Ycp?HxH3L-+iQ3D8@-Qq z)m{ZRq;$*sd=bCcdq&F5XeT|5FP8Pu1;bU1eNJ{4Dz9r)G&Jc|D)>x%e|{~2P|%6r zL@(1&?)AynWmMZ_<6ik|d5y*eFqkd!y6>%s zLKZ$8$$TXcn_3es5gJH|ef$jBC9aZ#G=AsRy`TSGXD70|N4M}k*@&|PZ`aj>+)+Hr z-loQwkC=oMXY%^lue;i?N!j|>#}y&lcgTG4Vh*gJV-w#f85VTM&*8-ei$Ole2*w6a zd$sR8HF8}DIx)lD?@c-GBE~vgc@^+4I9U$mKmwMP@t2-G^x5yCRI{U1*Mx#if>)k^4J*&m4JHvEj*PqVYm{IaHjgM=aFw*3Gy2Y~8u7 zt~^nqyj}B+xWxt*_4soV1Em>O8*D>INZazquL)tgh1Re4nshF8R*zJ=hyMYh^7x zqh{Uk&Bq6ID>nIH?tgra9qRioIv`j!U=?(+^fRG+YTZ{Bq7O)!uHB;&G3EuLsv6aa(Im+U+v8w8yX8QI3BokxN;}wi-F3FS*zRC+*bYH z(`s2>d_zk$h>VBt>6g4ZDYh-&Qz`PpA<;WVc?WKg3cc)tVp}&suIpSL5=JKuM_7n; z6w?$4G@i?@;)o~tOF5%z!f!kJtqs4;?=ES6k1apbcxzs2`s%(L5Rxo$hr8xB)R`L*`q4>qB~l16)~xXf2yr zi0P~JwR_W__a&Q@zspP$>pvi(>$Zw%yL8lDE@m~OS{t17h{aBB%;1*im(ri#*tyPz0)RYf4uQ`!* z-n(k3@jQnx@zHgqr>tKdX7}HW)Ns0Swtu(e*(WUWn-cT;LNB-QD|&KdhE!=>CRO65 z=nuTG5Fw@-i7SqbGGk|h`O+17*PYF6=RUQG!~N?u-XD044HvyQwfYASn@ah%_r6%; zb$1U`Zz1m~UF+iYnp?S9-A{Qass@wl_&A4^=H_S3odddz$Mi>5iJa0uUE~|DaOGH< zU2l7=;59;olX%AGwT@>Mrp6OFENgAlbu89uq{b-(v!1wg`VP%cN-{pp=F@C?|J%C- zV+l>c=?Fr|$BQPP8&73gii%fp;kB@`fjC_e{bp{Oo4f91 z&d6}7wXfYhvc`MQ>o1@AlQkK9QH&O6Y?U$5-)5?W}9=)-1edS$x^%!tPo|;ToDs#G@Csc6)K+ zu0g^==HETiug)awvCy)b=ImJ8+qJ*oOz!UE5%}%2#yi|?dXVMQ468lmT8o@^@=!i} zEGl4kyW~`oo2DYf5uzgS=%7zot@7;At64uZu3Z*ONTjfte^c7>gX_ventU($FPaX= znlqIx9}ExQ+MW@2l*4ef^<)Z* zu8@IX-*xNcWWjCM6+|TJtSV3`_pu!^9jnzx^c^p}qu-aPhLVc3@IT0v=zt&B&tln- zz#KD%vXv6Qc*jOF=OQuZvgWIfNPz&Bz9Uz|f10GQ1*IFb8Tx4s8Ab^vr&qYoWY=li*iY8;E+eE&f0K@D=Sp~I_<;j&?Y z=Z~sODJCA}zApJZUN9)IsMz2O@0;wJ;sIg=CCOV@=gl$bb#mg(3BCS2^t7zOHE}Lx z@szjLA);fZbPUY1#uaigmjd+eALRc%ZyeiFNC(A+0#aGegi!S={~Ekcpn@ zr$07i5%Ua`_RCy7smJJW+~}>I1p|+R$f*sQcGbln^hg(jDYWk{tRHG~*|Nn##W?7*`zt@5aF?PU`h&E7GVg{C!^|4i;| z3ut*QJw6#NmTAHzcg#Da?EAaXqPi0?A8%9`2}p)u>Pijy4@JuD!;O~uwC5O>Y-4)a z*BasXZ8%-~{pGRIsCByzRjcl36R%#oVeNZKQI1N(eih~yd_Ii&kDn5bZ1Vg_n`I!my>AwmU_)1hDx7VYU|}tdio<@YITEW zQKPB*qhyb4m)){0#a8Y19>4n^%x{-}dQu@(VE9$Nf%c$+MI)ndjq>|Dx9)po|LRN!X=`TkCy&!J@!9NZ>&|}l z?!g!Tu=4FW+r{@|#~WJ~_qM&7sXN)YLZmw$&6* zwz*qNC!wszhc&qCj=Eo>8DVnl;`q!C0P{wl{`MEXZ}RTAq^xUB8GE-j+~VRMyTjc9 z=B1W=w_CZAWLNKv-y7h=U2!g=e)tkiyTzWvQKo{0H0@6sYI20Qc=Zp~__lp!y>j$| zaIhM|`hAsSG5-2fxfY$$fU(nM6T<$Gu+LY$;og$ISw;(ETDtW#e;=8HsrjPM|89V8 UVa&(`Z>9zR9Kg2%FZ}EO06j*}rvLx| literal 0 HcmV?d00001 diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk-0.1.1.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk-0.1.1.tm new file mode 100644 index 00000000..e3ba36b4 --- /dev/null +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk-0.1.1.tm @@ -0,0 +1,9302 @@ +#Punk - where radical modification is a craft and anti-patterns are another exploratory tool for the Pattern Punk. +#Built on Tcl of course - because it's the most powerful piece of under-appreciated and alternate-thinking engineering you can plug into. + + +namespace eval punk { + proc lazyload {pkg} { + #experimental - for binary packages that have significant load time. + package require zzzload + if {[package provide $pkg] eq ""} { + zzzload::pkg_require $pkg + } + } + #lazyload twapi ? + + catch {package require vfs} ;#attempt load now so we can use faster 'package provide' to test existence later + + variable can_exec_windowsapp + set can_exec_windowsapp unknown ;#don't spend a potential X00ms testing until needed + variable windowsappdir + set windowsappdir "" + variable cmdexedir + set cmdexedir "" + + proc sync_package_paths_script {} { + #the tcl::tm namespace doesn't exist until one of the tcl::tm commands + #is run. (they are loaded via ::auto_index triggering load of tm.tcl) + #we call tcl::tm::list to trigger the initial set of tm paths before + #we can override it, otherwise our changes will be lost + #REVIEW - won't work on safebase interp where paths are mapped to {$p(:x:)} etc + list apply {{ap tmlist} { + set ::auto_path $ap + tcl::tm::list + set ::tcl::tm::paths $tmlist + }} $::auto_path [tcl::tm::list] + } + + + + proc ::punk::auto_execok_original name [info body ::auto_execok] + variable better_autoexec + + + #use this var via better_autoexec only + set better_autoexec 1 + proc ::punk::auto_execok_windows name { + ::punk::auto_execok_better $name + } + + set has_commandstack [expr {![catch {package require commandstack}]}] + if {$has_commandstack} { + if {[catch { + package require punk::packagepreference + } errM]} { + catch {puts stderr "Failed to load punk::packagepreference"} + } + catch punk::packagepreference::install + } else { + # + } + + if {![interp issafe] && $::tcl_platform(platform) eq "windows"} { + + #return the raw command string from the registry for the association of the given extension, without processing the placeholders such as %1 %SystemRoot% etc. + #This is because we want to process these ourselves to be able to return a proper list of command and arguments. + #Note that the resulting string can't be directly treated as a tcl list because it has double quoted segments with characters that are literals (not escaped) + #Accessing it directly as a list will cause tcl to interpret the backslashes as escapes and lose the literal meaning values such as the path. + proc extension_open_association {ext} { + #look up assoc and ftype to find associated file type and application. + #Note that the windows 'ftype' and 'assoc' commands only examine the system's data - not the user-specific data which may override the system data. + #to get the user-specific associations we need to read the registry keys. + + #extensions in the registry seem to be stored lower case wnd with a leading dot. + set lext [string tolower $ext] + package require registry + set user_assoc_path [join [list HKEY_CURRENT_USER Software Microsoft Windows CurrentVersion Explorer FileExts $lext UserChoice] "\\"] + + #The UserChoice subkey under this key is where the user-specific association is stored when the user has made a choice. It contains a Progid value which points to the associated file type. + #It can return something like "Python.File" or "Applications\python.exe" or even tcl_auto_file (for .tcl files associated with tclsh by a tcl installer) + + #The UserChoice key may not exist if the user hasn't made an explicit choice, in which case we fall back to the system association which is stored under HKEY_CLASSES_ROOT\$ext (which also contains user-specific overrides but is more cumbersome to query for them) + if {![catch {registry get $user_assoc_path Progid} user_choice]} { + if {$user_choice ne ""} { + #examples such as Applications\python.exe and tcl_auto_file are found under HKEY_CURRENT_USER\Software\Classes + #they then have a sub-path shell\open\command which contains the command to open files of that type, which is what we need to extract the associated application. + #it is faster to query for the key directly within a catch than to retrieve keys as lists and iterate through them to find the one we want. + if {![catch {registry get [join [list HKEY_CURRENT_USER Software Classes $user_choice shell open command] "\\"] ""} raw_assoc]} { + #The command string can contain placeholders like "%1" for the file name, so we need to extract just the executable path. + #e.g .py -> "c:\Program Files\Python\python.exe" "%1" + #e.g .rb -> "C:\tools\ruby31\bin\ruby.exe" "%1" %* + # e.g .vbs -> "%SystemRoot%\System32\WScript.exe" "%1" %* + #we need to process this without Tcl interpreting the backslashes as escapes. + #we will use double quotes to determine which entries belong together as a list item for the resulting list of command and arguments. + #set assoc [string map [list \\ \\\\] $raw_assoc] + set assoc $raw_assoc + } else { + #e.g Python.File + if {![catch {registry get [join [list HKEY_LOCAL_MACHINE SOFTWARE Classes $user_choice shell open command] "\\"] ""} raw_assoc]} { + #set assoc [string map [list \\ \\\\] $raw_assoc] + set assoc $raw_assoc + } else { + set assoc "" + } + } + + } else { + #review - is it possible for Progid to be empty string? If so we should probably fall back to system association instead of returning no association. + #alternatively it could mean the user has explicitly chosen to have no association for this file type - in which case returning an empty association may be the correct behaviour. + set assoc "" + } + } else { + #fall back to system association and ftype + if {![catch {registry get [join [list HKEY_LOCAL_MACHINE SOFTWARE Classes $lext] "\\"] ""} ftype]} { + #ftype is the file type associated with the extension, e.g "Python.File" + #we then need to look up the command associated with this file type under the same path but with the file type instead of the extension and with the additional sub-path shell\open\command + if {![catch {registry get [join [list HKEY_LOCAL_MACHINE SOFTWARE Classes $ftype shell open command] "\\"] ""} raw_assoc]} { + #set assoc [string map [list \\ \\\\] $raw_assoc] + set assoc $raw_assoc + } else { + set assoc "" + } + } else { + set assoc "" + } + } + return $assoc + } + + + } + + if {![interp issafe] && $has_commandstack && $::tcl_platform(platform) eq "windows"} { + + #still a caching version of auto_execok - but with proper(fixed) search order + + #set b [info body ::auto_execok] + #proc ::auto_execok_original name $b + + proc better_autoexec {{onoff ""}} { + variable better_autoexec + if {$onoff eq ""} { + return $better_autoexec + } + if {![string is boolean -strict $onoff]} { + error "better_autoexec argument 'onoff' must be a boolean, received: $onoff" + } + if {$onoff && ($onoff != $better_autoexec)} { + puts "Turning on better_autoexec - search PATH first then extension" + set better_autoexec 1 + proc ::punk::auto_execok_windows name { + ::punk::auto_execok_better $name + } + punk::auto_exec::rehash + } elseif {!$onoff && ($onoff != $better_autoexec)} { + puts "Turning off better_autoexec - search extension then PATH" + set better_autoexec 0 + proc ::punk::auto_execok_windows name { + ::punk::auto_execok_original $name + } + punk::auto_exec::rehash + } else { + puts "no change" + } + } + #better_autoexec $better_autoexec ;#init to default + + + proc auto_execok_better name { + #review - we have a gneral problem of auto_exec caching negative results for relative paths. + #A failed resolution of a relative path should not generate an entry in ::auto_execs. + #This happens in plain tclsh - so we need to determine where in Tcl this happens and fix it there. + #Simply returning an empty string here will still result in a negative cache entry. + #we want to cache negative results for absolute paths or plain filenames with no file-separator. + #e.g ./doesntexist.exe should not be cached as not found, but should be re-resolved every time. (cwd dependent) + #e.g doesntexist.exe should be cached as not found, because it will always be not found until it appears in the PATH. + #i.e it is required to prefix with ./ to exec a file in the current directory. (similar to unix shells) + + + global auto_execs env tcl_platform + #for now at least, auto_execok_better is windows-specific. + package require punk::auto_exec + + if {[info exists auto_execs($name)]} { + return $auto_execs($name) + } + #puts stdout "[a+ red]...[a]" + set auto_execs($name) "" + + set shellBuiltins [list {*}{ + assoc cls copy date del dir echo erase exit ftype + md mkdir mklink move rd ren rename rmdir start time type ver vol + }] + if {[info exists env(PATHEXT)]} { + # Add an initial ; to have the {} extension check first. + set execExtensions [split ";$env(PATHEXT)" ";"] + } else { + set execExtensions [list {} .com .exe .bat .cmd] + } + + if {[string tolower $name] in $shellBuiltins} { + # When this is command.com for some reason on Win2K, Tcl won't + # exec it unless the case is right, which this corrects. COMSPEC + # may not point to a real file, so do the check. + set cmd $env(COMSPEC) + if {[file exists $cmd]} { + set cmd [file attributes $cmd -shortname] + } + return [set auto_execs($name) [list $cmd /c $name]] + } + + if {[llength [file split $name]] != 1} { + #----------------------------------------------------- + #has a path component - could be relative or absolute. + #----------------------------------------------------- + if {[file pathtype $name] eq "relative"} { + #don't cache negative result for any relative paths - as they may become valid if the file appears in the relative location, or if the user changes directory and the same relative path points to a different file. + #our only way to do this is by cooperating with the unknown handler. + set auto_execs($name) "for_unknown_handler by punk::auto_exec relative_path - file existence should be re-checked at call time" + return $auto_execs($name) + } + + if {[string tolower [file extension $name]] eq ".lnk"} { + #special case .lnk + #todo - consider working directory or other properties of link before launching? + package require punk::winlnk + if {![catch {punk::winlnk::target $name} linktarget]} { + if {$linktarget ne ""} { + set target $linktarget + } else { + return "" + } + } else { + set target $name + } + } else { + set target $name + } + #always store $name as the key when setting auto_execs. + foreach ext $execExtensions { + set file ${target}${ext} + #first execExtension is empty string - ensure we test actual file as given before we try appending extensions. + if {$ext eq ""} { + set test_ext [file extension $file] + } else { + set test_ext $ext + } + if {[file exists $file] && ![file isdirectory $file]} { + #look up assoc and ftype to find associated file type and application. + #Note that the windows 'ftype' and 'assoc' commands only examine the system's data - not the user-specific data which may override the system data. + #set assoc [extension_open_association $ext] + set associnfo [punk::auto_exec::shell_open_command $test_ext] + set valuetype [dict get $associnfo type] + set assoc [dict get $associnfo value] + set windows_file_type [dict get $associnfo filetype] + if {$assoc eq ""} { + return [set auto_execs($name) [list $file]] + } else { + if {[file pathtype $target] eq "relative" && $windows_file_type eq "InternetShortcut"} { + #special case InternetShortcut - cannot accept relative path - so we can't cache it in auto_execs if we used a relative path to launch + #if we return an empty string - the auto_exec will fail to launch this every time. + #The best we can do is return a token for the 'unknown' process to detect and re-resolve the path every time. + #This requires cooperation from 'unknown' which may not be configured to handle this token if the default 'punk' version isn't installed. + + #we can't resolve using absolute path here - because we don't want to lock in a specific file for a relative path. + #e.g ::auto_execs(./link.url) = some.exe c:/desktop/link.url + #this would be wrong if the user changed directory and tried to run ./link.url again on a different file with the same name + # - as the cached path would no longer be correct. + return [set auto_execs($name) "for_unknown_handler by punk::auto_exec absolute_path required"] + } + puts stderr "auto_execok_better: (review required) assoc $assoc for file $file ext $test_ext" + set run [punk::auto_exec::shell_command_as_tcl_list -type $valuetype $assoc $file] ;# -workingdir [pwd] vs path of script? + return [set auto_execs($name) $run] + #return [set auto_execs($name) [list $file]] + } + } + } + #cache negative result for absolute paths - as they will always point to the same location, so if they don't exist now, they won't exist later. + set auto_execs($name) "" + return "" + } + + #change1 + #set path "[file dirname [info nameofexecutable]];.;" + set path "[file dirname [info nameofexecutable]];" + + + # ------------------------ + #Note that unlike an ordinary Tcl array - the linked ::env behaves differently. + #e.g parray ::env Path will not find ::env(PATH) and yet 'info exists env(Path)' returns true. + #similarly 'set ::env(Path) ?newval?' or any case variation can set/get the value of ::env(PATH) + #Windows environment variables are case-insensitive. + + #No evidence has been seen that any version of windows; current or historic since NT; can allow differently cased versions + # of an environment variable to exist concurrently in the same environment. + #for this reason we should be able to just use PATH. + # + if {[info exists env(PATH)]} { + append path ";$env(PATH)" + } + # ------------------------ + + if {[info exists env(SystemRoot)]} { + set windir $env(SystemRoot) + } elseif {[info exists env(WINDIR)]} { + set windir $env(WINDIR) + } + if {[info exists windir]} { + append path "$windir/system32;$windir/system;$windir;" + } + + #change2 + if {[file extension $name] ne "" && [string tolower [file extension $name]] in [string tolower $execExtensions]} { + set lookfor [list $name] + } else { + set lookfor [lmap ext $execExtensions {string cat ${name} ${ext}}] + } + #puts "-->$lookfor" + + + foreach dir [split $path {;}] { + set dir [string trim $dir {\\}] ;#trailing slash will result in a tail such as "/python.exe" + #set dir [file normalize $dir] + # Skip already checked directories + if {[info exists checked($dir)] || ($dir eq "")} { + continue + } + set checked($dir) {} + + #surprisingly fast + #set matches [glob -nocomplain -dir $dir -types f -tails {*}$lookfor] + ##puts "--dir $dir matches:$matches" + #if {[llength $matches]} { + # set file [file join $dir [lindex $matches 0]] + # #puts "--match0:[lindex $matches 0] file:$file" + # return [set auto_execs($name) [list $file]] + #} + + #what if it's a link? + #foreach match [glob -nocomplain -dir $dir -types f -tail {*}$lookfor] { + # set file [file join $dir $match] + # if {[file exists $file]} { + # return [set auto_execs($name) [list $file]] + # } + #} + + #safest? could be a link? + foreach match [glob -nocomplain -dir $dir -tail -- {*}$lookfor] { + set file [file join $dir $match] + if {[file exists $file] && ![file isdirectory $file]} { + #set assoc [extension_open_association [file extension $file]] + #todo - cache this lookup for each extension we encounter? maybe not, as the user might like changes reflected between runs. review. + if {"windows" ne $::tcl_platform(platform)} { + return [set auto_execs($name) [list $file]] + } + + set associnfo [punk::auto_exec::shell_open_command [file extension $file]] + set assoc [dict get $associnfo value] + set type [dict get $associnfo type] + if {$assoc eq ""} { + return [set auto_execs($name) [list $file]] + } else { + puts stderr "auto_execok_better: assoc $assoc for file $file with type $type" + #return [set auto_execs($name) [list $file]] + #review - our stored auto_execs doesn't have any way to capture the full assoc info such as how subsequent arguments should be processed. + #This may need handling in our Tcl shell 'unknown' function when calls are actually made to these commands + #- we may need to re-process the assoc info at that point to determine how to combine all arguments with the calling specification in the assoc string. + #The workingdir for the command may also need to be determined at that point - should it be the dir of the script being called, or the current dir of the shell? + + #The main point of Tcl's auto_execs is to avoid scanning the PATH entries every time a command is called, + #but we may want to keep some of the assoc info available for processing at call time. + set run [punk::auto_exec::shell_command_as_tcl_list -type $type $assoc $file] ;# -workingdir [pwd] vs path of script? + return [set auto_execs($name) $run] + } + } + } + } + + #foreach ext $execExtensions { + #unset -nocomplain checked + #foreach dir [split $path {;}] { + # # Skip already checked directories + # if {[info exists checked($dir)] || ($dir eq "")} { + # continue + # } + # set checked($dir) {} + # set file [file join $dir ${name}${ext}] + # if {[file exists $file] && ![file isdirectory $file]} { + # return [set auto_execs($name) [list $file]] + # } + #} + #} + return "" + } + + + + #review - what if punk package reloaded - but ::auto_execs has updated path for winget.exe? + #what if we create another interp and use the same ::auto_execs? The appdir won't be detected. + #TODO - see if there is a proper windows way to determine where the 'reparse point' apps are installed + + + + #winget is installed on all modern windows (but not on windows sandbox!) and is an example of the problem this addresses + #we target apps with same location + + #the main purpose of this override is to support windows app executables (installed as 'reparse points') + #for Tcl versions prior to the 2025-01 fix by APN https://core.tcl-lang.org/tcl/tktview/4f0b5767ac + #versions prior to this will use cmd.exe to resolve the links + set stackrecord [commandstack::rename_command -renamer ::punk auto_execok name { + #set windowsappdir "%appdir%" + upvar ::punk::can_exec_windowsapp can_exec_windowsapp + upvar ::punk::windowsappdir windowsappdir + upvar ::punk::cmdexedir cmdexedir + + if {$windowsappdir eq ""} { + #we are targeting the winget location under the presumption this is where microsoft store apps are stored as 'reparse points' + #Tcl (2025) can't exec when given a path to these 0KB files + #This path is probably something like C:/Users/username/AppData/Local/Microsoft/WindowsApps + if {!([info exists ::env(LOCALAPPDATA)] && + [file exists [set testapp [file join $::env(LOCALAPPDATA) "Microsoft" "WindowsApps" "winget.exe"]]])} { + #should be unlikely to get here - unless LOCALAPPDATA missing (or winget.exe missing e.g windows sandbox) + set windowsappdir [file dirname [lindex [::punk::auto_execok_windows winget.exe] 0]] + catch {puts stderr "(resolved winget by search)"} + } else { + set windowsappdir [file dirname $testapp] + } + } + + #set default_auto [$COMMANDSTACKNEXT $name] + set default_auto [::punk::auto_execok_windows $name] + #if {$name ni {cmd cmd.exe}} { + # unset -nocomplain ::auto_execs + #} + + if {$default_auto eq ""} { + return + } + set namedir [file dirname [lindex $default_auto 0]] + + if {$namedir eq $windowsappdir} { + if {$can_exec_windowsapp eq "unknown"} { + if {[catch {exec [file join $windowsappdir winget.exe] --version}]} { + set can_exec_windowsapp 0 + } else { + set can_exec_windowsapp 1 + } + } + if {$can_exec_windowsapp} { + return [file join $windowsappdir $name] + } + if {$cmdexedir eq ""} { + #cmd.exe very unlikely to move + set cmdexedir [file dirname [lindex [::punk::auto_execok_windows cmd.exe] 0]] + #auto_reset never seems to exist as a command - because auto_reset deletes all commands in the ::auto_index + #anyway.. it has other side effects (affects auto_load) + } + return "[file join $cmdexedir cmd.exe] /c $name" + } + return $default_auto + }] + + + } + +} + + + +#repltelemetry cooperation with other packages such as shellrun +#Maintenance warning: shellrun expects repltelemetry_emmitters to exist if punk namespace exists +namespace eval punk { + variable repltelemetry_emmitters + #don't stomp.. even if something created this namespace in advance and is 'cooperating' a bit early + if {![info exists repltelemetry_emitters]} { + set repltelemetry_emmitters [list] + } +} + +namespace eval punk::pipecmds { + #where to install proc/compilation artifacts for pieplines + namespace export * +} +namespace eval punk::pipecmds::split_patterns {} +namespace eval punk::pipecmds::split_rhs {} +namespace eval punk::pipecmds::var_classify {} +namespace eval punk::pipecmds::destructure {} +namespace eval punk::pipecmds::insertion {} + + +#globals... some minimal global var pollution +#punk's official silly test dictionary +set punk_testd [dict create \ + a0 a0val \ + b0 [dict create \ + a1 b0a1val \ + b1 b0b1val \ + c1 b0c1val \ + d1 b0d1val \ + ] \ + c0 [dict create] \ + d0 [dict create \ + a1 [dict create \ + a2 d0a1a2val \ + b2 d0a1b2val \ + c2 d0a1c2val \ + ] \ + b1 [dict create \ + a2 [dict create \ + a3 d0b1a2a3val \ + b3 d0b1a2b3val \ + ] \ + b2 [dict create \ + a3 d0b1b2a3val \ + bananas "in pyjamas" \ + c3 [dict create \ + po "in { }" \ + b4 ""\ + c4 "can go boom" \ + ] \ + d3 [dict create \ + a4 "-paper -cuts" \ + ] \ + e3 [dict create] \ + ] \ + ] \ + ] \ + e0 "multi\nline"\ + ] +#test dict 2 - uniform structure and some keys with common prefixes for glob matching +set punk_testd2 [dict create {*}{ + } a0 [dict create {*}{ + b1 {a b c} + b2 {a b c d} + x1 {x y z 1 2} + y2 {X Y Z 1 2} + z1 {k1 v1 k2 v2 k3 v3} + }] {*}{ + } a1 [dict create {*}{ + b1 {a b c} + b2 {a b c d} + x1 {x y z 1 2} + y2 {X Y Z 1 2} + z1 {k1 v1 k2 v2 k3 v3} + }] {*}{ + } b1 [dict create {*}{ + b1 {a b c} + b2 {a b c d} + x1 {x y z 1 2} + y2 {X Y Z 1 2} + z1 {k1 v1 k2 v2 k3 v3} + }] {*}{ + } +] + +#impolitely cooperative with punk repl - todo - tone it down. +#namespace eval ::punk::repl::codethread { +# variable running 0 +#} +package require punk::lib ;# subdependency punk::args +package require punk::ansi +if {![llength [info commands ::ansistring]]} { + namespace import punk::ansi::ansistring +} +#require aliascore after punk::lib & punk::ansi are loaded +#package require punk::aliascore ;#mostly punk::lib aliases +#punk::aliascore::init -force 1 + +package require punk::repl::codethread +package require punk::config +#package require textblock +catch {package require punk::console} ;#requires Thread - will not work in safe interps. +package require punk::ns +package require punk::winpath ;# for windows paths - but has functions that can be called on unix systems +package require punk::repo +package require punk::du +package require punk::mix::base +package require base64 + +package require punk::pipe + +namespace eval punk { + # -- --- --- + #namespace import ::control::assert ;#according to tcllib doc - assert can be enabled/disabled per namespace + # using control::control assert enabled within a namespace for which ::control::assert wasn't imported can produce surprising results. + #e.g setting to zero may keep asserts enabled - (e.g if the assert command is still available due to namespace path etc) - but.. querying the enabled status may show zero even in the parent namespace where asserts also still work. + #package require control + #control::control assert enabled 1 + + #We will use punk::assertion instead + + package require punk::assertion + if {[catch {namespace import ::punk::assertion::assert} errM]} { + catch { + puts stderr "punk error importing punk::assertion::assert\n$errM" + puts stderr "punk::a* commands:[info commands ::punk::a*]" + } + } + punk::assertion::active on + # -- --- --- + + interp alias {} purelist {} lreplace x 0 0 ;#required by pipe system + if {[catch { + package require pattern + } errpkg]} { + catch {puts stderr "Failed to load package pattern error: $errpkg"} + } + package require shellfilter + package require punkapp + + package require struct::list + package require fileutil + #package require punk::lib + + #NOTE - always call debug.xxx with braced message instead of double-quoted (unless specifically intending to do double-subtition) + #(or $ within values will be substituted, causing an extra error message if the var doesn't exist - which it quite possibly doesn't) + package require debug + + debug define punk.unknown + debug define punk.pipe + debug define punk.pipe.var + debug define punk.pipe.args + debug define punk.pipe.rep ;#string/list representation with tcl::unsupported::representation + debug define punk.pipe.compile ;#info about when we compile pipeline components into procs etc + + + #----------------------------------- + # todo - load initial debug state from config + debug off punk.unknown + debug level punk.unknown 1 + debug off punk.pipe + debug level punk.pipe 4 + debug off punk.pipe.var + debug level punk.pipe.var 4 + debug off punk.pipe.args + debug level punk.pipe.args 3 + debug off punk.pipe.rep 2 + debug off punk.pipe.compile + debug level punk.pipe.compile 2 + + + debug header "dbg> " + + + variable last_run_display [list] + + + #variable re_headvar1 {([a-zA-Z:@.(),]+?)(?![^(]*\))(,.*)*$} + + + + #----------------------------------------------------------------------------------- + #strlen is important for testing issues with string representationa and shimmering. + #This specific implementation with append (as at 2023-09) is designed to ensure the original str representation isn't changed + #It may need to be reviewed with different Tcl versions in case the append empty string is 'optimised/tuned' in some way that affects the behaviour + proc strlen {str} { + append str2 $str {} + string length $str2 + } + #----------------------------------------------------------------------------------- + + #get a copy of the item without affecting internal rep + proc valcopy {obj} { + append obj2 $obj {} + } + + + proc set_valcopy {varname obj} { + #maintenance: also punk::lib::set_valcopy + #e.g used by repl's codeinterp. Maintains internal rep, easier to call e.g interp eval code [list punk::set_valcopy varnmame $val] + append obj2 $obj {} + uplevel 1 [list set $varname $obj2] + } + + interp alias "" strlen "" ::punk::strlen + interp alias "" str_len "" ::punk::strlen + interp alias "" valcopy "" ::punk::valcopy + #proc ::strlen {str} { + # string length [append str2 $str {}] + #} + #proc ::valcopy {obj} { + # append obj2 $obj {} + #} + + #----------------------------------------------------------------------------------- + #order of arguments designed for pipelining + #review - 'piper_' prefix is a naming convention for functions that are ordered for tail-argument pipelining + #piper_ function names should read intuitively when used in a pipeline with tail argument supplied by the pipeline - but may seem reversed when using standalone. + proc piper_append {new base} { + append base $new + } + interp alias "" piper_append "" ::punk::piper_append + proc piper_prepend {new base} { + append new $base + } + interp alias "" piper_prepend "" ::punk::piper_prepend + + proc ::punk::K {x y} { return $x} + + #---------------------- + #todo - fix overtype + #create test + #overtype::renderline -insert_mode 0 -transparent 1 [a+ green]-----[a] " [a+ underline]x[a]" + #---------------------- + + + proc stacktrace {} { + set stack "Stack trace:\n" + for {set i 1} {$i < [info level]} {incr i} { + set lvl [info level -$i] + set pname [lindex $lvl 0] + append stack [string repeat " " $i]$pname + + if {![catch {info args $pname} pargs]} { + foreach value [lrange $lvl 1 end] arg $pargs { + + if {$value eq ""} { + if {$arg != 0} { + info default $pname $arg value + } + } + append stack " $arg='$value'" + } + } else { + append stack " !unknown vars for $pname" + } + + append stack \n + } + return $stack + } + + namespace eval argdoc { + punk::args::define { + @id -id ::punk::get_runchunk + @cmd -name "punk::get_runchunk" -help\ + "experimental" + @opts + -1 -optional 1 -type none + -2 -optional 1 -type none + @values -min 0 -max 0 + } + } + #get last command result that was run through the repl + proc ::punk::get_runchunk {args} { + #set argd [punk::args::parse $args withdef { + # @id -id ::punk::get_runchunk + # @cmd -name "punk::get_runchunk" -help\ + # "experimental" + # @opts + # -1 -optional 1 -type none + # -2 -optional 1 -type none + # @values -min 0 -max 0 + #}] + #todo - make this command run without truncating previous runchunks + set runchunks [tsv::array names repl runchunks-*] + + set sortlist [list] + foreach cname $runchunks { + set num [lindex [split $cname -] 1] + lappend sortlist [list $num $cname] + } + set sorted [lsort -index 0 -integer $sortlist] + set chunkname [lindex $sorted end-1 1] + set runlist [tsv::get repl $chunkname] + #puts stderr "--$runlist" + if {![llength $runlist]} { + return "" + } else { + return [lindex [lsearch -inline -index 0 $runlist result] 1] + } + } + interp alias {} _ {} ::punk::get_runchunk + + + proc ::punk::var {varname {= _=.=_} args} { + upvar $varname the_var + switch -exact -- ${=} { + = { + if {[llength $args] > 1} { + set the_var $args + } else { + set the_var [lindex $args 0] + } + } + .= { + if {[llength $args] > 1} { + set the_var [uplevel 1 $args] + } else { + set the_var [uplevel 1 [lindex $args 0]] + } + } + _=.=_ { + set the_var + } + default { + set the_var [list ${=} {*}$args] + } + } + } + proc src {args} { + #based on wiki.. https://wiki.tcl-lang.org/page/source+with+args + #added support for ?-encoding name? and other options of Tcl source command under assumption they come pairs before the filename + # review? seems unlikely source command will ever accept solo options. It would make complete disambiguation impossible when passing additional args as we are doing here. + set cmdargs [list] + set scriptargs [list] + set inopts 0 + set i 0 + foreach a $args { + if {$i eq [llength $args]-1} { + #reached end without finding end of opts + #must be file - even if it does match -* ? + break + } + if {!$inopts} { + if {[string match -* $a]} { + set inopts 1 + } else { + #leave loop at first nonoption - i should be index of file + break + } + } else { + #leave for next iteration to check + set inopts 0 + } + incr i + } + set cmdargs [lrange $args 0 $i] + set scriptargs [lrange $args $i+1 end] + set argv $::argv + set argc $::argc + set ::argv $scriptargs + set ::argc [llength $scriptargs] + set code [catch {uplevel [list source {*}$cmdargs]} return] + set ::argv $argv + set ::argc $argc + return -code $code $return + } + + + + + proc varinfo {vname {flag ""}} { + upvar $vname v + if {[array exists $vname]} { + error "can't read \"$vname\": variable is array" + } + if {[catch {set v} err]} { + error "can't read \"$vname\": no such variable" + } + set inf [shellfilter::list_element_info [list $v]] + set inf [dict get $inf 0] + if {$flag eq "-v"} { + return $inf + } + + set output [dict create] + dict set output wouldbrace [dict get $inf wouldbrace] + dict set output wouldescape [dict get $inf wouldescape] + dict set output head_tail_names [dict get $inf head_tail_names] + dict set output len [dict get $inf len] + return $output + } + + #review - extending core commands could be a bit intrusive...although it can make sense in a pipeline. + #e.g contrived pipeline example to only allow setting existing keys + ## .= @head.= list {a aaa b bbb c ccc} |d,dkeys@keys> |> &true.= {is_list_all_in_list $nkeys $dkeys} |> {dict modify d {*}$new} |> &true.= {is_list_all_ni_list $nkeys $dkeys} |> {dict modify d {*}$new} -1} { + #lassign [punk::lib::string_splitbefore $token $first_term] v k + set v [string range $token 0 $first_term-1] + set k [string range $token $first_term end] ;#key section includes the terminal char + lappend varlist [list $v $k] + } else { + lappend varlist [list $token ""] + } + set token "" + set token_index -1 ;#reduce by 1 because , not included in next token + set first_term -1 + } else { + if {$first_term == -1} { + if {$c in $var_terminals} { + set first_term $token_index + } + } + append token $c + if {$c eq "("} { + set in_brackets 1 + } + } + } + incr token_index + } + if {[string length $token]} { + if {$first_term > -1} { + set v [string range $token 0 $first_term-1] + set k [string range $token $first_term end] ;#key section includes the terminal char + lappend varlist [list $v $k] + } else { + lappend varlist [list $token ""] + } + } + return $varlist + } + + proc fp_restructure {selector data} { + if {$selector eq ""} { + fun=.= {val $input} and always break + set lhs "" + set rhs "" + #todo - check performance impact of catches around list and dict operations - consider single catch around destructure and less specific match error info? + foreach index $subindices { + set subpath [join [lrange $subindices 0 $i_keyindex] /] + set lhs $subpath + set assigned "" + set get_not 0 + set already_assigned 0 + set do_bounds_check 0 ;#modified by leading single @ for list operations - doesn't apply to certain items like 'head','tail' which have specifically defined bounds-checks implicit in their normal meaning. + #thse have anyhead and anytail for explicit allowance to be used on lists with insufficient items to produce values. + #todo - see if 'string is list' improved in tcl9 vs catch {llength $list} + switch -exact -- $index { + # { + set active_key_type "list" + if {![catch {llength $leveldata} assigned]} { + set already_assigned 1 + } else { + set action ?mismatch-not-a-list + break + } + } + ## { + set active_key_type "dict" + if {![catch {dict size $leveldata} assigned]} { + set already_assigned 1 + } else { + set action ?mismatch-not-a-dict + break + } + } + #? { + #review - compare to %# ????? + #seems to be unimplemented ? + set assigned [string length $leveldata] + set already_assigned 1 + } + @ { + upvar v_list_idx v_list_idx ;#positional tracker for /@ - list position + set active_key_type "list" + #e.g @1/1/@/1 the lone @ is a positional spec for this specific subkey + #no normalization done - ie @2/@ will not be considered same subkey as @end/@ or @end-0/@ even if llength = 3 + #while x@,y@.= is reasonably handy - especially for args e.g $len} { + set action ?mismatch-list-index-out-of-range + break + } + set assigned [lindex $leveldata $index] + set already_assigned 1 + } + @@ - @?@ - @??@ { + set active_key_type "dict" + + #NOTE: it may at first seem pointless to use @@/key, since we have to know the key - but this can be used to match 'key' only at the first position in .= list key {x y} key2 etc + #x@@ = a {x y} + #x@@/@0 = a + #x@@/@1 = x y + #x@@/a = a {x y} + # but.. as the @@ is stateful - it generally isn't very useful for multiple operations on the same pair within the pattern group. + # (note that ?@ forms a different subpath - so can be used to test match prior to @@ without affecting the index) + # It is analogous to v1@,v2@ for lists. + # @pairs is more useful for repeated operations + + # + #set subpath [join [lrange $subindices 0 $i_keyindex] /] + if {[catch {dict size $leveldata} dsize]} { + set action ?mismatch-not-a-dict + break + } + set next_this_level [incr v_dict_idx($subpath)] + set keyindex [expr {$next_this_level -1}] + if {($keyindex + 1) <= $dsize} { + set k [lindex [dict keys $leveldata] $keyindex] + if {$index eq "@?@"} { + set assigned [dict get $leveldata $k] + } else { + set assigned [list $k [dict get $leveldata $k]] + } + } else { + if {$index eq "@@"} { + set action ?mismatch-dict-index-out-of-range + break + } else { + set assigned [list] + } + } + set already_assigned 1 + } + default { + switch -glob -- $index { + @@* { + set active_key_type "dict" + set key [string range $index 2 end] + #dict exists test is safe - no need for catch + if {[dict exists $leveldata $key]} { + set assigned [dict get $leveldata $key] + } else { + set action ?mismatch-dict-key-not-found + break + } + set already_assigned 1 + } + {@\?@*} { + set active_key_type "dict" + set key [string range $index 3 end] + #dict exists test is safe - no need for catch + if {[dict exists $leveldata $key]} { + set assigned [dict get $leveldata $key] + } else { + set assigned [list] + } + set already_assigned 1 + } + {@\?\?@*} { + set active_key_type "dict" + set key [string range $index 4 end] + #dict exists test is safe - no need for catch + if {[dict exists $leveldata $key]} { + set assigned [list $key [dict get $leveldata $key]] + } else { + set assigned [list] + } + set already_assigned 1 + } + @* { + set active_key_type "list" + set do_bounds_check 1 + set index [string trimleft $index @] + } + default { + # + } + } + + if {!$already_assigned} { + if {[string match "not-*" $index] && $active_key_type in [list "" "list"]} { + #e.g not-0-end-1 not-end-4-end-2 + set get_not 1 + #cherry-pick some easy cases, and either assign, or re-map to corresponding index + switch -- $index { + not-tail { + set active_key_type "list" + set assigned [lindex $leveldata 0]; set already_assigned 1 + } + not-head { + set active_key_type "list" + #set selector "tail"; set get_not 0 + set assigned [lrange $leveldata 1 end]; set already_assigned 1 + } + not-end { + set active_key_type "list" + set assigned [lrange $leveldata 0 end-1]; set already_assigned 1 + } + default { + #trim off the not- and let the remaining index handle based on get_not being 1 + set index [string range $index 4 end] + } + } + } + } + } + } + + if {!$already_assigned} { + + #keyword 'pipesyntax' at beginning of error message + set listmsg "pipesyntax Unable to interpret subindex $index\n" + append listmsg "selector: '$selector'\n" + append listmsg "@ must be followed by a selector (possibly compound separated by forward slashes) suitable for lindex or lrange commands, or a not-x expression\n" + append listmsg "Additional accepted keywords include: head tail\n" + append listmsg "Use var@@key to treat value as a dict and retrieve element at key" + + + #we can't just set 'assigned' for a position spec for in/ni (not-in) because we don't have the value here to test against + #need to set a corresponding action + if {$active_key_type in [list "" "list"]} { + set active_key_type "list" + #for pattern matching purposes - head/tail not valid on empty lists (similar to elixir) + if {$index eq "0"} { + if {[catch {llength $leveldata} len]} { + set action ?mismatch-not-a-list + break + } + set assigned [lindex $leveldata 0] + } elseif {$index eq "head"} { + #NOTE: /@head and /head both do bounds check. This is intentional + if {[catch {llength $leveldata} len]} { + set action ?mismatch-not-a-list + break + } + if {$len == 0} { + set action ?mismatch-list-index-out-of-range-empty + break + } + #alias for 0 - for h@head,t@tail= similar to erlang/elixir hd() tl() or [head | tail] = list syntax + set assigned [lindex $leveldata 0] + } elseif {$index eq "end"} { + # @end /end + if {[catch {llength $leveldata} len]} { + set action ?mismatch-not-a-list + break + } + if {$do_bounds_check && $len < 1} { + set action ?mismatch-list-index-out-of-range + } + set assigned [lindex $leveldata end] + } elseif {$index eq "tail"} { + #NOTE: /@tail and /tail both do bounds check. This is intentional. + if {[catch {llength $leveldata} len]} { + set action ?mismatch-not-a-list + break + } + #tail is a little different in that we allow tail on a single element list - returning an empty result - but it can't be called on an empty list + #arguably tail could be considered as an index-out-of-range for less than 2 elements - but this would be less useful, and surprising to those coming from other pattern-matching systems. + #In this way tail is different to @1-end + if {$len == 0} { + set action ?mismatch-list-index-out-of-range + break + } + set assigned [lrange $leveldata 1 end] ;#return zero or more elements - but only if there is something (a head) at position zero. + } elseif {$index eq "anyhead"} { + # @anyhead + #allow returning of head or nothing if empty list + if {[catch {llength $leveldata} len]} { + set action ?mismatch-not-a-list + break + } + set assigned [lindex $leveldata 0] + } elseif {$index eq "anytail"} { + # @anytail + #allow returning of tail or nothing if empty list + #anytail will return empty both for empty list, or single element list - but potentially useful in combination with anyhead. + if {[catch {llength $leveldata} len]} { + set action ?mismatch-not-a-list + break + } + set assigned [lrange $leveldata 1 end] + } elseif {$index eq "init"} { + # @init + #all but last element - same as haskell 'init' + if {[catch {llength $leveldata} len]} { + set action ?mismatch-not-a-list + break + } + set assigned [lrange $leveldata 0 end-1] + } elseif {$index eq "list"} { + # @list + #allow returning of entire list even if empty + if {[catch {llength $leveldata} len]} { + set action ?mismatch-not-a-list + break + } + set assigned $leveldata + } elseif {$index eq "raw"} { + #no list checking.. + set assigned $leveldata + } elseif {$index eq "keys"} { + #need active_key_type of 'list' for 'keys' and 'values' keywords which act on either dict or a list with even number of elements + if {[catch {dict size $leveldata} dsize]} { + set action ?mismatch-not-a-dict + break + } + set assigned [dict keys $leveldata] + } elseif {$index eq "values"} { + #need active_key_type of 'list' for 'keys' and 'values' keywords which act on either dict or a list with even number of elements + if {[catch {dict size $leveldata} dsize]} { + set action ?mismatch-not-a-dict + break + } + set assigned [dict values $leveldata] + } elseif {$index eq "pairs"} { + if {[catch {dict size $leveldata} dsize]} { + set action ?mismatch-not-a-dict + break + } + #set assigned [dict values $leveldata] + set pairs [list] + tcl::dict::for {k v} $leveldata {lappend pairs [list $k $v]} + set assigned [lindex [list $pairs [unset pairs]] 0] + } elseif {[string is integer -strict $index]} { + if {[catch {llength $leveldata} len]} { + set action ?mismatch-not-a-list + break + } + # only check if @ was directly in original index section + if {$do_bounds_check && ($index+1 > $len || $index < 0)} { + set action ?mismatch-list-index-out-of-range + break + } + if {$get_not} { + #already handled not-0 + set assigned [lreplace $leveldata $index $index] + } else { + set assigned [lindex $leveldata $index] + } + } elseif {[string first "end" $index] >=0} { + if {[regexp {^end([-+]{1,2}[0-9]+)$} $index _match endspec]} { + if {[catch {llength $leveldata} len]} { + set action ?mismatch-not-a-list + break + } + #leave the - from the end- as part of the offset + set offset [expr $endspec] ;#don't brace! (consider: set x --34;puts expr $j;puts expr {$j} ) + if {$do_bounds_check && ($offset > 0 || abs($offset) >= $len)} { + set action ?mismatch-list-index-out-of-range + break + } + if {$get_not} { + set assigned [lreplace $leveldata $index $index] + } else { + set assigned [lindex $leveldata $index] + } + } elseif {[regexp {^([0-9]+|end|end[-+]{1,2}[0-9]+)-([0-9]+|end|end[-+]{1,2}([0-9]+))$} $index _ start end]} { + if {[catch {llength $leveldata} len]} { + set action ?mismatch-not-a-list + break + } + if {$do_bounds_check && [string is integer -strict $start]} { + if {$start+1 > $len || $start < 0} { + set action ?mismatch-list-index-out-of-range + break + } + } elseif {$start eq "end"} { + #ok + } elseif {$do_bounds_check} { + set startoffset [string range $start 3 end] ;#include the - from end- + set startoffset [expr $startoffset] ;#don't brace! + if {$startoffset > 0 || abs($startoffset) >= $len} { + set action ?mismatch-list-index-out-of-range + break + } + } + if {$do_bounds_check && [string is integer -strict $end]} { + if {$end+1 > $len || $end < 0} { + set action ?mismatch-list-index-out-of-range + break + } + } elseif {$end eq "end"} { + #ok + } elseif {$do_bounds_check} { + set endoffset [string range $end 3 end] ;#include the - from end- + set endoffset [expr $endoffset] ;#don't brace! + if {$endoffset > 0 || abs($endoffset) >= $len} { + set action ?mismatch-list-index-out-of-range + break + } + } + if {$get_not} { + set assigned [lreplace $leveldata $start $end] + } else { + set assigned [lrange $leveldata $start $end] + } + } else { + error $listmsg "destructure $selector" [list pipesyntax destructure selector $selector] + } + } elseif {[string first - $index] > 0} { + puts "====> index:$index leveldata:$leveldata" + if {[catch {llength $leveldata} len]} { + set action ?mismatch-not-a-list + break + } + #handle pure int-int ranges separately + set testindex [string map [list - "" + ""] $index] + if {[string is digit -strict $testindex]} { + #don't worry about leading - negative value for indices not valid anyway + set parts [split $index -] + if {[llength $parts] != 2} { + error $listmsg "destructure $selector" [list pipesyntax destructure selector $selector] + } + lassign $parts start end + if {$start+1 > $len || $end+1 > $len} { + set action ?mismatch-not-a-list + break + } + if {$get_not} { + set assigned [lreplace $leveldata $start $end] + } else { + set assigned [lrange $leveldata $start $end] + } + } else { + error $listmsg "destructure $selector" [list pipesyntax destructure selector $selector] + } + + } else { + #keyword 'pipesyntax' at beginning of error message + error $listmsg "destructure $selector" [list pipesyntax destructure selector $selector] + } + } else { + #treat as dict key + set active_key_type "dict" + if {[dict exists $leveldata $index]} { + set assigned [dict get $leveldata $index] + } else { + set action ?mismatch-dict-key-not-found + break + } + + } + } + set leveldata $assigned + set rhs $leveldata + #don't break on empty data - operations such as # and ## can return 0 + #if {![llength $leveldata]} { + # break + #} + incr i_keyindex + } + #puts stdout "----> destructure rep leveldata: [rep $leveldata]" + #puts stdout ">> destructure returning: [dict create -assigned $leveldata -action $action -lhs $lhs -rhs $rhs]" + + #maintain key order - caller unpacks using lassign + return [dict create -assigned $leveldata -action $action -lhs $lhs -rhs $rhs] + + } + #todo - fp_destructure - return a function-pipeline that can then be transformed to a funcl and finally a more efficient tcl script + proc destructure_func {selector data} { + #puts stderr ".d." + set selector [string trim $selector /] + #upvar v_list_idx v_list_idx ;#positional tracker for /@ - list position + #upvar v_dict_idx v_dict_idx ;#positional tracker for /@@ - dict position + + #map some problematic things out of the way in a manner that maintains some transparency + #e.g glob chars ? * in a command name can make testing using {[info commands $cmd] ne ""} produce spurious results - requiring a stricter (and slower) test such as {$cmd in [info commands $cmd]} + #The selector forms part of the proc name + #review - compare with pipecmd_namemapping + set selector_safe [string map [list {*}{ + ? + * + \\ + {"} + {$} + "\x1b\[" + "\x1b\]" + {[} + {]} + :: + {;} + " " + \t + \n + \r + }] $selector] + + set cmdname ::punk::pipecmds::destructure::_$selector_safe + if {[info commands $cmdname] ne ""} { + return [$cmdname $data] ;# note upvar 2 for stateful v_list_idx to be resolved in _multi_bind_result context + } + + set leveldata $data + set body [destructure_func_build_procbody $cmdname $selector $data] + + puts stdout ---- + puts stderr "proc $cmdname {leveldata} {" + puts stderr $body + puts stderr "}" + puts stdout --- + proc $cmdname {leveldata} $body + #eval $script ;#create the proc + debug.punk.pipe.compile {proc $cmdname} 4 + #return [dict create -assigned $leveldata -action $action -lhs $lhs -rhs $rhs] + #use return - script has upvar 2 for v_list_idx to be resolved in _multi_bind_result context + return [$cmdname $data] + } + + #Builds a *basic* function to do the destructuring. + #This is simply a set of steps to destructure each level of the data based on the hierarchical selector. + #It just uses intermediate variables and adds some comments to the code to show the indices used at each point. + #This may be useful in the long run as a debug/fallback mechanism - but ideally we should be building a more efficient script. + proc destructure_func_build_procbody {cmdname selector data} { + set script "" + #place selector in comment in script only - if there is an error in selector we pick it up when building the script. + #The script itself should only be returning errors in its action key of the result dictionary + append script \n [string map [list $selector] {# set selector {}}] + set subindices [split $selector /] + append script \n [string map [list [list $subindices]] {# set subindices }] + set action ?match ;#default assumption. Alternatively set to ?mismatch or ?mismatch- and always break + append script \n {set action ?match} + #append script \n {set assigned ""} ;#review + set active_key_type "" + append script \n {# set active_key_type ""} + set lhs "" + #append script \n [tstr {set lhs ${{$lhs}}}] + append script \n {set lhs ""} + set rhs "" + append script \n {set rhs ""} + + set INDEX_OPERATIONS {} ;#caps to make clear in templates that this is substituted from script building scope + + #maintain key order - caller unpacks using lassign + set returnline {dict create -assigned $leveldata -action $action -lhs $lhs -rhs $rhs} + set return_template {return [tcl::dict::create -assigned $leveldata -action $action -lhs $lhs -rhs xxx -index_operations {${$INDEX_OPERATIONS}}]} + #set tpl_return_mismatch {return [dict create -assigned $leveldata -action ${$MISMATCH} -lhs $lhs -rhs $rhs -index_operations {${$INDEX_OPERATIONS}}]} + set tpl_return_mismatch {return [dict create -assigned $leveldata -action ${$MISMATCH} -lhs $lhs -rhs xxx -index_operations {${$INDEX_OPERATIONS}}]} + set tpl_return_mismatch_not_a_list {return [dict create -assigned $leveldata -action ?mismatch-not-a-list -lhs $lhs -rhs xxx -index_operations {${$INDEX_OPERATIONS}}]} + set tpl_return_mismatch_list_index_out_of_range {return [dict create -assigned $leveldata -action ?mismatch-list-index-out-of-range -lhs $lhs -rhs xxx -index_operations {${$INDEX_OPERATIONS}}]} + set tpl_return_mismatch_list_index_out_of_range_empty {return [dict create -assigned $leveldata -action ?mismatch-list-index-out-of-range-empty -lhs $lhs -rhs xxx -index_operations {${$INDEX_OPERATIONS}}]} + set tpl_return_mismatch_not_a_dict {return [dict create -assigned $leveldata -action ?mismatch-not-a-dict -lhs $lhs -rhs xxx -index_operations {${$INDEX_OPERATIONS}}]} + #dict 'index' when using stateful @@ etc to iterate over dict instead of by key + set tpl_return_mismatch_dict_index_out_of_range {return [dict create -assigned $leveldata -action ?mismatch-dict-index-out-of-range -lhs $lhs -rhs xxx -index_operations {${$INDEX_OPERATIONS}}]} + set tpl_return_mismatch_dict_key_not_found {return [dict create -assigned $leveldata -action ?mismatch-dict-key-not-found -lhs $lhs -rhs xxx -index_operations {${$INDEX_OPERATIONS}}]} + + + if {![string length $selector]} { + #just return $leveldata + set script { + dict create -assigned $leveldata -action ?match -lhs "" -rhs $leveldata + } + return $script + } + + if {[string is digit -strict [join $subindices ""]]} { + #review tip 551 (underscores in numerical literals) (tcl9+) + #puts stderr ">>>>>>>>>>>>>>>> data: $leveldata selector: $selector subindices: $subindices" + #pure numeric keylist - put straight to lindex + # + #NOTE: this direct access e.g v/0/1/2 doesn't check out of bounds which is at odds with list access containing @ + #We will leave this as a syntax for different (more performant) behaviour + #- it's potentially a little confusing - but it would be a shame not to have the possibility to take advantage of the lindex deep indexing capability in pattern matching. + #TODO - review and/or document + # + #Todo - add a handler for v/n/n/n/n/# to allow unchecked counting at depth too. + #(or more generally - loop until we hit another type of subindex) + + #set assigned [lindex $leveldata {*}$subindices] + if {[llength $subindices] == 1} { + append script \n "# index_operation listindex" \n + lappend INDEX_OPERATIONS listindex + } else { + append script \n "# index_operation listindex-nested" \n + lappend INDEX_OPERATIONS listindex-nested + } + append script \n [tstr -return string -allowcommands { + if {[catch {lindex $leveldata ${$subindices}} leveldata]} { + ${[tstr -ret string $tpl_return_mismatch_not_a_list]} + } + }] + # -- --- --- + #append script \n $returnline \n + append script [tstr -return string $return_template] + return $script + # -- --- --- + } + if {[string match @@* $selector]} { + #part following a double @ is dict key possibly with forward-slash separators for subpath access e.g @@key/subkey/etc + set rawkeylist [split $selector /] ;#first key retains @@ - may be just '@@' + set keypath [string range $selector 2 end] + set keylist [split $keypath /] + lappend INDEX_OPERATIONS dict_path + if {([lindex $rawkeylist 0] ne "@@") && ([lsearch $keylist @*] == -1) && ([lsearch $keylist #*] == -1) && ([lsearch $keylist %*] == -1)} { + #pure keylist for dict - process in one go + #dict exists will return 0 if not a valid dict. + # is equivalent to {*}keylist when substituted + append script \n [tstr -return string -allowcommands { + if {[dict exists $leveldata ${$keylist}]} { + set leveldata [dict get $leveldata ${$keylist}] + } else { + #set action ?mismatch-dict-key-not-found + ${[tstr -ret string $tpl_return_mismatch_dict_key_not_found]} + } + }] + append script [tstr -return string $return_template] + return $script + # -- --- --- + } + #else + #compound keylist e.g x@@data/@0/1 or x@@/a (combined dict/list access) + #process level by level + } + + + + set i_keyindex 0 + append script \n {set i_keyindex 0} + #todo - check performance impact of catches around list and dict operations - consider single catch around destructure and less specific match error info? + foreach index $subindices { + #set index_operation "unspecified" + set level_script_complete 0 ;#instead of break - as we can't use data to determine break when building script + set SUBPATH [join [lrange $subindices 0 $i_keyindex] /] + append script \n "# ------- START index:$index subpath:$SUBPATH ------" + set lhs $index + append script \n "set lhs {$index}" + + set assigned "" + append script \n {set assigned ""} + + #got_not shouldn't need to be in script + set get_not 0 + if {[tcl::string::index $index 0] eq "!"} { + append script \n {#get_not is true e.g !0-end-1 !end-4-end-2 !0 !@0 !@@key} + set index [tcl::string::range $index 1 end] + set get_not 1 + } + + # do_bounds_check shouldn't need to be in script + set do_bounds_check 0 ;#modified by leading single @ for list operations - doesn't apply to certain items like 'head','tail' which have specifically defined bounds-checks implicit in their normal meaning. + #thse have anyhead and anytail for explicit allowance to be used on lists with insufficient items to produce values. + #append script \n {set do_boundscheck 0} + switch -exact -- $index { + # - @# { + #list length + set active_key_type "list" + if {$get_not} { + lappend INDEX_OPERATIONS not-list + append script \n {# set active_key_type "list" index_operation: not-list} + append script \n { + if {[catch {llength $leveldata}]} { + #not a list - not-length is true + set assigned 1 + } else { + #is a list - not-length is false + set assigned 0 + } + } + } else { + lappend INDEX_OPERATIONS list-length + append script \n {# set active_key_type "list" index_operation: list-length} + append script \n [tstr -return string -allowcommands { + if {[catch {llength $leveldata} assigned]} { + ${[tstr -ret string $tpl_return_mismatch_not_a_list]} + } + }] + } + set level_script_complete 1 + } + ## { + #dict size + set active_key_type "dict" + if {$get_not} { + lappend INDEX_OPERATIONS not-dict + append script \n {# set active_key_type "dict" index_operation: not-dict} + append script \n { + if {[catch {dict size $leveldata}]} { + set assigned 1 ;#not a dict - not-size is true + } else { + set assigned 0 ;#is a dict - not-size is false + } + } + } else { + lappend INDEX_OPERATIONS dict-size + append script \n {# set active_key_type "dict" index_operation: dict-size} + append script \n [tstr -return string -allowcommands { + if {[catch {dict size $leveldata} assigned]} { + #set action ?mismatch-not-a-dict + ${[tstr -ret string $tpl_return_mismatch_not_a_dict]} + } + }] + } + set level_script_complete 1 + } + %# { + set active_key_type "string" + if {$get_not} { + error "!%# not string length is not supported" + } + #string length - REVIEW - + lappend INDEX_OPERATIONS string-length + append script \n {# set active_key_type "" index_operation: string-length} + append script \n {set assigned [string length $leveldata]} + set level_script_complete 1 + } + %%# { + #experimental + set active_key_type "string" + if {$get_not} { + error "!%%# not string length is not supported" + } + #string length - REVIEW - + lappend INDEX_OPERATIONS ansistring-length + append script \n {# set active_key_type "" index_operation: ansistring-length} + append script \n {set assigned [ansistring length $leveldata]} + set level_script_complete 1 + } + %str - %string { + set active_key_type "string" + if {$get_not} { + error "!%str - not string-get is not supported" + } + lappend INDEX_OPERATIONS string-get + append script \n {# set active_key_type "" index_operation: string-get} + append script \n {set assigned $leveldata} + set level_script_complete 1 + + #todo - %lpad- %lpadstr- %join- etc as in punk::lib::showdict + #review - merge code shared with showdict for these operations + } + %sp { + #experimental + set active_key_type "string" + if {$get_not} { + error "!%sp - not string-space is not supported" + } + lappend INDEX_OPERATIONS string-space + append script \n {# set active_key_type "" index_operation: string-space} + append script \n {set assigned " "} + set level_script_complete 1 + } + %empty { + #experimental + set active_key_type "string" + if {$get_not} { + error "!%empty - not string-empty is not supported" + } + lappend INDEX_OPERATIONS string-empty + append script \n {# set active_key_type "" index_operation: string-empty} + append script \n {set assigned ""} + set level_script_complete 1 + } + @words { + set active_key_type "string" + if {$get_not} { + error "!%words - not list-words-from-string is not supported" + } + lappend INDEX_OPERATIONS list-words-from-string + append script \n {# set active_key_type "" index_operation: list-words-from-string} + append script \n {set assigned [regexp -inline -all {\S+} $leveldata]} + set level_script_complete 1 + } + @chars { + #experimental - leading character based on result not input(?) + #input type is string - but output is list + set active_key_type "list" + if {$get_not} { + error "!%chars - not list-chars-from-string is not supported" + } + lappend INDEX_OPERATIONS list-from_chars + append script \n {# set active_key_type "" index_operation: list-chars-from-string} + append script \n {set assigned [split $leveldata ""]} + set level_script_complete 1 + } + @join { + #experimental - flatten one level of list + #join without arg - output is list + set active_key_type "string" + if {$get_not} { + error "!@join - not list-join-list is not supported" + } + lappend INDEX_OPERATIONS list-join-list + append script \n {# set active_key_type "" index_operation: list-join-list} + append script \n {set assigned [join $leveldata]} + set level_script_complete 1 + } + %join { + #experimental + #input type is list - but output is string + set active_key_type "string" + if {$get_not} { + error "!%join - not string-join-list is not supported" + } + lappend INDEX_OPERATIONS string-join-list + append script \n {# set active_key_type "" index_operation: string-join-list} + append script \n {set assigned [join $leveldata ""]} + set level_script_complete 1 + } + %ansiview { + #review - implemented differently in showdict. + #(showdict uses ansistring VIEW -lf 1 ) + set active_key_type "string" + if {$get_not} { + error "!%# not string-ansiview is not supported" + } + lappend INDEX_OPERATIONS string-ansiview + append script \n {# set active_key_type "" index_operation: string-ansiview} + append script \n {set assigned [ansistring VIEW $leveldata]} + set level_script_complete 1 + } + %ansiviewstyle { + set active_key_type "string" + if {$get_not} { + error "!%# not string-ansiviewstyle is not supported" + } + lappend INDEX_OPERATIONS string-ansiviewstyle + append script \n {# set active_key_type "" index_operation: string-ansiviewstyle} + append script \n {set assigned [ansistring VIEWSTYLE $leveldata]} + set level_script_complete 1 + } + @ { + #as this is a stateful list next index operation - we use not (!@) to mean there is no element at the next index (instead of returning the complement ie all elements except next) + #This is in contrast to other not operations on indices e.g /!2 which returns all elements except that at index 2 + + + #append script \n {puts stderr [uplevel 1 [list info vars]]} + + #NOTE: + #v_list_idx in context of _multi_bind_result + #we call destructure_func from _mult_bind_result which in turn calls the proc (or the script on first run) + append script \n {upvar 2 v_list_idx v_list_idx} + + set active_key_type "list" + append script \n {# set active_key_type "list" index_operation: list-get-next} + #e.g @1/1/@/1 the lone @ is a positional spec for this specific subkey + #no normalization done - ie @2/@ will not be considered same subkey as @end/@ or @end-0/@ even if llength = 3 + #while x@,y@.= is reasonably handy - especially for args e.g $len} { + set assigned 1 + } else { + set assigned 0 + } + }] + + } else { + lappend INDEX_OPERATIONS get-next + append script \n [tstr -return string -allowcommands { + set index [expr {[incr v_list_idx(@)]-1}] + + if {[catch {llength $leveldata} len]} { + #set action ?mismatch-not-a-list + ${[tstr -ret string $tpl_return_mismatch_not_a_list]} + } elseif {$index+1 > $len} { + #set action ?mismatch-list-index-out-of-range + ${[tstr -ret string $tpl_return_mismatch_list_index_out_of_range]} + } else { + set assigned [lindex $leveldata $index] + } + }] + } + set level_script_complete 1 + } + @* { + set active_key_type "list" + if {$get_not} { + lappend INDEX_OPERATIONS list-is-empty + append script \n [tstr -return string -allowcommands { + if {[catch {llength $leveldata} len]} { + ${[tstr -ret string $tpl_return_mismatch_not_a_list]} + } elseif {$len == 0} { + set assigned 1 ;#list is empty + } else { + set assigned 0 + } + }] + } else { + lappend INDEX_OPERATIONS list-get-all + append script \n [tstr -return string -allowcommands { + if {[catch {llength $leveldata} len]} { + ${[tstr -ret string $tpl_return_mismatch_not_a_list]} + } else { + set assigned [lrange $leveldata 0 end] + } + }] + } + set level_script_complete 1 + } + @@ { + #stateful: tracking of index using v_dict_idx + set active_key_type "dict" + lappend INDEX_OPERATIONS get-next-value + append script \n {# set active_key_type "dict" index_operation: get-next-value} + append script \n {upvar v_dict_idx v_dict_idx} ;#review! + + #NOTE: it may at first seem pointless to use @@/key, since we have to know the key - but this can be used to match 'key' only at the first position in .= list key {x y} key2 etc + #x@@ = a {x y} + #x@@/@0 = a + #x@@/@1 = x y + #x@@/a = a {x y} + # but.. as the @@ is stateful - it generally isn't very useful for multiple operations on the same pair within the pattern group. + # (note that @@ @?@ @??@ form different subpaths - so the ? & ?? versions can be used to test match prior to @@ without affecting the index) + #review - might be more useful if they shared an index ? + # It is analogous to v1@,v2@ for lists. + # @pairs is more useful for repeated operations + + + set indent " " + set assignment_script [string map [list \r\n "\r\n$indent" \n "\n$indent" ] { + if {($keyindex + 1) <= $dsize} { + set k [lindex [dict keys $leveldata] $keyindex] + set assigned [list $k [dict get $leveldata $k]] + } else { + ${[tstr -ret string $tpl_return_mismatch_dict_index_out_of_range]} + } + }] + + set assignment_script [tstr -ret string -allowcommands $assignment_script] + + append script [tstr -return string -allowcommands { + if {[catch {dict size $leveldata} dsize]} { + ${[tstr -ret string $tpl_return_mismatch_not_a_dict]} + } else { + set next_this_level [incr v_dict_idx(${$SUBPATH})] + set keyindex [expr {$next_this_level -1}] + ${$assignment_script} + } + }] + set level_script_complete 1 + } + @?@ { + #stateful: tracking of index using v_dict_idx + set active_key_type "dict" + lappend INDEX_OPERATIONS get?-next-value + append script \n {# set active_key_type "dict" index_operation: get?-next-value} + append script \n {upvar v_dict_idx v_dict_idx} ;#review! + set indent " " + set assignment_script [string map [list \r\n "\r\n$indent" \n "\n$indent" ] { + if {($keyindex + 1) <= $dsize} { + set k [lindex [dict keys $leveldata] $keyindex] + set assigned [dict get $leveldata $k] + } else { + set assigned [list] + } + }] + append script [tstr -return string -allowcommands { + if {[catch {dict size $leveldata} dsize]} { + ${[tstr -ret string $tpl_return_mismatch_not_a_dict]} + } else { + set next_this_level [incr v_dict_idx(${$SUBPATH})] + set keyindex [expr {$next_this_level -1}] + ${$assignment_script} + } + }] + set level_script_complete 1 + } + @??@ { + set active_key_type "dict" + lappend INDEX_OPERATIONS get?-next-pair + append script \n {# set active_key_type "dict" index_operation: get?-next-pair} + append script \n {upvar v_dict_idx v_dict_idx} ;#review! + set indent " " + set assignment_script [string map [list \r\n "\r\n$indent" \n "\n$indent" ] { + if {($keyindex + 1) <= $dsize} { + set k [lindex [dict keys $leveldata] $keyindex] + set assigned [list $k [dict get $leveldata $k]] + } else { + set assigned [list] + } + }] + append script [tstr -return string -allowcommands { + if {[catch {dict size $leveldata} dsize]} { + ${[tstr -ret string $tpl_return_mismatch_not_a_dict]} + } else { + set next_this_level [incr v_dict_idx(${$SUBPATH})] + set keyindex [expr {$next_this_level -1}] + ${$assignment_script} + } + }] + set level_script_complete 1 + } + @vv@ - @VV@ - @kk@ - @KK@ { + error "unsupported index $index" + } + default { + + #assert rules for values within @@ + #glob search is done only if there is at least one * within @@ + #if there is at least one ? within @@ - then a non match will not raise an error (quiet) + + #single or no char between @@: + #lookup/search is based on key - return is values + + #double char within @@: + #anything with a dot returns k v pairs e.g @k.@ @v.@ @..@ + #anything that is a duplicate returns k v pairs e.g @kk@ @vv@ @**@ + #anything with a letter and a star returns the type of the letter, and the search is based on the position of the star where posn 1 is for key, posn 2 is for value + #e.g @k*@ returns keys - search on values + #e.g @*k@ returns keys - search on keys + #e.g @v*@ returns values - search on values + #e.g @*v@ returns values - search on keys + + switch -glob -- $index { + @@* { + #exact key match - return value + #noisy get value - complain if key non-existent + #doesn't complain if not a dict - because we use 'tcl::dict::exists' which will return false without error even if the value isn't dict-shaped + set active_key_type "dict" + set key [string range $index 2 end] + if {$get_not} { + lappend INDEX_OPERATIONS exactkey-get-value-not + #review - dict remove allows silent call if key doesn't exist - but we are enforcing existence here + #this seems reasonable given we have an explicit @?@ syntax (nocomplain equivalent) and there could be a legitimate case for wanting a non-match if trying to return the complement of a non-existent key + append script \n [tstr -return string -allowcommands { + # set active_key_type "dict" index_operation: exactkey-get-value-not + if {[dict exists $leveldata ${$key}]} { + set assigned [dict values [dict remove $leveldata ${$key}]] + } else { + #set action ?mismatch-dict-key-not-found + ${[tstr -ret string $tpl_return_mismatch_dict_key_not_found]} + } + }] + + } else { + lappend INDEX_OPERATIONS exactkey-get-value + append script \n [tstr -return string -allowcommands { + # set active_key_type "dict index_operation: exactkey-get-value" + if {[dict exists $leveldata ${$key}]} { + set assigned [dict get $leveldata ${$key}] + } else { + #set action ?mismatch-dict-key-not-found + ${[tstr -ret string $tpl_return_mismatch_dict_key_not_found]} + } + }] + } + set level_script_complete 1 + } + {@\?@*} { + #exact key match - quiet get value + #silent empty result if non-existent key - silence when non-existent key also if using not-@?@badkey which will just return whole dict + #note - dict remove will raise error on non-dict-shaped value whilst dict exists will not + set active_key_type "dict" + set key [string range $index 3 end] + if {$get_not} { + lappend INDEX_OPERATIONS exactkey?-get-value-not + append script \n [tstr -return string -allowcommands { + # set active_key_type "dict" index_operation: exactkey?-get-value-not + if {[catch {dict size $leveldata}]} { + ${[tstr -ret string $tpl_return_mismatch_not_a_dict]} + } + set assigned [dict values [dict remove $leveldata ${$key}]] + }] + + } else { + lappend INDEX_OPERATIONS exactkey?-get-value + #dict exists test is safe - no need for catch + append script \n [string map [list $key] { + # set active_key_type "dict" index_operation: exactkey?-get-value + if {[dict exists $leveldata ]} { + set assigned [dict get $leveldata ] + } else { + set assigned [dict create] + } + }] + } + set level_script_complete 1 + } + {@\?\?@*} { + #quiet get pairs + #this is silent too.. so how do we do a checked return of dict key+val? + set active_key_type "dict" + set key [string range $index 4 end] + if {$get_not} { + lappend INDEX_OPERATIONS exactkey?-get-pair-not + append script \n [tstr -return string -allowcommands { + # set active_key_type "dict" index_operation: exactkey?-get-pair-not + if {[catch {dict size $leveldata}]} { + ${[tstr -ret string $tpl_return_mismatch_not_a_dict]} + } + set assigned [dict remove $leveldata ${$key}] + }] + } else { + lappend INDEX_OPERATIONS exactkey?-get-pair + append script \n [string map [list $key] { + # set active_key_type "dict" index_operation: exactkey?-get-pair + if {[dict exists $leveldata ]} { + set assigned [dict create [dict get $leveldata ]] + } else { + set assigned [dict create] + } + }] + } + set level_script_complete 1 + } + @..@* - @kk@* - @KK@* { + #noisy get pairs by key + set active_key_type "dict" + set key [string range $index 4 end] + if {$get_not} { + lappend INDEX_OPERATIONS exactkey-get-pairs-not + #review - dict remove allows silent call if key doesn't exist - but we are enforcing existence here + #this seems reasonable given we have an explicit @?@ syntax (nocomplain equivalent) and there could be a legitimate case for wanting a non-match if trying to return the complement of a non-existent key + append script \n [tstr -return string -allowcommands { + # set active_key_type "dict" index_operation: exactkey-get-pairs-not + if {[dict exists $leveldata ${$key}]} { + set assigned [tcl::dict::remove $leveldata ${$key}] + } else { + ${[tstr -ret string $tpl_return_mismatch_dict_key_not_found]} + } + }] + + } else { + lappend INDEX_OPERATIONS exactkey-get-pairs + append script \n [tstr -return string -allowcommands { + # set active_key_type "dict index_operation: exactkey-get-pairs" + if {[dict exists $leveldata ${$key}]} { + tcl::dict::set assigned ${$key} [tcl::dict::get $leveldata ${$key}] + } else { + ${[tstr -ret string $tpl_return_mismatch_dict_key_not_found]} + } + }] + } + set level_script_complete 1 + + } + @vv@* - @VV@* { + #noisy(?) get pairs by exact value + #return mismatch on non-match even when not- specified + set active_key_type "dict" + set keyglob [string range $index 4 end] + set active_key_type "dict" + set key [string range $index 4 end] + if {$get_not} { + #review - for consistency we are reporting a mismatch when the antikey being looked up doesn't exist + #The utility of this is debatable + lappend INDEX_OPERATIONS exactvalue-get-pairs-not + append script \n [tstr -return string -allowcommands { + # set active_key_type "dict" index_operation: exactvalue-get-pairs-not + if {[catch {dict size $leveldata}]} { + ${[tstr -ret string $tpl_return_mismatch_not_a_dict]} + } + set nonmatches [dict create] + tcl::dict::for {k v} $leveldata { + if {![string equal ${$key} $v]} { + dict set nonmatches $k $v + } + } + + if {[dict size $nonmatches] < [dict size $leveldata]} { + #our key matched something + set assigned $nonmatches + } else { + #our key didn't match anything - don't return the nonmatches + #set action ?mismatch-dict-key-not-found + ${[tstr -ret string $tpl_return_mismatch_dict_key_not_found]} + } + }] + + } else { + lappend INDEX_OPERATIONS exactvalue-get-pairs + append script \n [tstr -return string -allowcommands { + # set active_key_type "dict index_operation: exactvalue-get-pairs-not" + if {[catch {dict size $leveldata}]} { + ${[tstr -ret string $tpl_return_mismatch_not_a_dict]} + } + set matches [list] + tcl::dict::for {k v} $leveldata { + if {[string equal ${$key} $v]} { + lappend matches $k $v + } + } + if {[llength $matches]} { + set assigned $matches + } else { + #set action ?mismatch-dict-key-not-found + ${[tstr -ret string $tpl_return_mismatch_dict_key_not_found]} + } + }] + } + set level_script_complete 1 + + } + {@\*@*} - {@\*v@*} - {@\*V@*} { + #dict key glob - return values only + set active_key_type "dict" + if {[string match {@\*@*} $index]} { + set keyglob [string range $index 3 end] + } else { + #vV + set keyglob [string range $index 4 end] + } + #if $keyglob eq "" - needs to query for dict key that is empty string. + if {$get_not} { + lappend INDEX_OPERATIONS globkey-get-values-not + append script \n [tstr -return string -allowcommands { + if {[catch {dict size $leveldata}]} { + ${[tstr -ret string $tpl_return_mismatch_not_a_dict]} + } + # set active_key_type "dict" index_operation: globkey-get-values-not + set matched [dict keys $leveldata {${$keyglob}}] + set assigned [dict values [dict remove $leveldata {*}$matched]] + }] + + } else { + lappend INDEX_OPERATIONS globkey-get-values + append script \n [tstr -return string -allowcommands { + # set active_key_type "dict" index_operation: globkey-get-values + if {[catch {dict size $leveldata}]} { + ${[tstr -ret string $tpl_return_mismatch_not_a_dict]} + } + set matched [dict keys $leveldata {${$keyglob}}] + set assigned [list] + foreach m $matched { + lappend assigned [dict get $leveldata $m] + } + }] + } + set level_script_complete 1 + + } + {@\*.@*} { + #dict key glob - return pairs + set active_key_type "dict" + set keyglob [string range $index 4 end] + append script [tstr -return string -allowcommands { + if {[catch {dict size $leveldata}]} { + ${[tstr -ret string $tpl_return_mismatch_not_a_dict]} + } + }] + if {$get_not} { + lappend INDEX_OPERATIONS globkey-get-pairs-not + append script \n [string map [list $keyglob] { + # set active_key_type "dict" index_operation: globkey-get-pairs-not + set matched [dict keys $leveldata {}] + set assigned [dict remove $leveldata {*}$matched] + }] + + } else { + lappend INDEX_OPERATIONS globkey-get-pairs + append script \n [string map [list $keyglob] { + # set active_key_type "dict" index_operations: globkey-get-pairs + set matched [dict keys $leveldata {}] + set assigned [dict create] + foreach m $matched { + dict set assigned $m [dict get $leveldata $m] + } + }] + } + set level_script_complete 1 + } + {@\*k@*} - {@\*K@*} { + #dict key glob - return keys + set active_key_type "dict" + set keyglob [string range $index 4 end] + append script [tstr -return string -allowcommands { + if {[catch {dict size $leveldata}]} { + ${[tstr -ret string $tpl_return_mismatch_not_a_dict]} + } + }] + if {$get_not} { + lappend INDEX_OPERATIONS globkey-get-keys-not + append script \n [string map [list $keyglob] { + # set active_key_type "dict" index_operation: globkey-get-keys-not + set matched [dict keys $leveldata {}] + set assigned [dict keys [dict remove $leveldata {*}$matched]] + }] + + } else { + lappend INDEX_OPERATIONS globkey-get-keys + append script \n [string map [list $keyglob] { + # set active_key_type "dict" index_operation: globkey-get-keys + set assigned [dict keys $leveldata {}] + }] + } + set level_script_complete 1 + } + {@k\*@*} - {@K\*@*} { + #dict value glob - return keys + set active_key_type "dict" + set valglob [string range $index 4 end] + append script [tstr -return string -allowcommands { + if {[catch {dict size $leveldata}]} { + ${[tstr -ret string $tpl_return_mismatch_not_a_dict]} + } + }] + if {$get_not} { + lappend INDEX_OPERATIONS globvalue-get-keys-not + append script \n [string map [list $valglob] { + # set active_key_type "dict" index_operation: globvalue-get-keys-not + set assigned [list] + tcl::dict::for {k v} $leveldata { + if {![string match {} $v]} { + lappend assigned $k + } + } + }] + } else { + lappend INDEX_OPERATIONS globvalue-get-keys + append script \n [string map [list $valglob] { + # set active_key_type "dict" index_operation: globvalue-get-keys + set assigned [list] + tcl::dict::for {k v} $leveldata { + if {[string match {} $v]} { + lappend assigned $k + } + } + }] + } + set level_script_complete 1 + } + {@.\*@*} { + #dict value glob - return pairs + set active_key_type "dict" + set valglob [string range $index 4 end] + append script [tstr -return string -allowcommands { + if {[catch {dict size $leveldata}]} { + ${[tstr -ret string $tpl_return_mismatch_not_a_dict]} + } + }] + if {$get_not} { + lappend INDEX_OPERATIONS globvalue-get-pairs-not + append script \n [string map [list $valglob] { + # set active_key_type "dict" index_operation: globvalue-get-pairs-not + set assigned [dict create] + tcl::dict::for {k v} $leveldata { + if {![string match {} $v]} { + dict set assigned $k $v + } + } + }] + } else { + lappend INDEX_OPERATIONS globvalue-get-pairs + append script \n [string map [list $valglob] { + # set active_key_type "dict" index_operation: globvalue-get-pairs + set assigned [dict create] + tcl::dict::for {k v} $leveldata { + if {[string match {} $v]} { + dict set assigned $k $v + } + } + }] + } + set level_script_complete 1 + } + {@V\*@*} - {@v\*@*} { + #dict value glob - return values + set active_key_type dict + set valglob [string range $index 4 end] + append script [tstr -return string -allowcommands { + if {[catch {dict size $leveldata}]} { + ${[tstr -ret string $tpl_return_mismatch_not_a_dict]} + } + }] + if {$get_not} { + lappend INDEX_OPERATIONS globvalue-get-values-not + append script \n [string map [list $valglob] { + # set active_key_type "dict" ;# index_operation: globvalue-get-values-not + set assigned [list] + tcl::dict::for {k v} $leveldata { + if {![string match {} $v]} { + lappend assigned $v + } + } + }] + + } else { + lappend INDEX_OPERATIONS globvalue-get-values + append script \n [string map [list $valglob] { + # set active_key_type "dict" ;#index_operation: globvalue-get-value + set assigned [dict values $leveldata ] + }] + } + set level_script_complete 1 + + } + {@\*\*@*} { + #dict val/key glob return pairs) + set active_key_type "dict" + set keyvalglob [string range $index 4 end] + append script [tstr -return string -allowcommands { + if {[catch {dict size $leveldata}]} { + ${[tstr -ret string $tpl_return_mismatch_not_a_dict]} + } + }] + if {$get_not} { + lappend INDEX_OPERATIONS globkeyvalue-get-pairs-not + error "globkeyvalue-get-pairs-not todo" + } 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 assigned [dict create] + tcl::dict::for {k v} $leveldata { + if {[string match {} $k] || [string match {} $v]} { + dict set assigned $k $v + } + } + }] + } + set level_script_complete 1 + puts stderr "globkeyvalue-get-pairs review" + } + @* { + set active_key_type "list" + set do_bounds_check 1 + + set index [string trimleft $index @] + append script \n [string map [list $index] { + # set active_key_type "list" index_operation: ? + set index + }] + } + %split-* { + #split on one or more chars - review + #set hidekey 1 + #lassign [split $key -] _ splitchars + #set thisval [split $dval $splitchars] + set active_key_type "string" + set splitchars [string range $index 7 end] + append script \n [string map [list $splitchars] { + # set active_key_type "string" index_operation: split-string + #e.g supports %split-"\\n"= "l1\n\nl3" -> {l1 "" l3} + set splitchars "" + set assigned [split $leveldata $splitchars] + }] + puts "---split script: $script" + set level_script_complete 1 + + #todo %splitat- %splitn- ?? + } + %lpad-* { + #moved from punk::lib::showdict patterns. + #set hidekey 1 + #lassign [split $key -] _ extra + #set width [expr {[textblock::width $dval] + $extra}] + #set thisval [textblock::pad $dval -which left -width $width] + set active_key_type "string" + set extra [string range $index 6 end] + append script \n [string map [list $extra] { + # set active_key_type "string" index_operation: lpad-string + set extra "" + set width [expr {[textblock::width $leveldata] + $extra}] + set assigned [textblock::pad $leveldata -which left -width $width] + }] + set level_script_complete 1 + } + %* { + #see above re %lpad- etc and synchronizing with showdict + set active_key_type "string" + set do_bounds_check 0 + set index [string range $index 1 end] + append script \n [string map [list $index] { + # set active_key_type "string" index_operation: ? + set index + }] + } + default { + puts "destructure_func_build_body unmatched index $index" + } + } + } + } + + if {!$level_script_complete} { + + + #keyword 'pipesyntax' at beginning of error message + set listmsg "pipesyntax Unable to interpret subindex $index\n" + append listmsg "selector: '$selector'\n" + append listmsg "@ must be followed by a selector (possibly compound separated by forward slashes) suitable for lindex or lrange commands, or a not-x expression\n" + append listmsg "Additional accepted keywords include: head tail\n" + append listmsg "Use var@@key to treat value as a dict and retrieve element at key" + + #append script \n [string map [list $listmsg] {set listmsg ""}] + + + + #we can't just set 'assigned' for a position spec for in/ni (not-in) because we don't have the value here to test against + #need to set a corresponding action + if {$active_key_type in [list "" "list"]} { + set active_key_type "list" + append script \n {# set active_key_type "list"} + #for pattern matching purposes - head/tail not valid on empty lists (similar to elixir) + switch -exact -- $index { + 0 { + if {$get_not} { + append script \n "# index_operation listindex-int-not" \n + lappend INDEX_OPERATIONS listindex-zero-not + set assignment_script {set assigned [lrange $leveldata 1 end]} + } else { + lappend INDEX_OPERATIONS listindex-zero + set assignment_script {set assigned [lindex $leveldata 0]} + if {$do_bounds_check} { + append script \n "# index_operation listindex-int (bounds checked)" \n + append script \n [tstr -return string -allowcommands { + if {[catch {llength $leveldata} len]} { + ${[tstr -ret string $tpl_return_mismatch_not_a_list]} + } elseif {[llength $leveldata] == 0} { + ${[tstr -ret string $tpl_return_mismatch_list_index_out_of_range_empty]} + } else { + ${$assignment_script} + } + }] + } else { + append script \n "# index_operation listindex-int" \n + append script \n [tstr -return string -allowcommands { + if {[catch {llength $leveldata} len]} { + ${[tstr -ret string $tpl_return_mismatch_not_a_list]} + } else { + ${$assignment_script} + } + }] + } + } + } + head { + #NOTE: /@head and /head both do bounds check. This is intentional + if {$get_not} { + append script \n "# index_operation listindex-head-not" \n + lappend INDEX_OPERATIONS listindex-head-not + set assignment_script {set assigned [lrange $leveldata 1 end]} + } else { + append script \n "# index_operation listindex-head" \n + lappend INDEX_OPERATIONS listindex-head + set assignment_script {set assigned [lindex $leveldata 0]} + } + append script \n [tstr -return string -allowcommands { + if {[catch {llength $leveldata} len]} { + #set action ?mismatch-not-a-list + ${[tstr -ret string $tpl_return_mismatch_not_a_list]} + } elseif {$len == 0} { + #set action ?mismatch-list-index-out-of-range-empty + ${[tstr -ret string $tpl_return_mismatch_list_index_out_of_range_empty]} + } else { + #alias for 0 - for h@head,t@tail= similar to erlang/elixir hd() tl() or [head | tail] = list syntax + ${$assignment_script} + } + }] + } + end { + if {$get_not} { + append script \n "# index_operation listindex-end-not" \n + lappend INDEX_OPERATIONS listindex-end-not + #on single element list Tcl's lrange will do what we want here and return nothing + set assignment_script {set assigned [lrange $leveldata 0 end-1]} + } else { + append script \n "# index_operation listindex-end" \n + lappend INDEX_OPERATIONS listindex-end + set assignment_script {set assigned [lindex $leveldata end]} + } + if {$do_bounds_check} { + append script \n [tstr -return string -allowcommands { + if {[catch {llength $leveldata} len]} { + #set action ?mismatch-not-a-list + ${[tstr -ret string $tpl_return_mismatch_not_a_list]} + } elseif {$len == 0} { + #set action ?mismatch-list-index-out-of-range + ${[tstr -ret string $tpl_return_mismatch_list_index_out_of_range_empty]} + } else { + ${$assignment_script} + } + }] + } else { + append script \n [tstr -return string -allowcommands { + if {[catch {llength $leveldata} len]} { + #set action ?mismatch-not-a-list + ${[tstr -ret string $tpl_return_mismatch_not_a_list]} + } else { + ${$assignment_script} + } + }] + } + } + tail { + #NOTE: /@tail and /tail both do bounds check. This is intentional. + # + #tail is a little different in that we allow tail on a single element list - returning an empty result - but it can't be called on an empty list + #arguably tail could be considered as an index-out-of-range for less than 2 elements - but this would be less useful, and surprising to those coming from other pattern-matching systems. + #In this way tail is different to @1-end + if {$get_not} { + append script \n "# index_operation listindex-tail-not" \n + lappend INDEX_OPERATIONS listindex-tail-not + set assignment_script {set assigned [lindex $leveldata 0]} + } else { + append script \n "# index_operation listindex-tail" \n + lappend INDEX_OPERATIONS listindex-tail + set assignment_script {set assigned [lrange $leveldata 1 end] ;#return zero or more elements - but only if there is something (a head) at position zero} + } + append script \n [tstr -return string -allowcommands { + if {[catch {llength $leveldata} len]} { + #set action ?mismatch-not-a-list + ${[tstr -ret string $tpl_return_mismatch_not_a_list]} + } elseif {$len == 0} { + #set action ?mismatch-list-index-out-of-range + ${[tstr -ret string $tpl_return_mismatch_list_index_out_of_range_empty]} + } else { + ${$assignment_script} + } + }] + } + anyhead { + #allow returning of head or nothing if empty list + if {$get_not} { + append script \n "# index_operation listindex-anyhead-not" \n + lappend INDEX_OPERATIONS listindex-anyhead-not + set assignment_script {set assigned [lrange $leveldata 1 end]} + } else { + append script \n "# index_operation listindex-anyhead" \n + lappend INDEX_OPERATIONS listindex-anyhead + set assignment_script {set assigned [lindex $leveldata 0]} + } + append script \n [tstr -return string -allowcommands { + if {[catch {llength $leveldata} len]} { + #set action ?mismatch-not-a-list + ${[tstr -ret string $tpl_return_mismatch_not_a_list]} + } else { + ${$assignment_script} + } + }] + } + anytail { + #allow returning of tail or nothing if empty list + #anytail will return empty both for empty list, or single element list - but potentially useful in combination with anyhead. + if {$get_not} { + append script \n "# index_operation listindex-anytail-not" \n + lappend INDEX_OPERATIONS listindex-anytail-not + set assignment_script {set assigned [lindex $leveldata 0]} + } else { + append script \n "# index_operation listindex-anytail" \n + lappend INDEX_OPERATIONS listindex-anytail + set assignment_script {set assigned [lrange $leveldata 1 end]} + } + append script \n [tstr -return string -allowcommands { + if {[catch {llength $leveldata} len]} { + #set action ?mismatch-not-a-list + ${[tstr -ret string $tpl_return_mismatch_not_a_list]} + } else { + ${$assignment_script} + } + }] + } + init { + #all but last element - same as haskell 'init' + #counterintuitively, get-notinit can therefore return first element if it is a single element list + #does bounds_check for get-not@init make sense here? maybe - review + if {$get_not} { + append script \n "# index_operation listindex-init-not" \n + lappend INDEX_OPERATIONS listindex-init-not + set assignment_script {set assigned [lindex $leveldata end]} + } else { + append script \n "# index_operation listindex-init" \n + lappend INDEX_OPERATIONS listindex-init + set assignment_script {set assigned [lrange $leveldata 0 end-1]} + } + append script \n [tstr -return string -allowcommands { + if {[catch {llength $leveldata} len]} { + #set action ?mismatch-not-a-list + ${[tstr -ret string $tpl_return_mismatch_not_a_list]} + } else { + ${$assignment_script} + } + }] + } + list { + #get_not? + #allow returning of entire list even if empty + if {$get_not} { + lappend INDEX_OPERATIONS list-getall-not + set assignment_script {set assigned {}} + } else { + lappend INDEX_OPERATIONS list-getall + set assignment_script {set assigned $leveldata} + } + append script \n [tstr -return string -allowcommands { + if {[catch {llength $leveldata} len]} { + #set action ?mismatch-not-a-list + ${[tstr -ret string $tpl_return_mismatch_not_a_list]} + } else { + ${$assignment_script} + } + }] + } + raw { + #get_not - return nothing?? + #no list checking.. + if {$get_not} { + lappend INDEX_OPERATIONS getraw-not + append script \n {set assigned {}} + } else { + lappend INDEX_OPERATIONS getraw + append script \n {set assigned $leveldata} + } + } + keys { + #@get_not?? + #need active_key_type of 'list' for 'keys' and 'values' keywords which act on either dict or a list with even number of elements + if {$get_not} { + lappend INDEX_OPERATIONS list-getkeys-not + set assignment_script {set assigned [dict values $leveldata]} ;#not-keys is equivalent to values + } else { + lappend INDEX_OPERATIONS list-getkeys + set assignment_script {set assigned [dict keys $leveldata]} + } + append script \n [tstr -return string -allowcommands { + if {[catch {dict size $leveldata} dsize]} { + #set action ?mismatch-not-a-dict + ${[tstr -ret string $tpl_return_mismatch_not_a_dict]} + } else { + ${$assignment_script} + } + }] + } + values { + #get_not ?? + #need active_key_type of 'list' for 'keys' and 'values' keywords which act on either dict or a list with even number of elements + if {$get_not} { + lappend INDEX_OPERATIONS list-getvalues-not + set assignment_script {set assigned [dict keys $leveldata]} ;#not-values is equivalent to keys + } else { + lappend INDEX_OPERATIONS list-getvalues + set assignment_script {set assigned [dict values $leveldata]} + } + append script \n [tstr -return string -allowcommands { + if {[catch {dict size $leveldata} dsize]} { + #set action ?mismatch-not-a-dict + ${[tstr -ret string $tpl_return_mismatch_not_a_dict]} + } else { + ${$assignment_script} + } + }] + } + pairs { + #get_not ?? + if {$get_not} { + #review - return empty list instead like not-list and not-raw? + error $listmsg "destructure $selector" [list pipesyntax destructure selector $selector not-pairs_not_supported] + } else { + lappend INDEX_OPERATIONS list-getpairs + } + append script \n [tstr -return string -allowcommands { + if {[catch {dict size $leveldata} dsize]} { + #set action ?mismatch-not-a-dict + ${[tstr -ret string $tpl_return_mismatch_not_a_dict]} + } else { + set pairs [list] + tcl::dict::for {k v} $leveldata {lappend pairs [list $k $v]} + set assigned [lindex [list $pairs [unset pairs]] 0] + } + }] + } + default { + if {[regexp {[?*]} $index]} { + if {$get_not} { + lappend INDEX_OPERATIONS listsearch-not + set assign_script [string map [list $index] { + set assigned [lsearch -all -inline -not $leveldata ] + }] + } else { + lappend INDEX_OPERATIONS listsearch + set assign_script [string map [list $index] { + set assigned [lsearch -all -inline $leveldata ] + }] + } + append script \n [tstr -return string -allowcommands { + if {[catch {llength $leveldata} len]} { + ${[tstr -ret string $tpl_return_mismatch_not_a_list]} + } else { + ${$assign_script} + } + }] + } elseif {[string is integer -strict $index]} { + if {$get_not} { + lappend INDEX_OPERATIONS listindex-not + set assign_script [string map [list $index] { + #not- was specified (already handled not-0) + set assigned [lreplace $leveldata ] + }] + } else { + lappend INDEX_OPERATIONS listindex + set assign_script [string map [list $index] {set assigned [lindex $leveldata ]}] + } + + if {$do_bounds_check} { + if {$index < 0} { + error $listmsg "destructure $selector" [list pipesyntax destructure selector $selector index_lessthanzero_out_of_bounds_for_all_data_while_bounds_check_on] + } + set max [expr {$index + 1}] + append script \n [tstr -return string -allowcommands { + if {[catch {llength $leveldata} len]} { + #set action ?mismatch-not-a-list + ${[tstr -ret string $tpl_return_mismatch_not_a_list]} + } else { + # bounds_check due to @ directly specified in original index section + if {${$max} > $len} { + #set action ?mismatch-list-index-out-of-range + ${[tstr -ret string $tpl_return_mismatch_list_index_out_of_range]} + } else { + ${$assign_script} + } + } + }] + } else { + append script \n [tstr -return string -allowcommands { + if {[catch {llength $leveldata} len]} { + #set action ?mismatch-not-a-list + ${[tstr -ret string $tpl_return_mismatch_not_a_list]} + } else { + ${$assign_script} + } + }] + } + } elseif {[punk::lib::is_indexset $index]} { + #review - a basic math statement such as 5-1 is also a valid member of an indexset + #see punk::lib::is_indexset and punk::lib::indexset_resolve + #single element of an indexset - e.g @..3 or @1..5 or @..end or @.. or @end..0 or @end-5..8 etc + set is_range [expr {[string first ".." $index] >= 0}] + if {$get_not} { + if {$is_range} { + lappend INDEX_OPERATIONS list-range-not + } else { + lappend INDEX_OPERATIONS listindex-not + } + set assign_script { + set assigned [lremove $assigned {*}[punk::lib::indexset_resolve [llength $leveldata] ]] + } + } else { + if {$is_range} { + lappend INDEX_OPERATIONS list-range + #todo - if we know it's a contiguous range, we could use lrange here instead of lindex + #we would also need to detect if it's a reverse range such as @5..1 and handle that correctly + #- lrange doesn't support reverse ranges, but we could resolve the indexset to a list of indices + #and then use lindex with that list of indices to get the correct result. + #we don't always know at this point if the range is in reverse or not because we don't know the size of the list until + #runtime - so we will handle both cases in the same way for now. + #e.g for index 5..end-6 - this could be forward or reverse depending on the length of the list. + set assign_script { + set assigned [lmap i [punk::lib::indexset_resolve [llength $leveldata] ] {lindex $leveldata $i}] + } + } else { + lappend INDEX_OPERATIONS listindex + set assign_script { + set assigned [lindex $leveldata [punk::lib::indexset_resolve [llength $leveldata] ]] + } + } + } + + if {$do_bounds_check} { + #bounds check each element of the resolved indexset - if any are out of bounds, return mismatch-list-index-out-of-range + if {$is_range} { + append script \n [tstr -return string -allowcommands { + if {[catch {llength $leveldata} len]} { + #set action ?mismatch-not-a-list + ${[tstr -ret string $tpl_return_mismatch_not_a_list]} + } else { + lassign [split ..] idx1 _ idx2 + set v2 [punk::lib::lindex_resolve_basic $len $idx2] + if {isinf($v2)} { + ${[tstr -ret string $tpl_return_mismatch_list_index_out_of_range]} + } + set v1 [punk::lib::lindex_resolve_basic $len $idx1] + if {isinf($v1)} { + ${[tstr -ret string $tpl_return_mismatch_list_index_out_of_range]} + } + ${$assign_script} + } + }] + } else { + append script \n [tstr -return string -allowcommands { + if {[catch {llength $leveldata} len]} { + #set action ?mismatch-not-a-list + ${[tstr -ret string $tpl_return_mismatch_not_a_list]} + } else { + set v1 [punk::lib::lindex_resolve_basic $len ] + if {isinf($v1)} { + ${[tstr -ret string $tpl_return_mismatch_list_index_out_of_range]} + } + ${$assign_script} + } + }] + } + } else { + append script \n [tstr -return string -allowcommands { + if {[catch {llength $leveldata} len]} { + #set action ?mismatch-not-a-list + ${[tstr -ret string $tpl_return_mismatch_not_a_list]} + } else { + ${$assign_script} + } + }] + } + set script [string map [list $index] $script] + } elseif {[string first "end" $index] >=0} { + #review - obsoleted by indexset syntax. prune branch? + puts stderr "index with end detected - review if this branch still reachable - prune? $index" + if {[regexp {^end([-+]{1,2}[0-9]+)$} $index _match endspec]} { + + if {$get_not} { + lappend INDEX_OPERATIONS listindex-endoffset-not + set assign_script [string map [list $index] { + #not- was specified (already handled not-0) + set assigned [lreplace $leveldata ] + }] + } else { + lappend INDEX_OPERATIONS listindex-endoffset + set assign_script [string map [list $index ] {set assigned [lindex $leveldata ]}] + } + + if {$do_bounds_check} { + #tstr won't add braces - so the ${$endspec} value inserted in the expr will remain unbraced as required in this case. + append script \n [tstr -return string -allowcommands { + if {[catch {llength $leveldata} len]} { + set action ?mismatch-not-a-list + } else { + #bounds-check is true + #leave the - from the end- as part of the offset + set offset [expr ${$endspec}] ;#don't brace! + if {($offset > 0 || abs($offset) >= $len)} { + #set action ?mismatch-list-index-out-of-range + ${[tstr -ret string $tpl_return_mismatch_list_index_out_of_range]} + } else { + ${$assign_script} + } + } + }] + } else { + append script \n [tstr -ret string -allowcommands { + if {[catch {llength $leveldata} len]} { + #set action ?mismatch-not-a-list + ${[tstr -ret string $tpl_return_mismatch_not_a_list]} + } else { + ${$assign_script} + } + }] + } + + } elseif {[regexp {^([0-9]+|end|end[-+]{1,2}[0-9]+)-([0-9]+|end|end[-+]{1,2}([0-9]+))$} $index _ start end]} { + #review - obsoleted by indexset syntax. prune branch? + puts stderr "index with range and end detected - review if this branch still reachable - prune? $index" + if {$get_not} { + lappend INDEX_OPERATIONS list-range-not + set assign_script [string map [list $start $end ] { + #not- was specified (already handled not-0) + set assigned [lreplace $leveldata ] + }] + } else { + lappend INDEX_OPERATIONS list-range + set assign_script [string map [list $start $end] {set assigned [lrange $leveldata ]}] + } + + append script \n [tstr -ret string -allowcommands { + if {[catch {llength $leveldata} len]} { + #set action ?mismatch-not-a-list + ${[tstr -ret string $tpl_return_mismatch_not_a_list]} + } + }] + + if {$do_bounds_check} { + if {[string is integer -strict $start]} { + if {$start < 0} { + error $listmsg "destructure $selector" [list pipesyntax destructure selector $selector start_lessthanzero_out_of_bounds_for_all_data_while_bounds_check_on] + } + append script \n [tstr -return string -allowcommands { + set start ${$start} + if {$start+1 > $len} { + #set action ?mismatch-list-index-out-of-range + ${[tstr -ret string $tpl_return_mismatch_list_index_out_of_range]} + } + }] + } elseif {$start eq "end"} { + #noop + } else { + set startoffset [string range $start 3 end] ;#include the - from end- + set startoffset [expr $startoffset] ;#don't brace! + if {$startoffset > 0} { + #e.g end+1 + error $listmsg "destructure $selector" [list pipesyntax destructure selector $selector end+x_out_of_bounds_for_all_data_while_bounds_check_on] + + } + append script \n [tstr -return string -allowcommands { + set startoffset ${$startoffset} + if {abs($startoffset) >= $len} { + #set action ?mismatch-list-index-out-of-range + ${[tstr -ret string $tpl_return_mismatch_list_index_out_of_range]} + } + }] + } + if {[string is integer -strict $end]} { + if {$end < 0} { + error $listmsg "destructure $selector" [list pipesyntax destructure selector $selector end_lessthanzero_out_of_bounds_for_all_data_while_bounds_check_on] + } + append script \n [tstr -return string -allowcommands { + set end ${$end} + if {$end+1 > $len} { + #set action ?mismatch-list-index-out-of-range + ${[tstr -ret string $tpl_return_mismatch_list_index_out_of_range]} + } + }] + } elseif {$end eq "end"} { + #noop + } else { + set endoffset [string range $end 3 end] ;#include the - from end- + + set endoffset [expr $endoffset] ;#don't brace! + if {$endoffset > 0} { + error $listmsg "destructure $selector" [list pipesyntax destructure selector $selector end+x_out_of_bounds_for_all_data_while_bounds_check_on] + } + append script \n [tstr -return string -allowcommands { + set endoffset ${$endoffset} + if {abs($endoffset) >= $len} { + #set action ?mismatch-list-index-out-of-range + ${[tstr -ret string $tpl_return_mismatch_list_index_out_of_range]} + } + }] + } + } + + append script \n [string map [list $assign_script] { + if {![string match ?mismatch-* $action]} { + + } + }] + + } else { + #fail now - no need for script + error $listmsg "destructure $selector" [list pipesyntax destructure selector $selector] + } + } elseif {[string first - $index] > 0} { + puts stderr "index with - detected - review if this branch still reachable - prune? $index" + #review - we changed to detect indexset above. + #syntax @m-n should be deprecated in favour of @m..n + #todo - check if this branch still reachable - prune? + #e.g @1-3 gets here + #JMN + if {$get_not} { + lappend INDEX_OPERATIONS list-range-not + } else { + lappend INDEX_OPERATIONS list-range + } + + append script \n [tstr -return string -allowcommands { + if {[catch {llength $leveldata} len]} { + #set action ?mismatch-not-a-list + ${[tstr -ret string $tpl_return_mismatch_not_a_list]} + } + }] + + #handle pure int-int ranges separately + set testindex [string map [list - "" + ""] $index] + if {[string is digit -strict $testindex]} { + #don't worry about leading - negative value for indices not valid anyway + set parts [split $index -] + if {[llength $parts] != 2} { + error $listmsg "destructure $selector" [list pipesyntax destructure selector $selector] + } + lassign $parts start end + + #review - Tcl lrange just returns nothing silently. + #if we don't intend to implement reverse indexing - we should probably not emit an error + if {$start > $end} { + puts stderr "pipesyntax for selector $selector error - reverse index unimplemented" + error $listmsg "destructure $selector" [list pipesyntax destructure selector $selector] + } + if {$do_bounds_check} { + #append script [string map [list $start $end] { + # set start + # set end + # if {$start+1 > $len || $end+1 > $len} { + # set action ?mismatch-list-index-out-of-range + # } + #}] + #set eplusone [expr {$end+1}] + append script [tstr -return string -allowcommands { + if {$len < ${[expr {$end+1}]}} { + set action ?mismatch-list-index-out-of-range + ${[tstr -ret string $tpl_return_mismatch_list_index_out_of_range]} + } + }] + } + + + if {$get_not} { + set assign_script [string map [list $start $end] { + #not- was specified (already handled not-0) + set assigned [lreplace $leveldata ] + }] + } else { + set assign_script [string map [list $start $end] {set assigned [lrange $leveldata ]}] + } + + + } else { + error $listmsg "destructure $selector" [list pipesyntax destructure selector $selector] + } + + append script \n [string map [list $assign_script] { + if {![string match ?mismatch-* $action]} { + + } + }] + + } else { + #keyword 'pipesyntax' at beginning of error message + #pipesyntax error - no need to even build script - can fail now + error $listmsg "destructure $selector" [list pipesyntax destructure selector $selector] + } + } + } + } elseif {$active_key_type eq "string"} { + #changed to indexset notation m..n allowing eg 2..end-1 etc. + #if {[string match *-* $index]} {} + + if {[punk::lib::is_indexset $index]} { + #review - we are assuming a single element indexset here - ie no comma separated sets. + + #todo - support $get_not + #todo - consider bounds_check for string indices. + # - Tcl doesn't do bounds checking for string index, but we need to consider in the context of pattern-matching + # whether we want to support syntaxes for with and without bounds checking on string indices. + + set is_range [expr {[string first ".." $index] >= 0}] + if {$is_range} { + lappend INDEX_OPERATIONS string-range + #review - not efficient for contiguous monotonically increasing ranges + #because we are retrievinng each character individually and concatenating + #- but it is more flexible because it also supports reverse ranges and could support non-contiguous ranges such as @0,2,4..6 + set assign_script { + set assigned [join [lmap i [punk::lib::indexset_resolve [string length $leveldata] ] {string index $leveldata $i}] ""] + } + } else { + lappend INDEX_OPERATIONS string-index + set assign_script { + set assigned [string index $leveldata [punk::lib::indexset_resolve [string length $leveldata] ]] + } + } + + #set assign_script { + # set assigned [lmap i [punk::lib::indexset_resolve [llength $leveldata] ] {lindex $leveldata $i}] + #} + + #todo - consider where/if we can support 'ansistring INDEX' for ANSI strings. + #if so - it shouldn't overload the % operator we currently use for string access. + append script \n [tstr -return string -allowcommands { + if {$leveldata eq ""} { + set assigned "" + } else { + ${$assign_script} + } + }] + set script [string map [list $index] $script] + + + #set re_idxdashidx {^([-+]{0,1}\d+|end[-+]{1}\d+|end)-([-+]{0,1}\d+|end[-+]{1}\d+|end)$} + ##todo - support more complex indices: 0-end-1 etc + + #lassign [split $index -] a b + #append script \n [tstr -return string -allowcommands { + # # set active_key_type "string" + # set assigned [string range $leveldata ${$a} ${$b}] + #}] + + } else { + if {$index eq "*"} { + #equivalent to indexset ".." + lappend INDEX_OPERATIONS string-all + append script \n [tstr -return string -allowcommands { + # set active_key_type "string" + set assigned $leveldata + }] + } elseif {[regexp {[?*]} $index]} { + lappend INDEX_OPERATIONS string-globmatch + append script \n [tstr -return string -allowcommands { + # set active_key_type "string" + if {[string match $index $leveldata]} { + set assigned $leveldata + } else { + set assigned "" + } + }] + } else { + lappend INDEX_OPERATIONS string-index + append script \n [tstr -return string -allowcommands { + # set active_key_type "string" + set assigned [string index $leveldata ${$index}] + }] + } + } + + } else { + #treat as dict key + if {$get_not} { + #dict remove can accept non-existent keys.. review do we require not-@?@key to get silence? + append script \n [tstr -return string { + set assigned [dict remove $leveldata ${$index}] + }] + } else { + append script \n [tstr -return string -allowcommands { + # set active_key_type "dict" + if {[dict exists $leveldata {${$index}}]} { + set assigned [dict get $leveldata {${$index}}] + } else { + set action ?mismatch-dict-key-not-found + ${[tstr -ret string $tpl_return_mismatch_dict_key_not_found]} + } + }] + } + + } + + + } ;# end if $level_script_complete + + + append script \n { + set leveldata $assigned + } + incr i_keyindex + append script \n "# ------- END index $index ------" + } ;# end foreach + + + + #puts stdout "----> destructure rep leveldata: [rep $leveldata]" + #puts stdout ">> destructure returning: [dict create -assigned $leveldata -action $action -lhs $lhs -rhs $rhs]" + + #maintain key order - caller unpacks using lassign + #append script \n {dict create -assigned $leveldata -action $action -lhs $lhs -rhs $rhs} + append script \n [tstr -return string $return_template] \n + return $script + } + + + + + #called from match_assign/know_dot_assign for lhs of assignment - uplevel 2 to caller's level + #called from match_assign/know_dot_assign for rhs pipelined vars - uplevel 1 to write vars only in 'apply' scope + #return a dict with keys result, setvars, unsetvars + #TODO - implement cross-binding (as opposed to overwrite/reassignment) when a var appears multiple times in a pattern/multivar + #e.g x@0,x@1 will only match if value at positions 0 & 1 is the same (a form of auto-pinning?) + #e.g x,x@0 will only match a single element list + #todo blocking or - p1|p2 if p1 matches - return p1 and continue pipeline - immediately return p2 if p1 didn't match. (ie p2 not forwarded in pipeline) + # non-blocking or - p1||p2 if p1 matches - return p1 and continue pipeline - else match p2 and continue pipeline + proc _multi_bind_result {multivar data args} { + #puts stdout "---- _multi_bind_result multivar:'$multivar' data:'$data' options:'$args'" + #'ismatch' must always be first element of dict - as we dispatch on ismatch 0 or ismatch 1 + if {![string length $multivar]} { + #treat the absence of a pattern as a match to anything + #JMN2 - changed to list based destructuring + return [dict create ismatch 1 result $data setvars {} script {}] + #return [dict create ismatch 1 result [list $data] setvars {} script {}] + } + set returndict [dict create ismatch 0 result "" setvars {}] + set script "" + + set defaults [list -unset 0 -levelup 2 -mismatchinfo 1 -script 0] + set opts [dict merge $defaults $args] + set unset [dict get $opts -unset] + set lvlup [dict get $opts -levelup] + set get_mismatchinfo [dict get $opts -mismatchinfo] + + + + #first classify into var_returntype of either "pipeline" or "segment" + #segment returntype is indicated by leading % + + set varinfo [punk::pipe::lib::_var_classify $multivar] + set var_names [dict get $varinfo var_names] + set var_class [dict get $varinfo var_class] + set varspecs_trimmed [dict get $varinfo varspecs_trimmed] + + set var_actions [list] + set expected_values [list] + #e.g {a = abc} {b set ""} + foreach classinfo $var_class vname $var_names { + lassign [lindex $classinfo 0] v + lappend var_actions [list $v "" ""] ;#varactions keeps original lhs - not trimmed version + lappend expected_values [list var $vname spec $v info - lhs - rhs -] ;#code looks for 'info -' to see if changed from default + } + + #puts stdout "var_actions: $var_actions" + #puts stdout "expected_values: $expected_values" + + + #puts stdout "\n var_class: $var_class\n" + # e.g {{x {}} 0} {{y @0} 0} {{'ok @0} 1} {{^v @@key} 2} + + #set varspecs_trimmed [lmap varinfo $var_class {expr {([lindex $varinfo 1] > 0) ? [list [string range [lindex $varinfo 0 0] 1 end] [lindex $varinfo 0 1]] : [lindex $varinfo 0]}}] + #puts stdout "\n varspecs_trimmed: $varspecs_trimmed\n" + + + #var names (possibly empty portion to the left of ) + #debug.punk.pipe.var "varnames: $var_names" 4 + + set v_list_idx(@) 0 ;#for spec with single @ only + set v_dict_idx(@@) 0 ;#for spec with @@ only + + #jn + + #member lists of returndict which will be appended to in the initial value-retrieving loop + set returndict_setvars [dict get $returndict setvars] + + set assigned_values [list] + + + #varname action value - where value is value to be set if action is set + #actions: + # "" unconfigured - assert none remain unconfigured at end + # noop no-change + # matchvar-set name is a var to be matched + # matchatom-set names is an atom to be matched + # matchglob-set + # set + # question mark versions are temporary - awaiting a check of action vs var_class + # e.g ?set may be changed to matchvar or matchatom or set + + + debug.punk.pipe.var {initial map expected_values: $expected_values} 5 + + set returnval "" + set i 0 + #assertion i incremented at each continue and at each end of loop - at end i == list length + 1 + #always use 'assigned' var in each loop + # (for consistency and to assist with returnval) + # ^var means a pinned variable - compare value of $var to rhs - don't assign + # + # In this loop we don't set variables - but assign an action entry in var_actions - all with leading question mark. + # as well as adding the data values to the var_actions list + # + # TODO! we may (commonly) encounter same vkey in the pattern - no need to reparse and re-fetch from data! + set vkeys_seen [list] + foreach v_and_key $varspecs_trimmed { + set vspec [join $v_and_key ""] + lassign $v_and_key v vkey + + set assigned "" + #The binding spec begins at first @ or # or / + + #set firstq [string first "'" $vspec] + #set v [lindex $var_names $i] + #if v contains any * and/or ? - then it is a glob match - not a varname + + lassign [destructure_func $vkey $data] _assigned assigned _action matchaction _lhs lhs _rhs rhs + if {$matchaction eq "?match"} { + set matchaction "?set" + } + lset var_actions $i 1 $matchaction + lset var_actions $i 2 $assigned + + #update the setvars/unsetvars elements + if {[string length $v]} { + dict set returndict_setvars $v $assigned + } + + #JMN2 + #special case expansion for empty varspec (e.g , or ,,) + #if {$vspec eq ""} { + # lappend assigned_values {*}$assigned + #} else { + lappend assigned_values $assigned + #} + incr i + } + + #todo - fix! this isn't the actual tclvars that were set! + dict set returndict setvars $returndict_setvars + + #assigned_values is the ordered list of source elements in the data (rhs) as extracted by each position-spec + #For booleans the final val may later be normalised to 0 or 1 + + + #assertion all var_actions were set with leading question mark + #perform assignments only if matched ok + + + #0 - novar + #1 - atom ' + #2 - pin ^ + #3 - boolean & + #4 - integer + #5 - double + #6 - var + #7 - glob (no classifier and contains * or ?) + if 0 { + debug.punk.pipe.var {VAR_CLASS: $var_class} 5 + debug.punk.pipe.var {VARACTIONS: $var_actions} 5 + debug.punk.pipe.var {VARSPECS_TRIMMED: $varspecs_trimmed} 5 + + debug.punk.pipe.var {atoms: [lsearch -all -inline -index 1 $var_class 1]} 5 + debug.punk.pipe.var {pins: [lsearch -all -inline -index 1 $var_class 2]} 5 + debug.punk.pipe.var {bools: [lsearch -all -inline -index 1 $var_class 3]} 5 + debug.punk.pipe.var {ints: [lsearch -all -inline -index 1 $var_class 4]} 5 + debug.punk.pipe.var {doubles: [lsearch -all -inline -index 1 $var_class 5]} 5 + debug.punk.pipe.var {vars: [lsearch -all -inline -index 1 $var_class 6]} 5 + debug.punk.pipe.var {globs: [lsearch -all -inline -index 1 $var_class 7]} 5 + } + + set match_state [lrepeat [llength $var_names] ?] + unset -nocomplain v + unset -nocomplain nm + set mismatched [list] + set i 0 + #todo - stop at first mismatch - for pattern matching (especially pipecase - we don't want to waste time reading vars if we already have a mismatch earlier in the pattern) + foreach va $var_actions { + #val comes from -assigned + lassign $va lhsspec act val ;#lhsspec is the full value source for LHS ie the full atom/number/varspec e.g for pattern ^var@@key/@0 it is "^var" + set varname [lindex $var_names $i] + + if {[string match "?mismatch*" $act]} { + #already determined a mismatch - e.g list or dict key not present + lset match_state $i 0 + lset expected_values $i [list var $varname spec $lhsspec info mismatch lhs ? rhs $val] + break + } + + + set class_key [lindex $var_class $i 1] + lassign {0 0 0 0 0 0 0 0 0 0} isatom ispin isbool isint isdouble isvar isglob isnumeric isgreaterthan islessthan + foreach ck $class_key { + switch -- $ck { + 1 {set isatom 1} + 2 {set ispin 1} + 3 {set isbool 1} + 4 {set isint 1} + 5 {set isdouble 1} + 6 {set isvar 1} + 7 {set isglob 1} + 8 {set isnumeric 1} + 9 {set isgreaterthan 1} + 10 {set islessthan 1} + } + } + + + #set isatom [expr {$class_key == 1}] + #set ispin [expr {2 in $class_key}] + #set isbool [expr {3 in $class_key}] + #set isint [expr {4 in $class_key}] + #set isdouble [expr {5 in $class_key}] + #set isvar [expr {$class_key == 6}] + #set isglob [expr {7 in $class_key}] + #set isnumeric [expr {8 in $class_key}] ;#force numeric comparison (only if # classifier present) + ##marking numbers with pin ^ has undetermined meaning. Perhaps force expr matching only? + #set isgreaterthan [expr {9 in $class_key}] + #set islessthan [expr {10 in $class_key}] + + + + if {$isatom} { + #puts stdout "==>isatom $lhsspec" + set lhs [string range $lhsspec 1 end] + if {[string index $lhs end] eq "'"} { + set lhs [string range $lhs 0 end-1] + } + lset var_actions $i 1 matchatom-set + if {$lhs eq $val} { + lset match_state $i 1 + lset expected_values $i [list var $varname spec $lhsspec info match lhs $lhs rhs $val] + incr i + continue + } else { + lset match_state $i 0 + lset expected_values $i [list var $varname spec $lhsspec info strings-not-equal lhs $lhs rhs $val] + break + } + } + + + + + # - should set expected_values in each branch where match_state is not set to 1 + # - setting expected_values when match_state is set to 0 is ok except for performance + + + #todo - pinned booleans? we would need to disambiguate from a direct value match.. ie double tag as something like: ^&var or + #ispin may reclassify as isint,isdouble based on contained value (as they don't have their own classifier char and are unambiguous and require special handling) + if {$ispin} { + #puts stdout "==>ispin $lhsspec" + if {$act in [list "?set" "?matchvar-set"]} { + lset var_actions $i 1 matchvar-set + #attempt to read + upvar $lvlup $varname the_var + #if {![catch {uplevel $lvlup [list ::set $varname]} existingval]} {} + if {![catch {set the_var} existingval]} { + + if {$isbool} { + #isbool due to 2nd classifier i.e ^& + lset expected_values $i [list var $varname spec $lhsspec info test-lhs-bool lhs $existingval rhs $val] + #normalise to LHS! + lset assigned_values $i $existingval + } elseif {$isglob} { + #isglob due to 2nd classifier ^* + lset expected_values $i [list var $varname spec $lhsspec info test-lhs-glob lhs $existingval rhs $val] + } elseif {$isnumeric} { + #flagged as numeric by user using ^# classifiers + set testexistingval [join [scan $existingval %lld%s] ""] ;# handles octals (leading zeros), ok for use with bignums, internal decimal points and sci notation (but not leading .) + if {[string is integer -strict $testexistingval]} { + set isint 1 + lset assigned_values $i $existingval + lset expected_values $i [list var $varname spec $lhsspec info test-lhs-int lhs $existingval rhs $val] + } elseif {[string is double $existingval] || [string is double -strict $testexistingval]} { + #test existingval in case something like .5 (which scan will have missed - producing empty testexistingval) + set isdouble 1 + #doubles comparisons use float_almost_equal - so lhs can differ from rhs - for pins we always want to return the normalised lhs ie exactly what is in the var + lset assigned_values $i $existingval + + lset expected_values $i [list var $varname spec $lhsspec info test-lhs-double lhs $existingval rhs $val] + } else { + #user's variable doesn't seem to have a numeric value + lset match_state $i 0 + lset expected_values $i [list var $varname spec $lhsspec info mismatch-lhs-not-numeric lhs $existingval rhs $val] + break + } + + } else { + #standard pin - single classifier ^var + lset match_state $i [expr {$existingval eq $val}] + if {![lindex $match_state $i]} { + lset match_state $i 0 + lset expected_values $i [list var $varname spec $lhsspec info "string-compare-not-equal" lhs $existingval rhs $val] + break + } else { + lset expected_values $i [list var $varname spec $lhsspec info "string-compare-equal" lhs $existingval rhs $val] + } + } + + } else { + #puts stdout "pinned var $varname result:$result vs val:$val" + #failure is *probably* because var is unset - but could be a read-only var due to read-trace or it could be nonexistant namespace + lset match_state $i 0 + lset expected_values $i [list var $varname spec $lhsspec info failread-$varname lhs ? rhs $val] + break + } + } + } + + + + if {$isint} { + #note - we can have classified (above) a value such as 08 on lhs as integer - even though expr and string is integer don't do so. + #expected_values $i [list var $varname spec $lhsspec info match-lhs-int lhs $existingval rhs $val] + + if {$ispin} { + set existing_expected [lindex $expected_values $i] + set lhs [dict get $existing_expected lhs] + } else { + set lhs $lhsspec ;#literal integer in the pattern + } + if {$isgreaterthan || $islessthan} { + set lhs [string range $lhsspec 0 end-1] + set testlhs $lhs + } + if {[string index $lhs 0] eq "."} { + set testlhs $lhs + } else { + set testlhs [join [scan $lhs %lld%s] ""] + } + if {[string index $val 0] eq "."} { + set testval $val + } else { + set testval [join [scan $val %lld%s] ""] ;# handles octals (leading zeros) and bignums (not leading .) + } + if {[string is integer -strict $testval]} { + if {$isgreaterthan} { + #puts "lhsspec: $lhsspec testlhs: $testlhs testval: $testval" + if {$testlhs <= $testval} { + lset match_state $i 1 + } else { + lset match_state $i 0 + lset expected_values $i [list var $varname spec $lhsspec info "expr-not-greater-than-int-int" lhs $lhs rhs $val] + break + } + } elseif {$islessthan} { + if {$testlhs >= $testval} { + lset match_state $i 1 + } else { + lset match_state $i 0 + lset expected_values $i [list var $varname spec $lhsspec info "expr-not-less-than-int-int" lhs $lhs rhs $val] + break + } + } else { + if {$testlhs == $testval} { + lset match_state $i 1 + } else { + lset match_state $i 0 + lset expected_values $i [list var $varname spec $lhsspec info "expr-mismatch-int-int" lhs $lhs rhs $val] + break + } + } + } elseif {[string is double -strict $testval]} { + #dragons. (and shimmering) + if {[string first "e" $val] != -1} { + #scientific notation - let expr compare + if {$isgreaterhthan} { + if {$testlhs <= $testval} { + lset match_state $i 1 + } else { + lset match_state $i 0 + lset expected_values $i [list var $varname spec $lhsspec info "expr-not-greater-than-int-sci" lhs $lhs rhs $val] + break + } + } elseif {$islessthan} { + if {$testlhs >= $testval} { + lset match_state $i 1 + } else { + lset match_state $i 0 + lset expected_values $i [list var $varname spec $lhsspec info "expr-not-less-than-int-sci" lhs $lhs rhs $val] + break + } + } else { + if {$testlhs == $testval} { + lset match_state $i 1 + } else { + lset match_state $i 0 + lset expected_values $i [list var $varname spec $lhsspec info "expr-mismatch-int-sci" lhs $lhs rhs $val] + break + } + } + } elseif {[string is digit -strict [string trim $val -]] } { + #probably a wideint or bignum with no decimal point + #It seems odd that bignums which just look like large integers should ever compare equal if you do a +1 to one side . + #if we use float_almost_equal they may compare equal. on the other hand expr also does apparently inconsistent thins with comparing integer-like bignums vs similar sized nums with .x at the end. + #2 values further apart can compare equal while int-like ones closer together can compare different. + #The rule seems to be for bignums that if it *looks* like a whole int the comparison is exact - but otherwise the float behaviours kick in. + #This is basically what we're doing here but with an arguably better (for some purposes!) float comparison. + #string comparison can presumably always be used as an alternative. + # + #let expr compare + if {$isgreaterthan} { + if {$testlhs <= $testval} { + lset match_state $i 1 + } else { + lset match_state $i 0 + lset expected_values $i [list var $varname spec $lhsspec info "expr-not-greater-than-int-puredigits" lhs $lhs rhs $val] + break + } + } elseif {$islessthan} { + if {$testlhs >= $testval} { + lset match_state $i 1 + } else { + lset match_state $i 0 + lset expected_values $i [list var $varname spec $lhsspec info "expr-not-less-than-int-puredigits" lhs $lhs rhs $val] + break + } + } else { + if {$testlhs == $testval} { + lset match_state $i 1 + } else { + lset match_state $i 0 + lset expected_values $i [list var $varname spec $lhsspec info "expr-mismatch-int-puredigits" lhs $lhs rhs $val] + break + } + } + } else { + if {[punk::pipe::float_almost_equal $testlhs $testval]} { + lset match_state $i 1 + } else { + if {$isgreaterthan} { + if {$testlhs <= $testval} { + lset match_state $i 1 + } else { + lset match_state $i 0 + lset expected_values $i [list var $varname spec $lhsspec info "expr-not-greater-than-int-float" lhs $lhs rhs $val] + break + } + } elseif {$islessthan} { + if {$testlhs >= $testval} { + lset match_state $i 1 + } else { + lset match_state $i 0 + lset expected_values $i [list var $varname spec $lhsspec info "expr-not-less-than-int-float" lhs $lhs rhs $val] + break + } + } else { + lset match_state $i 0 + lset expected_values $i [list var $varname spec $lhsspec info "float_almost_equal-mismatch-int-float" lhs $lhs rhs $val] + break + } + } + } + } else { + #e.g rhs not a number.. + if {$testlhs == $testval} { + lset match_state $i 1 + } else { + lset match_state $i 0 + lset expected_values $i [list var $varname spec $lhsspec info "expr-mismatch-unknown-rhstestval-$testval" lhs $lhs rhs $val] + break + } + } + } elseif {$isdouble} { + #dragons (and shimmering) + # + # + if {$ispin} { + set existing_expected [lindex $expected_values $i] + set lhs [dict get $existing_expected lhs] + } else { + set lhs $lhsspec ;#literal integer in the pattern + } + if {$isgreaterthan || $islessthan} { + error "+/- not yet supported for lhs float" + set lhs [string range $lhsspec 0 end-1] + set testlhs $lhs + } + if {[string index $val 0] eq "."} { + set testval $val ;#not something with some number of leading zeros + } else { + set testval [join [scan $val %lld%s] ""] ;# handles octals (leading zeros), ok for use with bignums, internal decimal points and sci notation (but not leading .) + } + #expr handles leading 08.1 0009.1 etc without triggering octal + #so we don't need to scan lhs + if {[string first "e" $lhs] >= 0 || [string first "e" $testval] >= 0} { + if {$lhs == $testval} { + lset match_state $i 1 + lset expected_values $i [list var $varname spec $lhsspec info match-expr-sci lhs $lhs rhs $val] + } else { + lset match_state $i 0 + lset expected_values $i [list var $varname spec $lhsspec info mismatch-expr-sci lhs $lhs rhs $val] + break + } + } elseif {[string is digit -strict [string trim $lhs -]] && [string is digit -strict [string trim $val -]]} { + #both look like big whole numbers.. let expr compare using it's bignum capability + if {$lhs == $testval} { + lset match_state $i 1 + lset expected_values $i [list var $varname spec $lhsspec info match-expr-pure-digits lhs $lhs rhs $val] + } else { + lset match_state $i 0 + lset expected_values $i [list var $varname spec $lhsspec info mismatch-expr-pure-digits lhs $lhs rhs $val] + break + } + } else { + #float_almost_equal will disagree with expr based on scale.. just enough to allow for example [expr 0.2 + 0.1] to equal 0.3 - whereas expr will declare a mismatch + if {[punk::pipe::float_almost_equal $lhs $testval]} { + lset match_state $i 1 + lset expected_values $i [list var $varname spec $lhsspec info match-float-almost-equal lhs $lhs rhs $val] + } else { + lset match_state $i 0 + lset expected_values $i [list var $varname spec $lhsspec info mismatch-float-almost-equal lhs $lhs rhs $val] + break + } + } + } elseif {$isbool} { + #Note - cross binding of booleans deliberately doesn't compare actual underlying values - only that truthiness or falsiness matches. + #e.g &x/0,&x/1,&x/2= {1 2 yes} + # all resolve to true so the cross-binding is ok. + # Also - the setting of the variable x is normalized to 1 or 0 only. (true & false would perhaps be nicer - but 1 & 0 are theoretically more efficient for later comparisons as they can have a pure int rep?.) + # todo - consider the booleanString rep. Can/should we return true & false instead and maintain efficiency w.r.t shimmering? + # + #punk::pipe::boolean_equal $a $b + set extra_match_info "" ;# possible crossbind indication + set is_literal_boolean 0 + if {$ispin} { + #for a pinned boolean - the most useful return is the value in the pinned var rather than the rhs. This is not entirely consistent .. e.g pinned numbers will return rhs !review! + #As an additional pattern can always retrieve the raw value - pinned vars returning themselves (normalisation use-case ) seems the most consistent overall, and the most useful + set existing_expected [lindex $expected_values $i] + set lhs [dict get $existing_expected lhs] + } else { + set lhs [string range $lhsspec 1 end] ;# - strip off & classifier prefix + + if {![string length $lhs]} { + #empty varname - ok + if {[string is boolean -strict $val] || [string is double -strict $val]} { + lset match_state $i 1 + lset var_actions $i 1 "return-normalised-value" + lset assigned_values $i [expr {bool($val)}] + lset expected_values $i [list var $varname spec $lhsspec info "return-boolean-rhs-normalised" lhs - rhs $val] + } else { + lset match_state $i 0 + lset expected_values $i [list var $varname spec $lhsspec info "mismatch-boolean-rhs" lhs - rhs $val] + break + } + } elseif {$lhs in [list 0 1]} { + #0 & 1 are the only literal numbers that satisfy Tcl's 'string is boolean' test. + set is_literal_boolean 1 + } elseif {[string index $lhs 0] eq "'" && [string index $lhs end] eq "'"} { + #literal boolean (&'yes',&'false',&'1',&'0' etc) in the pattern + #we won't waste any cycles doing an extra validity test here - it will fail in the comparison below if not a string understood by Tcl to represent a boolean. + set is_literal_boolean 1 + set lhs [string range $lhs 1 end-1] ;#strip off squotes + } else { + #todo - a standard variable name checking function for consistency.. for now we'll rule out numbers here to help avoid mistakes. + set tclvar $lhs + if {[string is double $tclvar]} { + error "pipesyntax invalid variable name '$tclvar' for boolean in pattern. (subset of legal tcl vars allowed in pattern context)" "_multi_bind_result $multivar $data $args" [list pipesyntax patternvariable invalid_boolean $tclvar] + #proc _multi_bind_result {multivar data args} + } + #treat as variable - need to check cross-binding within this pattern group + set first_bound [lsearch -index 0 $var_actions $lhsspec] + if {$first_bound == $i} { + #test only rhs (val) for boolean-ness - but boolean-ness as boolean_almost_equal understands it. (e.g floats allowed) + if {[string is boolean -strict $val] || [string is double -strict $val]} { + lset match_state $i 1 + lset var_actions $i 1 [string range $act 1 end] ;# should now be the value "set". We only need this on the first_bound + #review - consider what happens if boolean is leftmost pattern - underlying value vs normalised value to continue in pipeline + #Passing underlying value is inconsistent with what goes in the tclvar - so we need to update the returnval + #puts stderr "==========[lindex $assigned_values $i]" + lset var_actions $i 2 [expr {bool($val)}] ;#normalise to 1 or 0 + lset assigned_values $i [lindex $var_actions $i 2] + #puts stderr "==========[lindex $assigned_values $i]" + lset expected_values $i [list var $varname spec $lhsspec info "match-boolean-rhs-any-lhs" lhs - rhs $val] ;#retain underlying val in expected_values for diagnostics. + } else { + lset match_state $i 0 + lset expected_values $i [list var $varname spec $lhsspec info "mismatch-boolean-rhs-any-lhs" lhs - rhs $val] + break + } + } else { + set expectedinfo [lindex $expected_values $first_bound] + set expected_earlier [dict get $expectedinfo rhs] + set extra_match_info "-crossbind-first" + set lhs $expected_earlier + } + } + } + + + #may have already matched above..(for variable) + if {[lindex $match_state $i] != 1} { + if {![catch {punk::pipe::boolean_almost_equal $lhs $val} ismatch]} { + if {$ismatch} { + lset match_state $i 1 + lset expected_values $i [list var $varname spec $lhsspec info match-boolean-almost-equal$extra_match_info lhs $lhs rhs $val] + } else { + lset match_state $i 0 + lset expected_values $i [list var $varname spec $lhsspec info mismatch-boolean-almost-equal$extra_match_info lhs $lhs rhs $val] + break + } + } else { + #we should only error from boolean_equal if passed something Tcl doesn't recognise as a boolean + lset match_state $i 0 + lset expected_values $i [list var $varname spec $lhsspec info badvalue-boolean$extra_match_info lhs $lhs rhs $val] + break + } + } + + } elseif {$isglob} { + if {$ispin} { + set existing_expected [lindex $expected_values $i] + set lhs [dict get $existing_expected lhs] + } else { + set lhs $lhsspec ;#literal glob in the pattern - no classifier prefix + } + if {[string match $lhs $val]} { + lset match_state $i 1 + lset expected_values $i [list var $varname spec $lhsspec info "match-glob" lhs $lhs rhs $val] + } else { + lset match_state $i 0 + lset expected_values $i [list var $varname spec $lhsspec info "mismatch-glob" lhs $lhs rhs $val] + break + } + + } elseif {$ispin} { + #handled above.. leave case in place so we don't run else for pins + + } else { + #puts stdout "==> $lhsspec" + #NOTE - pinned var of same name is independent! + #ie ^x shouldn't look at earlier x bindings in same pattern + #unpinned non-atoms + #cross-binding. Within this multivar pattern group only (use pin ^ for binding to result from a previous pattern) + # + switch -- $varname { + "" { + #don't attempt cross-bind on empty-varname + lset match_state $i 1 + #don't change var_action $i 1 to set + lset expected_values $i [list var $varname spec $lhsspec info "match-no-lhs-var" lhs - rhs $val] + } + "_" { + #don't cross-bind on the special 'don't-care' varname + lset match_state $i 1 + lset var_actions $i 1 [string range $act 1 end] ;# ?set -> set + lset expected_values $i [list var $varname spec $lhsspec info "match-any-lhs-dontcare-var" lhs - rhs $val] + } + default { + set first_bound [lsearch -index 0 $var_actions $varname] + #assertion first_bound >=0, we will always find something - usually self + if {$first_bound == $i} { + lset match_state $i 1 + lset var_actions $i 1 [string range $act 1 end] ;# ?set -> set + lset expected_values $i [list var $varname spec $lhsspec info "match-any-lhs" lhs - rhs $val] + } else { + assert {$first_bound < $i} assertion_fail: _multi_bind_result condition: [list $first_bound < $i] + set expectedinfo [lindex $expected_values $first_bound] + set expected_earlier [dict get $expectedinfo rhs] + if {$expected_earlier ne $val} { + lset match_state $i 0 + lset expected_values $i [list var $varname spec $lhsspec info "mismatch-crossbind-first" lhs $expected_earlier rhs $val] + break + } else { + lset match_state $i 1 + #don't convert ?set to set - or var setter will write for each crossbound instance. Possibly no big deal for performance - but could trigger unnecessary write traces for example + #lset var_actions $i 1 [string range $act 1 end] + lset expected_values $i [list var $varname spec $lhsspec info "match-crossbind-first" lhs $expected_earlier rhs $val] + } + } + } + } + } + + incr i + } + + #JMN2 - review + #set returnval [lindex $assigned_values 0] + if {[llength $assigned_values] == 1} { + set returnval [join $assigned_values] + } else { + set returnval $assigned_values + } + #puts stdout "----> > rep returnval: [rep $returnval]" + + + + + + #-------------------------------------------------------------------------- + #Variable assignments (set) should only occur down here, and only if we have a match + #-------------------------------------------------------------------------- + set match_count_needed [llength $var_actions] + #set match_count [expr [join $match_state +]] ;#expr must be unbraced here + set matches [lsearch -all -inline $match_state 1] ;#default value for each match_state entry is "?" + set match_count [llength $matches] + + + debug.punk.pipe.var {MATCH_STATE: $match_state count_needed: $match_count_needed vs match_count: $match_count} 4 + debug.punk.pipe.var {VARACTIONS2: $var_actions} 5 + debug.punk.pipe.var {EXPECTED : $expected_values} 4 + + #set match_count [>f . foldl 0 [>f . sum .] $match_state] ;#ok method.. but slow compared to expr with join + if {$match_count == $match_count_needed} { + #do assignments + for {set i 0} {$i < [llength $var_actions]} {incr i} { + if {([lindex $var_class $i 1] == 6 || [lindex $var_class $i] == 3 ) && ([string length [set varname [lindex $var_names $i]]])} { + #isvar + if {[lindex $var_actions $i 1] eq "set"} { + upvar $lvlup $varname the_var + set the_var [lindex $var_actions $i 2] + } + } + } + dict set returndict ismatch 1 + #set i 0 + #foreach va $var_actions { + # #set isvar [expr {[lindex $var_class $i 1] == 6}] + # if {([lindex $var_class $i 1] == 6 || [lindex $var_class $i] == 3 ) && ([string length [set varname [lindex $var_names $i]]])} { + # #isvar + # lassign $va lhsspec act val + # upvar $lvlup $varname the_var + # if {$act eq "set"} { + # set the_var $val + # } + # #if {[lindex $var_actions $i 1] eq "set"} { + # # set the_var $val + # #} + # } + # incr i + #} + } else { + #todo - some way to restrict mismatch info to simple "mismatch" and avoid overhead of verbose message + #e.g for within pipeswitch block where mismatches are expected and the reasons are less important than moving on quickly + set vidx 0 + #set mismatches [lmap m $match_state v $var_names {expr {$m == 0} ? {[list mismatch $v]} : {[list match $v]}}] + set mismatches [lmap m $match_state v $var_names {expr {$m == 0 ? [list mismatch $v] : [list match $v]}}] + set var_display_names [list] + foreach v $var_names { + if {$v eq ""} { + lappend var_display_names {{}} + } else { + lappend var_display_names $v + } + } + #REVIEW 2025 + #set mismatches_display [lmap m $match_state v $var_display_names {expr {$m == 0} ? {$v} : {[expr {$m eq "?"} ? {"?[string repeat { } [expr [string length $v] -1]]"} : {[string repeat " " [string length $v]]} ]}}] + set mismatches_display [lmap m $match_state v $var_display_names {expr {$m == 0 ? $v : [expr {$m eq "?" ? "?[string repeat { } [expr {[string length $v] -1}]]" : [string repeat " " [string length $v]] }]}}] + set msg "\n" + append msg "Unmatched\n" + append msg "Cannot match right hand side to pattern $multivar\n" + append msg "vars/atoms/etc: $var_names\n" + append msg "mismatches: [join $mismatches_display { } ]\n" + set i 0 + #0 - novar + #1 - atom ' + #2 - pin ^ + #3 - boolean & + #4 - integer + #5 - double + #6 - var + #7 - glob (no classifier and contains * or ?) + foreach mismatchinfo $mismatches { + lassign $mismatchinfo status varname + if {$status eq "mismatch"} { + # varname can be empty string + set varclass [lindex $var_class $i 1] + set val [lindex $var_actions $i 2] + set e [dict get [lindex $expected_values $i] lhs] + set type "" + if {2 in $varclass} { + append type "pinned " + } + + if {$varclass == 1} { + set type "atom" + } elseif {$varclass == 2} { + set type "pinned var" + } elseif {3 in $varclass} { + append type "boolean" + } elseif {4 in $varclass} { + append type "int" + } elseif {5 in $varclass} { + append type "double" + } elseif {$varclass == 6} { + set type "var" + } elseif {7 in $varclass} { + append type "glob" + } elseif {8 in $varclass} { + append type "numeric" + } + if {$type eq ""} { + set type "" + } + + set lhs_tag "- [dict get [lindex $expected_values $i] info]" + set mmaction [lindex $var_actions $i 1] ;#e.g ?mismatch-dict-index-out-of-range + set tag "?mismatch-" + if {[string match $tag* $mmaction]} { + set mismatch_reason [string range $mmaction [string length $tag] end] + } else { + set mismatch_reason $mmaction + } + append msg " $type: '$varname' $mismatch_reason $lhs_tag LHS: '$e' vs RHS: '$val'\n" + } + incr i + } + #error $msg + dict unset returndict result + #structured error return - used by pipeswitch/pipecase - matching on "binding mismatch*" + dict set returndict mismatch [dict create binding mismatch varnames $var_names matchinfo $mismatches display $msg data $data] + return $returndict + } + + if {![llength $var_names]} { + #var_name entries can be blank - but it will still be a list + #JMN2 + #dict set returndict result [list $data] + dict set returndict result $data + } else { + assert {$i == [llength $var_names]} assertion_fail _multi_bind_result condition {$i == [llength $var_names]} + dict set returndict result $returnval + } + return $returndict + } + + ######################################################## + # dragons. + # using an error as out-of-band way to signal mismatch is the easiest. + # It comes at some cost (2us 2023?) to trigger catches. (which is small relative to uncompiled pipeline costs in initial version - but per pattern mismatch will add up) + # The alternative of attempting to tailcall return the mismatch as data - is *hard* if not impossible to get right. + # We need to be able to match on things like {error {mismatch etc}} - without it then itself being interpreted as a mismatch! + # A proper solution may involve a callback? tailcall some_mismatch_func? + # There may be a monad-like boxing we could do.. to keep it in data e.g {internalresult match } {internalresult mismatch } and be careful to not let boxed data escape ?? + # make sure there is good test coverage before experimenting with this + proc _handle_bind_result {d} { + #set match_caller [info level 2] + #debug.punk.pipe {_handle_bind_result match_caller: $match_caller} 9 + if {![dict exists $d result]} { + #uplevel 1 [list error [dict get $d mismatch]] + #error [dict get $d mismatch] + return -code error -errorcode [list binding mismatch varnames [dict get $d mismatch varnames]] [dict get $d mismatch] + } else { + return [dict get $d result] + } + } + # initially promising - but the approach runs into impossible disambiguation of mismatch as data vs an actual mismatch + proc _handle_bind_result_experimental1 {d} { + #set match_caller [info level 2] + #debug.punk.pipe {_handle_bind_result match_caller: $match_caller} 9 + if {![dict exists $d result]} { + tailcall return [dict get $d mismatch] + } else { + return [dict get $d result] + } + } + ######################################################## + + #timings very similar. listset3 closest in performance to pipeset. review - test on different tcl versions. + #Unfortunately all these variations seem around 10x slower than 'set list {a b c}' or 'set list [list a b c]' + #there seems to be no builtin for list setting with args syntax. lappend is close but we would need to catch unset the var first. + #proc listset1 {listvarname args} { + # tailcall set $listvarname $args + #} + #interp alias {} listset2 {} apply {{vname args} {tailcall set $vname $args}} + #interp alias {} listset3 {} apply {{vname args} {upvar $vname v; set v $args}} + proc pipeset {pipevarname args} { + upvar $pipevarname the_pipe + set the_pipe $args + } + + #pipealias should capture the namespace context of the pipeline so that commands are resolved in the namespace in which the pipealias is created + proc pipealias {targetcmd args} { + set cmdcopy [punk::valcopy $args] + set nscaller [uplevel 1 [list ::tcl::namespace::current]] + tailcall interp alias {} $targetcmd {} apply [list args [append cmdcopy " {*}\$args"] $nscaller] + } + proc pipealias_extract {targetcmd} { + set applybody [lindex [interp alias "" $targetcmd] 1 1] + #strip off trailing " {*}$args" + return [lrange [string range $applybody 0 end-9] 0 end] + } + #although the pipealias2 'concat' alias is cleaner in that the original pipeline can be extracted using list commands - it runs much slower + proc pipealias2 {targetcmd args} { + set cmdcopy [punk::valcopy $args] + set nscaller [uplevel 1 [list ::tcl::namespace::current]] + tailcall interp alias {} $targetcmd {} apply [list args [concat "\[concat" [list $cmdcopy] "\$args]"] $nscaller] + } + + + #same as used in unknown func for initial launch + #variable re_assign {^([^\r\n=\{]*)=(.*)} + #variable re_assign {^[\{]{0,1}([^ \t\r\n=]*)=(.*)} + variable re_assign {^([^ \t\r\n=\{]*)=(.*)} + variable re_dot_assign {^([^ \t\r\n=\{]*)\.=(.*)} + #match_assign is tailcalled from unknown - uplevel 1 gets to caller level + proc match_assign {scopepattern equalsrhs args} { + #review - :: is legal in atoms! + if {[string match "*::*" $scopepattern]} { + error "match_assign scopepattern '$scopepattern' contains namespace separator '::' - invalid." + } + #puts stderr ">> match_assign '$scopepattern=$equalsrhs' $args" + set fulltail $args + set cmdns ::punk::pipecmds + set namemapping [punk::pipe::lib::pipecmd_namemapping $equalsrhs] + + #we deliberately don't call pipecmd_namemapping on the scopepattern even though it may contain globs. REVIEW + #(we need for example x*= to be available as is via namespace path mechanism (from punk::pipecmds namespace)) + + set pipecmd ${cmdns}::$scopepattern=$namemapping + + #pipecmd could have glob chars - test $pipecmd in the list - not just that info commands returns results. + if {$pipecmd in [info commands $pipecmd]} { + #puts "==nscaller: '[uplevel 1 [list namespace current]]'" + #uplevel 1 [list ::namespace import $pipecmd] + set existing_path [uplevel 1 [list ::tcl::namespace::path]] + if {$cmdns ni $existing_path} { + uplevel 1 [list ::tcl::namespace::path [concat $existing_path $cmdns]] + } + tailcall $pipecmd {*}$args + } + + + #NOTE: + #we need to ensure for case: + #= x=y + #that the second arg is treated as a raw value - never a pipeline command + + #equalsrhs is set if there is a segment-insertion-pattern *directly* after the = + #debug.punk.pipe {match_assign '$multivar' '$equalsrhs' '$fulltail'} 4 + #can match pattern on lhs with a value where pattern is a minilang that can refer to atoms (simple non-whitespace strings), numbers, or varnames (possibly pinned) as well as a trailing spec for position within the data. + + # allow x=insertionpattern to begin a pipeline e.g x= |> string tolower ? or x=1 a b c <| X to produce a X b c + # + #to assign an entire pipeline to a var - use pipeset varname instead. + + # in our script's handling of args: + #avoid use of regexp match on each element - or we will unnecessarily force string reps on lists + #same with lsearch with a string pattern - + #wouldn't matter for small lists - but we need to be able to handle large ones efficiently without unneccessary string reps + set script [string map [list [list $scopepattern] $equalsrhs] { + #script built by punk::match_assign + if {[llength $args]} { + #scan for existence of any pipe operator (|*> or <*|) only - we don't need position + #all pipe operators must be a single element + #we don't first check llength args == 1 because for example: + # x= <| + # x= |> + #both leave x empty. To assign a pipelike value to x we would have to do: x= <| |> (equiv: set x |>) + set scopep + foreach a $args { + if {![catch {llength $a} sublen]} { + #don't enforce sublen == 1. Legal to have whitespace including newlines {| x >} + if {[string match |*> $a] || [string match <*| $a]} { + tailcall punk::pipeline = $scopep "" {*}$args + } + } + } + if {[llength $args] == 1} { + set segmenttail [lindex $args 0] + } else { + error "pipedata = must take a single argument. Got [llength $args] args: '$args'" "match_assign $args" [list pipedata segment too_many_elements segment_type =] + } + } else { + #set segmenttail [purelist] + set segmenttail [lreplace x 0 0] + } + }] + + + + + if {[string length $equalsrhs]} { + # as we aren't in a pipleine - there is no data to insert - we proably still need to run _split_equalsrhs to verify the syntax. + # review - consider way to turn it off as optimisation for non-pipelined assignment - but generally standard Tcl set could be used for that purpose. + # We are probably only here if testing in the repl - in which case the error messages are important. + set var_index_position_list [punk::pipe::lib::_split_equalsrhs $equalsrhs] + #we may have an insertion-spec that inserts a literal atom e.g to wrap in "ok" + # x='ok'>0/0 data + # => {ok data} + # we won't examine for vars as there is no pipeline - ignore + # also ignore trailing * (indicator for variable data to be expanded or not - ie {*}) + # we will differentiate between / and @ in the same way that general pattern matching works. + # /x will simply call linsert without reference to length of list + # @x will check for out of bounds + # + # !TODO - sort by position lowest to highest? or just require user to order the pattern correctly? + + + + foreach v_pos $var_index_position_list { + lassign $v_pos v indexspec positionspec + #e.g =v1/1>0 A pattern predator system) + # + #todo - review + # + # + #for now - the script only needs to handle the case of a single segment pipeline (no |> <|) + + + #temp - needs_insertion + #we can safely output no script for variable insertions for now - because if there was data available, + #we would have to be in a pipeline - in which case the script above would have delegated all our operations anyway. + #tag: positionspechandler + if {([string index $v 0] eq "'" && [string index $v end] eq "'") || [string is integer -strict $v]} { + #(for now)don't allow indexspec on a literal value baked into the pipeline - it doesn't really make sense + #- unless the pipeline construction has been parameterised somehow e.g "=${something}/0" + #review + if {[string length $indexspec]} { + error "pipesyntax literal value $v - index specification not allowed (match_assign)1" "match_assign $scopepattern $equalsrhs $args" [list pipesyntax index_on_literal] + } + if {[string index $v 0] eq "'" && [string index $v end] eq "'"} { + set datasource [string range $v 1 end-1] + } elseif {[string is integer -strict $v]} { + set datasource $v + } + append script [string map [list $datasource] { + set insertion_data "" ;#atom could have whitespace + }] + + set needs_insertion 1 + } elseif {$v eq ""} { + #default variable is 'data' + set needs_insertion 0 + } else { + append script [string map [list $v] { + #uplevel? + #set insertion_data [set ] + }] + set needs_insertion 0 + } + if {$needs_insertion} { + set script2 [punk::list_insertion_script $positionspec segmenttail ] + set script2 [string map [list "\$insertion_data" ] $script2] + append script $script2 + } + + + } + + + } + + if {![string length $scopepattern]} { + append script { + return $segmenttail + } + } else { + append script [string map [list $scopepattern] { + #we still need to bind whether list is empty or not to allow any patternmatch to succeed/fail + set d [punk::_multi_bind_result {} $segmenttail] + #return [punk::_handle_bind_result $d] + #maintenance: inlined + if {![dict exists $d result]} { + #uplevel 1 [list error [dict get $d mismatch]] + #error [dict get $d mismatch] + return -code error -level 1 -errorcode [list binding mismatch] [dict get $d mismatch] + } else { + return [dict get $d result] + } + }] + } + + debug.punk.pipe.compile {match_assign creating proc $pipecmd} 2 + uplevel 1 [list ::proc $pipecmd args $script] + set existing_path [uplevel 1 [list ::tcl::namespace::path]] + if {$cmdns ni $existing_path} { + uplevel 1 [list ::tcl::namespace::path [concat $existing_path $cmdns]] + } + tailcall $pipecmd {*}$args + } + + #return a script for inserting data into listvar + #review - needs updating for list-return semantics of patterns? + proc list_insertion_script {keyspec listvar {data }} { + set positionspec [string trimright $keyspec "*"] + set do_expand [expr {[string index $keyspec end] eq "*"}] + if {$do_expand} { + set exp {{*}} + } else { + set exp "" + } + #NOTE: linsert and lreplace can take multiple values at tail ie expanded data + + set ptype [string index $positionspec 0] + if {$ptype in [list @ /]} { + set index [string range $positionspec 1 end] + } else { + #the / is optional (default) at first position - and we have already discarded the ">" + set ptype "/" + set index $positionspec + } + #puts stderr ">> >> $index" + set script "" + set isint [string is integer -strict $index] + if {$index eq "."} { + #do nothing - this char signifies no insertion + } elseif {$isint || [regexp {^(end|end[-+]{1,2}[0-9]+)$} $index]} { + if {$ptype eq "@"} { + #compare position to *possibly updated* list - note use of $index > $datalen rather than $index+1 > $datalen - (we allow 'insertion' at end of list by numeric index) + if {$isint} { + append script [string map [list $listvar $index] { + if {( > [llength $])} { + #not a pipesyntax error + error "pipedata insertionpattern index out of bounds. index: vs len: [llength $] use /x instead of @x to avoid check (list_insertion_script)" "list_insertion_script $keyspec" [list pipedata insertionpattern index_out_f_bounds] + } + }] + } + #todo check end-x bounds? + } + #todo - change to ledit + #consider also $[set {}] instead of using unset + #see https://wiki.tcl-lang.org/page/K regarding Unsharing Objects + if {$isint} { + append script [string map [list $listvar $index $exp $data] { + set [linsert [lindex [list $ [unset ]] 0] ] + }] + } else { + append script [string map [list $listvar $index $exp $data] { + #use inline K to make sure the list is unshared (optimize for larger lists) + set [linsert [lindex [list $ [unset ]] 0] ] + }] + + } + } elseif {[string first / $index] < 0 && [string first - $index] > 0} { + if {[regexp {^([0-9]+|end|end[-+]{1,2}[0-9]+)-([0-9]+|end|end[-+]{1,2}([0-9]+))$} $index _ start end]} { + #also - range checks for @ which must go into script !!! + append script [string map [list $listvar $start $end $exp $data] { + set [lreplace [lindex [list $ [unset ]] 0] ] + }] + } else { + error "pipesyntax error in segment insertionpattern - positionspec:'$keyspec' unable to interpret position spec (list_insertion_script)2" "list_insertion_script $keyspec" [list pipedata insertionpattern_invalid] + } + } elseif {[string first / $index] >= 0} { + #nested insertion e.g /0/1/2 /0/1-1 + set parts [split $index /] + set last [lindex $parts end] + if {[string first - $last] >=0} { + lassign [split $last -] a b + if {![regexp {^([0-9]+|end|end[-+]{1,2}[0-9]+)-([0-9]+|end|end[-+]{1,2}([0-9]+))$} $last _ a b]} { + error "pipesyntax error in segment insertionpattern - positionspec:'$keyspec' unable to interpret position spec (list_insertion_script)3" "list_insertion_script $keyspec" [list pipesyntax insertionpattern_invalid] + } + if {$a eq $b} { + if {!$do_expand} { + #we can do an lset + set lsetkeys [list {*}[lrange $parts 0 end-1] $a] + append script [string map [list $listvar $lsetkeys $data] { + lset + }] + } else { + #we need to lreplace the containing item + append script [string map [list $listvar [lrange $parts 0 end-1] $a $data] { + set target [lindex $ ] + lset target {*} + lset $target + }] + } + } else { + #we need to lreplace a range at the target level + append script [string map [list $listvar [lrange $parts 0 end-1] $a $b $exp $data] { + set target [lindex $ ] + set target [lreplace $target ] + lset $target + }] + } + } else { + #last element has no -, so we are inserting at the final position - not replacing + append script [string map [list $listvar [lrange $parts 0 end-1] $last $exp $data] { + set target [lindex $ ] + #set target [linsert $target ] + ledit target -1 + lset $target + }] + } + + + } else { + error "pipesyntax error in segment - positionspec:'$keyspec' unable to interpret position spec (list_insertion_script)4" "list_insertion_script $keyspec" [list pipesyntax insertionpattern_invalid] + } + return $script + } + + + + + proc _is_math_func_prefix {e1} { + #also catch starting brackets.. e.g "(min(4,$x) " + if {[regexp {^[^[:alnum:]]*([[:alnum:]]*).*} $e1 _ word]} { + #possible math func + if {$word in [info functions]} { + return true + } + } + return false + } + + #todo - option to disable these traces which provide clarifying errors (performance hit?) + proc pipeline_args_read_trace_error {args} { + error "The pipelined data doesn't appear to be a valid Tcl list\nModify input, or use \$data or another variable name instead of \$args." "pipeline_args_read_trace_error $args" [list pipedata args_unavailable_data_not_a_list] + } + + + #NOTE: the whole idea of scanning for %x% is a lot of work(performance penalty) + #consider single placeholder e.g "_" as only positional indicator - for $data only - and require braced script with $var for more complex requirements + #possibly also *_ for expanded _ ? + #This would simplify code a lot - but also quite possible to collide with user data. + #Perhaps not a big deal as unbraced segments between |> are mainly(?) a convenience for readability/repl etc. + # (but importantly (at pipeline start anyway) unbraced segments are a mechanism to inject data from calling scope or from pipeline args <|) + # + #detect and retrieve %xxx% elements from item without affecting list/string rep + #commas, @, ', ^ and whitespace not part of a valid tag (allows some substitution within varspecs) + #%% is not a valid tag + #(as opposed to using regexp matching which causes string reps) + proc get_tags {item} { + set chars [split $item {}] + set terminal_chars [list , @ ' ^ " " \t \n \r] + #note % is both terminal and initiating - so for the algorithm we don't include it in the list of terminal_chars + set nonterminal [lmap v $chars {expr {$v ni $terminal_chars}}] + set percents [lmap v $chars {expr {$v eq "%"}}] + #useful for test/debug + #puts "CHARS : $chars" + #puts "NONTERMINAL: $nonterminal" + #puts "PERCENTS : $percents" + set sequences [list] + set in_sequence 0 + set start -1 + set end -1 + set i 0 + #todo - some more functional way of zipping/comparing these lists? + set s_length 0 ;#sequence length including % symbols - minimum for tag therefore 2 + foreach n $nonterminal p $percents { + if {!$in_sequence} { + if {$n & $p} { + set s_length 1 + set in_sequence 1 + set start $i + set end $i + } else { + set s_length 0 + } + } else { + if {$n ^ $p} { + incr s_length + incr end + } else { + if {$n & $p} { + if {$s_length == 1} { + # % followed dirctly by % - false start + #start again from second % + set s_length 1 + set in_sequence 1 + set start $i + set end $i + } else { + incr end + lappend sequences [list $start $end] + set in_sequence 0 + set s_length 0 + set start -1; set end -1 + } + } else { + #terminated - not a tag + set in_sequence 0 + set s_length 0 + set start -1; set end -1 + } + } + } + incr i + } + + set tags [list] + foreach s $sequences { + lassign $s start end + set parts [lrange $chars $start $end] + lappend tags [join $parts ""] + } + return $tags + } + + #show underlying rep of list and first level + proc rep_listname {lname} { + upvar $lname l + set output "$lname list rep: [rep $l]\n" + foreach item $l { + append output "-rep $item\n" + append output " [rep $item]\n" + } + return $output + } + + + # -- + #consider possible tilde templating version ~= vs .= + #support ~ and ~* placeholders only. + #e.g x~= list aa b c |> lmap v ~ {string length $v} |> tcl::mathfunc::max ~* + #The ~ being mapped to $data in the pipeline. + #This is more readable and simpler for beginners - although it doesn't handle more advanced insertion requirements. + #possibility to mix as we can already with .= and = + #e.g + #x.= list aa b c |> ~= lmap v ~ {string length $v} |> .=>* tcl::mathfunc::max + # -- + proc pipeline {segment_op initial_returnvarspec equalsrhs args} { + set fulltail $args + #unset args ;#leave args in place for error diagnostics + debug.punk.pipe {call pipeline: op:'$segment_op' '$initial_returnvarspec' '$equalsrhs' '$fulltail'} 4 + #debug.punk.pipe.rep {[rep_listname fulltail]} 6 + + + #review + set equalsrhs [string map [list {;} {\;}] $equalsrhs] + + + #--------------------------------------------------------------------- + # test if we have an initial x.=y.= or x.= y.= + + #nextail is tail for possible recursion based on first argument in the segment + #set nexttail [lassign $fulltail next1] ;#tail head + + set next1 [lindex $args 0] + switch -- $next1 { + pipematch { + set nexttail [lrange $args 1 end] + set results [uplevel 1 [list pipematch {*}$nexttail]] + debug.punk.pipe {>>> pipematch results: $results} 1 + + set d [_multi_bind_result $initial_returnvarspec $results] + return [_handle_bind_result $d] + } + pipecase { + set msg "pipesyntax\n" + append msg "pipecase does not return a value directly in the normal way\n" + append msg "It will return a casemismatch dict on mismatch\n" + append msg "But on a successful match - it will use an 'error' mechanism to return {ok result {something}} in the caller's scope -\n" + append msg "This will appear as an error in the repl, or disrupt pipeline result propagation if not in an appropriate wrapper\n" + append msg "Call pipecase from within a pipeline script block or wrapper such as pipeswitch or apply." + error $msg + } + } + + #temp - this is related to a script for the entire pipeline (functional composition) - not the script for the segment-based x=y or x.=y proc. + set ::_pipescript "" + + + + #NOTE: + #important that for assignment: + #= x=y .. + #The second element is always treated as a raw value - not a pipeline instruction. + #whereas... for execution: + #.= x=y the second element is a pipeline-significant symbol based on the '=' even if it was passed in as an argument. + #Usually an execution segment (.= cmd etc..) will have args inserted at the tail anyway - + #- but if the pipeline is designed to put an argument in the zero position - then presumably it is intended as a pipeline-significant element anyway + #This gives a *slight* incompatibility with external commands containing '=' - in that they may not work properly in pipelines + # + if {$segment_op ne "="} { + #handle for example: + #var1.= var2= "etc" |> string toupper + # + #var1 will contain ETC (from entire pipeline), var2 will contain etc (from associated segment) + # + + + if {([set nexteposn [string last = $next1]] >= 0)} { + set next1 [string map [list {;} {\;}] $next1] ;#review + #do we really need to test for script_shaped if last char is = ? + if {![punk::pipe::lib::arg_is_script_shaped $next1]} { + set nexttail [lrange $args 1 end] + #*SUB* pipeline recursion. + #puts "======> recurse based on next1:$next1 " + if {[string index $next1 $nexteposn-1] eq {.}} { + #var1.= var2.= ... + #non pipelined call to self - return result + set results [uplevel 1 [list $next1 {*}$nexttail]] + #debug.punk.pipe.rep {==> rep recursive results: [rep $results]} 5 + #debug.punk.pipe {>>> results: $results} 1 + return [_handle_bind_result [_multi_bind_result $initial_returnvarspec $results]] + } + #puts "======> recurse assign based on next1:$next1 " + #if {[regexp {^([^ \t\r\n=\{]*)=(.*)} $next1 _ nextreturnvarspec nextrhs]} { + #} + #non pipelined call to plain = assignment - return result + set results [uplevel 1 [list $next1 {*}$nexttail]] + #debug.punk.pipe {>>> results: $results} 1 + set d [_multi_bind_result $initial_returnvarspec $results] + return [_handle_bind_result $d] + } + } + } + + set procname $initial_returnvarspec.=$equalsrhs + + #--------------------------------------------------------------------- + + #todo add 'op' argument and handle both .= and = + # + #|> data piper symbol + #<| args piper symbol (arguments supplied at end of pipeline e.g from commandline or from calling and/or currying the command) + # + + set more_pipe_segments 1 ;#first loop + + #this contains the main %data% and %datalist% values going forward in the pipeline + #as well as any extra pipeline vars defined in each |> + #It also contains any 'args' with names supplied in <| + set dict_tagval [dict create] ;#cumulative %x% tag dict which operates on the whole length of the pipeline + + #determine if there are input args at the end of the pipeline indicated by reverse <| symbol possibly with argspecs e.g transform x y z =0} { + set tailremaining [lrange $fulltail 0 $firstargpipe_posn-1] + set argslist [lrange $fulltail $firstargpipe_posn+1 end] ;#Note that this could be a whole other pipeline with |> and/or <| elements. + set argpipe [lindex $fulltail $firstargpipe_posn] + set argpipespec [string range $argpipe 1 end-1] ;# strip off < & | from " b1 b2 b3 |outpipespec> c1 c2 c3 + # for a1 a2 a3 - the pipe to the right is actually an outpipespec and for c1 c2 c3 the pipe to the left is an inpipespec + + + #our initial command list always has *something* before we see any pipespec |> + #Therefore we initially have a blank inpipespec (although in effect, it comes from the argpipespec <|) + set inpipespec $argpipespec + set outpipespec "" + + #avoiding regexp on each arg to maintain list reps + #set tailmap [lmap v $tailremaining {lreplace [split $v {}] 1 end-1}] + ## set tailmap [lmap v $tailremaining {if {[regexp {^\|(.*)>$} $v _ outpipespec] && !$pipeseen} {set pipeseen 1;set outpipespec} {if {$pipeseen} {set v} 0}}] + #e.g for: a b c |> e f g |> h + #set firstpipe_posn [lsearch $tailmap {| >}] + + set firstpipe_posn [lsearch $tailremaining "|*>"] + + if {$firstpipe_posn >=0} { + set outpipespec [string range [lindex $tailremaining $firstpipe_posn] 1 end-1] + set segment_members [lrange $tailremaining 0 $firstpipe_posn-1] + #set tailremaining [lrange $tailremaining $firstpipe_posn+1 end] + set tailremaining [lreplace $tailremaining 0 $firstpipe_posn] ;#generally too short for any K combinator benefit? what about lists with scripts? is it dependent on list length or also element content size? + } else { + set segment_members $tailremaining + set tailremaining [list] + } + + + + set script_like_first_word 0 + set rhs $equalsrhs + + set segment_first_is_script 0 ;#default assumption until tested + + set segment_first_word [lindex $segment_members 0] + if {$segment_op ne "="} { + if {[punk::pipe::lib::arg_is_script_shaped $segment_first_word]} { + set segment_first_is_script 1 + } + } else { + if {[llength $segment_members] > 1} { + error "pipedata = can only accept a single argument (got: '$segment_members')" "pipeline $segment_op $initial_returnvarspec $equalsrhs $fulltail" [list pipedata too_many_elements] + #proc pipeline {segment_op initial_returnvarspec equalsrhs args} + } + set segment_members $segment_first_word + } + + + + #tailremaining includes x=y during the loop. + set returnvarspec $initial_returnvarspec + if {![llength $argslist]} { + unset -nocomplain previous_result ;# we want it unset for first iteration - differentiate from empty string + } else { + set previous_result $argslist + } + + set segment_result_list [list] + set i 0 ;#segment id + set j 1 ;#next segment id + set pipespec(args) $argpipespec ;# from trailing <| + set pipespec(0,in) $inpipespec + set pipespec(0,out) $outpipespec + + set max_iterations 100 ;# configurable? -1 for no limit ? This is primarily here to aid debugging of runaway loops in initial development .. should probably set to no-limit in final version. + while {$more_pipe_segments == 1} { + #--------------------------------- + debug.punk.pipe {[a yellow bold]i$i SEGMENT MEMBERS([llength $segment_members]): $segment_members[a]} 4 + debug.punk.pipe {[a yellow bold]i$i TAIL REMAINING([llength $tailremaining]): $tailremaining[a]} 4 + debug.punk.pipe {[a] inpipespec(prev [a yellow bold]|$pipespec($i,in)[a]>) outpipespec(next [a+ yellow bold]|$pipespec($i,out)>[a])} 4 + debug.punk.pipe {[a cyan bold] segment_first_is_script:$segment_first_is_script} 4 + if {$segment_first_is_script} { + debug.punk.pipe {[a cyan bold] script segment: [lindex $segment_members 0][a]} 4 + } + + + + #examine inpipespec early to give faster chance for mismatch. ie before scanning segment for argument position + set segment_result "" + if {[info exists previous_result]} { + set prevr $previous_result + } else { + set prevr "" + } + set pipedvars [dict create] + if {[string length $pipespec($i,in)]} { + #check the varspecs within the input piper + # - data and/or args may have been manipulated + set d [apply {{mv res} { + punk::_multi_bind_result $mv $res -levelup 1 + }} $pipespec($i,in) $prevr] + #temp debug + #if {[dict exists $d result]} { + #set jjj [dict get $d result] + #puts "!!!!! [rep $jjj]" + #} + set inpipespec_result [_handle_bind_result $d] + set pipedvars [dict get $d setvars] + set prevr $inpipespec_result ;# leftmost spec in |> needs to affect pipeline flow of 'data' + #puts stdout "inpipespec:|$pipespec($i,in)> prevr:$prevr setvars: $pipedvars" + } + debug.punk.pipe {[a] previous_iteration_result: $prevr[a]} 6 + debug.punk.pipe.rep {rep previous_iteration_result [rep $prevr]} + + + if {$i == $max_iterations} { + puts stderr "ABORTING. Reached max_iterations $max_iterations (todo: make configurable)" + set more_pipe_segments 0 + } + + set insertion_patterns [punk::pipe::lib::_split_equalsrhs $rhs] ;#raises error if rhs of positionspec not like /* or @* + set segment_has_insertions [expr {[llength $insertion_patterns] > 0}] + #if {$segment_has_insertions} { + # puts stdout ">>> $segment_members insertion_patterns $insertion_patterns" + #} + + debug.punk.pipe.var {segment_has_insertions: $insertion_patterns} 5 + debug.punk.pipe.rep {[rep_listname segment_members]} 4 + + + + + #whether the segment has insertion_patterns or not - apply any modification from the piper argspecs (script will use modified args/data) + #pipedvars comes from either previous segment |>, or <| args + if {[dict exists $pipedvars "data"]} { + #dict set dict_tagval %data% [list [dict get $pipedvars "data"]] + dict set dict_tagval data [dict get $pipedvars "data"] + } else { + if {[info exists previous_result]} { + dict set dict_tagval data $prevr + } + } + foreach {vname val} $pipedvars { + #add additionally specified vars and allow overriding of %args% and %data% by not setting them here + if {$vname eq "data"} { + #already potentially overridden + continue + } + dict set dict_tagval $vname $val + } + + #todo! + #segment_script - not in use yet. + #will require non-iterative pipeline processor to use ... recursive.. or coroutine based + set script "" + + if {!$segment_has_insertions} { + #debug.punk.pipe.var {[a cyan]SEGMENT has no tags[a]} 7 + #add previous_result as data in end position by default, only if *no* insertions specified (data is just list-wrapped previous_result) + #set segment_members_filled [concat $segment_members [dict get $dict_tagval %data%]] ;# data flows through by default as single element - not args - because some strings are not valid lists + #insertion-specs with a trailing * can be used to insert data in args format + set segment_members_filled $segment_members + if {[dict exists $dict_tagval data]} { + lappend segment_members_filled [dict get $dict_tagval data] + } + + } else { + debug.punk.pipe.var {processing insertion_pattern dict_tagval: $dict_tagval} 4 + set segment_members_filled [list] + set segmenttail $segment_members ;# todo - change to segment_members here to match punk::match_assign + + set rhsmapped [punk::pipe::lib::pipecmd_namemapping $rhs] + set cmdname "::punk::pipecmds::insertion::_$rhsmapped" + #glob chars have been mapped - so we can test by comparing info commands result to empty string + if {[info commands $cmdname] eq ""} { + + set insertion_script "proc $cmdname {dict_tagval segmenttail} {\n" + foreach v_pos $insertion_patterns { + #puts stdout "v_pos '$v_pos'" + lassign $v_pos v indexspec positionspec ;#v may be atom, or varname (in pipeline scope) + #puts stdout "v:'$v' indexspec:'$indexspec' positionspec:'$positionspec'" + #julz + + append insertion_script \n [string map [list $v_pos] { + lassign [list ] v indexspec positionspec + }] + + if {([string index $v 0] eq "'") && ([string index $v end] eq "'")} { + set v [string range $v 1 end-1] ;#assume trailing ' is present! + if {[string length $indexspec]} { + error "pipesyntax - index not supported on atom" "pipeline $segment_op $initial_returnvarspec $equalsrhs $args" [list pipesyntax index_on_literal] + } + append insertion_script \n "set insertion_data [list $v]" ;#sub in shortened $v now -i.e use atom value itself (string within single quotes) + } elseif {[string is double -strict $v]} { + #don't treat numbers as variables + if {[string length $indexspec]} { + error "pipesyntax - index not supported on number" "pipeline $segment_op $initial_returnvarspec $equalsrhs $args" [list pipesyntax index_on_literal] + } + append insertion_script \n {set insertion_data $v} + } else { + #todo - we should potentially group by the variable name and pass as a single call to _multi_bind_result - because stateful @ and @@ won't work in independent calls + append insertion_script \n [string map [list $cmdname] { + #puts ">>> v: $v dict_tagval:'$dict_tagval'" + if {$v eq ""} { + set v "data" + } + if {[dict exists $dict_tagval $v]} { + set insertion_data [dict get $dict_tagval $v] + #todo - use destructure_func + set d [punk::_multi_bind_result $indexspec $insertion_data] + set insertion_data [punk::_handle_bind_result $d] + } else { + #review - skip error if varname is 'data' ? + #e.g we shouldn't really fail for: + #.=>* list a b c <| + #??? Technically + #we need to be careful not to insert empty-list as an argument by default + error "pipevariable - varname $v not present in pipeline context. pipecontext_vars: [dict keys $dict_tagval] (2)" " pipecontext_vars: [dict keys $dict_tagval]" [list pipevariable variable_not_in_pipeline_scope] + } + + }] + } + + + + + #append script [string map [list $getv]{ + # + #}] + #maintenance - index logic should be similar identical? to to match_assign - which only needs to process atoms because it (for now?) delegates all pipeline ops here, so no vars available (single segment assign) + #tag: positionspechandler + + + #puts stdout "=== list_insertion_script '$positionspec' segmenttail " + set script2 [punk::list_insertion_script $positionspec segmenttail ] + set script2 [string map [list "\$insertion_data" ] $script2] + append insertion_script \n $script2 + + } + append insertion_script \n {set segmenttail} + append insertion_script \n "}" + #puts stderr "$insertion_script" + debug.punk.pipe.compile {creating proc ::punk::pipecmds::insertion::_$rhsmapped } 4 + eval $insertion_script + } + + set segment_members_filled [::punk::pipecmds::insertion::_$rhsmapped $dict_tagval [lindex [list $segmenttail [unset segmenttail]] 0] ] + + #set segment_members_filled $segmenttail + #note - length of segment_members_filled may now differ from length of original segment_members! (if do_expand i.e trailing * in any insertion_patterns) + + } + set rhs [string map $dict_tagval $rhs] ;#obsolete? + + debug.punk.pipe.rep {segment_members_filled rep: [rep $segment_members_filled]} 4 + + + # script index could have changed!!! todo fix! + + #we require re_dot_assign before re_assign (or fix regexes so order doesn't matter!) + if {(!$segment_first_is_script ) && $segment_op eq ".="} { + #no scriptiness detected + + #debug.punk.pipe.rep {[a yellow bold][rep_listname segment_members_filled][a]} 4 + + set cmdlist_result [uplevel 1 $segment_members_filled] + #debug.punk.pipe {[a green bold]forward_result: $forward_result[a]} 4 + #debug.punk.pipe.rep {[a yellow bold]forward_result REP: [rep $forward_result][a]} 4 + + #set d [_multi_bind_result $returnvarspec [punk::K $cmdlist_result [unset cmdlist_result]]] + set d [_multi_bind_result $returnvarspec [lindex [list $cmdlist_result [unset cmdlist_result ]] 0]] + + set segment_result [_handle_bind_result $d] + #puts stderr ">>forward_result: $forward_result segment_result $segment_result" + + + } elseif {$segment_op eq "="} { + #slightly different semantics for assigment! + #We index into the DATA - not the position within the segment! + #(an = segment must take a single argument, as opposed to a .= segment) + #(This was a deliberate design choice for consistency with set, and to reduce errors.) + #(we could have allowed multiple args to = e.g to form a list, but it was tried, and the edge-cases were unintuitive and prone to user error) + #(The choice to restrict to single argument, but allow insertion and appending via insertion-specs is more explicit and reliable even though the insertion-specs operate differently to those of .=) + # + #we have to ensure that for an empty segment - we don't append to the empty list, thus listifying the data + #v= {a b c} |> = + # must return: {a b c} not a b c + # + if {!$segment_has_insertions} { + set segment_members_filled $segment_members + if {[dict exists $dict_tagval data]} { + if {![llength $segment_members_filled]} { + set segment_members_filled [dict get $dict_tagval data] + } else { + lappend segment_members_filled [dict get $dict_tagval data] + } + } + } + + set d [_multi_bind_result $returnvarspec [lindex [list $segment_members_filled [unset segment_members_filled ]] 0]] + set segment_result [_handle_bind_result $d] + + + } elseif {$segment_first_is_script || $segment_op eq "script"} { + #script + debug.punk.pipe {[a+ cyan bold].. evaluating as script[a]} 2 + + set script [lindex $segment_members 0] + + #build argument lists for 'apply' + set segmentargnames [list] + set segmentargvals [list] + foreach {k val} $dict_tagval { + if {$k eq "args"} { + #skip args - it is manually added at the end of the apply list if it's a valid tcl list + continue + } + lappend segmentargnames $k + lappend segmentargvals $val + } + + set argsdatalist $prevr ;#default is raw result as a list. May be overridden by an argspec within |> e.g |args@@key> or stripped if not a tcl list + #puts "------> rep prevr argsdatalist: [rep $argsdatalist]" + set add_argsdata 0 + if {[dict exists $dict_tagval "args"]} { + set argsdatalist [dict get $dict_tagval "args"] + #see if the raw result can be treated as a list + if {[catch {lindex $argsdatalist 0}]} { + #we cannot supply 'args' + set pre_script "" + #todo - only add trace if verbose warnings enabled? + append pre_script "trace add variable args read punk::pipeline_args_read_trace_error\n" + set script $pre_script + append script $segment_first_word + set add_argsdata 0 + } else { + set add_argsdata 1 + } + } + + debug.punk.pipe.rep {>> [rep_listname segmentargvals]} 4 + set ns [uplevel 1 {::tcl::namespace::current}] + if {!$add_argsdata} { + debug.punk.pipe {APPLY1: (args not set; not a list) segment vars:$segmentargnames} 4 + #puts stderr " script: $script" + #puts stderr " vals: $segmentargvals" + set evaluation [uplevel 1 [list ::apply [::list $segmentargnames $script $ns] {*}$segmentargvals]] + } else { + debug.punk.pipe {APPLY2: (args is set)segment vars:$segmentargnames} 4 + #puts stderr " script: $script" + #puts stderr " vals: $segmentargvals $argsdatalist" + #pipeline script context should be one below calling context - so upvar v v will work + #ns with leading colon will fail with apply + set evaluation [uplevel 1 [list ::apply [::list [::concat $segmentargnames args] $script $ns] {*}$segmentargvals {*}$argsdatalist]] + } + + debug.punk.pipe.rep {script result, evaluation: [rep_listname evaluation]} 4 + #puts "---> rep script evaluation result: [rep $evaluation]" + #set d [_multi_bind_result $returnvarspec [punk::K $evaluation [unset evaluation]]] + + #trailing segment_members are *pipedata* scripts - as opposed to ordinary pipeline scripts! + set tail_scripts [lrange $segment_members 1 end] + if {[llength $tail_scripts]} { + set r [pipedata $evaluation {*}$tail_scripts] + } else { + set r $evaluation + } + set d [_multi_bind_result $returnvarspec [lindex [list $r [unset r]] 0]] + set segment_result [_handle_bind_result $d] + } else { + #tags ? + #debug.punk.pipe {>>raw commandline: [concat $rhs $segment_members_filled]} 5 + if {false} { + #experimental. + package require funcl + #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] + } 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 " + #append snew "set pipe_[expr $i -1]" + #append pscript $snew + set pscript [funcl::o_of_n 1 $segment_members $pscript] + + } + } + + 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 ]] + + #multi_bind_result needs to return a funcl for rhs of: + #lindex [list [set syncvar [main pipeline.. ]] [rhs binding funcl...] 1 ] + #which uses syncvar + # + #The lhs of 'list' runs first so now syncvar can be the root level of the rhs function list and bind the necessary vars. + #NOTE: unintuitively, we are returning the value of rhs to the main pipleline! (leftmost binding) this is because the leftmost binding determines what goes back to the pipeline result + + set segment_result [_handle_bind_result $d] + } + #the subresult doesn't need to go backwards - as the final assignment can emit the result into a variable + #It makes more sense and is ultimately more useful (and more easy to reason about) for the result of each assignment to be related only to the pre-pipe section + #It may however make a good debug point + #puts stderr "segment $i segment_result:$segment_result" + + debug.punk.pipe.rep {[rep_listname segment_result]} 3 + + + + + + #examine tailremaining. + # either x x x |?> y y y ... + # or just y y y + #we want the x side for next loop + + #set up the conditions for the next loop + #|> x=y args + # inpipespec - contents of previous piper |xxx> + # outpipespec - empty or content of subsequent piper |xxx> + # previous_result + # assignment (x=y) + + + set pipespec($j,in) $pipespec($i,out) + set outpipespec "" + set tailmap "" + set next_pipe_posn -1 + if {[llength $tailremaining]} { + + #set tailmap [lmap v $tailremaining {lreplace [split $v {}] 1 end-1}] + ##e.g for: a b c |> e f g |> h + #set next_pipe_posn [lsearch $tailmap {| >}] + set next_pipe_posn [lsearch $tailremaining "|*>"] + + set outpipespec [string range [lindex $tailremaining $next_pipe_posn] 1 end-1] + } + set pipespec($j,out) $outpipespec + + + set script_like_first_word 0 + if {[llength $tailremaining] || $next_pipe_posn >= 0} { + + if {$next_pipe_posn >=0} { + set next_all_members [lrange $tailremaining 0 $next_pipe_posn-1] ;#exclude only piper |xxx> for + set tailremaining [lrange $tailremaining $next_pipe_posn+1 end] + + } else { + set next_all_members $tailremaining + set tailremaining [list] + } + + + #assignment is the arg immediately following |> operator e.g x.=blah or x=etc (or a normal commandlist or script!) + set segment_first_word "" + set returnvarspec "" ;# the lhs of x=y + set segment_op "" + set rhs "" + set segment_first_is_script 0 + if {[llength $next_all_members]} { + if {[punk::pipe::lib::arg_is_script_shaped [lindex $next_all_members 0]]} { + set segment_first_word [lindex $next_all_members 0] + set segment_first_is_script 1 + set segment_op "" + set segment_members $next_all_members + } else { + set possible_assignment [lindex $next_all_members 0] + #set re_dot_assign {^([^ \t\r\n=\{]*)\.=(.*)} + if {[regexp {^([^ \t\r\n=\{]*)\.=(.*)} $possible_assignment _ returnvarspec rhs]} { + set segment_op ".=" + set segment_first_word [lindex $next_all_members 1] + set script_like_first_word [punk::pipe::lib::arg_is_script_shaped $segment_first_word] + if {$script_like_first_word} { + set segment_first_is_script 1 ;#relative to segment_members which no longer includes the .= + } + set segment_members [lrange $next_all_members 1 end] + } elseif {[regexp {^([^ \t\r\n=]*)=(.*)} $possible_assignment _ returnvarspec rhs]} { + set segment_op "=" + #never scripts + #must be at most a single element after the = ! + if {[llength $next_all_members] > 2} { + #raise this as pipesyntax as opposed to pipedata? + error "pipesyntax - at most one element can follow = (got [lrange $next_all_members 1 end])" "pipeline $segment_op $returnvarspec $rhs [lrange $next_all_members 1 end]" [list pipesyntax too_many_elements] + } + set segment_first_word [lindex $next_all_members 1] + if {[catch {llength $segment_first_word}]} { + set segment_is_list 0 ;#only used for segment_op = + } else { + set segment_is_list 1 ;#only used for segment_op = + } + + set segment_members $segment_first_word + } else { + #no assignment operator and not script shaped + set segment_op "" + set returnvarspec "" + set segment_first_word [lindex $next_all_members 0] + set segment_first_word [lindex $next_all_members 1] + set segment_members $next_all_members + #puts stderr ">>3 no-operator segment_first_word: '$segment_first_word'" + } + } + + + } else { + #?? two pipes in a row ? + debug.punk.pipe {[a+ yellow bold]WARNING: no segment members found[a]} 0 + set segment_members return + set segment_first_word return + } + + #set forward_result $segment_result + #JMN2 + set previous_result $segment_result + #set previous_result [join $segment_result] + } else { + debug.punk.pipe {[a+ cyan bold]End of pipe segments ($i)[a]} 4 + #output pipe spec at tail of pipeline + + set pipedvars [dict create] + if {[string length $pipespec($i,out)]} { + set d [apply {{mv res} { + punk::_multi_bind_result $mv $res -levelup 1 + }} $pipespec($i,out) $segment_result] + set segment_result [_handle_bind_result $d] + set pipedvars [dict get $d setvars] + } + + set more_pipe_segments 0 + } + + #the segment_result is based on the leftmost var on the lhs of the .= + #whereas forward_result is always the entire output of the segment + #JMN2 + #lappend segment_result_list [join $segment_result] + lappend segment_result_list $segment_result + incr i + incr j + } ;# end while + + return [lindex $segment_result_list end] + #JMN2 + #return $segment_result_list + #return $forward_result + } + + + #just an experiment + #what advantage/difference versus [llength [lrange $data $start $end]] ??? + proc data_range_length {data start end} { + set datalen [llength $data] + + #normalize to s and e + if {$start eq "end"} { + set s [expr {$datalen - 1}] + } elseif {[string match end-* $start]} { + set stail [string range $start 4 end] + set posn [expr {$datalen - $stail -1}] + if {$posn < 0} { + return 0 + } + set s $posn + } else { + #int + if {($start < 0) || ($start > ($datalen -1))} { + return 0 + } + set s $start + } + if {$end eq "end"} { + set e [expr {$datalen - 1}] + } elseif {[string match end-* $end]} { + set etail [string range $end 4 end] + set posn [expr {$datalen - $etail -1}] + if {$posn < 0} { + return 0 + } + set e $posn + } else { + #int + if {($end < 0)} { + return 0 + } + set e $end + } + if {$s > ($datalen -1)} { + return 0 + } + if {$e > ($datalen -1)} { + set e [expr {$datalen -1}] + } + + + + if {$e < $s} { + return 0 + } + + return [expr {$e - $s + 1}] + } + + # unknown -- + # This procedure is called when a Tcl command is invoked that doesn't + # exist in the interpreter. It takes the following steps to make the + # command available: + # + # 1. See if the autoload facility can locate the command in a + # Tcl script file. If so, load it and execute it. + # 2. If the command was invoked interactively at top-level: + # (a) see if the command exists as an executable UNIX program. + # If so, "exec" the command. + # (b) see if the command requests csh-like history substitution + # in one of the common forms !!, !, or ^old^new. If + # so, emulate csh's history substitution. + # (c) see if the command is a unique abbreviation for another + # command. If so, invoke the command. + # + # Arguments: + # args - A list whose elements are the words of the original + # command, including the command name. + + #review - we shouldn't really be doing this + #We need to work out if we can live with the real default unknown and just inject some special cases at the beginning before falling-back to the normal one + + proc ::unknown args { + #puts stderr "unk>$args" + variable ::tcl::UnknownPending + global auto_noexec auto_noload env tcl_interactive errorInfo errorCode + + if {[info exists errorInfo]} { + set savedErrorInfo $errorInfo + } + if {[info exists errorCode]} { + set savedErrorCode $errorCode + } + + set name [lindex $args 0] + if {![info exists auto_noload]} { + # + # Make sure we're not trying to load the same proc twice. + # + if {[info exists UnknownPending($name)]} { + return -code error "self-referential recursion\ + in \"unknown\" for command \"$name\"" + } + set UnknownPending($name) pending + set ret [catch { + auto_load $name [uplevel 1 {::tcl::namespace::current}] + } msg opts] + unset UnknownPending($name) + if {$ret != 0} { + dict append opts -errorinfo "\n (autoloading \"$name\")" + return -options $opts $msg + } + if {![array size UnknownPending]} { + unset UnknownPending + } + if {$msg} { + if {[info exists savedErrorCode]} { + set ::errorCode $savedErrorCode + } else { + unset -nocomplain ::errorCode + } + if {[info exists savedErrorInfo]} { + set errorInfo $savedErrorInfo + } else { + unset -nocomplain errorInfo + } + set code [catch {uplevel 1 $args} msg opts] + if {$code == 1} { + # + # Compute stack trace contribution from the [uplevel]. + # Note the dependence on how Tcl_AddErrorInfo, etc. + # construct the stack trace. + # + set errInfo [dict get $opts -errorinfo] + set errCode [dict get $opts -errorcode] + set cinfo $args + if {[string length [encoding convertto utf-8 $cinfo]] > 150} { + set cinfo [string range $cinfo 0 150] + while {[string length [encoding convertto utf-8 $cinfo]] > 150} { + set cinfo [string range $cinfo 0 end-1] + } + append cinfo ... + } + set tail "\n (\"uplevel\" body line 1)\n invoked\ + from within\n\"uplevel 1 \$args\"" + set expect "$msg\n while executing\n\"$cinfo\"$tail" + if {$errInfo eq $expect} { + # + # The stack has only the eval from the expanded command + # Do not generate any stack trace here. + # + dict unset opts -errorinfo + dict incr opts -level + return -options $opts $msg + } + # + # Stack trace is nested, trim off just the contribution + # from the extra "eval" of $args due to the "catch" above. + # + set last [string last $tail $errInfo] + if {$last + [string length $tail] != [string length $errInfo]} { + # Very likely cannot happen + return -options $opts $msg + } + set errInfo [string range $errInfo 0 $last-1] + set tail "\"$cinfo\"" + set last [string last $tail $errInfo] + if {$last < 0 || $last + [string length $tail] != [string length $errInfo]} { + return -code error -errorcode $errCode \ + -errorinfo $errInfo $msg + } + set errInfo [string range $errInfo 0 $last-1] + set tail "\n invoked from within\n" + set last [string last $tail $errInfo] + if {$last + [string length $tail] == [string length $errInfo]} { + return -code error -errorcode $errCode \ + -errorinfo [string range $errInfo 0 $last-1] $msg + } + set tail "\n while executing\n" + set last [string last $tail $errInfo] + if {$last + [string length $tail] == [string length $errInfo]} { + return -code error -errorcode $errCode \ + -errorinfo [string range $errInfo 0 $last-1] $msg + } + return -options $opts $msg + } else { + dict incr opts -level + return -options $opts $msg + } + } + } + #set isrepl [expr {[file tail [file rootname [info script]]] eq "repl"}] + set isrepl [punk::repl::codethread::is_running] ;#may not be reading though + if {$isrepl} { + #set ::tcl_interactive 1 + } + if {$isrepl || (([info level] == 1) && (([info script] eq "" ) ) + && ([info exists tcl_interactive] && $tcl_interactive))} { + + if {![info exists auto_noexec]} { + set new [auto_execok $name] + if {$new ne ""} { + set redir "" + if {[namespace which -command console] eq ""} { + set redir ">&@stdout <@stdin" + } + + + #windows experiment todo - use twapi and named pipes + #twapi::namedpipe_server {\\.\pipe\something} + #Then override tcl 'exec' and replace all stdout/stderr/stdin with our fake ones + #These can be stacked with shellfilter and operate as OS handles - which we can't do with fifo2 etc + # + + #if {[string first " " $new] > 0} { + # set c1 $name + #} else { + # set c1 $new + #} + + # -- --- --- --- --- + set idlist_stdout [list] + set idlist_stderr [list] + #set shellrun::runout "" + #when using exec with >&@stdout (to ensure process is connected to console) - the output unfortunately doesn't go via the shellfilter stacks + #lappend idlist_stderr [shellfilter::stack::add stderr ansiwrap -settings {-colour {red bold}}] + #lappend idlist_stdout [shellfilter::stack::add stdout tee_to_var -action float -settings {-varname ::shellrun::runout}] + + if {[punk::config::configure running auto_exec_mechanism] eq "experimental"} { + #TODO - something cross-platform that allows us to maintain a separate console(s) with an additional set of IO channels to drive it + #not a trivial task + + #This runs external executables in a context in which they are not attached to a terminal + #VIM for example won't run, and various programs can't detect terminal dimensions etc and/or will default to ansi-free output + #ctrl-c propagation also needs to be considered + + set teehandle punksh + uplevel 1 [list ::catch {*}{ + } [list ::shellfilter::run [concat [list $new] [lrange $args 1 end]] -teehandle $teehandle -inbuffering line -outbuffering none ] {*}{ + } ::tcl::UnknownResult ::tcl::UnknownOptions + ] + + if {[string trim $::tcl::UnknownResult] ne "exitcode 0"} { + dict set ::tcl::UnknownOptions -code error + set ::tcl::UnknownResult "Non-zero exit code from command '$args' $::tcl::UnknownResult" + } else { + #no point returning "exitcode 0" if that's the only non-error return. + #It is misleading. Better to return empty string. + set ::tcl::UnknownResult "" + } + } else { + set repl_runid [punk::get_repl_runid] + #set ::punk::last_run_display [list] + set resolved $new + if {[string match "for_unknown_handler *" $new]} { + set ext [file extension $name] + if {[string tolower $ext] eq ".lnk"} { + #for .lnk files we can often resolve the target path without needing to execute the shell open command + #- which is desirable because it allows us to avoid the absolute path requirement for unknown-handler auto_execok commands, + #which is desirable because it allows us to support relative paths and paths with environment variables in them + #(e.g for .lnk files that point to executables with environment variables in the path) + set targetinfo [punk::winlnk::resolve $name] + if {[dict exists $targetinfo link_roottarget]} { + set resolved [dict get $targetinfo link_roottarget] + #arguments? + } else { + puts "(unknown-handler): failed to resolve .lnk target for $name. Falling back to shell open command resolution, which may fail if absolute path is required." + } + } else { + #re-resolve. + set associnfo [punk::auto_exec::shell_open_command $ext] + set registry_valuetype [dict get $associnfo type] ;#sz vs expand_sz + set command_spec [dict get $associnfo value] + set windows_file_type [dict get $associnfo filetype] + if {[string match "*absolute_path required" $new]} { + puts "(unknown-handler): auto_execok for $name requires absolute path. Re-resolving $name with absolute path." + set fullpath [file normalize $name] + #at least for .url files - long paths (paths with multiple spaces?) can fail to run. Using the short path seems to fix this. + #This seems hacky but anyway.. + set attributes [file attributes $fullpath] + if {[dict exists $attributes -shortname]} { + set fullpath [dict get $attributes -shortname] + } + set resolved [punk::auto_exec::shell_command_as_tcl_list -type $registry_valuetype $command_spec $fullpath] + } else { + #todo + set newnorm [file normalize $name] + puts stderr "(unknown-handler): re-resolving $name with auto_execok $newnorm" + set resolved [auto_execok $newnorm] + } + } + } + + if {$resolved eq ""} { + #resolved may be emptyif auto_execok returns an empty string. + dict set ::tcl::UnknownOptions -code error + set ::tcl::UnknownResult "unresolved path '$name'" + return -options $::tcl::UnknownOptions $::tcl::UnknownResult + } + set redir ">&@stdout <@stdin" + uplevel 1 [list ::catch [concat exec $redir $resolved [lrange $args 1 end]] ::tcl::UnknownResult ::tcl::UnknownOptions] + #we can't detect stdout/stderr output from the exec + #for now emit an extra \n on stderr + #todo - there is probably no way around this but to somehow exec in the context of a completely separate console + #This is probably a tricky problem - especially to do cross-platform + # + # - use [dict get $::tcl::UnknownOptions -code] (0|1) exit + if {[dict get $::tcl::UnknownOptions -code] == 0} { + set c green + set m "ok" + } else { + set c yellow + set m "errorCode $::errorCode" + } + set chunklist [list] + lappend chunklist [list "info" "[a $c]$m[a] " ] + if {$repl_runid != 0} { + tsv::lappend repl runchunks-$repl_runid {*}$chunklist + } + + } + + foreach id $idlist_stdout { + shellfilter::stack::remove stdout $id + } + foreach id $idlist_stderr { + shellfilter::stack::remove stderr $id + } + # -- --- --- --- --- + + + #uplevel 1 [list ::catch \ + # [concat exec $redir $new [lrange $args 1 end]] \ + # ::tcl::UnknownResult ::tcl::UnknownOptions] + + #puts "===exec with redir:$redir $::tcl::UnknownResult ==" + dict incr ::tcl::UnknownOptions -level + return -options $::tcl::UnknownOptions $::tcl::UnknownResult + } + } + + if {$name eq "!!"} { + set newcmd [history event] + } elseif {[regexp {^!(.+)$} $name -> event]} { + set newcmd [history event $event] + } elseif {[regexp {^\^([^^]*)\^([^^]*)\^?$} $name -> old new]} { + set newcmd [history event -1] + catch {regsub -all -- $old $newcmd $new newcmd} + } + if {[info exists newcmd]} { + tclLog $newcmd + history change $newcmd 0 + uplevel 1 [list ::catch $newcmd \ + ::tcl::UnknownResult ::tcl::UnknownOptions] + dict incr ::tcl::UnknownOptions -level + return -options $::tcl::UnknownOptions $::tcl::UnknownResult + } + + set ret [catch {set candidates [info commands $name*]} msg] + if {$name eq "::"} { + set name "" + } + if {$ret != 0} { + dict append opts -errorinfo \ + "\n (expanding command prefix \"$name\" in unknown)" + return -options $opts $msg + } + # Filter out bogus matches when $name contained + # a glob-special char [Bug 946952] + if {$name eq ""} { + # Handle empty $name separately due to strangeness + # in [string first] (See RFE 1243354) + set cmds $candidates + } else { + set cmds [list] + foreach x $candidates { + if {[string first $name $x] == 0} { + lappend cmds $x + } + } + } + + #punk - disable prefix match search + set default_cmd_search 0 + if {$default_cmd_search} { + if {[llength $cmds] == 1} { + uplevel 1 [list ::catch [lreplace $args 0 0 [lindex $cmds 0]] ::tcl::UnknownResult ::tcl::UnknownOptions] + dict incr ::tcl::UnknownOptions -level + return -options $::tcl::UnknownOptions $::tcl::UnknownResult + } + if {[llength $cmds]} { + return -code error "ambiguous command name \"$name\": [lsort $cmds]" + } + } else { + #punk hacked version - report matches but don't run + if {[llength $cmds]} { + return -code error "unknown command name \"$name\": possible match(es) [lsort $cmds]" + } + + } + + + } + return -code error -errorcode [list TCL LOOKUP COMMAND $name] "invalid command name $name" + } + + proc know {cond body} { + set existing [info body ::unknown] + #assuming we can't test on cond being present in existing unknown script - because it may be fairly simple and prone to false positives (?) + ##This means we can't have 2 different conds with same body if we test for body in unknown. + ##if {$body ni $existing} { + set scr [base64::encode -maxlen 0 $cond] ;#will only be decoded if the debug is triggered + #tcllib has some double-substitution going on.. base64 seems easiest and will not impact the speed of normal execution when debug off. + + #tclint-disable-next-line + proc ::unknown {args} [string map [list @c@ $cond @b@ $body @scr@ $scr] { + #--------------------------------------- + if {![catch {expr {@c@}} res] && $res} { + debug.punk.unknown {HANDLED BY: punk unknown_handler ([llength $args]) args:'$args' "cond_script:'[punk::decodescript @scr@]'" } 4 + return [eval {@b@}] + } else { + debug.punk.unknown {skipped: punk unknown_handler ([llength $args]) args:'$args' "cond_script:'[punk::decodescript @scr@]'" } 4 + } + #--------------------------------------- + }]$existing + #} + } + + proc know? {{len 2000}} { + puts [string range [info body ::unknown] 0 $len] + } + proc decodescript {b64} { + if {[ catch { + base64::decode $b64 + } scr]} { + return "" + } else { + return "($scr)" + } + } + + # --------------------------- + # commands that should be aliased in safe interps that need to use punk repl + # + proc get_repl_runid {} { + if {[interp issafe]} { + if {[info commands ::tsv::exists] eq ""} { + puts stderr "punk::get_repl_runid cannot operate directly in safe interp - install the appropriate punk aliases" + error "punk::get_repl_runid punk repl aliases not installed" + } + #if safe interp got here - there must presumably be a direct set of aliases on tsv::* commands + } + if {[tsv::exists repl runid]} { + return [tsv::get repl runid] + } else { + return 0 + } + } + #ensure we don't get into loop in unknown when in safe interp - which won't have tsv + proc set_repl_last_unknown {args} { + if {[interp issafe]} { + if {[info commands ::tsv::set] eq ""} { + puts stderr "punk::set_repl_last_unknown cannot operate directly in safe interp - install an alias to tsv::set repl last_unknown" + return + } + #tsv::* somehow working - possibly custom aliases for tsv functionality ? review + } + if {[info commands ::tsv::set] eq ""} { + puts stderr "set_repl_last_unknown - tsv unavailable!" + return + } + tsv::set repl last_unknown {*}$args + } + # --------------------------- + + #---------------- + #for var="val {a b c}" + #proc ::punk::val {{v {}}} {tailcall lindex $v} + #proc ::punk::val {{v {}}} {return $v} ;#2023 - approx 2x faster than the tailcall lindex version + + proc ::punk::val [list [list v [purelist]]] {return $v} + #---------------- + + proc configure_unknown {} { + #----------------------------- + #these are critical e.g core behaviour or important for repl displaying output correctly + + + #can't use know - because we don't want to return before original unknown body is called. + proc ::unknown {args} [string cat { + #set ::punk::last_run_display [list] + #set ::repl::last_unknown [lindex $args 0] ;#jn + #tsv::set repl last_unknown [lindex $args 0] ;#REVIEW + punk::set_repl_last_unknown [lindex $args 0] + }][info body ::unknown] + + + #handle process return dict of form {exitcode num etc blah} + #ie when the return result as a whole is treated as a command + #exitcode must be the first key + know {[lindex $args 0 0] eq "exitcode"} { + uplevel 1 [list exitcode {*}[lrange [lindex $args 0] 1 end]] + } + + + #----------------------------- + # + # potentially can be disabled by config(?) - but then scripts not able to use all repl features.. + + + #------------------------ + #todo 2026 - remove - use new : expr syntax instead + #todo - repl output info that it was evaluated as an expression + #know {[expr $args] || 1} {expr $args} + #know {[expr $args] || 1} {tailcall expr $args} + #--------------------------- + + #it is significantly faster to call a proc such as punk::lib::range like this than to inline it in the unknown proc + #punk::lib::range is defined as a wrapper to lseq if it is available (8.7+) + know {[regexp {^([+-]*[0-9_]+)\.\.([+-]*[0-9_]+)$} [lindex $args 0 0] -> from to]} {punk::lib::range $from $to} + + + #NOTE: + #we don't allow setting namespace qualified vars in the lhs assignment pattern. + #The principle is that we shouldn't be setting vars outside of the immediate calling scope. + #(It would also be difficult and error-prone and generally make the pipelines less re-usable and reliable) + #Therefore ::nswhatever::blah= x is the pipeline: blah= x - where the corresponding command, if any is first resolved in ::nswhatever + #We will require that the namespace already exists - which is consistent with if the command were to be run without unknown + proc ::punk::_unknown_assign_dispatch {matchedon pattern equalsrhs args} { + set tail [lassign $args hd] + #puts "-> _unknown_assign_dispatch '$partzerozero' pattern:'$pattern' equalsrhs:'$equalsrhs' args:'$args' argshd:'$hd' argstail:'$tail'" + if {$hd ne $matchedon} { + if {[llength $tail]} { + error "unknown_assign_dispatch: pipeline with args unexpanded. Try {*}\$pipeline $tail" + } + #regexp $punk::re_assign $hd _ pattern equalsrhs + #we assume the whole pipeline has been provided as the head + #regexp {^([^\t\r\n=]*)\=([^ \t\r\n]*)(.*)} $hd _ pattern equalsrhs tail + regexp {^([^\t\r\n=]*)\=([^\r\n]*)} $hd _ pattern fullrhs + lassign [punk::pipe::lib::_rhs_tail_split $fullrhs] equalsrhs tail + } + #NOTE: - it doesn't make sense to call 'namespace' qualifiers or 'namespace tail' on a compound hd such as v,::etc= blah + # we only look at leftmost namespace-like thing and need to take account of the pattern syntax + # e.g for ::etc,'::x'= + # the ns is :: and the tail is etc,'::x'= + # (Tcl's namespace qualifiers/tail won't help here) + if {[string match ::* $hd]} { + set patterns [punk::pipe::lib::_split_patterns_memoized $hd] + #get a pair-list something like: {::x /0} {etc {}} + set ns [namespace qualifiers [lindex $patterns 0 0]] + set nslen [string length $ns] + set patterntail [string range $ns $nslen end] + } else { + set ns "" + set patterntail $pattern + } + if {[string length $ns] && ![namespace exists $ns]} { + error "unknown_assign_dispatch: namespace '$ns' not found. (Note that pipeline lhs variables cannot be namespaced)" + } else { + set nscaller [uplevel 1 [list ::tcl::namespace::current]] + #jmn + set rhsmapped [punk::pipe::lib::pipecmd_namemapping $equalsrhs] + set commands [uplevel 1 [list ::tcl::info::commands $pattern=$rhsmapped]] ;#uplevel - or else we are checking from perspective of this namespace ::punk + #we must check for exact match of the command in the list - because command could have glob chars. + if {"$pattern=$rhsmapped" in $commands} { + puts stderr "unknown_assign_dispatch>> '$pattern=$equalsrhs' $commands nscaller: '$nscaller'" + #we call the namespaced function - we don't evaluate it *in* the namespace. + #REVIEW + #warn for now...? + #tailcall $pattern=$equalsrhs {*}$args + tailcall $pattern=$rhsmapped {*}$tail + } + } + #puts "--->nscurrent [uplevel 1 [list ::namespace current]]" + #ignore the namespace.. + #We could interpret the fact that the nonexistant pipe was called with a namespace to indicate that's where the pipecommand should be created.. + #But.. we would need to ensure 1st (compiling) invocation runs the same way as subsequent invocations. + #namespace evaling match_assign here probably wouldn't accomplish that and may create surprises with regards to where lhs vars(if any) are created + tailcall ::punk::match_assign $patterntail $equalsrhs {*}$tail + #return [uplevel 1 [list ::punk::match_assign $varspecs $rhs $tail]] + } + #variable re_assign {^([^\r\n=\{]*)=(.*)} + #characters directly following = need to be assigned to the var even if they are escaped whitespace (e.g \t \r \n) + #unescaped whitespace causes the remaining elements to be part of the tail -ie are appended to the var as a list + #e.g x=a\nb c + #x will be assigned the list {a\nb c} ie the spaces between b & c are not maintained + # + #know {[regexp {^([^\t\r\n=]*)\=([^ \t\r\n]*)} [lindex $args 0] matchedon pattern equalsrhs]} {tailcall ::punk::_unknown_assign_dispatch $matchedon $pattern $equalsrhs {*}$args} + #know {[regexp {^{([^\t\r\n=]*)\=([^ \t\r\n]*)}} [lindex $args 0] matchedon pattern equalsrhs]} {tailcall ::punk::_unknown_assign_dispatch $matchedon $pattern $equalsrhs {*}$args} + + + + proc ::punk::_unknown_compare {val1 val2 args} { + if {![string length [string trim $val2]]} { + if {[llength $args] > 1} { + #error "Extra args after comparison operator ==. usage e.g : \$var1==\$var2 or \$var1==\$var2 + 2" + set val2 [string cat {*}[lrange $args 1 end]] + return [expr {$val1 eq $val2}] + } + return $val1 + } elseif {[llength $args] == 1} { + #simple comparison + if {[string is digit -strict $val1$val2]} { + return [expr {$val1 == $val2}] + } else { + return [string equal $val1 $val2] + } + } elseif {![catch {expr $val2 {*}[lrange $args 1 end]} evaluated]} { + if {[string is digit -strict $val1$evaluated]} { + return [expr {$val1 == $evaluated}] + } else { + return [expr {$val1 eq $evaluated}] + } + } else { + set evaluated [uplevel 1 [list {*}$val2 {*}[lrange $args 1 end]]] + if {[string is digit -strict $val1$evaluated]} { + return [expr {$val1 == $evaluated}] + } else { + return [expr {$val1 eq $evaluated}] + } + } + } + #ensure == is after = in know sequence + #.* on left is pretty broad - todo: make it a little more specific to avoid unexpected interactions + know {[regexp {(.*)==(.*)} [lindex $args 0] _ val1 val2]} {tailcall ::punk::_unknown_compare $val1 $val2 {*}$args} + #.= must come after = here to ensure it comes before = in the 'unknown' proc + #set punk::re_dot_assign {([^=]*)\.=(.*)} + #know {[regexp $punk::re_dot_assign [lindex $args 0 0] _ varspecs rhs]} { + # set tail [expr {([lindex $args 0] eq [lindex $args 0 0]) ? [lrange $args 1 end] : [concat [lrange [lindex $args 0] 1 end] [lrange $args 1 end] ] }] + # tailcall ::punk::match_exec $varspecs $rhs {*}$tail + # #return [uplevel 1 [list ::punk::match_exec $varspecs $rhs {*}$tail]] + # } + # + + + + proc ::punk::_unknown_dot_assign_dispatch {partzerozero pattern equalsrhs args} { + #puts stderr ". unknown dispatch $partzerozero" + set argstail [lassign $args hd] + + #this equates to auto-flattening the head.. which seems like a bad idea, the structure was there for a reason. + #we should require explicit {*} expansion if the intention is for the args to be joined in at that level. + #expr {($hd eq $partzerozero) ? [set tail $argstail] : [set tail [concat [lrange $hd 1 end] $argstail ]] } + + if {$hd ne $partzerozero} { + if {[llength $argstail]} { + error "unknown_dot_assign_dispatch: pipeline with args unexpanded. Try {*}\$pipeline $argstail" + } + #regexp $punk::re_assign $hd _ pattern equalsrhs + #we assume the whole pipeline has been provided as the head + #regexp {^([^ \t\r\n=\{]*)\.=([^ \t\r\n]*)(.*)} $hd _ pattern equalsrhs argstail + #regexp {^([^ \t\r\n=\{]*)\.=([^ \t\r\n]*)(.*)} $hd _ pattern equalsrhs argstail + + regexp {^([^ \t\r\n=\{]*)\.=([^\r\n]*)} $hd _ pattern fullrhs + lassign [punk::pipe::lib::_rhs_tail_split $fullrhs] equalsrhs argstail + } + #tailcall ::punk::match_assign $pattern $equalsrhs {*}$argstail + + + return [uplevel 1 [list ::punk::pipeline .= $pattern $equalsrhs {*}$argstail]] + + } + + # + know {[regexp {^([^\t\r\n=]*)\=([^\r\n]*)} [lindex $args 0] matchedon pattern equalsrhs]} {tailcall ::punk::_unknown_assign_dispatch $matchedon $pattern $equalsrhs {*}$args} + know {[regexp {^{([^\t\r\n=]*)\=([^\r\n]*)}} [lindex $args 0] matchedon pattern equalsrhs]} {tailcall ::punk::_unknown_assign_dispatch $matchedon $pattern $equalsrhs {*}$args} + + #variable re_dot_assign {^([^ \t\r\n=\{]*)\.=(.*)} + #know {[regexp {^([^ \t\r\n=\{]*)\.=(.*)} [lindex $args 0 0] partzerozero varspecs rhs]} {tailcall punk::_unknown_dot_assign_dispatch $partzerozero $varspecs $rhs {*}$args} + #know {[regexp {^([^ \t\r\n=\{]*)\.=(.*)} [lindex $args 0] partzerozero varspecs rhs]} {tailcall punk::_unknown_dot_assign_dispatch $partzerozero $varspecs $rhs {*}$args} + #know {[regexp {^([^\t\r\n=\{]*)\.=(.*)} [lindex $args 0] partzerozero varspecs rhs]} {tailcall punk::_unknown_dot_assign_dispatch $partzerozero $varspecs $rhs {*}$args} + #know {[regexp {^([^\t\r\n=]*)\.=(.*)} [lindex $args 0] partzerozero varspecs rhs]} {tailcall punk::_unknown_dot_assign_dispatch $partzerozero $varspecs $rhs {*}$args} + know {[regexp {^([^=]*)\.=(.*)} [lindex $args 0] partzerozero varspecs rhs]} {tailcall punk::_unknown_dot_assign_dispatch $partzerozero $varspecs $rhs {*}$args} + + #add escaping backslashes to a value + #matching odd keys in dicts using pipeline syntax can be tricky - as + #e.g + #set ktest {a"b} + #@@[escv $ktest].= list a"b val + #without escv: + #@@"a\\"b".= list a"b val + #with more backslashes in keys the escv use becomes more apparent: + #set ktest {\\x} + #@@[escv $ktest].= list $ktest val + #without escv we would need: + #@@\\\\\\\\x.= list $ktest val + proc escv {v} { + #https://stackoverflow.com/questions/11135090/is-there-any-tcl-function-to-add-escape-character-automatically + #thanks to DKF + regsub -all {\W} $v {\\&} + } + interp alias {} escv {} punk::escv + #review + #set v "\u2767" + # + #escv $v + #\ + #the + + + #know {[regexp $punk::re_dot_assign [lindex $args 0 0] partzerozero varspecs rhs]} { + # set argstail [lassign $args hd] + # #set tail [expr {($hd eq $partzerozero) ? $argstail : [concat [lrange $hd 1 end] $argstail ] }] ;#!WRONG. expr will convert some numbers to scientific notation - this is premature/undesirable! + # #avoid using the return from expr and it works: + # expr {($hd eq $partzerozero) ? [set tail $argstail] : [set tail [concat [lrange $hd 1 end] $argstail ]] } + # + # tailcall ::punk::match_exec $varspecs $rhs {*}$tail + # #return [uplevel 1 [list ::punk::match_exec $varspecs $rhs {*}$tail]] + #} + + } + configure_unknown + #if client redefines 'unknown' after package require punk, they must call punk::configure_unknown afterwards. + # + + #main Pipe initiator function - needed especially if 'unknown' not configured to interpret x.= x= etc + #Should theoretically be slightly faster.. but pipelines are relatively slow until we can get pipeline compiling and optimisation. + proc % {args} { + set arglist [lassign $args assign] ;#tail, head + if {$assign eq ".="} { + tailcall {*}[list ::punk::pipeline .= "" "" {*}$arglist] + } elseif {$assign eq "="} { + tailcall {*}[list ::punk::pipeline = "" "" {*}$arglist] + } + + #review + set assign [string map {; \\;} $assign] + + set is_script [punk::pipe::lib::arg_is_script_shaped $assign] + + if {!$is_script && [string index $assign end] eq "="} { + #set re_dotequals {^([^ \t\r\n=\{]*)\.=$} + #set dumbeditor {\}} + #set re_equals {^([^ \t\r\n=\{]*)=$} + #set dumbeditor {\}} + if {[regexp {^([^ \t\r\n=\{]*)\.=$} $assign _ returnvarspecs]} { + set cmdlist [list ::punk::pipeline .= $returnvarspecs "" {*}$arglist] + } elseif {[regexp {^([^ \t\r\n=\{]*)=$} $assign _ returnvarspecs]} { + set cmdlist [list ::punk::pipeline = $returnvarspecs "" {*}$arglist] + } else { + error "pipesyntax punk::% unable to interpret pipeline '$args'" "% $args" [list pipesyntax unable_to_interpret] + } + } else { + if {$is_script} { + set cmdlist [list ::punk::pipeline "script" "" "" {*}$args] + } else { + set cmdlist [list ::punk::pipeline ".=" "" "" $assign {*}$arglist] + } + } + tailcall {*}$cmdlist + + + #result-based mismatch detection can probably never work nicely.. + #we need out-of-band method to detect mismatch. Otherwise we can't match on mismatch results! + # + set result [uplevel 1 $cmdlist] + #pipeline result not guaranteed to be a proper list so we can't use list methods to directly look for 'binding mismatch' + #.. but if we use certain string methods - we shimmer the case where the main result is a list + #string match doesn't seem to change the rep.. though it does generate a string rep. + #puts >>1>[rep $result] + if {[catch {lrange $result 0 1} first2wordsorless]} { + #if we can't get as a list then it definitely isn't the semi-structured 'binding mismatch' + return $result + } else { + if {$first2wordsorless eq {binding mismatch}} { + error $result + } else { + #puts >>2>[rep $result] + return $result + } + } + } + + proc ispipematch {args} { + expr {[lindex [uplevel 1 [list ::punk::pipematch {*}$args]] 0] eq "ok"} + } + + #pipe initiator which will never raise an error *except for pipesyntax* , but always returns {ok {result something}} or {error {mismatch something}} or, for tcl errors {error {reason something}} + proc pipematch {args} { + #debug.punk.pipe {pipematch level [info level] levelinfo [info level 0]} 2 + variable re_dot_assign + variable re_assign + + set arglist [lassign $args assign] + if {$assign eq ".="} { + set cmdlist [list ::punk::pipeline .= "" "" {*}$arglist] + } elseif {$assign eq "="} { + set cmdlist [list ::punk::pipeline = "" "" {*}$arglist] + } elseif {![punk::pipe::lib::arg_is_script_shaped $assign] && [string index $assign end] eq "="} { + #set re_dotequals {^([^ \t\r\n=\{]*)\.=$} + # set dumbeditor {\}} + #set re_equals {^([^ \t\r\n=\{]*)=$} + # set dumbeditor {\}} + if {[regexp {^([^ \t\r\n=]*)\.=.*} $assign _ returnvarspecs]} { + set cmdlist [list ::punk::pipeline .= $returnvarspecs "" {*}$arglist] + } elseif {[regexp {^([^ \t\r\n=]*)=.*} $assign _ returnvarspecs]} { + set cmdlist [list $assign {*}$arglist] + #set cmdlist [list ::punk::pipeline = $returnvarspecs "" {*}$arglist] + } else { + error "pipesyntax punk::pipematch unable to interpret pipeline '$args'" "pipematch $args" [pipesyntax unable_to_interpret] + } + } else { + set cmdlist $args + #script? + #set cmdlist [list ::punk::pipeline .= "" "" {*}$args] + } + + if {[catch {uplevel 1 $cmdlist} result erroptions]} { + #puts stderr "pipematch erroptions:$erroptions" + #debug.punk.pipe {pipematch error $result} 4 + set ecode [dict get $erroptions -errorcode] + switch -- [lindex $ecode 0] { + binding { + if {[lindex $ecode 1] eq "mismatch"} { + #error {reason xxx} should only be returned for underlying tcl errors. error {someotherkey xxx} for structured errors such as a binding mismatch + #return [dict create error [dict create mismatch $result]] + #puts stderr "pipematch converting error to {error {mismatch }}" + return [list error [list mismatch $result]] + } + } + pipesyntax { + #error $result + return -options $erroptions $result + } + casematch { + return $result + } + } + #return [dict create error [dict create reason $result]] + return [list error [list reason $result]] + } else { + return [list ok [list result $result]] + #debug.punk.pipe {pipematch result $result } 4 + #return [dict create ok [dict create result $result]] + } + } + + proc pipenomatchvar {varname args} { + if {[string first = $varname] >=0} { + #first word "pipesyntax" is looked for by pipecase + error "pipesyntax pipenomatch expects a simple varname as first argument" "pipenomatchvar $varname $args" [list pipesyntax expected_simple_varname] + } + #debug.punk.pipe {pipematch level [info level] levelinfo [info level 0]} 2 + + set assign [lindex $args 0] + set arglist [lrange $args 1 end] + if {[string first = $assign] >= 0} { + variable re_dot_assign + variable re_assign + #what if we get passed a script block containing = ?? e.g {error x=a} + if {$assign eq ".="} { + set cmdlist [list ::punk::pipeline .= "" "" {*}$arglist] + } elseif {$assign eq "="} { + set cmdlist [list ::punk::pipeline = "" "" {*}$arglist] + } elseif {[regexp $re_dot_assign $assign _ returnvarspecs rhs]} { + set cmdlist [list ::punk::pipeline .= $returnvarspecs $rhs {*}$arglist] + } elseif {[regexp $re_assign $assign _ returnvarspecs rhs]} { + set cmdlist [list ::punk::pipeline = $returnvarspecs $rhs {*}$arglist] + } else { + debug.punk.pipe {[a+ yellow bold] Unexpected arg following pipenomatchvar variable [a]} 0 + set cmdlist $args + #return [dict create error [dict create reason [dict create pipematch bad_first_word value $assign pipeline [list pipematch $assign {*}$args]]]] + } + } else { + set cmdlist $args + } + + upvar 1 $varname nomatchvar + if {[catch {uplevel 1 $cmdlist} result erroptions]} { + set ecode [dict get $erroptions -errorcode] + debug.punk.pipe {[a+ yellow bold]pipematchnomatch error $result[a]} 3 + if {[lindex $ecode 0] eq "pipesyntax"} { + set errordict [dict create error [dict create pipesyntax $result]] + set nomatchvar $errordict + return -options $erroptions $result + } + if {[lrange $ecode 0 1] eq "binding mismatch"} { + #error {reason xxx} should only be returned for underlying tcl errors. error {someotherkey xxx} for structured errors such as a binding mismatch + set errordict [dict create error [dict create mismatch $result]] + set nomatchvar $errordict + return -options $erroptions $result + } + set errordict [dict create error [dict create reason $result]] + set nomatchvar $errordict + #re-raise the error for pipeswitch to deal with + return -options $erroptions $result + } else { + debug.punk.pipe {pipematchnomatch result $result } 4 + set nomatchvar "" + #uplevel 1 [list set $varname ""] + #return raw result only - to pass through to pipeswitch + return $result + #return [dict create ok [dict create result $result]] + } + } + + #should only raise an error for pipe syntax errors - all other errors should be wrapped + proc pipecase {args} { + #debug.punk.pipe {pipecase level [info level] levelinfo [info level 0]} 9 + set arglist [lassign $args assign] + if {$assign eq ".="} { + set cmdlist [list ::punk::pipeline .= "" "" {*}$arglist] + } elseif {$assign eq "="} { + #set cmdlist [list ::punk::pipeline = "" "" {*}$arglist] + set cmdlist [list ::= {*}$arglist] + } elseif {![punk::pipe::lib::arg_is_script_shaped $assign] && [string first "=" $assign] >= 0} { + #set re_dotequals {^([^ \t\r\n=\{]*)\.=$} + #set dumbeditor {\}} + #set re_equals {^([^ \t\r\n=\{]*)=$} + #set dumbeditor {\}} + + if {[regexp {^([^ \t\r\n=]*)\.=.*} $assign _ returnvarspecs]} { + set cmdlist [list ::punk::pipeline .= $returnvarspecs "" {*}$arglist] + } elseif {[regexp {^([^ \t\r\n=]*)=.*} $assign _ returnvarspecs]} { + set cmdlist [list $assign {*}$arglist] + #set cmdlist [list ::punk::pipeline = $returnvarspecs "" {*}$arglist] + } else { + error "pipesyntax pipecase unable to interpret pipeline '$args'" + } + #todo - account for insertion-specs e.g x=* x.=/0* + } else { + #script? + set cmdlist [list ::punk::pipeline .= "" "" {*}$args] + } + + + if {[catch {uplevel 1 [list ::if 1 $cmdlist]} result erroptions]} { + #puts stderr "====>>> result: $result erroptions" + set ecode [dict get $erroptions -errorcode] + switch -- [lindex $ecode 0] { + pipesyntax { + #error $result + return -options $erroptions $result + } + casenomatch { + return -options $erroptions $result + } + binding { + if {[lindex $ecode 1] eq "mismatch"} { + #error {reason xxx} should only be returned for underlying tcl errors. error {someotherkey xxx} for structured errors such as a binding mismatch + #return [dict create error [dict create mismatch $result]] + # + #NOTE: casemismatch is part of the api for pipecase. It is a casemismatch rather than an error - because for a pipecase - a casemismatch is an expected event (many casemismatches - one match) + return [dict create casemismatch $result] + } + } + } + + #we can't always treat $result as a list - may be an error string which can't be represented as a list, and there may be no useful errorCode + #todo - use errorCode instead + if {[catch {lindex $result 0} word1]} { + #tailcall error $result + return -options $erroptions $result + } else { + switch -- $word1 { + switcherror - funerror { + error $result "pipecase [lsearch -all -inline $args "*="]" + } + resultswitcherror - resultfunerror { + #recast the error as a result without @@ok wrapping + #use the tailcall return to stop processing other cases in the switch! + tailcall return [dict create error $result] + } + ignore { + #suppress error, but use normal return + return [dict create error [dict create suppressed $result]] + } + default { + #normal tcl error + #return [dict create error [dict create reason $result]] + tailcall error $result "pipecase $args" [list caseerror] + } + } + } + } else { + tailcall return -errorcode [list casematch] [dict create ok [dict create result $result]] + } + + } + + #note that pipeswitch deliberately runs in callers scope to have direct access to variables - it is akin to a control structure. + #It also - somewhat unusually accepts args - which we provide as 'switchargs' + #This is unorthodox/risky in that it will clobber any existing var of that name in callers scope. + #Solve using documentation.. consider raising error if 'switchargs' already exists, which would require user to unset switchargs in some circumstances. + proc pipeswitch {pipescript args} { + #set nextargs $args + #unset args + #upvar args upargs + #set upargs $nextargs + upvar switchargs switchargs + set switchargs $args + uplevel 1 [::list ::if 1 $pipescript] + } + #static-closure version - because we shouldn't be writing back to calling context vars directly + #Tcl doesn't (2023) have mutable closures - but for functional pipeline composition - we probably don't want that anyway! + #pipeswitchc is preferable to pipeswitch in that we can access context without risk of affecting it, but is less performant. (particularly in global scope.. but that probably isn't an important usecase) + proc pipeswitchc {pipescript args} { + set binding {} + if {[info level] == 1} { + #up 1 is global + set get_vars [list info vars] + } else { + set get_vars [list info locals] + } + set vars [uplevel 1 {*}$get_vars] + set posn [lsearch $vars switchargs] + #set vars [lreplace $vars $posn $posn] + set vars [lreplace $vars[set vars {}] $posn $posn] + foreach v $vars { + upvar 1 $v var + if {(![array exists var]) && [info exists var]} { + lappend binding [list $v $var] ;#values captured as defaults for apply args. + } + } + lappend binding [list switchargs $args] + apply [list $binding $pipescript [uplevel 1 {::tcl::namespace::current}]] + } + + proc pipedata {data args} { + #puts stderr "'$args'" + set r $data + for {set i 0} {$i < [llength $args]} {incr i} { + set e [lindex $args $i] + #review: string is list is as slow as catch {llength $e} - and also affects ::errorInfo unlike other string is commands. bug/enhancement report? + if {![string is list $e]} { + #not a list - assume script and run anyway + set r [apply [list {data} $e] $r] + } else { + if {[llength $e] == 1} { + switch -- $e { + > { + #output to calling context. only pipedata return value and '> varname' should affect caller. + incr i + uplevel 1 [list set [lindex $args $i] $r] + } + % - pipematch - ispipematch { + incr i + set e2 [lindex $args $i] + #set body [list $e {*}$e2] + #append body { $data} + + set body [list $e {*}$e2] + append body { {*}$data} + + + set applylist [list {data} $body] + #puts stderr $applylist + set r [apply $applylist $r] + } + pipeswitch - pipeswitchc { + #pipeswitch takes a script not a list. + incr i + set e2 [lindex $args $i] + set body [list $e $e2] + #pipeswitch takes 'args' - so expand $data when in pipedata context + append body { {*}$data} + #use applylist instead of uplevel when in pipedata context! + #can use either switchdata/data but not vars in calling context of 'pipedata' command. + #this is consistent with pipeswitch running in a % / .= pipeline which can only access vars in immediate calling context. + set applylist [list {data} $body] + #puts stderr $applylist + set r [apply $applylist $r] + } + default { + #puts "other single arg: [list $e $r]" + append e { $data} + set r [apply [list {data} $e] $r] + } + } + } elseif {[llength $e] == 0} { + #do nothing - pass data through + #leave r as is. + } else { + set r [apply [list {data} $e] $r] + } + } + } + return $r + } + + + proc scriptlibpath {{shortname {}} args} { + set scriptlib [punk::config::configure running scriptlib] + if {[string match "lib::*" $shortname]} { + set relpath [string map [list "lib::" "" "::" "/"] $shortname] + set relpath [string trimleft $relpath "/"] + set fullpath $scriptlib/$relpath + } else { + set shortname [string trimleft $shortname "/"] + set fullpath $scriptlib/$shortname + } + return $fullpath + } + + + #useful for aliases e.g treemore -> xmore tree + proc xmore {args} { + if {[llength $args]} { + #more is older and not as featureful as less + #more importantly - at least some implementations (msys on windows) can skip output lines - unknown as to why + #uplevel #0 [list {*}$args | more] + uplevel #0 [list {*}$args | less -X] ;#-X to avoid use of alternate-screen + } else { + error "usage: punk::xmore args where args are run as {*}\$args | more" + } + } + + + #environment path as list + # + #return *appendable* pipeline - i.e no args via <| + proc path_list_pipe {{glob *}} { + if {$::tcl_platform(platform) eq "windows"} { + set sep ";" + } else { + # : ok for linux/bsd ... mac? + set sep ":" + } + set cond [string map [list $glob] {expr {[string length $item] && [string match $item]}}] + #env members such as ''path' not case sensitive on windows - but are on some other platforms (at least FreeBSD) + return [list .= set ::env(PATH) |> .=>2 string trimright $sep |> .=>1 split $sep |> list_filter_cond $cond ] + } + proc path_list {{glob *}} { + set pipe [punk::path_list_pipe $glob] + {*}$pipe + } + proc path_basic {{glob *}} { + set pipe [punk::path_list_pipe $glob] + {*}$pipe |> list_as_lines + } + namespace eval argdoc { + punk::args::define { + @id -id ::punk::path + @cmd -name "punk::path"\ + -summary\ + "Display PATH executable shadowing and conflicts with TCL commands"\ + -help\ + {Introspection of the PATH environment variable. + This tool will examine executables within each PATH entry and show which binaries + are overshadowed by earlier PATH entries. + It can also be used to examine the contents of each PATH entry, and to filter results using glob patterns. + + ${[punk::args::helpers::example { + + #show all executables in all PATH entries + punk::path + #show all executables in all PATH entries that contain 'Windows' in the path + punk::path -pathglob *Windows* + #show all executables in all PATH entries that contain 'scoop' in the path, + #and filter the executables to show only those that are named dir, ls or start with 'ca' + punk::path -pathglob *scoop* dir ls ca* + #show all executables that conflict with TCL commands starting with 'a' in the current namespace. + punk::path {*}[nscommandlist a*] + #show all executables that conflict with TCL commands resolvable from the current namespace. + punk::path {*}[info commands] + + }]} + + see also the punk::auto_exec package. + } + @opts + -pathglob -type string -default {*} -multiple true -help "Case insensitive glob pattern to filter path entries. Default '*' to include all PATH directories." + @values -min 0 -max -1 + binglob -type list -default {*} -multiple true -optional 1 -help "glob pattern to filter results. Default '*' to include all entries." + } + } + + variable d_path_info + variable d_bin_info + variable d_index_executables + #there is still a potential conflict regarding auto_execok on windows - which has some cmd.exe builtins as auto-executable + #- but these are not actually executable files on the filesystem - so they won't be found by our path search + #- but they will be found when not masked by a tcl command. + proc path {args} { + variable d_path_info + variable d_bin_info + variable d_index_executables + set is_windows [expr {$::tcl_platform(platform) eq "windows"}] + set argd [punk::args::parse $args withid ::punk::path] + lassign [dict values $argd] leaders opts values received + set pathglobs [dict get $opts -pathglob] + set binglobs [dict get $values binglob] + if {$is_windows} { + set sep ";" + } else { + # : ok for linux/bsd ... mac? + set sep ":" + } + set all_paths [split [string trimright $::env(PATH) $sep] $sep] + if {[llength $pathglobs]} { + if {[lsearch -exact $pathglobs "*"] >= 0} { + #if we have a wildcard glob then the others are irrelevant - we want to match all paths + set matched_paths $all_paths + } else { + set matched_paths [list] + foreach p $all_paths { + foreach pg $pathglobs { + if {[string match -nocase $pg $p]} { + lappend matched_paths $p + break + } + } + } + } + } + + #This should be designed to be useful on all platforms. + #Case sensitivity represents a difficulty because even on a particular platform + #- different filesystems or folders may have different case sensitivity configurations. + + #as a first step - we can detect windows and mac platforms and treat paths as case-insensitive, vs case-sensitive on other unix-like platforms. + #as a second step - we will consider running a test on each path to determine if the folder at the leaf level is case-sensitive or not. + #- and then use that information to determine how to treat the executables in that path. + #This may be a bit of a performance hit - so we may want to cache the results of this test for each path - and provide a way to clear the cache if needed. + #Alternatively we could just provide an option to treat all paths as case-sensitive or case-insensitive. + + #Windows executable search location order: + #1. The current directory. + #2. The directories that are listed in the PATH environment variable. + # within each directory windows uses the PATHEXT environment variable to determine + #which files are considered executable and in which order they are considered. + #So for example if PATHEXT is set to .COM;.EXE;.BAT;.CMD then if there are files + #with the same name but different extensions in the same directory, then the one + #with the extension that appears first in PATHEXT will be executed when that name is called. + + #On windows platform, PATH entries can be case-insensitively duplicated - we want to treat these as the same path for the purposes of overshadowing - but we want to show the actual paths in the output. + #Duplicate PATH entries are also a fairly likely possibility on all platforms. + #This is likely a misconfiguration, but we want to be able to show it in the output - as it can affect which executables are overshadowed by which PATH entries. + + #By default we don't want to display all executables in all PATH entries - as this can be very verbose + #- but we want to be able to show which executables are overshadowed by which PATH entries, + #and to be able to filter the PATH entries and the executables using glob patterns. + #To achieve this we will build two dicts - one keyed by normalized path, and one keyed by normalized executable name. + #The path dict will contain the original paths that correspond to each normalized path, and the indices of those paths + #in the original PATH list. The executable dict will contain the paths and path indices where each executable is found, + #and the actual executable names (with case and extensions as they appear on the filesystem). We will also build a + #dict keyed by path index which contains the list of executables in that path - to make it easy to show which + #executables are overshadowed by which paths. + if {$is_windows} { + #Sometimes PATHEXT includes an entry of just a dot - which means files with no extension are considered executable. + #We need to account for this in our glob pattern. + set pathexts [list] + #review - we assume this is only relevant on windows for now. + if {[info exists ::env(PATHEXT)]} { + set env_pathexts [split $::env(PATHEXT) ";"] + #set pathexts [lmap e $env_pathexts {string tolower $e}] + foreach pe $env_pathexts { + if {$pe eq "."} { + continue + } + lappend pathexts [string tolower $pe] + } + } else { + set env_pathexts [list] + #default PATHEXT if not set - according to Microsoft docs + set pathexts [list .com .exe .bat .cmd] + } + foreach bg $binglobs { + set has_pathext 0 + foreach pe $pathexts { + if {[string match -nocase "*$pe" $bg]} { + set has_pathext 1 + break + } + } + if {!$has_pathext} { + foreach pe $pathexts { + set globext "$bg$pe" + if {$globext ni $binglobs} { + lappend binglobs "$bg$pe" + } + } + } + } + set lc_binglobs [lmap e $binglobs {string tolower $e}] + if {"." in $pathexts} { + foreach bg $binglobs { + set has_pathext 0 + foreach pe $pathexts { + if {[string match -nocase "*$pe" $bg]} { + set base [string range $bg 0 [expr {[string length $bg] - [string length $pe] - 1}]] + set has_pathext 1 + break + } + } + if {$has_pathext} { + if {[string tolower $base] ni $lc_binglobs} { + lappend binglobs "$base" + } + } + } + } + } + + set d_path_info [dict create] ;#key is normalized path (e.g case-insensitive on windows). + set d_bin_info [dict create] ;#key is normalized executable name (e.g case-insensitive on windows, or callable with extensions stripped off). + set d_index_executables [dict create] ;#key is path index, value is list of executables in that path + set path_idx 0 + foreach p $all_paths { + if {$is_windows} { + set pnorm [string tolower $p] + } else { + set pnorm $p + } + if {[string length $pnorm] > 1} { + set lastchar [string index $pnorm end] + if {$lastchar eq "/" || $lastchar eq "\\"} { + set pnorm [string range $pnorm 0 end-1] + } + } + if {![dict exists $d_path_info $pnorm]} { + dict set d_path_info $pnorm [dict create original_paths [list $p] indices [list $path_idx]] + set executables [list] + if {[file isdirectory $p]} { + #get all files that are executable in this path. + #If we don't normalize the path here - then trailing backslashes on windows can cause a problem with the -tail glob returning a leading slash on the executable names. + #also as we don't necessarily normalize the resulting final path with executable - we want the case to be correct. + set pnormglob [file normalize $p] + if {$is_windows} { + + #TCL's glob on windows is case-insensitive, but in some cases return the result with the case as globbed for regardless of the actual case on the filesystem. + #(This seems to occur when the pattern does *not* contain a wildcard and is probably a bug) + #We would rather report results with the actual case as they appear on the filesystem - so we try to normalize the results. + #The normalization doesn't work as expected - but can be worked around by using 'string range $e 0 end' instead of just $e - which seems to force Tcl to give us the actual case from the filesystem rather than the case as globbed for. + #(another workaround is to use a degenerate case glob e.g when looking for 'SDX.exe' to glob for '[S]DX.exe' + # but tcl's glob does not respect the case of even the character-class pattern - so this is not a reliable workaround). + #see punk::fglob for a work-in-progress glob implementation which gives us more control over case sensitivity and the case of results on windows. + + #----------------------- + #JJJ + #set globresults [lsort -unique [glob -nocomplain -directory $pnormglob -types {f x} {*}$binglobs]] + #set executables [list] + #foreach e $globresults { + # puts stderr "glob result: $e" + # puts stderr "normalized executable name: [file tail [file normalize [string range $e 0 end]]]]" + # lappend executables [file tail [file normalize $e]] + #} + #----------------------- + + #track all executables in the path - even those that don't match the binglobs + #use fglob to get the actual case of the executables on windows - as glob seems to return the case as globbed for rather than the actual case on the filesystem in some cases. + #this doesn't run a full 'file normalize' on the results which affects whether a more efficient internal representation is stored + + #fglob with single glob argument should already return a unique list. + set folder_exes [fglob -nocomplain -directory $pnormglob -types {f x} *] + set executables [list] + foreach e $folder_exes { + lappend executables [file tail $e] + } + + } else { + #set executables [lsort -unique [glob -nocomplain -directory $p -types {f x} -tail {*}$binglobs]] + set executables [lsort -unique [glob -nocomplain -directory $p -types {f x} -tail *]] + } + } + dict set d_index_executables $path_idx $executables + foreach exe $executables { + #todo - other case-insensitive platforms/filesystems. + if {$is_windows} { + set exe_key [string tolower $exe] + } else { + #on case + set exe_key $exe + } + if {![dict exists $d_bin_info $exe_key]} { + dict set d_bin_info $exe_key [dict create path_indices [list $path_idx] paths [list $p] executable_names [list $exe]] + } else { + #dict lappend d_bin_info $exe_key path_indices $path_idx paths $p executable_names $exe + set bindata [dict get $d_bin_info $exe_key] + dict lappend bindata path_indices $path_idx + dict lappend bindata paths $p + dict lappend bindata executable_names $exe + dict set d_bin_info $exe_key $bindata + } + } + } else { + #duplicate path entry - add to list of original paths for this normalized path + + # Tcl's dict lappend takes the arguments dictionaryVariable key value ?value ...? + # we need to extract the inner dictionary containig lists to append to, and then set it back after appending to the lists within it. + set pathdata [dict get $d_path_info $pnorm] + dict lappend pathdata original_paths $p + dict lappend pathdata indices $path_idx + dict set d_path_info $pnorm $pathdata + + #consider this alternative approach which reduces number of references to the extracted inner dictionary. + #Will it help avoid copy on write performance issues with dicts? + #see voo package. + # --------------- + #set pathdata [dict get $d_path_info $pnorm] + #dict set d_path_info $pnorm {} + #try { + # dict lappend pathdata original_paths $p + # dict lappend pathdata indices $path_idx + #} finally { + # dict set d_path_info $pnorm $pathdata + #} + # --------------- + + #we don't need to add executables for this path - as they will be the same as the original path that we have already processed. + #However we do need to add the path index to the path_indices for each executable that is found in this path - as this will affect which paths are shown as overshadowing which executables. + set executables [dict get $d_index_executables [lindex [dict get $d_path_info $pnorm indices] 0]] ;#get executables for this path + foreach exe $executables { + if {$is_windows} { + set exe_key [string tolower $exe] + } else { + set exe_key $exe + } + #dict lappend d_bin_info $exe_key path_indices $path_idx paths $p executable_names $exe + set bindata [dict get $d_bin_info $exe_key] + dict lappend bindata path_indices $path_idx + dict lappend bindata paths $p + dict lappend bindata executable_names $exe + dict set d_bin_info $exe_key $bindata + } + } + + incr path_idx + } + + #temporary debug output to check dicts are being built correctly + #set debug "" + #append debug "Path info dict:" \n + #append debug [showdict $d_path_info] \n + #append debug "Binary info dict:" \n + #append debug [showdict $d_bin_info {*}$binglobs] \n + ##append debug "Index executables dict:" \n + ##append debug [showdict $d_index_executables] \n + ##return $debug + #puts stdout $debug + + + #dict for {p pinfo} $d_path_info { + # set original_paths [dict get $pinfo original_paths] + # set indices [dict get $pinfo indices] + # puts stdout "Path: $p" + # puts stdout " Original paths: $original_paths" + # puts stdout " Indices in PATH: $indices" + # if {[dict exists $d_index_executables [lindex $indices 0]]} { + # set executables [dict get $d_index_executables [lindex $indices 0]] + # puts stdout " Executables: [llength $executables]" + # } else { + # puts stdout " Executables: (not a directory or no executables found)" + # } + #} + + set nscaller [uplevel 1 {::tcl::namespace::current}] + set context_commands [namespace eval $nscaller {info commands}] + + #process paths in order they appear in the original PATH. + set pidx 0 + #use a punk::textblock::table for formatting. + set rows [list] + set headers [list "idx" "Path" "exe\nCount" "Shadow\nCount" "Executables" "TCL context\nConflicts"] + set ERR [punk::ansi::a+ red bold] + set RST [punk::ansi::a] + set STR [punk::ansi::a+ strike] + set SDW [punk::ansi::a+ red strike] + set WRN [punk::ansi::a+ yellow bold] + set subcols 2 + foreach p $all_paths { + #if {$p ni $matched_paths} { + # incr pidx + # continue + #} + set thisrow [list $pidx] + if {$is_windows} { + set pnorm [string tolower $p] + } else { + set pnorm $p + } + if {[string length $pnorm] > 1} { + set lastchar [string index $pnorm end] + if {$lastchar eq "/" || $lastchar eq "\\"} { + set pnorm [string range $pnorm 0 end-1] + } + } + set pinfo [dict get $d_path_info $pnorm] + set original_paths [dict get $pinfo original_paths] + set indices [dict get $pinfo indices] + if {[lindex $indices 0] == $pidx} { + #this is the first occurrence of this path in the original PATH. + set overshadowed [list] + set conflicts [list] + lappend thisrow $p + if {[dict exists $d_index_executables $pidx]} { + set executables [dict get $d_index_executables $pidx] + lappend thisrow [llength $executables] + set display_executables [list] + foreach exe $executables { + set matched_binglob 0 + if {$is_windows} { + foreach bg $binglobs { + #review - -nocase only on case-insensitive platforms/filesystems? + #todo - mac has case-insensitive filesystem by default. + if {[string match -nocase $bg $exe]} { + set matched_binglob 1 + continue + } + } + } else { + foreach bg $binglobs { + if {[string match $bg $exe]} { + set matched_binglob 1 + continue + } + } + } + if {$is_windows} { + set exe_key [string tolower $exe] + } else { + set exe_key $exe + } + if {[dict exists $d_bin_info $exe_key]} { + set bindata [dict get $d_bin_info $exe_key] + set path_indices [dict get $bindata path_indices] + set is_overshadowed 0 + foreach pi $path_indices { + if {$pi < $pidx} { + lappend overshadowed $exe + set is_overshadowed 1 + break + } + } + if {$matched_binglob} { + if {$is_windows} { + #check for matches in context_commands - which are case-insensitive on windows + #the context_commands are however case sensitive. + #we want to mark conflicts in one of two ways in the conflicts column. + #- if there is a case-insensitive match but not a case-sensitive match + #- then we have a conflict but not an exact match - so we will mark this with orange style. + #If there is an exact match in context_commands - then we will mark this with the red style + #to indicate that this executable is overshadowed by a command in the current context. + + #we may have multiple tcl commands that conflict with the same executable. + #e.g DIG and dig. + if {[llength [set ncmatches [lsearch -all -inline -nocase $context_commands [file rootname $exe]]]]} { + if {[set exactmatch [lsearch -exact $context_commands [file rootname $exe]]] ne ""} { + foreach nc $ncmatches { + set nc [namespace eval $nscaller [list namespace origin $nc]] + if {$nc eq $exactmatch} { + lappend conflicts $ERR$nc$RST + } else { + lappend conflicts "$WRN$nc$RST" + } + } + } else { + foreach nc $ncmatches { + set nc [namespace eval $nscaller [namespace origin $nc]] + lappend conflicts "$WRN$nc$RST" + } + } + } else { + if {[llength [set ncmatches [lsearch -all -inline -nocase $context_commands $exe]]]} { + if {[set exactmatch [lsearch -exact $context_commands $exe]] ne ""} { + foreach nc $ncmatches { + set nc [namespace eval $nscaller [namespace origin $nc]] + if {$nc eq $exactmatch} { + lappend conflicts $ERR$nc$RST + } else { + lappend conflicts "$WRN$nc$RST" + } + } + } else { + foreach nc $ncmatches { + set nc [namespace eval $nscaller [namespace origin $nc]] + lappend conflicts "$WRN$nc$RST" + } + } + } + } + + } else { + #check for any exact matches in context_commands + if {$exe in $context_commands} { + lappend conflicts $ERR$exe$RST + } + } + if {$is_overshadowed} { + lappend display_executables "$SDW$exe$RST" + } else { + lappend display_executables $exe + } + } + } else { + #executable not found in bin_info dict - this shouldn't happen - but if it does we will just treat it as not overshadowed and include it in the display. + lappend display_executables $WRN$exe$RST + } + } + if {[llength $overshadowed]} { + lappend thisrow "$ERR[llength $overshadowed]$RST" + } else { + lappend thisrow "0" + } + if {[llength $display_executables]} { + lappend thisrow [textblock::list_as_table -columns $subcols -show_edge 0 $display_executables] + } else { + lappend thisrow "" + } + if {[llength $conflicts]} { + #lappend thisrow [textblock::list_as_table -columns $subcols -show_edge 0 $conflicts] + lappend thisrow [join $conflicts \n] + } else { + lappend thisrow "" + } + } else { + lappend thisrow "" + lappend thisrow "" + lappend thisrow "" + lappend thisrow "(not a directory or no executables found)" + lappend thisrow "" + } + } else { + #this is a duplicate path entry - we want to show it as a duplicate of the original path entry. + set original_path_idx [lindex $indices 0] + set original_path [lindex [dict get $d_path_info $pnorm original_paths] 0] + #duplicate paths might be cased differently. + lappend thisrow "$ERR$p (repeated pathentry)\n original at index $original_path_idx as\n$original_path$RST" + set overshadowed [list] + set conflicts [list] + set display_executables [list] + if {[dict exists $d_index_executables $original_path_idx]} { + set executables [dict get $d_index_executables $original_path_idx] + lappend thisrow [llength $executables] + foreach exe $executables { + if {$is_windows} { + set exe_key [string tolower $exe] + } else { + set exe_key $exe + } + if {[dict exists $d_bin_info $exe_key]} { + set bindata [dict get $d_bin_info $exe_key] + set path_indices [dict get $bindata path_indices] + set is_overshadowed 0 + foreach pi $path_indices { + if {$pi < $pidx} { + lappend overshadowed $exe + set is_overshadowed 1 + break + } + } + + + + #dupe will always have all exes as overshadowed by the original. + #don't need to waste time and screen space to display duplicate info - the user should tidy up the PATH. + #if {$is_overshadowed} { + # lappend display_executables "$SDW$exe$RST" + #} else { + # lappend display_executables $exe + #} + } + } + } else { + #this shouldn't happen - but if it does we will just treat it as not overshadowed and include it in the display. + lappend thisrow "(not a directory or no executables found)" + } + if {[llength $overshadowed]} { + lappend thisrow "$ERR[llength $overshadowed]$RST" + } else { + lappend thisrow "0" + } + if {[llength $display_executables]} { + lappend thisrow [textblock::list_as_table -columns $subcols -show_edge 0 $display_executables] + } else { + lappend thisrow "" + } + lappend thisrow "" ;#don't show conflict info for duplicate paths - as the user should tidy up the PATH to remove duplicates, and the conflict info will be the same as the original path entry. + } + if {[llength $matched_paths] < [llength $all_paths]} { + #if there is any filtering of paths - then we want to show all these paths whether or not there are any matches for binglobs + if {$p in $matched_paths} { + lappend rows $thisrow + } + } else { + #no specific filtering of paths - so only show rows where there are matches for binglobs + if {[lsearch -exact $binglobs "*"] >= 0} { + lappend rows $thisrow + } else { + #end-1 is the executables column. + #if there are no matches for binglobs then we'll hide the row. + if {[string length [lindex $thisrow end-1]] > 0} { + lappend rows $thisrow + } + } + } + incr pidx + } + set t [textblock::table -return tableobject -rows $rows -headers $headers] + return [$t print] + + } + + #------------------------------------------------------------------- + #sh 'test' equivalent - to be used with exitcode of process + # + + #single evaluation to get exitcode + proc sh_test {args} { + set a1 [lindex $args 0] + if {$a1 in [list -b -c -d -e -f -h -L -s -S -x -w]} { + set a2 [lindex $args 1] + if {![catch { + set attrinfo [file attributes $a2] + } errM]} { + if {[dict exists $attrinfo -vfs] && [dict get $attrinfo -vfs] == 1} { + puts stderr "WARNING: external 'test' being called on vfs path. External command will probably not have access to the vfs. Use 'TEST' for Tcl view of vfs mounted filesystems." + } + } + } + tailcall run test {*}$args + } + + #whether v is an integer from perspective of unix test command. + #can be be bigger than a tcl int or wide ie bignum - but must be whole number + #test doesn't handle 1.0 - so we shouldn't auto-convert + proc is_sh_test_integer {v} { + if {[string first . $v] >=0 || [string first e $v] >= 0} { + return false + } + #if it is double but not sci notation and has no dots - then we can treat as a large integer for 'test' + if {[string is double -strict $v]} { + return true + } else { + return false + } + } + #can use double-evaluation to get true/false + #faster tcl equivalents where possible to accuratley provide, and fallthrough to sh for compatibility of unimplemented + #The problem with fallthrough is that sh/bash etc have a different view of existant files + #e.g unix files such as /dev/null vs windows devices such as CON,PRN + #e.g COM1 is mapped as /dev/ttyS1 in wsl (?) + #Note also - tcl can have vfs mounted file which will appear as a directory to Tcl - but a file to external commands! + #We will stick with the Tcl view of the file system. + #User can use their own direct calls to external utils if + #Note we can't support $? directly in Tcl - script would have to test ${?} or use [set ?] + proc sh_TEST {args} { + upvar ? lasterr + set lasterr 0 + set a1 [lindex $args 0] + set a2 [lindex $args 1] + set a3 [lindex $args 2] + set fileops [list -b -c -d -e -f -h -L -s -S -x -w] + if {[llength $args] == 1} { + #equivalent of -n STRING + set boolresult [expr {[string length $a1] != 0}] + } elseif {[llength $args] == 2} { + if {$a1 in $fileops} { + if {$::tcl_platform(platform) eq "windows"} { + #e.g trailing dot or trailing space + if {[punk::winpath::illegalname_test $a2]} { + #protect with \\?\ to stop windows api from parsing + #will do nothing if already prefixed with \\?\ + + set a2 [punk::winpath::illegalname_fix $a2] + } + } + } + switch -- $a1 { + -b { + #dubious utility on FreeBSD, windows? + #FreeBSD has dropped support for block devices - stating 'No serious applications rely on block devices' + #Linux apparently uses them though + if{[file exists $a2]} { + set boolresult [expr {[file type $a2] eq "blockSpecial"}] + } else { + set boolresult false + } + } + -c { + #e.g on windows CON,NUL + if {[file exists $a2]} { + set boolresult [expr {[file type $a2] eq "characterSpecial"}] + } else { + set boolresult false + } + } + -d { + set boolresult [file isdirectory $a2] + } + -e { + set boolresult [file exists $a2] + } + -f { + #e.g on windows CON,NUL + if {[file exists $a2]} { + set boolresult [expr {[file type $a2] eq "file"}] + } else { + set boolresult false + } + } + -h - + -L { + set boolresult [expr {[file type $a2] eq "link"}] + } + -s { + set boolresult [expr {[file exists $a2] && ([file size $a2] > 0 )}] + } + -S { + if {[file exists $a2]} { + set boolresult [expr {[file type $a2] eq "socket"}] + } else { + set boolresult false + } + } + -x { + set boolresult [expr {[file exists $a2] && [file executable $a2]}] + } + -w { + set boolresult [expr {[file exists $a2] && [file writable $a2]}] + } + -z { + set boolresult [expr {[string length $a2] == 0}] + } + -n { + set boolresult [expr {[string length $a2] != 0}] + } + default { + puts stderr "sh_TEST: delegating 'test $args' to external 'test' command" + #set boolresult [apply {arglist {uplevel #0 [runx test {*}$arglist]} ::} $args] + set callinfo [runx test {*}$args] + set errinfo [dict get $callinfo stderr] + set exitcode [dict get $callinfo exitcode] + if {[string length $errinfo]} { + puts stderr "sh_TEST error in external call to 'test $args': $errinfo" + set lasterr $exitcode + } + if {$exitcode == 0} { + set boolresult true + } else { + set boolresult false + } + } + } + } elseif {[llength $args] == 3} { + switch -- $a2 { + "=" { + #test does string comparisons + set boolresult [string equal $a1 $a3] + } + "!=" { + #string comparison + set boolresult [expr {$a1 ne $a3}] + } + "-eq" { + #test expects a possibly-large integer-like thing + #shell scripts will + if {![is_sh_test_integer $a1]} { + puts stderr "sh_TEST: invalid integer '$a1'" + set lasterr 2 + return false + } + if {![is_sh_test_integer $a3]} { + puts stderr "sh_TEST: invalid integer '$a3'" + set lasterr 2 + return false + } + set boolresult [expr {$a1 == $a3}] + } + "-ge" { + if {![is_sh_test_integer $a1]} { + puts stderr "sh_TEST: invalid integer '$a1'" + set lasterr 2 + return false + } + if {![is_sh_test_integer $a3]} { + puts stderr "sh_TEST: invalid integer '$a3'" + set lasterr 2 + return false + } + set boolresult [expr {$a1 >= $a3}] + } + "-gt" { + if {![is_sh_test_integer $a1]} { + puts stderr "sh_TEST: invalid integer '$a1'" + set lasterr 2 + return false + } + if {![is_sh_test_integer $a3]} { + puts stderr "sh_TEST: invalid integer '$a3'" + set lasterr 2 + return false + } + set boolresult [expr {$a1 > $a3}] + } + "-le" { + if {![is_sh_test_integer $a1]} { + puts stderr "sh_TEST: invalid integer '$a1'" + set lasterr 2 + return false + } + if {![is_sh_test_integer $a3]} { + puts stderr "sh_TEST: invalid integer '$a3'" + set lasterr 2 + return false + } + set boolresult [expr {$a1 <= $a3}] + } + "-lt" { + if {![is_sh_test_integer $a1]} { + puts stderr "sh_TEST: invalid integer '$a1'" + set lasterr 2 + return false + } + if {![is_sh_test_integer $a3]} { + puts stderr "sh_TEST: invalid integer '$a3'" + set lasterr 2 + return false + } + set boolresult [expr {$a1 < $a3}] + } + "-ne" { + if {![is_sh_test_integer $a1]} { + puts stderr "sh_TEST: invalid integer '$a1'" + set lasterr 2 + return false + } + if {![is_sh_test_integer $a3]} { + puts stderr "sh_TEST: invalid integer '$a3'" + set lasterr 2 + return false + } + set boolresult [expr {$a1 != $a3}] + } + default { + puts stderr "sh_TEST: delegating 'test $args' to external 'test' command" + #set boolresult [apply {arglist {uplevel #0 [runx test {*}$arglist]} ::} $args] + set callinfo [runx test {*}$args] + set errinfo [dict get $callinfo stderr] + set exitcode [dict get $callinfo exitcode] + if {[string length $errinfo]} { + puts stderr "sh_TEST error in external call to 'test $args': $errinfo" + set lasterr $exitcode + } + if {$exitcode == 0} { + set boolresult true + } else { + set boolresult false + } + + } + } + } else { + puts stderr "sh_TEST: delegating 'test $args' to external 'test' command" + #set boolresult [apply {arglist {uplevel #0 [runx test {*}$arglist]} ::} $args] + set callinfo [runx test {*}$args] + set errinfo [dict get $callinfo stderr] + set exitcode [dict get $callinfo exitcode] + if {[string length $errinfo]} { + puts stderr "sh_TEST error in external call to 'test $args': $errinfo" + set lasterr $exitcode + } + if {$exitcode == 0} { + set boolresult true + } else { + set boolresult false + } + } + + #normalize 1,0 etc to true,false + #we want to make it obvious we are not just reporting exitcode 0 for example - which represents true in tcl. + if {$boolresult} { + return true + } else { + if {$lasterr == 0} { + set lasterr 1 + } + return false + } + + + } + proc sh_echo {args} { + tailcall run echo {*}$args + } + proc sh_ECHO {args} { + #execute the result of the run command - which is something like: 'exitcode n' - to get true/false + tailcall apply {arglist {uplevel #0 [run echo {*}$arglist]} ::} $args + } + + + #sh style true/false for process exitcode. 0 is true - everything else false + proc exitcode {args} { + set c [lindex $args 0] + if {[string is integer -strict $c]} { + #return [expr {$c == 0}] + #return true/false to make it clearer we are outputting tcl-boolean inverse mapping from the shell style 0=true + if {$c == 0} { + return true + } else { + return false + } + } else { + return false + } + } + #------------------------------------------------------------------- + + namespace export help aliases alias exitcode % pipedata pipecase pipeline pipematch pipeswitch pipeswitchc pipecase linelist linesort inspect list_as_lines val treemore + + #namespace ensemble create + + + + + + + #maint - punk::args has similar + #this is largely obsolete - uses dict for argspecs (defaults) instead of textblock as in punk::args + #textblock has more flexibility in some ways - but not as easy to manipulate especially with regards to substitutions + #todo - consider a simple wrapper for punk::args to allow calling with dict of just name and default? + #JMN + #generally we expect values to contain leading dashes only if -- specified. Otherwise no reliable way determine difference between bad flags and values + #If no eopts (--) specified we stop looking for opts at the first nondash encountered in a position we'd expect a dash - so without eopt, values could contain dashes - but not in first position after flags. + #only supports -flag val pairs, not solo options + #If an option is supplied multiple times - only the last value is used. + #TODO - remove + proc get_leading_opts_and_values {defaults rawargs args} { + if {[llength $defaults] %2 != 0} { + error "get_leading_opts_and_values expected first argument 'defaults' to be a dictionary" + } + dict for {k v} $defaults { + if {![string match -* $k]} { + error "get_leading_opts_and_values problem with supplied defaults. Expect each key to begin with a dash. Got key '$k'" + } + } + #puts "--> [info frame -2] <--" + set cmdinfo [dict get [info frame -2] cmd] + #we can't treat cmdinfo as a list - it may be something like {command {*}$args} in which case lindex $cmdinfo 0 won't work + #hopefully first word is a plain proc name if this function was called in the normal manner - directly from a proc + #we will break at first space and assume the lhs of that will give enough info to be reasonable - (alternatively we could use entire cmdinfo - but it might be big and ugly) + set caller [regexp -inline {\S+} $cmdinfo] + + #if called from commandline or some other contexts such as outside of a proc in a namespace - caller may just be "namespace" + if {$caller eq "namespace"} { + set caller "get_leading_opts_and_values called from namespace" + } + + # ------------------------------ + if {$caller ne "get_leading_opts_and_values"} { + #check our own args + lassign [get_leading_opts_and_values {-anyopts 0 -minvalues 0 -maxvalues -1} $args] _o ownopts _v ownvalues + if {[llength $ownvalues] > 0} { + error "get_leading_opts_and_values expected: a dictionary of defaults, a list of args and at most two option pairs -minvalues and -maxvalues - got extra arguments: '$ownvalues'" + } + set opt_minvalues [dict get $ownopts -minvalues] + set opt_maxvalues [dict get $ownopts -maxvalues] + set opt_anyopts [dict get $ownopts -anyopts] + } else { + #don't check our own args if we called ourself + set opt_minvalues 0 + set opt_maxvalues 0 + set opt_anyopts 0 + } + # ------------------------------ + + if {[set eopts [lsearch $rawargs "--"]] >= 0} { + set values [lrange $rawargs $eopts+1 end] + set arglist [lrange $rawargs 0 $eopts-1] + } else { + if {[lsearch $rawargs -*] >= 0} { + #to support option values with leading dash e.g -offset -1 , we can't just take the last flagindex + set i 0 + foreach {k v} $rawargs { + if {![string match -* $k]} { + break + } + if {$i+1 >= [llength $rawargs]} { + #no value for last flag + error "bad options for $caller. No value supplied for last option $k" + } + incr i 2 + } + set arglist [lrange $rawargs 0 $i-1] + set values [lrange $rawargs $i end] + } else { + set values $rawargs ;#no -flags detected + set arglist [list] + } + } + if {$opt_maxvalues == -1} { + #only check min + if {[llength $values] < $opt_minvalues} { + error "bad number of trailing values for $caller. Got [llength $values] values. Expected at least $opt_minvalues" + } + } else { + if {[llength $values] < $opt_minvalues || [llength $values] > $opt_maxvalues} { + if {$opt_minvalues == $opt_maxvalues} { + error "bad number of trailing values for $caller. Got [llength $values] values. Expected exactly $opt_minvalues" + } else { + error "bad number of trailing values for $caller. Got [llength $values] values. Expected between $opt_minvalues and $opt_maxvalues inclusive" + } + } + } + + if {!$opt_anyopts} { + set checked_args [dict create] + for {set i 0} {$i < [llength $arglist]} {incr i} { + #allow this to error out with message indicating expected flags + dict set checked_args [tcl::prefix match -message "options for $caller. Unexpected option" [dict keys $defaults] [lindex $arglist $i]] [lindex $arglist $i+1] + incr i ;#skip val + } + } else { + set checked_args $arglist + } + set opts [dict merge $defaults $checked_args] + + #maintain order of opts $opts values $values as caller may use lassign. + return [dict create opts $opts values $values] + } + + + + + + + + + + #-------------------------------------------------- + #some haskell-like operations + #group equivalent + #http://zvon.org/other/haskell/Outputlist/group_f.html + #as we can't really distinguish a single element list from a string we will use 2 functions + proc group_list1 {lst} { + set out [list] + set prev [lindex $lst 0] + set g [list] + foreach i $lst { + if {$i eq $prev} { + lappend g $i + } else { + lappend out $g + set g [list $i] + } + set prev $i + } + lappend out $g + return $out + } + proc group_list {lst} { + set out [list] + set next [lindex $lst 1] + set tail [lassign $lst x] + set g [list $x] + set y [lindex $tail 0] + set last_condresult [expr {$x}] + set n 1 ;#start at one instead of zero for lookahead + foreach x $tail { + set y [lindex $tail $n] + set condresult [expr {$x}] + if {$condresult eq $last_condresult} { + lappend g $x + } else { + lappend out $g + set g [list $x] + set last_condresult $condresult + } + incr n + } + lappend out $g + return $out + } + + #NOT attempting to match haskell other than in overall concept. + # + #magic var-names are a bit of a code-smell. But submitting only an expr argument is more Tcl-like than requiring an 'apply' specification. + #Haskell seems to take an entire lambda so varnames can be user-specified - but the 'magic' there is in it's choice of submitting 2 elements at a time + #We could do similar .. but we'll focus on comprehensibility for the basic cases - especially as begginning and end of list issues could be confusing. + # + #vars: index prev, prev0, prev1, item, next, next0, next1,nextr, cond + #(nextr is a bit obscure - but basically means next-repeat ie if no next - use same value. just once though.) + #group by cond result or first 3 wordlike parts of error + #e.g group_list_by {[lindex $item 0]} {{a 1} {a 2} {b 1}} + proc group_list_by {cond lst} { + set out [list] + set prev [list] + set next [lindex $lst 1] + set tail [lassign $lst item] + set g [list $item] + set next [lindex $tail 0] + if {$prev eq ""} { + set prev0 0 + set prev1 1 + set prevr $item + } else { + set prev0 $prev + set prev1 $prev + set prevr $prev + } + if {$next eq ""} { + set next0 0 + set next1 1 + set nextr $item + } else { + set next0 $next + set next1 $next + set nextr $next + } + set last_condresult [apply {{index cond prev prev0 prev1 prevr item next next0 next1 nextr} { + if {[catch {expr $cond} r]} { + puts stderr "index: 0 ERROR $r" + set wordlike_parts [regexp -inline -all {\S+} $r] + set r [list ERROR {*}[lrange $wordlike_parts 0 2]] + } + set r + } + } 0 $cond $prev $prev0 $prev1 $prevr $item $next $next0 $next1 $nextr] + set n 1 ;#start at one instead of zero for lookahead + #note - n also happens to matchi zero-based index of original list + set prev $item + foreach item $tail { + set next [lindex $tail $n] + if {$prev eq ""} { + set prev0 0 + set prev1 1 + set prevr $item + } else { + set prev0 $prev + set prev1 $prev + set prevr $prev + } + if {$next eq ""} { + set next0 0 + set next1 1 + set nextr $item + } else { + set next0 $next + set next1 $next + set nextr $next + } + set condresult [apply {{index cond prev prev0 prev1 prevr item next next0 next1 nextr} { + if {[catch {expr $cond} r]} { + puts stderr "index: $index ERROR $r" + set wordlike_parts [regexp -inline -all {\S+} $r] + set r [list ERROR {*}[lrange $wordlike_parts 0 2]] + } + set r + } + } $n $cond $prev $prev0 $prev1 $prevr $item $next $next0 $next1 $nextr] + if {$condresult eq $last_condresult} { + lappend g $item + } else { + lappend out $g + set g [list $item] + set last_condresult $condresult + } + incr n + set prev $item + } + lappend out $g + return $out + } + + #group_numlist ? preserve representation of numbers rather than use string comparison? + + + # - group_string + #.= punk::group_string "aabcccdefff" + # aa b ccc d e fff + proc group_string {str} { + lmap v [group_list [split $str ""]] {string cat {*}$v} + } + + #lists may be of unequal lengths + proc transpose_lists {list_rows} { + set res {} + #set widest [pipedata $list_rows {lmap v $data {llength $v}} {tcl::mathfunc::max {*}$data}] + set widest [tcl::mathfunc::max {*}[lmap v $list_rows {llength $v}]] + for {set j 0} {$j < $widest} {incr j} { + set newrow {} + foreach oldrow $list_rows { + if {$j >= [llength $oldrow]} { + #continue + lappend newrow "" + } else { + lappend newrow [lindex $oldrow $j] + } + } + lappend res $newrow + } + return $res + } + proc transpose_equal_lists {list_rows} { + set columns [list] + set rowidx -1 + foreach l $list_rows { + set colidx -1 + incr rowidx + foreach val $l { + incr colidx + lset columns $colidx $rowidx $val + } + } + return $columns + } + proc transpose_strings {list_of_strings} { + set charlists [lmap v $list_of_strings {split $v ""}] + set tchars [transpose_lists $charlists] + lmap v $tchars {string cat {*}$v} + } + + package require struct::matrix + #transpose a serialized matrix using the matrix command + #Note that we can have missing row values below and to right + #e.g + #a + #a b + #a + proc transpose_matrix {matrix_rows} { + set mcmd [struct::matrix] + #serialization format: numcols numrows rowlist + set widest [tcl::mathfunc::max {*}[lmap v $matrix_rows {llength $v}]] + $mcmd deserialize [list [llength $matrix_rows] $widest $matrix_rows] + $mcmd transpose + set result [lindex [$mcmd serialize] 2] ;#strip off dimensions + $mcmd destroy + return $result + } + + set objname [namespace current]::matrixchain + if {$objname ni [info commands $objname]} { + oo::class create matrixchain { + variable mcmd + constructor {matrixcommand} { + puts "wrapping $matrixcommand with [self]" + set mcmd $matrixcommand + } + destructor { + puts "matrixchain destructor called for [self] (wrapping $mcmd)" + $mcmd destroy + } + method unknown {args} { + if {[llength $args]} { + switch -- [lindex $args 0] { + add - delete - insert - transpose - sort - set - swap { + $mcmd {*}$args + return [self] ;#result is the wrapper object for further chaining in pipelines + } + default { + tailcall $mcmd {*}$args + } + } + } else { + #will error.. but we should pass that on + tailcall $mcmd + } + } + } + } + + #review + #how do we stop matrix pipelines from leaving commands around? i.e how do we call destroy on the matrixchain wrapper if not explicitly? + #Perhaps will be solved by: Tip 550: Garbage collection for TclOO + #Theoretically this should allow tidy up of objects created within the pipeline automatically + #If the object name is placed in the pipeline variable dict then it should survive across segment apply scripts and only go out of scope at the end. + proc matrix_command_from_rows {matrix_rows} { + set mcmd [struct::matrix] + set widest [tcl::mathfunc::max {*}[lmap v $matrix_rows {llength $v}]] + $mcmd deserialize [list [llength $matrix_rows] $widest $matrix_rows] + #return $mcmd + set wrapper [punk::matrixchain new $mcmd] + } + + #-------------------------------------------------- + + proc list_filter_cond {itemcond listval} { + set filtered_list [list] + set binding {} + if {[info level] == 1} { + #up 1 is global + set get_vars [list ::info vars] + } else { + set get_vars [list ::info locals] + } + set vars [uplevel 1 {*}$get_vars] + set posn [lsearch $vars item] + #set vars [lreplace $vars $posn $posn] + set vars [lreplace $vars[set vars {}] $posn $posn] + foreach v $vars { + upvar 1 $v var + if {(![array exists var]) && [info exists var]} { + lappend binding [list $v $var] ;#values captured as defaults for apply args. + } + } + #lappend binding [list item $args] + + #puts stderr "binding: [join $binding \n]" + #apply [list $binding $pipescript [uplevel 1 ::namespace current]] + foreach item $listval { + set bindlist [list {*}$binding [list item $item]] + if {[apply [list $bindlist $itemcond [uplevel 1 ::tcl::namespace::current]] ]} { + lappend filtered_list $item + } + } + return $filtered_list + } + + + proc ls {args} { + if {![llength $args]} { + set args [list [pwd]] + } + if {[llength $args] ==1} { + return [glob -nocomplain -tails -dir [lindex $args 0] *] + } else { + set result [dict create] + foreach a $args { + set k [file normalize $a] + set contents [glob -nocomplain -tails -dir $a *] + dict set result $k $contents + } + return $result + } + } + + + + #linelistraw is essentially split $text \n so is only really of use for pipelines, where the argument order is more convenient + #like linelist - but keeps leading and trailing empty lines + #single \n produces {} {} + #the result can be joined to reform the arg if a single arg supplied + # + proc linelistraw {args} { + set linelist [list] + foreach {a} $args { + set nlsplit [split $a \n] + lappend linelist {*}$nlsplit + } + #return [split $text \n] + return $linelist + } + proc linelist1 {args} { + set linelist [list] + foreach {a} $args { + set nlsplit [split $a \n] + set start 0 + set end "end" + + if {[lindex $nlsplit 0] eq ""} { + set start 1 + } + if {[lindex $nlsplit end] eq ""} { + set end "end-1" + } + set alist [lrange $nlsplit $start $end] + lappend linelist {*}$alist + } + return $linelist + } + + namespace eval argdoc { + set DYN_ANTIGLOB_PATHS {${[punk::args::resolved_def -types opts ::punk::path::treefilenames -exclude-paths]}} + punk::args::define { + @dynamic + @id -id ::punk::LOC + @cmd -name punk::LOC\ + -summary\ + "Lines Of Code counter"\ + -help\ + "LOC - lines of code. + An implementation of a notoriously controversial metric. + Returns a dict or dictionary-display containing various + counts such as: + 'loc' - total lines of code. + 'purepunctuationlines' - lines consisting soley of punctuation. + 'filecount' - number of files examined." + @opts + -return -default showdict -choices {dict showdict} + -dir -default "\uFFFF" + -no-dupfiles -default 1 -type boolean + -no-punctlines -default 1 -type boolean + ${$DYN_ANTIGLOB_PATHS} + -exclude-files -default "" -type list -help\ + "Exclude if file tail matches any of these patterns" + -show_largest -default 0 -type integer -help\ + "Report the top largest linecount files. + The value represents the number of files + to report on." + } " + #we could map away whitespace and use string is punct - but not as flexible? review + -punctchars -default { [list \{ \} \" \\ - _ + = . > , < ' : \; ` ~ ! @ # \$ % ^ & * \[ \] ( ) | / ?] } + " { + @values + fileglob -type string -default * -optional 1 -multiple 1 -help\ + "glob patterns to match against the filename portion (last segment) of each + file path. e.g *.tcl *.tm" + } + } + #An implementation of a notoriously controversial metric. + proc LOC {args} { + set argd [punk::args::parse $args withid ::punk::LOC] + lassign [dict values $argd] leaders opts values received + set searchspecs [dict get $values fileglob] + + # -- --- --- --- --- --- + set opt_return [dict get $opts -return] + set opt_dir [dict get $opts -dir] + if {$opt_dir eq "\uFFFF"} { + set opt_dir [pwd] ;#pwd can take over a ms on windows in a not terribly deep path even with SSDs - so as a general rule we don't use it in the original defaults list + } + # -- --- --- --- --- --- + set opt_no_dupfiles [dict get $opts -no-dupfiles] + set opt_no_punctlines [dict get $opts -no-punctlines] ;#exclude lines that consist purely of whitespace and the chars in -punctchars + set opt_punctchars [dict get $opts -punctchars] + set opt_largest [dict get $opts -show_largest] + set opt_exclude_paths [dict get $opts -exclude-paths] + set opt_exclude_files [dict get $opts -exclude-files] + # -- --- --- --- --- --- + + + set filepaths [punk::path::treefilenames -dir $opt_dir -exclude-paths $opt_exclude_paths -exclude-files $opt_exclude_files {*}$searchspecs] + set loc 0 + set dupfileloc 0 + set seentails [dict create] + set seencksums [dict create] ;#key is cksum value is list of paths + set largestloc [dict create] + set dupfilecount 0 + set extensions [list] + set purepunctlines 0 + set dupinfo [dict create] + set has_hashfunc [expr {![catch {package require sha1}]}] + set notes "" + if {$has_hashfunc} { + set dupfilemech sha1 + if {$opt_no_punctlines} { + append notes "checksums are on content stripped of whitespace lines,trailing whitespace, and pure punct lines. Does not indicate file contents equal.\n" + } else { + append notes "checksums are on content stripped of whitespace lines and trailing whitespace. Does not indicate file contents equal.\n" + } + } else { + set dupfilemech filetail + append notes "dupfilemech filetail because sha1 not loadable\n" + } + foreach fpath $filepaths { + set isdupfile 0 + set floc 0 + set fpurepunctlines 0 + set ext [file extension $fpath] + if {$ext ni $extensions} { + lappend extensions $ext + } + if {[catch {fcat $fpath} contents]} { + puts stderr "Error processing $fpath\n $contents" + continue + } + set lines [linelist -line {trimright} -block {trimall} $contents] + if {!$opt_no_punctlines} { + set floc [llength $lines] + set comparedlines $lines + } else { + set mapawaypunctuation [list] + foreach p $opt_punctchars empty {} { + lappend mapawaypunctuation $p $empty + } + set comparedlines [list] + foreach ln $lines { + if {[string length [string trim [string map $mapawaypunctuation $ln]]] > 0} { + incr floc + lappend comparedlines $ln + } else { + incr fpurepunctlines + } + } + } + if {$opt_largest > 0} { + dict set largestloc $fpath $floc + } + if {$has_hashfunc} { + set cksum [sha1::sha1 [encoding convertto utf-8 [join $comparedlines \n]]] + if {[dict exists $seencksums $cksum]} { + set isdupfile 1 + incr dupfilecount + incr dupfileloc $floc + dict lappend seencksums $cksum $fpath + } else { + dict set seencksums $cksum [list $fpath] + } + } else { + if {[dict exists $seentails [file tail $fpath]]} { + set isdupfile 1 + incr dupfilecount + incr dupfileloc $floc + } + } + if {!$isdupfile || ($isdupfile && !$opt_no_dupfiles)} { + incr loc $floc + incr purepunctlines $fpurepunctlines + } + + dict lappend seentails [file tail $fpath] $fpath + #lappend seentails [file tail $fpath] + } + if {$has_hashfunc} { + dict for {cksum paths} $seencksums { + if {[llength $paths] > 1} { + dict set dupinfo checksums $cksum $paths + } + } + } + dict for {tail paths} $seentails { + if {[llength $paths] > 1} { + dict set dupinfo sametail $tail $paths + } + } + + set result [dict create {*}[ + ] loc $loc {*}[ + ] filecount [llength $filepaths] {*}[ + ] dupfiles $dupfilecount {*}[ + ] dupfilemech $dupfilemech {*}[ + ] dupfileloc $dupfileloc {*}[ + ] dupinfo $dupinfo {*}[ + ] extensions $extensions {*}[ + # purepunctuationlines key only retained if punctuation lines are excluded from count by opt_no_punctlines + ] purepunctuationlines $purepunctlines {*}[ + ] notes $notes {*}[ + ]] + if {!$opt_no_punctlines} { + dict unset result purepunctuationlines + } + + if {$opt_largest > 0} { + set largest_n [dict create] + set sorted [lsort -stride 2 -index 1 -decreasing -integer $largestloc] + set kidx 0 + for {set i 0} {$i < $opt_largest} {incr i} { + if {$kidx+1 > [llength $sorted]} {break} + dict set largest_n [lindex $sorted $kidx] [lindex $sorted $kidx+1] + incr kidx 2 + } + dict set result largest $largest_n + } + if {$opt_return eq "showdict"} { + return [punk::lib::showdict $result @@dupinfo/*/* !@@dupinfo] + } + return $result + } + + ##dict of lists? + #a + # 1 + # 2 + #b + # 3 + # 4 + # "" + # etc + # d + # D + # "ok then" + + + ##dict of dicts + #a + # x + # 1 + # y + # 2 + #b + # x + # 11 + + ##dict of mixed + #list + # a + # b + # c + #dict + # a + # aa + # b + # bb + #val + # x + #list + # a + # b + + # each line has 1 key or value OR part of 1 key or value. ie <=1 key/val per line! + ##multiline + #key + # "multi + # line value" + # + + #-------------------------------- + #a + # 1 + # 2 + + #vs + + #a + # 1 + # 2 + + #dict of list-len 2 is equiv to dict of dict with one keyval pair + #-------------------------------- + + + + #!!!todo fix - linedict is unfinished and non-functioning + #linedict based on indents + proc linedict {args} { + puts stderr "linedict is experimental and incomplete" + set data [lindex $args 0] + set opts [lrange $args 1 end] ;#todo + set nlsplit [split $data \n] + set rootindent -1 + set stepindent -1 + + + #first do a partial loop through lines and work out the rootindent and stepindent. + #we could do this in the main loop - but we do it here to remove a small bit of logic from the main loop. + #review - if we ever move to streaming a linedict - we'll need to re-arrange to validating indents as we go anyway. + set linenum 0 + set firstkey_line "N/A" + set firstkey_linenum -1 + set firststep_line "N/A" + set firststep_linenum -1 + set indents_seen [dict create] + foreach ln $nlsplit { + incr linenum + if {![string length [string trim $ln]]} { + continue + } + + #todo - use info complete to accept keys/values with newlines + regexp {(\s*)(.*)} $ln _ space linedata + if {[catch {lindex $linedata 0}]} { + error "bad line value '$linedata' - each line must be a valid Tcl list of length 1. Use quotes or curly braces as necessary" + } + if {[llength $linedata] > 1} { + error "bad line value '$linedata' - each line must be a valid Tcl list of length 1. Use quotes or curly braces as necessary" + } + #puts stderr "--linenum:[format %-3s $linenum] line:[format "%-20s" $ln] [format %-4s [string length $space]] $linedata" + set this_indent [string length $space] + if {[dict exists $indents_seen $this_indent]} { + continue + } + if {$rootindent < 0} { + set firstkey_line $ln + set firstkey_linenum $linenum + set rootindent $this_indent + dict set indents_seen $this_indent 1 + } elseif {$stepindent < 0} { + if {$this_indent > $rootindent} { + set firststep_line $ln + set firststep_linenum $linenum + set stepindent [expr {$this_indent - $rootindent}] + dict set indents_seen $this_indent 1 + } elseif {$this_indent < $rootindent} { + error "bad root indentation ($this_indent) at line: $linenum. Smallest indent was set on linenumber: $firstkey_linenum by first key line: $firstkey_line" + } + #if equal - it's just another root key + } else { + #validate all others + if {$this_indent < $rootindent} { + error "bad root indentation ($this_indent) at line: $linenum. Smallest indent was set on linenumber: $firstkey_linenum by first key line: $firstkey_line" + } + if {($this_indent - $rootindent) % $stepindent != 0} { + error "bad indentation ($this_indent) at linenum: $linenum line:'$ln'. this_indent - rootindent ($this_indent - $rootindent == [expr {$this_indent - $rootindent}]) is not a multiple of the first key indent $stepindent seen on linenumber: $firststep_linenum value:'$firststep_line'" + } else { + dict set indents_seen $this_indent 1 + } + } + } + + + #set wordlike_parts [regexp -inline -all {\S+} $lastitem] + set d [dict create] + set keys [list] + set linenum 0 ;#line-numbers 1 based + foreach ln $nlsplit { + incr linenum + if {![string length [string trim $ln]]} { + incr linenum + continue + } + regexp {(\s*)(.*)} $ln _ space linedata + puts stderr ">>linenum:[format %-3s $linenum] line:[format "%-20s " $ln] [format %-4s [string length $space]] $linedata" + set linedata [lindex $linedata 0] + set this_indent [string length $space] + + + if {$this_indent == $rootindent} { + #is rootkey + dict set d $linedata {} + set keys [list $linedata] + } else { + set ispan [expr {$this_indent - $rootindent}] + set numsteps [expr {$ispan / $stepindent}] + #assert - since validated in initial loop - numsteps is always >= 1 + set keydepth [llength $keys] + if {$numsteps > $keydepth + 1} { + #too deep - not tested for in initial loop. ? todo - convert to leading spaces in key/val? + error "bad indentation ($this_indent) at linenum: $linenum line:'$ln'. (too deep) - review" + } + if {$numsteps > ($keydepth - 1)} { + #assert - from above test - must be 1 or 2 deeper + set parentkey [lindex $keys end] + set oldval [dict get $d {*}$parentkey] + if {$numsteps - ($keydepth -1) == 1} { + #1 deeper + if {$oldval ne {}} { + lappend keys [list {*}$parentkey $linedata] + dict unset d {*}$parentkey + #dict set d {*}$parentkey $oldval $linedata + dict set d {*}$parentkey $oldval {} ;#convert to key? + dict set d {*}$parentkey $linedata {} + } else { + dict set d {*}$parentkey $linedata + } + } else { + #2 deeper - only ok if there is an existing val + if {$oldval eq {}} { + error "bad indentation ($this_indent) at linenum: $linenum line:'$ln'. (too deep) - review" + } + puts ">>> 2deep d:'$d' oldval:$oldval linedata:$linedata parentkey:$parentkey" + dict unset d {*}$parentkey + dict set d {*}$parentkey $oldval $linedata + lappend keys [list {*}$parentkey $oldval] + } + } elseif {$numsteps < ($keydepth - 1)} { + set diff [expr {$keydepth - 1 - $numsteps}] + set keys [lrange $keys 0 end-$diff] + #now treat as same level + set parentkey [lindex $keys end-1] + lset keys end end $linedata + dict set d {*}$parentkey $linedata {} + } else { + #same level + set parentkey [lindex $keys end-1] + lset keys end end $linedata + dict set d {*}$parentkey $linedata {} + } + } + #puts ">>keys:$keys" + } + return $d + } + proc dictline {d {indent 2}} { + puts stderr "unimplemented" + set lines [list] + + return $lines + } + + + proc ooinspect {obj} { + set obj [uplevel 1 [list ::tcl::namespace::which -command $obj]] + set isa [lmap type {object class metaclass} { + if {![info object isa $type $obj]} continue + set type + }] + foreach tp $isa { + switch -- $tp { + class { + lappend info {class superclasses} {class mixins} {class filters} + lappend info {class methods} {class methods} + lappend info {class variables} {class variables} + } + object { + lappend info {object class} {object mixins} {object filters} + lappend info {object methods} {object methods} + lappend info {object variables} {object variables} + lappend info {object namespace} {object vars} ;#{object commands} + } + } + } + + set result [dict create isa $isa] + foreach args $info { + dict set result $args [info {*}$args $obj] + foreach opt {-private -all} { + catch { + dict set result [list {*}$args $opt] [info {*}$args $obj $opt] + } + } + } + dict filter $result value {?*} + } + + punk::args::define { + @id -id ::punk::inspect + @cmd -name punk::inspect -help\ + "Function to display values - used pimarily in a punk pipeline. + The raw value arguments (not options) are always returned to pass + forward in the pipeline. + (pipeline data inserted at end of each |...> segment is passed as single item unless + inserted with an expanding insertion specifier such as .=>* ) + e.g1: + .= list a b c |v1,/1-end,/0>\\ + .=>* inspect -label i1 -- |>\\ + .=v1> inspect -label i2 -- |>\\ + string toupper + (3) i1: {a b c} {b c} a + (1) i2: a b c + + - A B C + " + -label -type string -default "" -help\ + "An optional label to help distinguish output when multiple + inspect statements are in a pipeline. This appears after the + bracketed count indicating number of values supplied. + e.g (2) MYLABEL: val1 val2 + The label can include ANSI codes. + e.g + inspect -label [a+ red]mylabel -- val1 val2 val3 + " + -limit -type int -default 20 -help\ + "When multiple values are passed to inspect - limit the number + of elements displayed in -channel output. + + When truncation has occured an elipsis indication (...) will be appended. + e.g + ${[punk::args::helpers::example { + + .= lseq 20 to 50 by 3 |> .=>* inspect -limit 4 -- |> .=>* tcl::mathop::+ + (11) 20 23 26 29... + + - 385 + + }]} + + If the current pipeline data is not a list, the limit is applied to the + number of lines in the pipeline value. + + For no limit - use -limit -1 + " + -channel -type string -default stderr -help\ + "An existing open channel to write to. If value is any of nul, null, /dev/nul + the channel output is disabled. This effectively disables inspect as the args + are simply passed through in the return to continue the pipeline. + " + -showcount -type boolean -default 1 -help\ + "Display a leading indicator in brackets showing the number of arg values present." + -ansi -type integer -default 1 -nocase 1 -choices {0 1 2 VIEW 3 VIEWCODES 4 VIEWSTYLES} -choicelabels { + 0 " Strip ANSI codes from display + of values. The disply output will + still be colourised if -ansibase has + not been set to empty string or + [a+ normal]. The stderr or stdout + channels may also have an ansi colour. + (see 'colour off' or punk::config)" + 1 " Leave value as is" + 2 " Display the ANSI codes and + other control characters inline + with replacement indicators. + e.g esc, newline, space, tab" + VIEW " Alias for 2" + 3 " Display as per 2 but with + colourised ANSI replacement codes." + VIEWCODES " Alias for 3" + 4 " Display ANSI and control + chars in default colour, but + apply the contained ansi to + the text portions so they display + as they would for -ansi 1" + VIEWSTYLE "Alias for 4" + } + -ansibase -type ansistring -default {${[a+ brightgreen]}} -help\ + "Base ansi code(s) that will apply to output written to the chosen -channel. + If there are ansi resets in the displayed values - output will revert to this base. + Does not affect return value." + -- -type none -help\ + "End of options marker. + It is advisable to use this, as data in a pipeline may often begin with -" + + @values -min 0 -max -1 + arg -type string -optional 1 -multiple 1 -help\ + "value to display" + } + #pipeline inspect + #e.g + #= {a z c} |> inspect -label input_dict |> lsort |> {inspect $data} + proc inspect {args} { + set defaults [list -label "" -limit 20 -channel stderr -showcount 1 -ansi 1 -ansibase [a+ brightgreen]] + set flags [list] + set endoptsposn [lsearch $args --] ;#first -- if data expected to contain --, then should always be called with --. e.g inspect -- + if {$endoptsposn >= 0} { + set flags [lrange $args 0 $endoptsposn-1] + set pipeargs [lrange $args $endoptsposn+1 end] + } else { + #no explicit end of opts marker + #last trailing elements of args after taking *known* -tag v pairs is the value to inspect + for {set i 0} {$i < [llength $args]} {incr i} { + set k [lindex $args $i] + if {$k in [dict keys $defaults]} { + lappend flags {*}[lrange $args $i $i+1] + incr i + } else { + #first unrecognised option represents end of flags + break + } + } + set pipeargs [lrange $args $i end] + } + foreach {k v} $flags { + if {$k ni [dict keys $defaults]} { + #error "inspect: unknown option $k. Known options: [dict keys $defaults]. If data contains flaglike elements, consider calling with end-of-opts marker. e.g inspect --" + punk::args::parse $args -errorstyle minimal withid ::punk::inspect + } + } + set opts [dict merge $defaults $flags] + # -- --- --- --- --- + set label [dict get $opts -label] + set channel [dict get $opts -channel] + set showcount [dict get $opts -showcount] + if {[string length $label]} { + set label "${label}: " + } + set limit [dict get $opts -limit] + set opt_ansiraw [dict get $opts -ansi] + set opt_ansi [tcl::prefix::match -error "" [list 0 1 2 3 4 view viewcodes viewstyle] [string tolower $opt_ansiraw]] + switch -- [string tolower $opt_ansi] { + 0 - 1 - 2 - 3 - 4 {} + view {set opt_ansi 2} + viewcodes {set opt_ansi 3} + viewstyle {set opt_ansi 4} + default { + error "inspect -ansi 0|1|2|view|3|viewcodes|4|viewstyle - received -ansi $opt_ansiraw" + } + } + # -- --- --- --- --- + + set more "" + if {[llength $pipeargs] == 1} { + #usual case is data as a single element + set val [lindex $pipeargs 0] + set count 1 + } else { + #but the pipeline segment could have an insertion-pattern ending in * + set val $pipeargs + set count [llength $pipeargs] + } + switch -- [string tolower $channel] { + nul - null - /dev/null { + return $val + } + } + set displayval $val ;#default - may be overridden based on -limit + + if {$count > 1} { + #val is a list + set llen [llength $val] + if {$limit > 0 && ($limit < $llen)} { + set displayval [lrange $val 0 $limit-1] + if {$llen > $limit} { + set more "..." + } + } + } else { + #not a valid tcl list - limit by lines + if {$limit > 0} { + set rawlines [split $val \n] + set llen [llength $rawlines] + set displaylines [lrange $rawlines 0 $limit-1] + set displayval [join $displaylines "\n"] + if {$llen > $limit} { + set more "\n..." + } + } + + } + if {$showcount} { + set displaycount "[a purple bold]($count)[a] " + #if {$showcount} { + # set countspace [expr {[string length $count] + 3}] ;#lhs margin size of count number plus brackets and one space + # set margin [string repeat " " $countspace] + # set displayval [string map [list \r "" \n "\n$margin"] $displayval] + #} + } else { + set displaycount "" + } + + set ansibase [dict get $opts -ansibase] + if {$ansibase ne ""} { + #-ansibase default is hardcoded into punk::args definition + #run a test using any ansi code to see if colour is still enabled + if {[a+ red] eq ""} { + set ansibase "" ;#colour seems to be disabled + } + } + + switch -- $opt_ansi { + 0 { + set displayval $ansibase[punk::ansi::ansistrip $displayval] + } + 1 { + #val may have ansi - including resets. Pass through ansibase_lines to + if {$ansibase ne ""} { + #set displayval [::textblock::ansibase_lines $displayval $ansibase] + set displayval [punk::ansi::ansiwrap_raw $ansibase "" "" $displayval] + } + } + 2 { + set displayval $ansibase[ansistring VIEW $displayval] + if {$ansibase ne ""} { + #set displayval [::textblock::ansibase_lines $displayval $ansibase] + set displayval [punk::ansi::ansiwrap_raw $ansibase "" "" $displayval] + } + } + 3 { + set displayval $ansibase[ansistring VIEWCODE $displayval] + if {$ansibase ne ""} { + #set displayval [::textblock::ansibase_lines $displayval $ansibase] + set displayval [punk::ansi::ansiwrap_raw $ansibase "" "" $displayval] + } + } + 4 { + set displayval $ansibase[ansistring VIEWSTYLE $displayval] + if {$ansibase ne ""} { + #set displayval [::textblock::ansibase_lines $displayval $ansibase] + set displayval [punk::ansi::ansiwrap_raw $ansibase "" "" $displayval] + } + } + } + + if {![string length $more]} { + #puts $channel "$displaycount$label$displayval[a]" + set chunk [textblock::join -- $displaycount$label " " $displayval[a]] + } else { + #puts $channel "$displaycount$label$displayval[a yellow bold]$more[a]" + set chunk [textblock::join -- $displaycount$label " " "$displayval[a yellow bold]$more[a]"] + } + puts $channel $chunk + return $val + } + + + + proc help {args} { + set chunks [uplevel 1 [list ::punk::help_chunks {*}$args]] + foreach chunk $chunks { + lassign $chunk chan text + puts -nonewline $chan $text + } + puts -nonewline stdout \n + } + #return list of {chan chunk} elements + + namespace eval argdoc { + punk::args::define { + @id -id ::punk::help_chunks + @cmd -name "punk::help_chunks"\ + -summary\ + ""\ + -help\ + "" + @opts + -- -type none + @values -min 0 -max -1 + arg -type any -optional 1 -multiple 1 + } + } + proc help_chunks {args} { + set argd [punk::args::parse $args withid ::punk::help_chunks] + lassign [dict values $argd] leaders opts values received + if {[dict exists $values arg]} { + set topicparts [dict get $values arg] + } else { + set topicparts [list ""] + } + #set topic [lindex $args end] + #set argopts [lrange $args 0 end-1] + + + set chunks [list] + set linesep [string repeat - 76] + + set warningblock "" + + set I [punk::ansi::a+ italic] + set NI [punk::ansi::a+ noitalic] + + set sizedict [punk::console::get_size] + set cols [dict get $sizedict columns] + set rows [dict get $sizedict rows] + + + + #todo - provide a mechanism to configure the default frametype everywhere and describe it in this help. + + set frametype ascii ;#conservative default. + #if the test char width fails - it's likely we're on a very old terminal that doesn't support unicode at all. + if {![catch {punk::console::test_char_width \u00e9} testcharwidth]} { + if {$cols <= 80} { + # Be conservative with frame types on narrow terminals for help. + # an 80x30 terminal is more likely to be an older style terminal and may not have unicode support. + # unicode on a non-unicode terminal is a bad experience - with the frame chars showing as garbage (e.g 3 chars per grapheme). + set frametype ascii + } else { + if {$testcharwidth == 1} { + set frametype light ;#unicode box-drawing chars. + } + } + } + + + # ------------------------------------------------------- + set logoblock "" + if {[catch { + package require patternpunk + #lappend chunks [list stderr [>punk . rhs]] + append logoblock [textblock::frame -type $frametype -title "Punk Shell [package provide punk]" -width 29 -checkargs 0 [>punk . banner -title "" -left Tcl -right [package provide Tcl]]] + }]} { + append logoblock [textblock::frame -type $frametype -title "Punk Shell [package provide punk]" -subtitle "TCL [package provide Tcl]" -width 29 -height 10 -checkargs 0 ""] + } + set title "[a+ brightgreen] Help System: " + set cmdinfo [list] + lappend cmdinfo [list help "?${I}topic${NI}?" "This help.\nTo see available subitems type:\nhelp topics\n\nFor an unrecognised ${I}topic${NI}\nhelp will look for basic\ninfo for it as a command.\n"] + set t [textblock::class::table new -minwidth 51 -show_seps 0] + $t configure -frametype $frametype + foreach row $cmdinfo { + $t add_row $row + } + set width_0 [$t column_datawidth 0] + $t configure_column 0 -minwidth [expr {$width_0 + 2}] + set width_1 [$t column_datawidth 1] + $t configure_column 1 -minwidth [expr {$width_1 + 1}] + $t configure -title $title + set text [$t print] + + set introblock [textblock::join -- $logoblock $text] + + lappend chunks [list stdout $introblock\n] + # ------------------------------------------------------- + + switch -- [lindex $topicparts 0] { + "" { + + # ------------------------------------------------------- + set title "[a+ brightgreen] Filesystem navigation: " + set cmdinfo [list] + lappend cmdinfo [list ./ "?${I}glob${NI}?" "view/change dir, list dirs."] + lappend cmdinfo [list .// "?${I}glob${NI}?" "view/change dir, list dirs and files"] + lappend cmdinfo [list ../ "?${I}path${NI}" "go up one dir, then to path if given"] + lappend cmdinfo [list newdir "${I}subdir${NI}..." "make new dir or dirs and show status"] + lappend cmdinfo [list fcat "${I}file ?file?...${NI}" "cat file(s)"] + set t [textblock::class::table new -minwidth 80 -show_seps 0] + $t configure -frametype $frametype + foreach row $cmdinfo { + $t add_row $row + } + set width_0 [$t column_datawidth 0] + $t configure_column 0 -minwidth [expr {$width_0 + 2}] + set width_1 [$t column_datawidth 1] + $t configure_column 1 -minwidth [expr {$width_1 + 1}] + $t configure -title $title + + set text "" + append text [$t print] + lappend chunks [list stdout $text\n] + # ------------------------------------------------------- + + + # ------------------------------------------------------- + set title "[a+ brightgreen] Namespace navigation: " + set cmdinfo [list] + lappend cmdinfo [list n/ "?${I}ns${NI}|${I}glob${NI}?" "view/change namespace\n (accepts ns path globs e.g **::*get* to match\n commands at any level )"] + lappend cmdinfo [list n// "?${I}ns${NI}|${I}glob${NI}?" "view/change namespace (with command listing)"] + lappend cmdinfo [list "nn/" "" "go up one namespace"] + lappend cmdinfo [list "newns" "${I}ns${NI}" "make child namespace and switch to it"] + set t [textblock::class::table new -minwidth 80 -show_seps 0] + $t configure -frametype $frametype + foreach row $cmdinfo { + $t add_row $row + } + set width_0 [$t column_datawidth 0] + $t configure_column 0 -minwidth [expr {$width_0 + 2}] + set width_1 [$t column_datawidth 1] + $t configure_column 1 -minwidth [expr {$width_1 + 1}] + $t configure -title $title + + set text "" + append text [$t print] + lappend chunks [list stdout $text\n] + # ------------------------------------------------------- + + # ------------------------------------------------------- + set title "[a+ brightgreen] Command help: " + set cmdinfo [list] + lappend cmdinfo [list i "${I}cmd${NI} ?${I}subcommand${NI}...?" "Show usage for a command or ensemble subcommand"] + lappend cmdinfo [list s "${I}cmd${NI} ?${I}subcommand${NI}...?" "Show synopsis for a command or ensemble subcommand"] + lappend cmdinfo [list eg "${I}cmd${NI} ?${I}subcommand${NI}...?" "Show example from manpage"] + lappend cmdinfo [list corp "${I}proc${NI}" "View proc body and arguments with basic highlighting"] + set t [textblock::class::table new -minwidth 80 -show_seps 0] + $t configure -frametype $frametype + foreach row $cmdinfo { + $t add_row $row + } + set width_0 [$t column_datawidth 0] + $t configure_column 0 -minwidth [expr {$width_0 + 2}] + set width_1 [$t column_datawidth 1] + $t configure_column 1 -minwidth [expr {$width_1 + 1}] + $t configure -title $title + + set text "" + append text [$t print] + lappend chunks [list stdout $text\n] + # ------------------------------------------------------- + + + set title "[a+ brightgreen] Miscellaneous: " + #todo - load from source code annotation? + set cmdinfo [list] + lappend cmdinfo [list dev "?${I}subcommand${NI}?" "(ensemble command to make new projects/modules and\n to generate docs)"] + lappend cmdinfo [list a? "?${I}subcommand${NI}...?" "view ANSI colours\n e.g a? web\n or individual code samples/diagnostics\n e.g a? red bold\n e.g a? underline web-orange Term-purple3"] + lappend cmdinfo [list a+ "?${I}colourcode${NI}...?" "Return ANSI codes\n e.g puts \"\[a+ purple\]purple\[a+ Green\]purple on green\[a\]\"\n [a+ purple]purple[a+ Green]purple on green[a] "] + lappend cmdinfo [list a "?${I}colourcode${NI}...?" "Return ANSI codes (with leading reset)\n e.g puts \"\[a+ purple\]purple\[a Green\]normal on green\[a\]\"\n [a+ purple]purple[a Green]normal on green[a] "] + + set t [textblock::class::table new -minwidth 80 -show_seps 0] + $t configure -frametype $frametype + foreach row $cmdinfo { + $t add_row $row + } + set width_0 [$t column_datawidth 0] + $t configure_column 0 -minwidth [expr {$width_0 + 2}] + set width_1 [$t column_datawidth 1] + $t configure_column 1 -minwidth [expr {$width_1 + 1}] + $t configure -title $title + + set text "" + append text [$t print] + lappend chunks [list stdout $text] + # ------------------------------------------------------- + + } + tcl { + set text "Tcl Patchlevel: [info patchlevel]" + catch { + append text \n "Tcl build-info: [::tcl::build-info]" + } + #generate warningblocks for each triggered Tcl bug in namespace ::punk::lib::check + set bugcheck_procs [info procs ::punk::lib::check::has_tclbug*] + foreach bp $bugcheck_procs { + set buginfo [$bp] + if {[dict get $buginfo bug]} { + set level unknown + if {[dict exists $buginfo level]} { + set level [dict get $buginfo level] + } + switch -- $level { + minor {set highlight [punk::ansi::a+ cyan]} + medium {set highlight [punk::ansi::a+ yellow]} + major {set highlight [punk::ansi::a+ red bold]} + default {set highlight ""} + } + append warningblock \n $highlight "warning level: $level $bp triggered." + if {[dict exists $buginfo description]} { + set indent " " + append warningblock \n "[punk::lib::indent [dict get $buginfo description] $indent]" + } + if {[dict exists $buginfo bugref] && [dict get $buginfo bugref] ne ""} { + set bugref [dict get $buginfo bugref] + append warningblock \n "${indent}see [punk::ansi::hyperlink https://core.tcl-lang.org/tcl/tktview/$bugref]" + } + append warningblock [a] + } + } + + if {[catch {lsearch -stride 2 {a b} b}]} { + #has_tclbug_lsearch_strideallinline will have reported bug false because it couldn't test it. + set indent " " + append warningblock \n "[a+ web-red]warning: lsearch does not seem to support -stride option" \n + append warningblock "${indent}(Consider upgrading to a late release of tcl 8.6 or tcl 9+ )" \n + append warningblock [a] + } + lappend chunks [list stdout $text] + } + env - environment { + set text "" + #todo - move to punk::config? + upvar ::punk::config::punk_env_vars_config punkenv_config + upvar ::punk::config::other_env_vars_config otherenv_config + + set known_punk [dict keys $punkenv_config] + set known_other [dict keys $otherenv_config] + append text \n + set usetable 1 + if {$usetable} { + set t [textblock::class::table new -show_hseps 0 -show_header 1 -ansiborder_header [a+ web-green]] + $t configure -frametype $frametype + if {"windows" eq $::tcl_platform(platform)} { + #If any env vars have been set to empty string - this is considered a deletion of the variable on windows. + #The Tcl ::env array is linked to the underlying process view of the environment + #- but info exists ::env(var) can misreport as true if it has been deleted by setting to empty string rather than using unset. + #an 'array get' will resynchronise. + #Even if an env variable didn't exist before - setting it to empty string can get it to this inconsistent state. + array get ::env + } + #do an array read on ::env + foreach {v vinfo} $punkenv_config { + if {[info exists ::env($v)]} { + set c2 [set ::env($v)] + } else { + set c2 "(NOT SET)" + } + set help "" + if {[dict exists $vinfo help]} { + set help [dict get $vinfo help] + } + $t add_row [list $v $c2 $help] + } + $t configure_column 0 -headers [list "Punk environment vars"] + $t configure_column 0 -minwidth [expr {[$t column_datawidth 0]+4}] -blockalign left -textalign left -header_colspans {any} + + set punktable [$t print] + $t destroy + + set t [textblock::class::table new -show_hseps 0 -show_header 1 -ansiborder_header [a+ web-green]] + $t configure -frametype $frametype + foreach {v vinfo} $otherenv_config { + if {[info exists ::env($v)]} { + set env_val [set ::env($v)] + if {[string match "*_TM_PATH" $v]} { + set entries [split $env_val $::tcl_platform(pathSeparator)] + set c2 [join $entries \n] + } else { + set c2 $::env($v) + } + } else { + set c2 "(NOT SET)" + } + $t add_row [list $v $c2] + } + $t configure_column 0 -headers [list "Other environment vars"] + $t configure_column 0 -minwidth [expr {[$t column_datawidth 0]+4}] -blockalign left -textalign left -header_colspans {any} + + set othertable [$t print] + $t destroy + #append text [textblock::join -- $punktable " " $othertable]\n + append text $punktable\n$othertable\n + } else { + + append text $linesep\n + append text "punk environment vars:\n" + append text $linesep\n + set col1 [string repeat " " 25] + set col2 [string repeat " " 50] + foreach v $known_punk { + set c1 [overtype::left $col1 $v] + if {[info exists ::env($v)]} { + set c2 [overtype::left $col2 [set ::env($v)]] + } else { + set c2 [overtype::right $col2 "(NOT SET)"] + } + append text "$c1 $c2\n" + } + append text $linesep\n + } + + lappend chunks [list stdout $text] + } + console - term - terminal { + set term_env_vars {TERM TERM_PROGRAM TERM_PROGRAM_VERSION COLORTERM} + set term_dict [dict create] + foreach e $term_env_vars { + if {[info exists ::env($e)]} { + dict set term_dict $e [set ::env($e)] + } else { + dict set term_dict $e "(NOT SET)" + } + } + set text "Terminal environment variables:\n" + append text [punk::lib::showdict $term_dict] \n + lappend chunks [list stdout $text] + set text "" + set indent [string repeat " " [string length "WARNING: "]] + + if {[catch {package require punk::console} result]} { + set text "Unable to load punk::console package - cannot test\n$result" + lappend chunks [list stdout $text] + } else { + + if {![catch {punk::console::class_info} console_class_info]} { + set text "Terminal class info (from device secondary attributes query to terminal):\n" + append text [punk::lib::showdict $console_class_info] \n + } else { + set text "Unable to query terminal class info - err:$console_class_info\n" + } + lappend chunks [list stdout $text] + + lappend cstring_tests [dict create {*}{ + type "PM " + msg "UN" + f7 punk::ansi::controlstring_PM + f7prefix "7bit ESC ^ secret " + f7suffix "safe" + f8 punk::ansi::controlstring_PM8 + f8prefix "8bit \\x9e secret " + f8suffix "safe" + }] + lappend cstring_tests [dict create {*}{ + type SOS + msg "NOT" + f7 punk::ansi::controlstring_SOS + f7prefix "7bit ESC X string " + f7suffix " hidden" + f8 punk::ansi::controlstring_SOS8 + f8prefix "8bit \\x98 string " + f8suffix " hidden" + }] + lappend cstring_tests [dict create {*}{ + type APC + msg "NOT" + f7 punk::ansi::controlstring_APC + f7prefix "7bit ESC _ APPLICATION PROGRAM COMMAND " + f7suffix " hidden" + f8 punk::ansi::controlstring_APC8 + f8prefix "8bit \\x9f APPLICATION PROGRAM COMMAND " + f8suffix " hidden" + }] + + foreach test $cstring_tests { + set m [[dict get $test f7] [dict get $test msg]] + set hidden_width_m [punk::console::test_char_width $m] + set m8 [[dict get $test f8] [dict get $test msg]] + set hidden_width_m8 [punk::console::test_char_width $m8] + if {$hidden_width_m != 0 || $hidden_width_m8 != 0} { + if {$hidden_width_m == 0} { + set d "[a+ green bold][dict get $test f7prefix][a red]${m}[a][a+ green bold][dict get $test f7suffix][a]" + } else { + set d "[a+ yellow bold][dict get $test f7prefix][a red]$m[a][a+ yellow bold][dict get $test f7suffix][a]" + } + if {$hidden_width_m8 == 0} { + set d8 "[a+ green ][dict get $test f8prefix][a red]$m8[a][a+ green][dict get $test f8suffix][a]" + } else { + set d8 "[a+ yellow bold][dict get $test f8prefix][a red]$m8[a][a+ yellow bold][dict get $test f8suffix][a]" + } + append warningblock \n "WARNING: terminal doesn't hide all [dict get $test type] control strings: $d $d8" + } + } + if {![catch {punk::console::check::has_bug_legacysymbolwidth} result]} { + if {$result} { + append warningblock \n "WARNING: terminal has legacysymbolwidth bug - screen position for symbol reports 2 wide but displays 1 wide." + append warningblock \n $indent "Layout using 'legacy symbols for computing' affected." + append warningblock \n $indent "(e.g textblock frametype block2 unsupported)" + append warningblock \n $indent "This can cause extreme layout deformation when ANSI is present" + append warningblock \n $indent "In some cases unwanted spacing effects occur at a distance from the characters causing it" + } + } else { + append warningblock \n "WARNING: terminal unable to check for legacysymbolwidth bug. err:$result" + } + + if {![catch {punk::console::check::has_bug_zwsp} result]} { + if {$result} { + append warningblock \n "WARNING: terminal has zero width space (\\u200b) bug - cursor position incremented when it shouldn't be." + append warningblock \n $indent "The zwsp may or may not be displayed. zwsp contributes to line length and wrapping point" + } + } else { + append warningblock \n "WARNING: terminal unable to check for zwsp bug. err:$result" + } + + + set grapheme_support [punk::console::grapheme_cluster_support] + #mode, 1 = set, 2 = unset. (0 = mode not recognised, 3 = permanently set, 4 = permanently unset) + if {![dict size $grapheme_support] || [dict get $grapheme_support mode] eq "unsupported" } { + append warningblock \n "WARNING: terminal either doesn't support grapheme clusters, or doesn't report so via decmode 2027 query." + if {[dict size $grapheme_support] && [dict get $grapheme_support available]} { + append warningblock \n $indent "(but punk::console::grapheme_cluster_support has determined it is probably available)" + } + } else { + if {![dict get $grapheme_support available]} { + switch -- [dict get $grapheme_support mode] { + "unset" { + append warningblock \n "WARNING: terminal reports via decmode 2027 that grapheme cluster support is off." + } + "permanently_unset" { + append warningblock \n "WARNING: terminal reports via decmode 2027 that grapheme cluster support is permanently off." + } + "BAD_RESPONSE" { + append warningblock \n "WARNING: terminal doesn't seem to recognize decmode 2027 query. No grapheme cluster support." + } + } + } + } + set posn [punk::console::get_cursor_pos] ;#warmup call - and test if works + if {$posn eq ""} { + append warningblock \n "WARNING: terminal doesn't respond to cursor position query - may cause display bugs in some cases." + } else { + set timeresult [timerate {set cpos [punk::console::get_cursor_pos]}] + lassign [split $cpos {;}] row col + if {![string is integer -strict $row] || ![string is integer -strict $col]} { + append warningblock \n "WARNING: terminal returns non-integer values for cursor position query - may cause display bugs in some cases. got row:'$row' col:'$col'" + } else { + set micros [lindex $timeresult 0] + if {$micros > 2000} { + append warningblock \n "WARNING: terminal cursor position query is very slow ($micros microseconds - expect < 2000us )" + append warningblock \n $indent "- may cause display lag/bugs in some cases." + } else { + if {$micros > 1000} { + set text "\n[a+ yellow]Terminal cursor position query test passed." + append text \n $indent "Response time: ${micros} microseconds (OK, good would be <= 1000us).[a]" + + } else { + set text "[a+ green]Terminal cursor position query test passed." + append text \n $indent "Response time: ${micros} microseconds (GOOD).[a]" + } + lappend chunks [list stdout $text] + } + } + } + + + if {![string length $warningblock]} { + set text "[a+ green]No terminal warnings[a]\n" + lappend chunks [list stdout $text] + } else { + set mode [punk::console::mode] + if {$mode eq "line"} { + append warningblock \n "Terminal appears to be in line mode. Consider switching to raw mode and re-testing (command: punk::console::mode raw)." + } + } + puts stdout [punk::ansi::move_back 200] ;#hack for some horizontal position bugs where the above tests can leave the cursor in the wrong place for the next output. + #200 is arbitrary large number to move back enough to get to start of line. + } + } + topics - help { + set text "" + set topics [dict create {*}{ + "topics|help" "List help topics" + "tcl" "Tcl version warnings" + "env|environment" "punkshell environment vars" + "console|terminal" "Some console behaviour tests and warnings" + "*" "Try to find help on the topic as a command or external executable" + }] + + set t [textblock::class::table new -show_seps 0] + $t configure -frametype $frametype + $t add_column -headers [list "Topic"] + $t add_column + foreach {k v} $topics { + $t add_row [list $k $v] + } + set widest0 [$t column_datawidth 0] + $t configure_column 0 -minwidth [expr {$widest0 + 4}] + append text \n [$t print] + + lappend chunks [list stdout $text] + } + default { + set text "" + set cinfo [uplevel 1 [list ::punk::ns::cmdwhich [lindex $topicparts 0]]] + set wtype [dict get $cinfo whichtype] + if {$wtype eq "notfound"} { + set externalinfo [auto_execok [lindex $topicparts 0]] + if {[string length $externalinfo]} { + set text "$topicparts" + append text \n "Base type: External command" + append text \n "$externalinfo [lrange $topicparts 1 end]" + } else { + set text "$topicparts\n" + append text "No matching internal or external command found" + } + } else { + set text "[dict get $cinfo which] [lrange $topicparts 1 end]" + append text \n "Base type: $wtype" + set synopsis [uplevel 1 [list ::punk::ns::synopsis {*}$topicparts]] + set synshow "" + foreach sline [split $synopsis \n] { + if {[regexp {\s*#.*} $sline]} { + append synshow [punk::ansi::a+ bold term-darkgreen Term-white]$sline[punk::ansi::a] \n + } else { + append synshow $sline \n + } + } + if {[string index $synshow end] eq "\n"} { + set synshow [string range $synshow 0 end-1] + } + append text \n $synshow + } + lappend chunks [list stdout $text] + } + } + + + lappend chunks [list stderr $warningblock] + return $chunks + } + proc mode {{raw_or_line query}} { + package require punk::console + tailcall ::punk::console::mode $raw_or_line + } + + #this hides windows cmd's mode command - probably no big deal - anyone who needs it will know how to exec it. + interp alias {} mode {} punk::mode + + + + #proc aliases {{glob *}} { + # tailcall punk::ns::aliases $glob + #} + + ##review + #proc alias {{aliasorglob ""} args} { + # tailcall punk::ns::alias $aliasorglob {*}$args + #} + + + #pipeline-toys - put in lib/scriptlib? + ##geometric mean + #alias gmean .=> llength |> expr 1.0 / |e> .=i>* tcl::mathop::* |> .=>1,e>3 expr ** {::tcl::tm::add {*}$data; set path} |> inspect -label added_to_module_path <0/#| + + + + + + #todo - review + #interp alias {} clear {} ::punk::reset + #interp alias {} c {} ::punk::reset + + interp alias {} reset {} ::punk::reset + proc reset {} { + if {[llength [info commands ::punk::repl::reset_terminal]]} { + #punk::repl::reset_terminal notifies prompt system of reset + punk::repl::reset_terminal + } else { + puts -nonewline stdout [punk::ansi::reset] + } + } + + namespace eval argdoc { + punk::args::define { + @id -id ::punk::ansi8 + @cmd -name punk::ansi8\ + -summary\ + "Tell terminal to enable 8-bit ANSI codes."\ + -help\ + "Enable 8-bit ANSI codes in the terminal. + May not be supported by all terminals. + Some terminals may already have 8-bit ANSI enabled, but some may require an explicit command to enable it. + 7-bit ANSI codes are generally preferred - and will still work on terminals with 8-bit ANSI support. + + (This is nothing to do with 8-bit colors - it is about the underlying bytes used for ANSI control sequences). + The ANSI sequence sent to the terminal to enable 8-bit codes is: ESC 7 + + To disable 8-bit ANSI support - a reset of the terminal may be required. + " + @opts + @values -min 0 -max 0 + } + } + proc ansi8 {} { + punk::console::S8C1R + } + namespace eval argdoc { + punk::args::define { + @id -id ::punk::clear + @cmd -name punk::clear\ + -summary\ + "Clear the terminal screen (and scrollback buffer by default)."\ + -help\ + "Clear the terminal screen. + By default this will also clear scrollback if supported by the terminal. + With -x option it will preserve scrollback but clear the screen. + " + @opts + -x -optional 1 -type none -mash 1 -help\ + "Preserve scrollback (if supported by terminal) but clear screen." + -s -optional 1 -type none -mash 1 -help\ + "Stay at the current cursor position instead of moving to top-left after clearing." + @values -min 0 -max 0 + } + } + proc clear {args} { + set argd [punk::args::parse $args withid ::punk::clear] + lassign [dict values $argd] leaders opts values received + set opt_x [dict exists $received -x] + set opt_s [dict exists $received -s] + # -x preserves scrollback but clears screen + if {$opt_s} { + #set pre_move_cmd [punk::ansi::move_up 1] + #review - terminal support for save/restore. + #we can just move up one line before clearing to preserve the line we're on, + #but this won't work if we're already at the last line. + #save/restore would be better if widely supported. + + #review - get_size already calls get_cursor pos - maybe we can optimize by not calling get_cursor_pos separately? + #review - consider turning off cursor updating while doing this to avoid flicker? + set cpos [punk::console::get_cursor_pos] + set row [lindex $cpos 0] + set size [punk::console::get_size] + set lastrow [dict get $size rows] + if {$row >= $lastrow} { + set pre_move_cmd [punk::ansi::cursor_save_dec] + } else { + set pre_move_cmd [punk::ansi::move_up 1][punk::ansi::cursor_save_dec] + } + set move_cmd [punk::ansi::cursor_restore_dec] + + #set pre_move_cmd [punk::ansi::move_up 1] + #set move_cmd "" + + } else { + set pre_move_cmd "" + set move_cmd [punk::ansi::move 1 1] + } + if {$opt_x} { + puts -nonewline stdout $pre_move_cmd[punk::ansi::clear]$move_cmd + } else { + puts -nonewline stdout $pre_move_cmd[punk::ansi::clear_all]$move_cmd + } + } + #c aliased to clear -xs + #cc aliases to clear -x + + + + #fileutil::cat except with checking for windows illegal path names (when on windows platform) + interp alias {} fcat {} punk::mix::util::fcat + + #---------------------------------------------- + interp alias {} linelistraw {} punk::linelistraw + + # 'path' collides with kettle path in kettle::doc function - todo - patch kettle? + interp alias {} PATH {} punk::path + + interp alias {} path_list {} punk::path_list + interp alias {} list_filter_cond {} punk::list_filter_cond + + + interp alias {} inspect {} punk::inspect + interp alias {} ooinspect {} punk::ooinspect + + interp alias {} linedict {} punk::linedict + interp alias {} dictline {} punk::dictline + + #todo - pipepure - evaluate pipeline in a slave interp without commands that have side-effects. (safe interp?) + interp alias {} % {} punk::% + interp alias {} pipeswitch {} punk::pipeswitch + interp alias {} pipeswitchc {} punk::pipeswitchc ;#closure version - more correct + interp alias {} pipecase {} punk::pipecase + interp alias {} pipematch {} punk::pipematch + interp alias {} ispipematch {} punk::ispipematch + interp alias {} pipenomatchvar {} punk::pipenomatchvar + interp alias {} pipedata {} punk::pipedata + interp alias {} pipeset {} punk::pipeset + interp alias {} pipealias {} punk::pipealias + interp alias {} listset {} punk::listset ;#identical to pipeset + + + #non-core aliases + interp alias {} is_list_all_in_list {} punk::lib::is_list_all_in_list + interp alias {} is_list_all_ni_list {} punk::libis_list_all_ni_list + + + + #interp alias {} = {} ::punk::pipeline = "" "" + #interp alias {} = {} ::punk::match_assign "" "" + interp alias {} .= {} ::punk::pipeline .= "" "" + #proc .= {args} { + # #uplevel 1 [list ::punk::pipeline .= "" "" {*}$args] + # tailcall ::punk::pipeline .= "" "" {*}$args + #} + + + interp alias {} rep {} ::tcl::unsupported::representation + interp alias {} dis {} ::tcl::unsupported::disassemble + + + + # ls aliases - note that tcl doesn't exand * but sh_xxx functions pass to sh -c allowing shell expansion + interp alias {} l {} sh_runout -n ls -A ;#plain text listing + #interp alias {} ls {} sh_runout -n ls -AF --color=always + interp alias {} ls {} shellrun::runconsole ls -AF --color=always ;#use unknown to use terminal and allow | more | less + #note that shell globbing with * won't work on unix systems when using unknown/exec + interp alias {} lw {} sh_runout -n ls -AFC --color=always ;#wide listing (use A becaus no extra info on . & ..) + interp alias {} ll {} sh_runout -n ls -laFo --color=always ;#use a instead of A to see perms/owner of . & .. + # -v for natural number sorting not supported on freeBSD. Todo - test at startup and modify aliases? + #interp alias {} lw {} ls -aFv --color=always + + interp alias {} dir {} shellrun::runconsole dir + + # punk::nav::fs + package require punk::nav::fs + package require punk::nav::ns + + + + variable pshell_path "" + # ---------------------------------------- + set pshell_path [auto_execok pwsh] ;#Still not installed by default on win10 11? + if {$pshell_path eq ""} { + #fallback to powershell 5 + #set pshell_path [auto_execok powershell] + set pshell_path powershell ;#temp + } else { + set pshell_path pwsh ;#temp + } + #todo - review run commands and handling of paths with spaces + # ---------------------------------------- + + + + if {$pshell_path eq ""} { + set has_powershell 0 + } else { + #todo - review powershell detection on non-windows platforms + set has_powershell 1 + } + + if {$::tcl_platform(platform) eq "windows"} { + interp alias {} dl {} dir /q + interp alias {} dw {} dir /W/D + } else { + #todo - natsorted equivalent + #interp alias {} dl {} + interp alias {} dl {} puts stderr "not implemented" + interp alias {} dw {} puts stderr "not implemented" + } + + #todo - distinguish non-preinstalled pwsh (powershell core) from powershell which is available by default + if {$has_powershell} { + #see also powershell runspaces etc: + # powershell runspaces e.g $rs=[RunspaceFactory]::CreateRunspace() + # $ps = [Powershell]::Create() + + interp alias {} pse {} exec >@stdout {*}$pshell_path -nolo -nop -c + interp alias {} psx {} runx -n {*}$pshell_path -nop -nolo -c + interp alias {} psr {} run -n {*}$pshell_path -nop -nolo -c + interp alias {} psout {} runout -n {*}$pshell_path -nop -nolo -c + interp alias {} pserr {} runerr -n {*}$pshell_path -nop -nolo -c + #interp alias {} psls {} shellrun::runconsole $pshell_path -nop -nolo -c ls + #interp alias {} psls {} shellrun::runconsole {*}$pshell_path -nop -nolo -c {ls | Select-Object Mode, @{Name='Owner';Expression={(Get-Acl $_.FullName).Owner}}, LastWriteTime, Length, Name | Format-Table} + proc psls args { + variable pshell_path + shellrun::runconsole {*}$pshell_path -nop -nolo -c {*}[string map [list %a% $args] {{ls %a% | Select-Object Mode, @{Name='Owner';Expression={(Get-Acl $_.FullName).Owner}}, LastWriteTime, Length, Name | Format-Table}}] + } + interp alias {} psls {} punk::psls + interp alias {} psps {} shellrun::runconsole {*}$pshell_path -nop -nolo -c ps + } else { + set ps_missing "powershell missing (powershell is MIT licensed open source and can be installed on windows and most unix-like platforms)" + interp alias {} pse {} puts stderr $ps_missing + interp alias {} psx {} puts stderr $ps_missing + interp alias {} psr {} puts stderr $ps_missing + interp alias {} psout {} puts stderr $ps_missing + interp alias {} pserr {} puts stderr $ps_missing + interp alias {} psls {} puts stderr $ps_missing + interp alias {} psps {} puts stderr $ps_missing + } + proc psencode {cmdline} { + + } + proc psdecode {encodedcmd} { + + } + + #proc repl {startstop} { + # switch -- $startstop { + # stop { + # if {[punk::repl::codethread::is_running]} { + # puts stdout "Attempting repl stop. Try ctrl-c or exit command to leave interpreter" + # set ::repl::done 1 + # } + # } + # start { + # if {[punk::repl::codethread::is_running]} { + # repl::start stdin + # } + # } + # default { + # error "repl unknown action '$startstop' - must be start or stop" + # } + # } + #} + +} + + +# -- --- --- --- +#Load decks. commandset packages are not loaded until the deck is called. +# -- --- --- --- +package require punk::mod +#punk::mod::cli set_alias pmod +punk::mod::cli set_alias app + +#todo - change to punk::dev +package require punk::mix +punk::mix::cli set_alias dev +punk::mix::cli set_alias deck ;#deprecate! + +#todo - add punk::deck for managing cli modules and commandsets + +package require punkcheck::cli +punkcheck::cli set_alias pcheck +punkcheck::cli set_alias punkcheck +# -- --- --- --- + +package provide punk [namespace eval punk { + #FUNCTL + variable version + set version 0.1.1 +}] + + + diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/aliascore-0.1.0.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/aliascore-0.1.0.tm index 296fa148..bea6a48f 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/aliascore-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/aliascore-0.1.0.tm @@ -123,6 +123,7 @@ tcl::namespace::eval punk::aliascore { ansistrip ::punk::ansi::ansistrip stripansi ::punk::ansi::ansistrip ansiwrap ::punk::ansi::ansiwrap + ansisplit ::punk::ansi::ta::split_codes_single grepstr ::punk::ansi::grepstr untabify ::punk::ansi::untabify colour ::punk::console::colour diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/ansi-0.1.1.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/ansi-0.1.1.tm index e8518d0f..53ffd420 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/ansi-0.1.1.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/ansi-0.1.1.tm @@ -127,7 +127,8 @@ tcl::namespace::eval punk::ansi::class { -width -type integer -default "" -height -type integer -default "" -crm_mode -type boolean -default 0 - -binarytext -type string -default "" -choices {"" bios ice} + -format -type string -choices {ansi binarytext-bios binarytext-ice xbin} -help\ + "Format of new data being applied as an overlay" @values -min 0 -max 0 }] method rendertest {args} { @@ -135,7 +136,7 @@ tcl::namespace::eval punk::ansi::class { set opt_width [dict get $argd opts -width] set opt_height [dict get $argd opts -height] set opt_crm_mode [dict get $argd opts -crm_mode] - set opt_binarytext [dict get $argd opts -binarytext] + set opt_format [dict get $argd opts -format] set existing_dimensions $o_render_dimensions if {![regexp {^([0-9]+)[xX]([0-9]+)$} $existing_dimensions _m w h]} { @@ -150,8 +151,7 @@ tcl::namespace::eval punk::ansi::class { set o_render_dimensions ${w}x${h} - - set rendered [overtype::renderspace -binarytext $opt_binarytext -cp437 1 -crm_mode $opt_crm_mode -expand_right 0 -wrap 1 -width $w -height $h -appendlines 1 "" [$o_ansistringobj get]] + set rendered [overtype::renderspace -format $opt_format -cp437 1 -crm_mode $opt_crm_mode -expand_right 0 -wrap 1 -width $w -height $h -appendlines 1 "" [$o_ansistringobj get]] return $rendered } @@ -630,7 +630,8 @@ tcl::namespace::eval punk::ansi { package require punk::ansi::sauce set sdict [punk::ansi::sauce::from_file $filename] set result "" - if {[dict size $sdict]} { + #if no sauce header - sdict will contain only posn -1 + if {[dict size $sdict] > 1} { if {$opt_return eq "dict"} { return $sdict } @@ -695,33 +696,75 @@ tcl::namespace::eval punk::ansi { } set opt_crm_mode [dict get $opts -crm_mode] - set binarytext "" set sdict [dict create] #if SAUCE data is present - it may give an indication of encoding as well as number of columns/lines if {![catch {package require punk::ansi::sauce}]} { if {[catch {punk::ansi::sauce::from_file $fname} sdict]} { - #no 128 Byte SAUCE record at end of file + #error parsing 128 Byte SAUCE record at end of file set sdict [dict create] } + #if no error - there may be no SAUCE record at all (sdict is just posn -1) } else { puts stderr "Warning punk::ansi::sauce package not loaded - unable to detect or use any SAUCE data to aid in display" } - if {![dict size $sdict]} { - if {[string tolower [file extension $fname]] eq ".bin"} { - #In the absence of SAUCE data - assume .bin is binary text - set binarytext bios ;#16 fg, 8 bg + blink + + set format ansi ;#default assumption + + + if {[dict size $sdict] < 2} { + #either no SAUCE (dict is just posn -1) or there was an error during sauce::from_file parsing (empty sdict) + switch -exact -- [string tolower [file extension $fname]] { + .bin { + #In the absence of SAUCE data - assume .bin is binary text + set format binarytext-bios ;#16 fg, 8 bg + blink + } + .xb { + set format xbin + } } } + + #review - we open and read from file twice - once for sauce, once to slurp in whole file. + # - consider optimising to read file in first and use slurped data for sauce + #(create punk::ansi::sauce::from_data ?) + set ansidata [fcat -translation binary $fname] + if {[dict size $sdict] && [dict get $sdict posn] != -1} { + #the SAUCE ctrl-z may not be the only ctrl-z in the file data + #use the position returned by sauce::from_file rather than splitting on ctrl-z + #posn will be -1 if no SAUCE, or the position of the ctrl-z immediatly before the entire SAUCE block (including comments) + set ansidata [string range $ansidata 0 [dict get $sdict posn]-1] + } + + if {[dict exists $sdict datatype_name]} { - if {[dict get $sdict datatype_name] eq "binarytext"} { - #todo - SAUCE ANSiFlags - ice vs default bios - if {[dict exists $sdict ansiflags_ice] && [dict get $sdict ansiflags_ice]} { - set binarytext ice - } else { - set binarytext bios + switch -- [dict get $sdict datatype_name] { + binarytext { + #SAUCE ANSiFlags - iCE vs default bios + if {[dict exists $sdict ansiflags_ice] && [dict get $sdict ansiflags_ice]} { + set format binarytext-ice + } else { + set format binarytext-bios + } + } + xbin { + set format xbin + } + default { } } } + + if {$format eq "xbin"} { + #set ansidata [fcat -translation binary $fname] ;#don't split on \x1a - this is also present in xbin header + set xbin_header [string range $ansidata 0 10] ;#11 bytes + set non_header [string range $ansidata 11 end] + #set ansidata $xbin_header[lindex [split $non_header \x1a] 0] ;#ignore sauce at tail + set xbin_header_info [punk::ansi::xbin::parse_header $xbin_header] + #keys width height fontsize flags + set dimensions [dict get $xbin_header_info width]x[dict get $xbin_header_info height] ;#cols x rows + } + + if {$encoding eq ""} { if {[dict exists $sdict codepage]} { set encoding [dict get $sdict codepage] @@ -733,11 +776,13 @@ tcl::namespace::eval punk::ansi { if {$dimensions eq ""} { # defaults - if {$binarytext ne ""} { + if {[string match binarytext* $format]} { set cols 160 } else { set cols 80 } + + #sauce-specified if {[dict exists $sdict columns]} { set c [dict get $sdict columns] if {$c > 0} { @@ -764,17 +809,24 @@ tcl::namespace::eval punk::ansi { } lassign [split $dimensions x] cols rows - #set ansidata [fcat -encoding $encoding $fname] - set ansidata [lindex [split [fcat -translation binary $fname] \x1a] 0] - #hack - #if {$binarytext eq ""} { + if {$format eq "xbin"} { + #review + ##don't decode binary xbin header + #set hdr [string range $ansidata 0 10] + #set data [encoding convertfrom $encoding [string range $ansidata 11 end]] + #set ansidata $hdr$data + + #don't convert at all - compressed is binary? + } elseif {[string match binarytext* $format]} { + #don't convert - this is binary data - the rendering obj will handle it as binary + } else { set ansidata [encoding convertfrom $encoding $ansidata] - #} + } set obj [punk::ansi::class::class_ansi new $ansidata] if {$encoding eq "cp437"} { - set result [$obj rendertest -binarytext $binarytext -width $cols -height $rows -crm_mode $opt_crm_mode] + set result [$obj rendertest -format $format -width $cols -height $rows -crm_mode $opt_crm_mode] } else { set result [$obj render $dimensions] } @@ -6193,24 +6245,12 @@ be as if this was off - ie lone CR. #counterintuitively "x\b" still shows the x ie length is still one. The backspace just moves the position. There must be a char following \b for it to affect the length. #(we are not interested in the destructive backspace case present in editors,terminals etc - that is a different context) - set n 0 - #set chars [split $line ""] ; #review - graphemes vs chars? Terminals differ in how they treat this. - set chars [punk::char::grapheme_split $line] - set cr_posns [lsearch -all $chars \r] - set bs_posns [lsearch -all $chars \b] - foreach p $cr_posns { - lset chars $p - } - foreach p $bs_posns { - lset chars $p - } #mintty seems more 'correct'. It will backspace over an entire grapheme (char+combiners) whereas windows terminal/wezterm etc remove a combiner #build an output set idx 0 set outchars [list] - set outsizes [list] # -- #tcl8.6/8.7 we can get a fast byte-compiled switch statement only with literals in the source code #this is difficult/risky to maintain - hence the lsearch and grapheme-replacement above @@ -6220,39 +6260,65 @@ be as if this was off - ie lone CR. #set cr ? # -- - - #consider also that AB\0\bC will usually render as AC not ABC - foreach c $chars { - switch -- $c { - { - if {$idx > 0} { - incr idx -1 - } - } - { - set idx 0 - } - default { - if {$c eq "\0"} { - #nulls don't print - and backspace will ignore them and remove the preceding char if there is one. - #we need to remove them here or else backspace processing will only remove the null and not the preceding char - which is not how terminals work. - #review - other zero-width chars? - continue - } - #set nxt [llength $outchars] - if {$idx < [llength $outchars]} { - #overstrike? - should usually have no impact on width - width taken as last grapheme in that column - #e.g nroff would organise text such that underline written first, then backspace, then the character - so that terminals without overstrike would display something useful if no overstriking is done - #Conceivably double_wide_char then backspace then underscore would underreport the length if overstriking were intended. - lset outchars $idx $c - } else { - lappend outchars $c - } - #punk::ansi::internal::printing_length_addchar $idx $c - incr idx - } + set graphemes [punk::char::grapheme_split $line] + foreach g $graphemes { + if {$g eq "\0"} { + #nulls don't print - and backspace will ignore them and remove the preceding char if there is one. + #we need to remove them here or else backspace processing will only remove the null and not the preceding char - which is not how terminals work. + #review - other zero-width chars? + continue + } elseif {$g eq "\r"} { + set idx 0 + } elseif {$g eq "\b"} { + incr idx -1 + set idx [expr {max(0,$idx)}] + } else { + lset outchars $idx $g ;#lset will append if $idx is equal to the current length of the list - since we only increment idx by 1, this should be safe to do without checking the length first + #if {$idx < [llength $outchars]} { + # #overstrike? - should usually have no impact on width - width taken as last grapheme in that column + # #e.g nroff would organise text such that underline written first, then backspace, then the character - so that terminals without overstrike would display something useful if no overstriking is done + # #Conceivably double_wide_char then backspace then underscore would underreport the length if overstriking were intended. + # lset outchars $idx $g + #} else { + # lappend outchars $g + #} + incr idx } } + + + + #consider also that AB\0\bC will usually render as AC not ABC + #foreach g $graphemes { + # switch -exact -- $g { + # { + # if {$idx > 0} { + # incr idx -1 + # } + # } + # { + # set idx 0 + # } + # { + # #nulls don't print - and backspace will ignore them and remove the preceding char if there is one. + # #we need to remove them here or else backspace processing will only remove the null and not the preceding char - which is not how terminals work. + # #review - other zero-width chars? + # continue + # } + # default { + # #set nxt [llength $outchars] + # if {$idx < [llength $outchars]} { + # #overstrike? - should usually have no impact on width - width taken as last grapheme in that column + # #e.g nroff would organise text such that underline written first, then backspace, then the character - so that terminals without overstrike would display something useful if no overstriking is done + # #Conceivably double_wide_char then backspace then underscore would underreport the length if overstriking were intended. + # lset outchars $idx $g + # } else { + # lappend outchars $g + # } + # incr idx + # } + # } + #} #we already have the string split into grapheme clusters. #we should calculate length as the sum of the widths of the graphemes in the output list rather #than passing to a function that will need to split into graphemes again. @@ -6287,7 +6353,7 @@ be as if this was off - ie lone CR. set max_component_width 1 } } - } elseif {$c < 917504 || $c > 917631} { + } elseif {$dec < 917504 || $dec > 917631} { #codepoint not in the zero-width unicode tag block - \UE0000-\UE000F #set w [punk::char::char_width $dec] set w [textutil::wcswidth_char $dec] @@ -6314,19 +6380,6 @@ be as if this was off - ie lone CR. return $sumwidth #return [punk::char::ansifreestring_width [join $outchars ""]] } - namespace eval internal { - proc printing_length_addchar {i c} { - #review - upvar outchars outc - upvar outsizes outs - set nxt [llength $outc] - if {$i < $nxt} { - lset outc $i $c - } else { - lappend outc $c - } - } - } # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- @@ -7070,6 +7123,12 @@ be as if this was off - ie lone CR. set prev_stop_idx [lsearch -integer -bisect $tstops $current_column] set next_stop [lindex $tstops $prev_stop_idx+1] ;#if our current_column is exactly on a stop, we still want to move to the next stop. + if {$next_stop eq ""} { + #if we run out of stops + #Review + break + } + # how far is the next tab position ? #set dist [expr {$num - ($currPos % $num)}] set this_tab_width [expr {$next_stop - $current_column}] ;#diff between two adjacent columns is one. @@ -7515,6 +7574,10 @@ tcl::namespace::eval punk::ansi { #} #------------------------------------------------------- proc sgr_merge {codelist args} { + if {[llength $codelist] == 0 && [llength $args] == 0} { + return "" + } + #pass through even single code or empty codelist to sgr_merge_singles - as there may be arguments such as -info or -filter_* set allparts [list] foreach c $codelist { #set cparts [punk::ansi::ta::split_codes_single $c] @@ -8959,7 +9022,6 @@ tcl::namespace::eval punk::ansi::class { -overflow 0 -appendlines 1 -looplimit 15000 - -experimental {} -cursor_column 1 -cursor_row 1 -insert_mode 0 @@ -8970,7 +9032,7 @@ tcl::namespace::eval punk::ansi::class { foreach {k v} $argsflags { switch -- $k { -width - -height - - -overflow - -appendlines - -looplimit - -experimental - + -overflow - -appendlines - -looplimit - -autowrap_mode - -insert_mode - -initial_ansistring { @@ -9671,7 +9733,8 @@ tcl::namespace::eval punk::ansi::class { upvar ${ns}::o_gx0states new_gx0states upvar ${ns}::o_splitindex new_splitindex - lset o_ansisplits end [tcl::string::cat [lindex $o_ansisplits end] [lindex $new_ansisplits 0]] lappend o_ansisplits {*}[lrange $new_ansisplits 1 end] + lset o_ansisplits end [tcl::string::cat [lindex $o_ansisplits end] [lindex $new_ansisplits 0]] + lappend o_ansisplits {*}[lrange $new_ansisplits 1 end] lset o_ptlist end [tcl::string::cat [lindex $o_ptlist end] [lindex $new_ptlist 0]] lappend o_ptlist {*}[lrange $new_ptlist 1 end] @@ -10286,8 +10349,9 @@ tcl::namespace::eval punk::ansi::ansistring { set hack [tcl::dict::create] tcl::dict::set hack BOM1 [list \uFEFF "${obm}\U1f4a3$cbm"] ;#byte order mark/ ZWNBSP (ZWNBSP usage generally deprecated) - a picture of a bomb(2wide glyph) tcl::dict::set hack ZWSP [list \u200B "${obm}ZWSP$cbm"] - tcl::dict::set hack ZWNJ [list \u200D "${obm}ZWNJ$cbm"] ;#zero width non-joiner. + tcl::dict::set hack ZWNJ [list \u200C "${obm}ZWNJ$cbm"] ;#zero width non-joiner. tcl::dict::set hack ZWJ [list \u200D "${obm}ZWJ$cbm"] + tcl::dict::set hack CGJ [list \u034F "${obm}CGJ$cbm"] ;#combining grapheme joiner (MISNOMER) - zero width, but semantically important in some contexts - for example in indic scripts - where it can affect the shaping of the preceding character(s) #review - other boms? Encoding dependent? @@ -10561,6 +10625,7 @@ tcl::namespace::eval punk::ansi::ansistring { #Note that trim/trimleft/trimright will trim spaces at the extremities that are styled with background colour, underline etc #that may be unexpected, but it's probably the only thing that makes sense. Plain string trim can chop off whitespace that is extraneous to the ansi entirely. proc trimleft {string args} { + #todo - don't just trim whitespace - need to accept optional ?chars? to trim. set intext 0 set out "" #for split_codes only first or last pt can be empty string - but we can also get an empty ansiblock by using foreach with 2 vars on an odd-length list @@ -11808,7 +11873,7 @@ namespace eval punk::ansi::colour { @cmd -name "punk::ansi::colour::byteAnsi" -summary\ "ANSI/BIOS colour codes from attribute byte."\ -help\ - "Convert an attribute-byte (character) to ANSI SGR + "Convert a binarytext (.bin) attribute-byte (character) to ANSI SGR foreground and background colour. This is allows 16 foreground colours and only 8 background colours, with the highest bit being @@ -11828,7 +11893,7 @@ namespace eval punk::ansi::colour { lappend PUNKARGS [list { @id -id "::punk::ansi::colour::byteAnsiIce" @cmd -name "punk::ansi::colour::byteAnsiIce" -summary\ - "iCE colour codes from attribute byte."\ + "iCE colour codes from binarytext (.bin) attribute byte."\ -help\ "Convert an attribute-byte (character) to ANSI SGR foreground and background colour. @@ -11847,6 +11912,945 @@ namespace eval punk::ansi::colour { dict get $byte_to_ansi_ice $char } } +tcl::namespace::eval punk::ansi::xbin { + proc parse_header {str} { + #https://web.archive.org/web/20120204063040/http://www.acid.org/info/xbin/x_spec.htm + if {[string length $str] < 11} { + error "punk::ansi::xbin::parse_header error - invalid XBIN header - less than 11 bytes received" + } + set xbin_header [string range $str 0 10] ;#11 bytes + + set xbin_id [string range $xbin_header 0 3] + if {$xbin_id ne "XBIN"} { + error "punk::ansi::xbin::parse_header error - invalid XBIN header" + } + set xbin_eofchar [string index $xbin_header 4] + set xbin_width_raw [string range $xbin_header 5 6] + binary scan $xbin_width_raw su xbin_width ;#16bit unsigned little-endian + set xbin_height_raw [string range $xbin_header 7 8] + binary scan $xbin_height_raw su xbin_height ;#16bit unsigned little-endian + + set xbin_fontsize_raw [string index $xbin_header 9] + if {[binary scan $xbin_fontsize_raw cu xbin_fontsize]} { + #1 byte - unsigned + #numeric number of pixel rows (scanlines) in font. + #Any value from 1 to 32 is technically possible on VGA. + #Any other values should be considered illegal + if {$xbin_fontsize < 1 || $xbin_fontsize > 32} { + error "punk::ansi::xbin::parse_header error - invalid XBIN header - fontsize not in range 1 to 32 inclusive. received $xbin_fontsize" + } + } + set xbin_flags_raw [string index $xbin_header 10] + #valid flags: 512chars nonblink compress font palette + #bits: + #7 unused 6 unused 5 unused 4 512chars 3 nonblink 2 compress 1 font 0 palette + binary scan $xbin_flags_raw B8 flagbits + set flagbits [lrange [split $flagbits ""] 3 end] ;#skip first 3 unused + set allflags [list 512chars nonblink compress font palette] + set xbin_flags [list] + #puts "flagbits $flagbits" + foreach b $flagbits f $allflags { + if {$b} { + lappend xbin_flags $f + } + } + #width - number of columns, height - number of character rows + return [dict create width $xbin_width height $xbin_height fontsize $xbin_fontsize flags $xbin_flags] + } + proc default_palette {} { + # VGA 16-colour default palette as RGB 0-255 triples. + return { + {0 0 0} + {0 0 170} + {0 170 0} + {0 170 170} + {170 0 0} + {170 0 170} + {170 85 0} + {170 170 170} + {85 85 85} + {0 0 255} + {0 255 0} + {0 255 255} + {255 0 0} + {255 0 255} + {255 255 0} + {255 255 255} + } + } + + proc palette_value_8bit {value} { + if {$value < 0 || $value > 63} { + error "punk::ansi::xbin::palette_value_8bit error - expected palette value from 0 to 63 inclusive. received $value" + } + return [expr {round(($value * 255.0) / 63.0)}] + } + proc parse_palette {str} { + if {[string length $str] < 48} { + error "punk::ansi::xbin::parse_palette error - invalid XBIN palette - less than 48 bytes received" + } + binary scan [string range $str 0 47] cu* components + set palette [list] + foreach {r g b} $components { + lappend palette [list [palette_value_8bit $r] [palette_value_8bit $g] [palette_value_8bit $b]] + } + #for {set i 0} {$i < 48} {incr i 3} { + # set r [palette_value_8bit [lindex $components $i]] + # set g [palette_value_8bit [lindex $components $i+1]] + # set b [palette_value_8bit [lindex $components $i+2]] + # lappend palette [list $r $g $b] + #} + return $palette + } + proc attribute_ansi {char palette nonblink} { + #convert a binarytext (.bin) attribute byte (character) to ANSI SGR + #foreground and background colour. + #When nonblink is false, this allows 16 foreground colours and only 8 + #background colours, with the highest bit being + #used to set 'blink' on. + if {![binary scan $char cu value]} { + error "punk::ansi::xbin::attribute_ansi error - expected a single character for attribute byte. received string of length [string length $char] - '[ansistring VIEW $char]'" + } + + set fg_index [expr {$value & 0x0F}] + if {$nonblink} { + set bg_index [expr {($value >> 4) & 0x0F}] + set blink noblink + } else { + set bg_index [expr {($value >> 4) & 0x07}] + if {$value & 0x80} { + set blink blink + } else { + set blink noblink + } + } + lassign [lindex $palette $fg_index] fr fg fb + lassign [lindex $palette $bg_index] br bg bb + return [punk::ansi::a+ $blink rgb-$fr-$fg-$fb Rgb-$br-$bg-$bb] + } + + proc parse {xbindata} { + set bytenum 0 + set xbin_header [string range $xbindata 0 10] ;#11 bytes + set xbin_header_info [punk::ansi::xbin::parse_header $xbin_header] + set xbin_body [string range $xbindata 11 end] + incr bytenum 11 + + set flags [dict get $xbin_header_info flags] + set xbin_width [dict get $xbin_header_info width] + set xbin_height [dict get $xbin_header_info height] + set expected_cells [expr {$xbin_width * $xbin_height}] + set xbin_nonblink [expr {"nonblink" in $flags}] ;# ice. + set xbin_palette [punk::ansi::xbin::default_palette] + + set parse_warnings [list] + + #optional 16-entry palette, 3 bytes per entry, RGB values 0..63 + if {"palette" in $flags} { + #puts stderr "renderspace warning - palette unimplemented" + set xbin_palette [punk::ansi::xbin::parse_palette [string range $xbin_body 0 47]] + set xbin_body_after_palette [string range $xbin_body 48 end] + incr bytenum 48 + } else { + set xbin_body_after_palette $xbin_body + } + + #todo - font. + #hack - skip over font 256 x fontsize or 512 x fontsize + if {"512chars" in $flags} { + set sz 512 + } else { + set sz 256 + } + #temp + set skip [expr {$sz * [dict get $xbin_header_info fontsize]}] + if {"font" in $flags} { + #todo - consider sixel or similar for font data - but for now we just skip over it. + #puts stderr "punk::ansi::xbin::parse warning - xbin font unimplemented" + lappend parse_warnings "XBIN_FONT_UNIMPLEMENTED skipping over font data" + set celldata [string range $xbin_body_after_palette $skip end] + incr bytenum $skip + } else { + set celldata $xbin_body_after_palette + } + set celldata_bytes [split $celldata ""] + #puts stdout "xbin image data size [llength $celldata_bytes]" + + set decoded_cells 0 + set ansisplit [list ""] + if {"compress" in $flags} { + #puts stderr "renderspace warning - compress experimental" + #process 'repeatcounter' bytes + #first 2 bits - compression type + # 00 - no compression + # 01 - character compression + # 10 - attribute compression + # 11 - character/attribute compression + #remaining 6 bits - counter + set input "" + set byte_count [llength $celldata_bytes] + for {set b 0} {$b < $byte_count} {} { + set rc [lindex $celldata_bytes $b] + set dec [scan $rc %c] + set ctype [expr {$dec >> 6}] + #0x3F - 00111111 + set count [expr {$dec & 0x3F}] + incr count ;#count stored as 1 less than actual number of repeats + if {$count < 1 || $count > 64} { + #generally unlikely to occur if we are decoding 6 bits of count correctly. + # - but will be zero for example if we have a trailing carriage return. + puts stderr "punk::ansi::xbin::parse - max count must be between 1 and 64 inclusive. received $count" + } + incr b + if {$decoded_cells + $count > $expected_cells} { + #some of the more common causes of this could be additional non xbin data after the expected end of celldata, eg: + #\x1a (ctrl-z) decimal value 26 (= count 27) delimiter for start of SAUCE record. + #\r (carriage regurn) decimal value 13 (= count 14) + #\n (line feed) decimal value 10 (= count 11) + # or it could be more celldata but the header dimensions are wrong + #- either way we should probably just warn and stop processing. + lappend parse_warnings "XBIN_OVERFLOW - record would emit $count cells at decoded offset $decoded_cells, expected total $expected_cells cells for header dimensions ${xbin_width}x${xbin_height} (possible trailing SAUCE record or newlines)" + break + } + switch -exact -- $ctype { + 0 { + set needed [expr {$count * 2}] + } + 1 - + 2 { + set needed [expr {$count + 1}] + } + 3 { + set needed 2 + } + default { + #hard error - will probably cause desynchronization between decoder and byte stream + error "punk::ansi::xbin::parse - invalid compression type $ctype in repeatcounter byte '$rc' at offset $b" + } + } + if {$b + $needed > $byte_count} { + lappend parse_warnings "XBIN_BAD_RECORD - truncated record: type $ctype requires $needed bytes at payload offset $b, but only [expr {$byte_count - $b}] bytes remain." + #abort processing - would probably raise an error in the compression switch cases below. + #This may indicate a truncated file, but it could also be a file with additional data after the expected end of celldata. + #This is likely to happen if the xbindata includes a trailing SAUCE record. + #we shouldn't raise a hard error - as the caller may want to salvage what data they can from the file, and report the issue via warnings. + break + } + switch -exact -- $ctype { + 0 { + #no compression + for {set c 0} {$c < $count*2} {incr c 2} { + set ch [lindex $celldata_bytes $b+$c] + set ch [encoding convertfrom cp437 $ch] + set at [lindex $celldata_bytes [expr {$b+$c+1}]] + #binary scan $at cu code + #set clr [a+ term-$code] + #set clr [a+ red] ;#debug + set clr [punk::ansi::xbin::attribute_ansi $at $xbin_palette $xbin_nonblink] + lappend ansisplit $clr $ch + } + incr b [expr {$count*2}] + } + 1 { + #char compression + set ch [lindex $celldata_bytes $b] + set ch [encoding convertfrom cp437 $ch] + incr b + for {set c 0} {$c < $count} {incr c} { + set at [lindex $celldata_bytes $b+$c] + #binary scan $at cu code + #set clr [a+ term-$code] + #set clr [a+ cyan] ;#debug + set clr [punk::ansi::xbin::attribute_ansi $at $xbin_palette $xbin_nonblink] + lappend ansisplit $clr $ch + } + incr b [expr {$count}] + } + 2 { + #attribute compression + set at [lindex $celldata_bytes $b] + #binary scan $at cu code + #set clr [a+ term-$code] + #set clr [a+ green] ;#debug + set clr [punk::ansi::xbin::attribute_ansi $at $xbin_palette $xbin_nonblink] + incr b + for {set c 0} {$c < $count} {incr c} { + set ch [lindex $celldata_bytes $b+$c] + set ch [encoding convertfrom cp437 $ch] + lappend ansisplit $clr $ch + } + incr b $count + } + 3 { + #attribute and char compression + set ch [lindex $celldata_bytes $b] + set ch [encoding convertfrom cp437 $ch] + set at [lindex $celldata_bytes $b+1] + #binary scan $at cu code + #set clr [a+ term-$code] + #set clr [a+ white] ;#debug + set clr [punk::ansi::xbin::attribute_ansi $at $xbin_palette $xbin_nonblink] + for {set c 0} {$c < $count} {incr c} { + lappend ansisplit $clr $ch + } + incr b 2 + } + } + incr decoded_cells $count + } + if {$decoded_cells != $expected_cells} { + lappend parse_warnings "XBIN_CELLCOUNT_MISMATCH decoded $decoded_cells cells, expected $expected_cells cells for image dimensions ${xbin_width}x${xbin_height}" + } + } else { + foreach {ch at} $celldata_bytes { + #binary scan $at cu code + #set clr [a+ term-$code] + if {$at eq ""} { + #eg src/testansi/formatsamples/image/xbin/test.xb + #has missing last byte. for now just warn. + #puts stderr "renderspace warning - xbin attribute byte is empty at char '[ansistring VIEW $ch]'" + lappend parse_warnings "XBIN_MISSING_BYTE attribute byte is empty at byte [expr {$bytenum + 1}] char '[ansistring VIEW $ch]'" + #experiment - treat as a reset. + lappend ansisplit [a+] $ch + } else { + set clr [punk::ansi::xbin::attribute_ansi $at $xbin_palette $xbin_nonblink] + set ch [encoding convertfrom cp437 $ch] + lappend ansisplit $clr $ch + } + incr bytenum 2 + incr decoded_cells + } + } + #lappend inputchunks [list ansisplit $ansisplit] + + #_reset key with ansi reset to ensure direct display of dict in terminal is readable. + return [dict create header $xbin_header_info palette $xbin_palette ansisplit $ansisplit _reset \x1b\[m warnings $parse_warnings decoded_cells $decoded_cells expected_cells $expected_cells] + } + +} +tcl::namespace::eval punk::ansi::png { + + proc paethPredictor {a b c} { + #A Paeth PNG filter is a pre-compression image processing algorithm used in the Portable Network Graphics (PNG) format. + #It is designed to prepare image data for the format's lossless compression by predicting the color of a pixel based on + #its neighbors + set p [expr {$a + $b - $c}] + set pa [expr {abs($p - $a)}] + set pb [expr {abs($p - $b)}] + set pc [expr {abs($p - $c)}] + if {$pa <= $pb && $pa <= $pc} { return $a } + if {$pb <= $pc} { return $b } + return $c + } + + proc pngdataToAnsi {pngdata} { + #This will create very large ansi images as the smallest possible colorised cell is the half-block character. + #To create smaller images, we could consider some kind of lossy conversion to a smaller palette, or even to monochrome with dithering. + #A better alternative might be sixel or similar. + + #if {[::png::validate $filename] ne "OK"} { + # error "Invalid PNG file." + #} + # Extract PNG header metadata + #set info [::png::imageInfo $filename] + + if {[string range $pngdata 0 7] ne "\x89PNG\r\n\x1a\n"} { + error "pngdataToAnsi: Invalid PNG data - missing PNG signature" + } + + #----------------------------------------------------------------------------------------- + #set info [::png::imageInfo $filename] + #----------------------------------------------------------------------------------------- + set posn [expr {8}] ;# Skip PNG signature + binary scan [string range $pngdata $posn [expr {$posn + 7}]] Ia4 len type + incr posn 8 + set r [string range $pngdata $posn [expr {$posn + $len - 1}]] + incr posn $len + if {$type eq "IHDR"} { + binary scan $r IIccccc width height depth color compression filter interlace + binary scan [string range $pngdata $posn [expr {$posn + 3}]] I check + if {$check < 0} { + set check [format %u [expr {$check & 0xffffffff}]] + } + if {![catch {package present crc32}] && [::crc32::crc32 IHDR$r] != $check} { + error "pngdataToAnsi: Invalid PNG data - IHDR chunk CRC mismatch" + } + set info [list width $width height $height depth $depth color $color compression $compression filter $filter interlace $interlace] + } else { + error "pngdataToAnsi: Invalid PNG data - missing IHDR chunk" + } + #----------------------------------------------------------------------------------------- + + + set width [dict get $info width] + set height [dict get $info height] + set depth [dict get $info depth] + set color [dict get $info color] + set filter [dict get $info filter] + set interlace [dict get $info interlace] + set compression [dict get $info compression] + if {$compression != 0} { + #true as at PNG-3 2025 + error "pngdataToAnsi: Unsupported PNG compression method $compression - only method 0 (deflate/inflate) is supported." + } + puts stderr "pngdataToAnsi: PNG image info - width $width height $height depth $depth color $color interlace $interlace filter $filter" + + set color_types { + 0 Grayscale + 2 TrueColor (RGB) + 3 Indexed-color + 4 Grayscale with alpha + 6 TrueColor with alpha (RGBA) + } + switch -exact $color { + 0 { + error "pngdataToAnsi warning - PNG color type 0 (grayscale) not supported - todo: treat as RGB with R=G=B ?" + set ctype "grayscale" + if {$depth ni {1 2 4 8 16}} { + error "Unsupported format. Only grayscale PNGs with bit depths of 1, 2, 4, 8, or 16 are supported." + } + } + 2 { + # RGB TrueColor - supported + set ctype "rgb" + #todo depth 16 + if {$depth != 8} { + error "Unsupported format. Only 8-bit RGB or RGBA PNGs are supported." + } + set bpp 3 + } + 3 { + set ctype "indexed" + puts stderr "pngdataToAnsi warning - PNG color type 3 (indexed colour)" + if {$depth ni {1 2 4 8}} { + error "Unsupported format. Only indexed-color PNGs with 1,2,4 or 8 bit depth are supported." + } + set bpp 1 + } + 4 { + error "pngdataToAnsi warning - PNG color type 4 (grayscale with alpha) not supported - todo: treat as RGBA with R=G=B and alpha channel" + set ctype "grayscale_alpha" + set bpp 3 ;#Bytes per pixel + if {$depth ni {8 16}} { + error "Unsupported format. Only grayscale PNGs with bit depths of 8 or 16 are supported." + } + } + 6 { + puts stderr "pngdataToAnsi warning - PNG color type 6 (truecolor with alpha)" + set ctype "rgba" + if {$depth == 8} { + set bpp 4 ;#Bytes per pixel + } elseif {$depth == 16} { + set bpp 8 ;#Bytes per pixel + } else { + error "Unsupported format. Only depths of 8 or 16 bits per channel are supported for RGBA PNGs." + } + } + default { + error "pngdataToAnsi: Unsupported PNG color type $color" + } + } + + + #------------------------------------------ + # Extract raw compressed IDAT stream chunks + #set chunks [::png::getChunks $filename] + set chunks [list] + set posn [expr {8}] ;# Skip PNG signature + while {[set r [string range $pngdata $posn [incr posn 8]]] ne ""} { + binary scan $r Ia4 len type + if {$type eq "IEND"} { + #end of PNG data - stop processing chunks + #(important to stop before we try to process any trailing non-PNG data such as a SAUCE record) + break + } + lappend chunks [list $type $posn $len] + incr posn [expr {$len + 4}] + } + #------------------------------------------ + puts stderr "pngdataToAnsi: found [llength $chunks] chunks in PNG data" + foreach chunk $chunks { + puts stderr "pngdataToAnsi: chunk type '[lindex $chunk 0]' length [lindex $chunk 2]" + } + + + set paletteRaw "" + + set idatData "" + foreach chunk $chunks { + switch -exact -- [lindex $chunk 0] { + "IDAT" { + set posn [lindex $chunk 1] + append idatData [string range $pngdata $posn [expr {$posn + [lindex $chunk 2] - 1}]] + } + "PLTE" { + set posn [lindex $chunk 1] + puts stderr "pngdataToAnsi warning - PNG PLTE chunk" + #implement PLTE chunk parsing and support for indexed colour PNGs + append paletteRaw [string range $pngdata $posn [expr {$posn + [lindex $chunk 2] - 1}]] + } + "tEXt" { + set posn [lindex $chunk 1] + #todo - consider supporting tEXt chunks for metadata such as title, author, description etc. + set textData [string range $pngdata $posn [expr {$posn + [lindex $chunk 2] - 1}]] + set nullpos [string first \x00 $textData] + #neither the keyword nor text data is supposed to contain nulls. + if {$nullpos >= 0} { + set keyword [string range $textData 0 [expr {$nullpos - 1}]] + set text [string range $textData [expr {$nullpos + 1}] end]] + puts stderr "pngdataToAnsi warning - PNG tEXt chunk - keyword '$keyword' text '$text'" + } else { + puts stderr "pngdataToAnsi warning - PNG tEXt chunk - no separator null found: $textData" + } + } + "zTXt" { + #set posn [lindex $chunk 1] + #todo - consider supporting zTXt chunks for compressed metadata such as title, author, description etc. + #puts stderr "pngdataToAnsi warning - PNG zTXt chunk - [string range $pngdata $posn [expr {$posn + [lindex $chunk 2] - 1}]]" + } + "iTXt" { + #set posn [lindex $chunk 1] + #todo - consider supporting iTXt chunks for international text metadata such as title, author, description etc. + #puts stderr "pngdataToAnsi warning - PNG iTXt chunk - [string range $pngdata $posn [expr {$posn + [lindex $chunk 2] - 1}]]" + } + "IEND" { + } + default { + #ignore other chunk types for now + } + } + } + if {$ctype eq "indexed" && $paletteRaw eq ""} { + error "pngdataToAnsi: Indexed colour PNG missing PLTE chunk" + } + if {[string match grayscale* $ctype] && $paletteRaw ne ""} { + puts stderr "pngdataToAnsi warning - PNG PLTE chunk present in grayscale image - ignoring palette data" + } + if {$paletteRaw ne ""} { + set palette [list] + binary scan $paletteRaw c* components + puts "components: $components '[ansistring VIEW $paletteRaw]'" + foreach {r g b} $components { + lappend palette [list [expr {$r & 0xFF}] [expr {$g & 0xFF}] [expr {$b & 0xFF}]] + } + } + + # Decompress using raw Tcl zlib inflation + set decompressed [zlib decompress $idatData] + #set decompressed [zlib deflate $idatData] + #PLTE data is not compressed. + + #set stride [expr {1 + ($width * $bpp)}] + #set prevLine [binary format x[expr {$width * $bpp}]] ;# Row 0 baseline + + if {$ctype eq "indexed"} { + set bytesPerLine [expr {($width * $depth + 7) / 8}] + } else { + set bytesPerLine [expr {$width * $bpp}] + } + set stride [expr {1 + $bytesPerLine}] ;# Filter type byte + pixel data bytes + set prevLine [binary format x$bytesPerLine] ;# Row 0 baseline + set allRows [list] + + + # Process rows + for {set y 0} {$y < $height} {incr y} { + set offset [expr {$y * $stride}] + + # Unpack the filter type byte at start of each scanline + #puts "---> filter type byte: [ansistring VIEW [string range $decompressed $offset $offset]] at offset $offset for row $y" + binary scan [string range $decompressed $offset $offset] c filterType + set filterType [expr {$filterType & 0xFF}] + if {$filterType < 0 || $filterType > 4} { + puts stderr "pngdataToAnsi warning - invalid filter type $filterType at row $y - treating as no filter" + set filterType 0 + } + + # Get filtered pixel payload bytes for the row + set rawRow [string range $decompressed [expr {$offset + 1}] [expr {$offset + $stride - 1}]] + set currentLine "" + + # Defilter scanline bytes based on specification types + for {set xBytes 0} {$xBytes < $bytesPerLine} {incr xBytes} { + binary scan [string range $rawRow $xBytes $xBytes] c origByte + set origByte [expr {$origByte & 0xFF}] + + # Get left byte (A) and upper byte (B) and upper-left byte (C) + #set leftVal [expr {$xBytes >= $bpp ? [string index $currentLine [expr {$xBytes - $bpp}]] : 0}] + #binary scan $leftVal c a + #set a [expr {$a & 0xFF}] + if {$xBytes >= $bpp} { + binary scan [string index $currentLine [expr {$xBytes - $bpp}]] c a + set a [expr {$a & 0xFF}] + } else { + set a 0 + } + + binary scan [string range $prevLine $xBytes $xBytes] c b; + set b [expr {$b & 0xFF}] + + #set upLeftVal [expr {$xBytes >= $bpp ? [string index $prevLine [expr {$xBytes - $bpp}]] : 0}] + #binary scan $upLeftVal c c + #set c [expr {$c & 0xFF}] + if {$xBytes >= $bpp} { + binary scan [string index $prevLine [expr {$xBytes - $bpp}]] c c + set c [expr {$c & 0xFF}] + } else { + set c 0 + } + + # Reverse the PNG filter transformations + switch -- $filterType { + 0 { set reconByte $origByte } ;# None + 1 { set reconByte [expr {($origByte + $a) % 256}] } ;# Sub + 2 { set reconByte [expr {($origByte + $b) % 256}] } ;# Up + 3 { set reconByte [expr {($origByte + (($a + $b) / 2)) % 256}] } ;# Average + 4 { set reconByte [expr {($origByte + [paethPredictor $a $b $c]) % 256}] } ;# Paeth + default { + } + } + append currentLine [binary format c $reconByte] + } + set prevLine $currentLine + + if {$ctype eq "indexed"} { + # For indexed colour PNGs, map pixel values to RGB using the PLTE chunk palette + set pixelRow [list] + set pixelCount 0 + + #pre-calculate masks and steps based on depth + # depth 4: mask = 15 (0x0F), pixels per byte = 2 + # depth 2: mask = 3 (0x03), pixels per byte = 4 + # depth 1: mask = 1 (0x01), pixels per byte = 8 + set mask [expr {(1 << $depth) - 1}] + set pixelsPerByte [expr {8 / $depth}] + + for {set x 0} {$x < $bytesPerLine} {incr x} { + binary scan [string range $currentLine $x $x] c packedByte + set byteVal [expr {$packedByte & 0xFF}] + + #read left-to-right within the byte, extracting pixel values based on depth and mask + for {set p 0} {$p < $pixelsPerByte} {incr p} { + if {$pixelCount < $width} { + #set shift [expr {($pixelsPerByte - 1 - $p) * $depth}] + set shift [expr {8 - $depth - ($p * $depth)}] + set idx [expr {($byteVal >> $shift) & $mask}] + set rgb [lindex $palette $idx] + #append outputBuffer [format "\x1b\[48\;2\;%d\;%d\;%dm " [lindex $rgb 0] [lindex $rgb 1] [lindex $rgb 2]] + #lappend pixelRow $idx + lappend pixelRow [list [lindex $rgb 0] [lindex $rgb 1] [lindex $rgb 2]] + incr pixelCount + } + } + + } + } else { + #RGB + set pixelRow [list] + for {set x 0} {$x < $width} {incr x} { + set idx [expr {$x * $bpp}] + #pull either 3 bytes (RGB) or 4 bytes (RGBA) for the pixel, depending on bpp + if {$depth == 16} { + binary scan [string range $currentLine $idx [expr {$idx + 3}]] c4 rgba + set r [expr {[lindex $rgba 0] & 0xFF}] + set g [expr {[lindex $rgba 1] & 0xFF}] + set b [expr {[lindex $rgba 2] & 0xFF}] + set a [expr {[lindex $rgba 3] & 0xFF}] + + #terminal fallback background colour .eg dark terminal grey + set bgR 30 + set bgG 30 + set bgB 30 + set alpha [expr {$a / 255.0}] + + set r [expr {int(($r * $alpha) + ($bgR * (1 - $alpha)))}] + set g [expr {int(($g * $alpha) + ($bgG * (1 - $alpha)))}] + set b [expr {int(($b * $alpha) + ($bgB * (1 - $alpha)))}] + } else { + binary scan [string range $currentLine $idx [expr {$idx + 2}]] c3 rgb + set r [expr {[lindex $rgb 0] & 0xFF}] + set g [expr {[lindex $rgb 1] & 0xFF}] + set b [expr {[lindex $rgb 2] & 0xFF}] + #puts stderr "pixel $x,$y - RGB($r,$g,$b)" + } + + + # Use background-color escape sequence with two blank spaces to build a square pixel + #append outputBuffer "\x1b\[48\;2\;${r}\;${g}\;${b}m " + lappend pixelRow [list $r $g $b] + } + #append outputBuffer "\x1b\[m\n" ;# Reset row styling + } + lappend allRows $pixelRow + } + + set symbols 1 + # ------------------------------------------------------------- + # Unicode Quadrant Mosaic Definition Matrix + # ------------------------------------------------------------- + # Maps a 4-bit representation of a 2x2 grid to a structural character. + # Layout: Bit 3 = TopLeft, Bit 2 = TopRight, Bit 1 = BottomLeft, Bit 0 = BottomRight + variable MOSAIC_MAP + array set MOSAIC_MAP { + 0 " " 1 "▗" 2 "▖" 3 "▄" + 4 "▝" 5 "▐" 6 "▞" 7 "▟" + 8 "▘" 9 "▚" 10 "▌" 11 "▙" + 12 "▀" 13 "▜" 14 "▛" 15 "█" + } + + # ------------------------------------------------------------- + # Sub-Pixel Structural Rendering Engine + # ------------------------------------------------------------- + proc renderSymbols {allRows width height} { + variable MOSAIC_MAP + set outputBuffer "" + fconfigure stdout -encoding utf-8 + + # Process chunks of 2 vertical rows and 2 horizontal columns + for {set y 0} {$y < $height} {incr y 2} { + set rowTop [lindex $allRows $y] + + # Edge safety padding for odd vertical bounds + if {($y + 1) < $height} { + set rowBottom [lindex $allRows [expr {$y + 1}]] + } else { + set rowBottom $rowTop + } + + for {set x 0} {$x < $width} {incr x 2} { + # Extract 4 pixels of the 2x2 cluster + set p_tl [lindex $rowTop $x] + + if {($x + 1) < $width} { + set p_tr [lindex $rowTop [expr {$x + 1}]] + set p_bl [lindex $rowBottom $x] + set p_br [lindex $rowBottom [expr {$x + 1}]] + } else { + # Pad horizontally if image width is odd + set p_tr $p_tl; set p_bl $p_tl; set p_br $p_tl + } + + # Calculate individual pixel luminance values (Standard Rec. 601 weights) + set l_tl [expr {[lindex $p_tl 0]*0.299 + [lindex $p_tl 1]*0.587 + [lindex $p_tl 2]*0.114}] + set l_tr [expr {[lindex $p_tr 0]*0.299 + [lindex $p_tr 1]*0.587 + [lindex $p_tr 2]*0.114}] + set l_bl [expr {[lindex $p_bl 0]*0.299 + [lindex $p_bl 1]*0.587 + [lindex $p_bl 2]*0.114}] + set l_br [expr {[lindex $p_br 0]*0.299 + [lindex $p_br 1]*0.587 + [lindex $p_br 2]*0.114}] + + # Block Threshold: Local average brightness + set avg_lum [expr {($l_tl + $l_tr + $l_bl + $l_br) / 4.0}] + + # Build the 4-bit structure index mapping bitwise states + set bitmask 0 + if {$l_tl >= $avg_lum} { set bitmask [expr {$bitmask | 8}] } + if {$l_tr >= $avg_lum} { set bitmask [expr {$bitmask | 4}] } + if {$l_bl >= $avg_lum} { set bitmask [expr {$bitmask | 2}] } + if {$l_br >= $avg_lum} { set bitmask [expr {$bitmask | 1}] } + + # Segregate pixels into foreground (bright) and background (dark) sets + set fg_r 0; set fg_g 0; set fg_b 0; set fg_count 0 + set bg_r 0; set bg_g 0; set bg_b 0; set bg_count 0 + + foreach p [list $p_tl $p_tr $p_bl $p_br] lum [list $l_tl $l_tr $l_bl $l_br] { + if {$lum >= $avg_lum} { + incr fg_r [lindex $p 0]; incr fg_g [lindex $p 1]; incr fg_b [lindex $p 2] + incr fg_count + } else { + incr bg_r [lindex $p 0]; incr bg_g [lindex $p 1]; incr bg_b [lindex $p 2] + incr bg_count + } + } + + # Compute color averages for both states + if {$fg_count > 0} { + set fR [expr {$fg_r / $fg_count}]; set fG [expr {$fg_g / $fg_count}]; set fB [expr {$fg_b / $fg_count}] + } else { + set fR 0; set fG 0; set fB 0 + } + if {$bg_count > 0} { + set bR [expr {$bg_r / $bg_count}]; set bG [expr {$bg_g / $bg_count}]; set bB [expr {$bg_b / $bg_count}] + } else { + # If everything is uniform, match foreground color to prevent ghosting borders + set bR $fR; set bG $fG; set bB $fB + } + + # Pull symbol match out of the layout map + set symbol $MOSAIC_MAP($bitmask) + + # Generate the combined true color escape output string + append outputBuffer "\x1b\[48\;2\;${bR}\;${bG}\;${bB}m\x1b\[38\;2\;${fR}\;${fG}\;${fB}m${symbol}" + } + append outputBuffer "\x1b\[m\n" + } + return $outputBuffer + } + # ------------------------------------------------------------- + # High-Density 8x4 Block (Braille Mosaic) Rendering Engine + # ------------------------------------------------------------- + proc renderBrailleDensity {allRows width height} { + set outputBuffer "" + fconfigure stdout -encoding utf-8 + + # We skip 8 vertical rows and 4 horizontal pixels per cell cycle + # to achieve a 4x reduction factor (accounting for terminal aspect ratios) + for {set y 0} {$y < $height} {incr y 8} { + + # Buffer up to 8 rows for processing this line + set activeRows [list] + for {set r 0} {$r < 8} {incr r} { + if {($y + $r) < $height} { + lappend activeRows [lindex $allRows [expr {$y + $r}]] + } else { + lappend activeRows "" ;# Pad vertical overflow with empty lines + } + } + + for {set x 0} {$x < $width} {incr x 4} { + + # --- 1. Downsample the 8x4 cluster into a 4x2 grid for Braille --- + # Each cell in our 4x2 grid averages a 2x2 pixel area from the image + set subGridLums [list 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0] + set subGridRgbs [list] + set totalBlockLum 0.0 + + set cellIdx 0 + for {set subY 0} {$subY < 8} {incr subY 2} { + for {set subX 0} {$subX < 4} {incr subX 2} { + + # Accumulate colors for this specific 2x2 sub-pixel zone + set sR 0; set sG 0; set sB 0; set sCount 0 + for {set dy 0} {$dy < 2} {incr dy} { + set rowIdx [expr {$subY + $dy}] + set currRow [lindex $activeRows $rowIdx] + if {$currRow eq ""} { continue } + + for {set dx 0} {$dx < 2} {incr dx} { + set pixelX [expr {$x + $subX + $dx}] + if {$pixelX >= $width} { continue } + + set pixel [lindex $currRow $pixelX] + incr sR [lindex $pixel 0] + incr sG [lindex $pixel 1] + incr sB [lindex $pixel 2] + incr sCount + } + } + + # Store sub-zone averages + if {$sCount > 0} { + set sR [expr {$sR / $sCount}]; set sG [expr {$sG / $sCount}]; set sB [expr {$sB / $sCount}] + } else { + set sR 0; set sG 0; set sB 0 + } + + set sLum [expr {$sR*0.299 + $sG*0.587 + $sB*0.114}] + lset subGridLums $cellIdx $sLum + lappend subGridRgbs [list $sR $sG $sB] + set totalBlockLum [expr {$totalBlockLum + $sLum}] + incr cellIdx + } + } + + # --- 2. Calculate Thresholding & Grouping --- + set avgBlockLum [expr {$totalBlockLum / 8.0}] + + set fg_r 0; set fg_g 0; set fg_b 0; set fg_count 0 + set bg_r 0; set bg_g 0; set bg_b 0; set bg_count 0 + set brailleOffset 0 + + # Unicode Braille bitmask generation table for 4x2 cells + # Maps sequential list index (0-7) to Unicode Braille bit flags + set bitWeights [list 1 8 2 16 4 32 64 128] + + for {set i 0} {$i < 8} {incr i} { + set sLum [lindex $subGridLums $i] + set sRgb [lindex $subGridRgbs $i] + + if {$sLum >= $avgBlockLum} { + # This sub-zone is bright: Turn on the Braille dot + set brailleOffset [expr {$brailleOffset | [lindex $bitWeights $i]}] + incr fg_r [lindex $sRgb 0]; incr fg_g [lindex $sRgb 1]; incr fg_b [lindex $sRgb 2] + incr fg_count + } else { + # This sub-zone is dark + incr bg_r [lindex $sRgb 0]; incr bg_g [lindex $sRgb 1]; incr bg_b [lindex $sRgb 2] + incr bg_count + } + } + + # --- 3. Compute Final Colors --- + if {$fg_count > 0} { + set fR [expr {$fg_r / $fg_count}]; set fG [expr {$fg_g / $fg_count}]; set fB [expr {$fg_b / $fg_count}] + } else { + set fR 0; set fG 0; set fB 0 + } + if {$bg_count > 0} { + set bR [expr {$bg_r / $bg_count}]; set bG [expr {$bg_g / $bg_count}]; set bB [expr {$bg_b / $bg_count}] + } else { + set bR $fR; set bG $fG; set bB $fB + } + + # Construct the final Unicode character using the Braille base boundary block (\u2800) + set brailleChar [format %c [expr {0x2800 + $brailleOffset}]] + + # Append the ANSI sequence + append outputBuffer "\x1b\[48\;2\;${bR}\;${bG}\;${bB}m\x1b\[38\;2\;${fR}\;${fG}\;${fB}m${brailleChar}" + } + append outputBuffer "\x1b\[m\n" + } + return $outputBuffer + } + + if {$symbols} { + # return [renderSymbols $allRows $width $height] + return [renderBrailleDensity $allRows $width $height] + } + + set outputBuffer "" + for {set y 0} {$y < $height} {incr y 2} { + set topRow [lindex $allRows $y] + #if image has an odd height, use pure black {0 0 0} for the missing bottom row of the final half-block character row. + set hasBottom [expr {$y + 1 < $height}] + if {$hasBottom} { + set bottomRow [lindex $allRows [expr {$y + 1}]] + } + for {set x 0} {$x < $width } {incr x} { + #set topIdx [lindex $topRow $x] + set topRgb [lindex $topRow $x] + set tR [lindex $topRgb 0] + set tG [lindex $topRgb 1] + set tB [lindex $topRgb 2] + if {$hasBottom} { + #set bottomIdx [lindex $bottomRow $x] + set bottomRgb [lindex $bottomRow $x] + set bR [lindex $bottomRgb 0] + set bG [lindex $bottomRgb 1] + set bB [lindex $bottomRgb 2] + } else { + set bR 0 + set bG 0 + set bB 0 + } + foreach v {bR bG bB tR tG tB} { + if {[set $v] eq ""} { + set $v 0 + } + } + append outputBuffer [format "\x1b\[38\;2\;%d\;%d\;%dm\x1b\[48\;2\;%d\;%d\;%dm▄" $tR $tG $tB $bR $bG $bB] + } + append outputBuffer "\x1b\[m\n" ;# Reset row styling + } + + return $outputBuffer + } + + proc pngfileToAnsi {filename} { + set f [open $filename rb] + set pngdata [read $f] + close $f + return [pngdataToAnsi $pngdata] + } + +} tcl::namespace::eval punk::ansi::internal { proc splitn {str {len 1}} { #from textutil::split::splitn diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/ansi/sauce-0.1.0.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/ansi/sauce-0.1.0.tm index e7428d84..0d3b53de 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/ansi/sauce-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/ansi/sauce-0.1.0.tm @@ -39,32 +39,35 @@ tcl::namespace::eval punk::ansi::sauce { proc from_file {fname} { if {[file size $fname] < 128} { - return + return [dict create posn -1] } set fd [open $fname r] chan conf $fd -translation binary chan seek $fd -128 end + set sauce_block_posn [expr {[chan tell $fd] -1}] ;#entire sauce block including ctrl-z and any comments - initial value assuming no comments + #If we treat the ctrl-z (\x1a) as part of the sauce - actual start of entire sauce info is 1 before sauce_header_posn, + #or further back if there are comments. set srec [read $fd] set srec_len 128 ;#This is the normal length of a SAUCE record - we may need to set it shorter if truncation detected if {[catch {set sdict [to_dict $srec]}]} { #review - have seen truncated SAUCE records < 128 bytes #we could search for SAUCE00 in the tail and see what records can be parsed? #specifically publicdomain roysac images sometimes only 99 Bytes of sauce - suspect remaining were null \x0 padded and trimmed - set sauceposn [string first SAUCE00 $srec] - if {$sauceposn <= 0} { + set saucestart [string first SAUCE00 $srec] + if {$saucestart <= 0} { close $fd - return + return [dict create posn -1] } #emit something to give user an indication something isn't right puts stderr "punk::ansi::sauce::from_file WARNING SAUCE record seems to be truncated - padding rhs with nulls and trying again.." #SAUCE00 is not at the beginning #pad the tail with nulls and try again - set srec [string range $srec $sauceposn end] + set srec [string range $srec $saucestart end] set srec_len [string length $srec] set srec ${srec}[string repeat \x0 [expr {128 - [string length $srec]}]] if {[catch {set sdict [to_dict $srec]}]} { close $fd - return + return [dict create posn -1] } dict set sdict warning "SAUCE truncation to $srec_len bytes detected" } @@ -73,6 +76,7 @@ tcl::namespace::eval punk::ansi::sauce { #Use srec_len instead of 128 - in case we had truncated source record which we padded and were able to parse set offset [expr {-1 *($srec_len + ($clines * 64) + 5)}] chan seek $fd $offset end + set sauce_block_posn [expr {[chan tell $fd] -1}] ;#entire sauce block including ctrl-z and any comments set tag [chan read $fd 5] if {$tag eq "COMNT"} { #'character' data - shouldn't be null terminated c-style string - but can be @@ -95,6 +99,7 @@ tcl::namespace::eval punk::ansi::sauce { dict set sdict commentlines $commentlines } } + dict set sdict posn $sauce_block_posn close $fd return $sdict } @@ -213,7 +218,9 @@ tcl::namespace::eval punk::ansi::sauce { - + #--------------------------------------------------------------------------------------------------------------------------------------------- + # This data comes from the sauce spec. + #--------------------------------------------------------------------------------------------------------------------------------------------- #todo - fontName - which can also specify e.g code page 437 ## Font name [1] Font size Resolution [2] Aspect ratio [3] Vertical stretch [6] Description ## Display [4] Pixel [5] @@ -221,7 +228,14 @@ tcl::namespace::eval punk::ansi::sauce { set fontnames [dict create] ## IBM VGA 9×16 [7] 720×400 4:3 20:27 (1:1.35) 35% Standard hardware font on VGA cards for 80×25 text mode (code page 437) - dict set fontnames "IBM VGA" [list fontsize "9x16" resolution "720x400" aspect_ratio_display "4:3" aspect_ratio_pixel "20:27 (1:1.35)" vertical_stretch "35%" description "Standard hardware font on VGA cards for 80×25 text mode (code page 437)"] + dict set fontnames "IBM VGA" [list {*}{ + fontsize "9x16" + resolution "720x400" + aspect_ratio_display "4:3" + aspect_ratio_pixel "20:27 (1:1.35)" + vertical_stretch "35%" + description "Standard hardware font on VGA cards for 80×25 text mode (code page 437)" + }] ## IBM VGA ### [8] 9×16 [7] 720×400 4:3 20:27 (1:1.35) 35% Software installed code page font for VGA 80×25 text mode # - where ### is placeholder for 437,720,737 etc @@ -247,6 +261,7 @@ tcl::namespace::eval punk::ansi::sauce { ## C64 PETSCII unshifted 8×8 [10] 320×200 4:3 5:6 (1:1.2) 20% Original Commodore PETSCII font (PET, VIC-20, C64, CBM-II, Plus/4, C16, C116 and C128) in the unshifted mode. Unshifted mode (graphics) only has uppercase letters and additional graphic characters. This is the normal boot font. ## C64 PETSCII shifted 8×8 [10] 320×200 4:3 5:6 (1:1.2) 20% Original PETSCII font in shifted mode. Shifted mode (text) has both uppercase and lowercase letters. This mode is actuated by pressing Shift+Commodore key. ## Atari ATASCII 8×8 [11] 320×192 4:3 4:5 (1:1.25) 25% Original ATASCII font (Atari 400, 800, XL, XE) + #--------------------------------------------------------------------------------------------------------------------------------------------- #expect a 128 Byte sauce record @@ -256,6 +271,7 @@ tcl::namespace::eval punk::ansi::sauce { variable datatypes variable filetypes variable encodings + set warnings [list] if {[string length $saucerecord] != 128} { error "punk::ansi::sauce::to_dict: Unable to interpret data as a SAUCE record - length != 128" } @@ -321,6 +337,8 @@ tcl::namespace::eval punk::ansi::sauce { dict set sdict filetype_name "" } } else { + #how can a byte fail to scan with cu? is this even reachable? + puts stderr "punk::ansi::sauce::to_dict filetype byte failed to scan - setting filetype and filetype_name to empty string byte: [ansistring VIEW -lf 1 [string range $saucerecord 95 95]]" dict set sdict filetype "" dict set sdict filetype_name "" } @@ -417,25 +435,40 @@ tcl::namespace::eval punk::ansi::sauce { 5 { #binarytext #filetype is supposed to represent half the characterwidth (only widths with multiples of 2 can be specified) - #HOWEVER - in the wild we may see width/height specified in tinfo1/tinfo2 with some other value in filetype (eg 1) - #If both tinfo1 and tinfo2 are non zero - we will use them, even though it's not in spec. - set t1 [dict get $sdict tinfo1] - if {$t1 eq ""} { - set t1 0 - } - set t2 [dict get $sdict tinfo2] - if {$t2 eq ""} { - set t2 0 + #HOWEVER - in the wild we may see width/height specified in tinfo1/tinfo2 with some apparently unrelated value in filetype (eg 0 or 1) that doesn't match the intended image dimensions. + #If both tinfo1 and tinfo2 are non zero - we *could* use them, even though it's not in spec. + #An example file (us-used1.bin) has filetype 0 and tinfo1/tinfo2 640/350 + #It's possible tinfo1/tinfo2 represent pixel dimensions for a 'standard' 8x16 font, but this image is 160 columns wide, so we would expect tinfo1 to be 1280. + #The sauce spec seems to indicate we should ignore tinfo1/tinfo2 for binarytext and only use filetype to determine width. + #the default for binarytext is 160 columns. + + #filetype 1 is theoretically possible, representing 2 columns + #in practice we see this value for binarytext images that are definitely not intended to be 2 columns wide. Why? + #is there some assumption that that images are at least a certain width, and filetype has been repurposed to indicate something else? + #The spec would seem to rule out images of a single column due to filetype being half the character width but a value of 0.5 isn't supported. + #It specifically mentions that only even widths up to 510 can be specified. ($filetype * 2 where filetype is 1-255?) + + + #proper mechanism to specify columns for binarytext is the datatype field. + set cols [expr {2*[dict get $sdict filetype]}] + if {$cols == 0} { + lappend warnings "binarytext filetype value of [dict get $sdict filetype] - using binarytext default cols of 160" + #default for binarytext is 160 columns + set cols 160 } - if {$t1 != 0 && $t2 != 0} { + if {$cols == 2 && [dict get $sdict tinfo1] != 0 && [dict get $sdict tinfo2] != 0} { #not to spec - but we will assume these have values for a reason.. - puts stderr "punk::ansi::sauce::to_dict using tinfo1/tinfo2 data for columns/rows (non-compliant SAUCE data)" - dict set sdict columns [expr {2 * $t1}] - dict set sdict rows $t2 + #--------------------------------------------------------------------------------------------------------------------- + #The sample file src/testansi/formatsamples/image/binaryText/test.bin has a filetype 1 and tinfo1 40 and tinfo2 25. + #(similarly ppe-ansi.bin has tinfo1 80 and tinfo2 26) + #They seem to use the 1 in filetype to indicate that the tinfo1/tinfo2 values should be used. + #(The 80 cols wide test.bin binaryText image matches the xbin sample file src/testansi/formatsamples/image/xbin/test.xb which is a more fully specified format using a header) + #--------------------------------------------------------------------------------------------------------------------- + lappend warnings "binarytext filetype of 1 with non-zero tinfo1/tinfo2 - using tinfo1/tinfo2 data for columns/rows (possibly non-conforming SAUCE data - matching observed data in the wild)" + set cols [expr {2 * [dict get $sdict tinfo1]}] + dict set sdict columns $cols + dict set sdict rows [dict get $sdict tinfo2] } else { - #proper mechanism to specify columns for binarytext is the datatype field. - - set cols [expr {2*[dict get $sdict filetype]}] dict set sdict columns $cols #rows must be calculated from file size #rows = (filesize - sauceinfosize)/ filetype * 2 * 2 @@ -447,11 +480,13 @@ tcl::namespace::eval punk::ansi::sauce { } 6 { - #xbin - only filtype is 0 + #xbin - only filetype is 0 #https://web.archive.org/web/20120204063040/http://www.acid.org/info/xbin/x_spec.htm dict set sdict columns [dict get $sdict tinfo1] dict set sdict rows [dict get $sdict tinfo2] dict set sdict fontname [dict get $sdict tinfos] + #Values from sauce record are probably only informational, because xbin has an 11-byte header with width,height,fontsize and flags. + #presumably the header-info should take precedence over all sauce data (? review) } } if {[dict exists $sdict fontname]} { @@ -474,6 +509,9 @@ tcl::namespace::eval punk::ansi::sauce { } } } + if {[llength $warnings]} { + dict set sdict warnings $warnings + } return $sdict } diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args-0.2.1.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args-0.2.1.tm index 1ff7fd37..24c2ddf7 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args-0.2.1.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args-0.2.1.tm @@ -9086,7 +9086,7 @@ tcl::namespace::eval punk::args { } if {!([tcl::string::first " " $a]>=0 || [tcl::string::first \t $a]>=0 || [tcl::string::last \n $a]>=0)} { if {$OPT_ANY} { - #exlude argument with whitespace from being a possible option e.g dict + #exclude argument with whitespace from being a possible option e.g dict #todo - passthrough of unrecognised --longopt=xxx without looking for following flag-value set eposn [string first = $a] if {$eposn > 2 && [string match --* $a]} { diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/char-0.1.0.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/char-0.1.0.tm index 53ef8ec1..349cc3b7 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/char-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/char-0.1.0.tm @@ -3033,14 +3033,18 @@ tcl::namespace::eval punk::char { #This still leaves a whole class of clusters.. korean etc unhandled :/ #todo - tk::startOfCluster / tk::endOfCluster - try to get it brought into Tcl #https://core.tcl-lang.org/tcl/tktview/a4c7eeaf63 - proc grapheme_split {text} { + proc grapheme_split {text {return list}} { #we should treat \r\n as a single grapheme cluster (as tk::endOfCluster does) set components [list] set csplits [combiner_split $text] foreach {pt combiners} [lrange $csplits 0 end-1] { set clist [split $pt ""] - lappend components {*}[lrange $clist 0 end-1] - lappend components [tcl::string::cat [lindex $clist end] $combiners] + #review + #lset clist end [tcl::string::cat [lindex $clist end] $combiners] + ledit clist end end [tcl::string::cat [lindex $clist end] $combiners] + lappend components {*}$clist + #lappend components {*}[lrange $clist 0 end-1] + #lappend components [tcl::string::cat [lindex $clist end] $combiners] } #last csplit never has a combiner (_perlish_split style) - and may be empty - in which case we don't append it as a grapheme if {[lindex $csplits end] ne ""} { @@ -3066,127 +3070,126 @@ tcl::namespace::eval punk::char { #review \uFE0F variation selector 16 - forces emoji presentation for preceding char - if 1 { - #This is a basic implementation that does not check that all combinations are valid. - set graphemes [list] - set current_cluster "" - - set cluster_base 0 ;#is the current cluster based on a char that can be combined with modifiers/ZWJs (e.g emoji or other cluster-based char) - # or is it based on a char that can't be combined with modifiers/ZWJs (e.g ascii letter) - set cluster_base_RI 0 ;#is the current cluster based on a regional indicator char - which can only combine in pairs, and don't combine with modifiers or ZWJs to form longer clusters - so not extensible. - - set current_cluster_is_extensible 0 - for {set i 0} {$i < [llength $components] } {incr i} { - set component [lindex $components $i] - if {$component eq "\r" && [lindex $components $i+1] eq "\n"} { - if {$current_cluster ne ""} { - lappend graphemes $current_cluster - } - lappend graphemes "\r\n" - incr i ;#skip the \n as we've already processed it as part of the cluster - set current_cluster "" - grapheme_split::reset_base + #This is a basic implementation that does not check that all combinations are valid. + set graphemes [list] + set current_cluster "" + + set cluster_base 0 ;#is the current cluster based on a char that can be combined with modifiers/ZWJs (e.g emoji or other cluster-based char) + # or is it based on a char that can't be combined with modifiers/ZWJs (e.g ascii letter) + set cluster_base_RI 0 ;#is the current cluster based on a regional indicator char - which can only combine in pairs, and don't combine with modifiers or ZWJs to form longer clusters - so not extensible. + + set current_cluster_is_extensible 0 + for {set i 0} {$i < [llength $components] } {incr i} { + set component [lindex $components $i] + if {$component eq "\r" && [lindex $components $i+1] eq "\n"} { + if {$current_cluster ne ""} { + lappend graphemes $current_cluster + } + lappend graphemes "\r\n" + incr i ;#skip the \n as we've already processed it as part of the cluster + set current_cluster "" + set cluster_base 0; set cluster_base_RI 0 ;#grapheme_split::reset_base + set current_cluster_is_extensible 0 + } elseif {$component eq "\u200d"} { + if {$current_cluster eq ""} { + #ZWJ at start of string - treat as separate grapheme cluster - but isn't a valid base for further combining with more ZWJs or modifiers + set current_cluster $component + set cluster_base 0; set cluster_base_RI 0 ;#grapheme_split::reset_base set current_cluster_is_extensible 0 - } elseif {$component eq "\u200d"} { - if {$current_cluster eq ""} { - #ZWJ at start of string - treat as separate grapheme cluster - but isn't a valid base for further combining with more ZWJs or modifiers - set current_cluster $component - grapheme_split::reset_base - set current_cluster_is_extensible 0 - } else { - if {$cluster_base} { - if {$current_cluster_is_extensible} { - #a double (or longer) ZWJ sequence in a row is part of the last cluster - but not extensible anymore. - append current_cluster $component - set current_is_cluster_extensible 0 - } else { - append current_cluster $component - if {$cluster_base_RI} { - #regional indicators can only combine in pairs, and don't combine with modifiers or ZWJs to form longer clusters - so not extensible. - grapheme_split::reset_base - set current_cluster_is_extensible 0 - #we can keep adding ZWJs or modifiers though - } else { - set current_cluster_is_extensible 1 - } - } + } else { + if {$cluster_base} { + if {$current_cluster_is_extensible} { + #a double (or longer) ZWJ sequence in a row is part of the last cluster - but not extensible anymore. + append current_cluster $component + set current_is_cluster_extensible 0 } else { - #ZWJ after non-cluster-based char - non extensible but we continue appending ZWJs to the current cluster. append current_cluster $component - set current_cluster_is_extensible 0 - } - - } - } elseif {[regexp {[\U1f3fb-\U1f3ff]} $component]} { - #emoji modifier - join with previous component - if {$current_cluster eq ""} { - #modifier at start of string - not a valid base for further combining with more modifiers or ZWJs - but we continue appending modifiers to the current cluster. - set current_cluster $component - grapheme_split::reset_base - } else { - if {$cluster_base} { - if {$current_cluster_is_extensible} { - append current_cluster $component - #invalidate the base! - grapheme_split::reset_base + if {$cluster_base_RI} { + #regional indicators can only combine in pairs, and don't combine with modifiers or ZWJs to form longer clusters - so not extensible. + set cluster_base 0; set cluster_base_RI 0 ;#grapheme_split::reset_base + set current_cluster_is_extensible 0 + #we can keep adding ZWJs or modifiers though } else { - append current_cluster $component + set current_cluster_is_extensible 1 } + } + } else { + #ZWJ after non-cluster-based char - non extensible but we continue appending ZWJs to the current cluster. + append current_cluster $component + set current_cluster_is_extensible 0 + } + + } + } elseif {[regexp {[\U1f3fb-\U1f3ff]} $component]} { + #emoji modifier - join with previous component + if {$current_cluster eq ""} { + #modifier at start of string - not a valid base for further combining with more modifiers or ZWJs - but we continue appending modifiers to the current cluster. + set current_cluster $component + set cluster_base 0; set cluster_base_RI 0 ;#grapheme_split::reset_base + } else { + if {$cluster_base} { + if {$current_cluster_is_extensible} { + append current_cluster $component + #invalidate the base! + set cluster_base 0; set cluster_base_RI 0 ;#grapheme_split::reset_base } else { - #modifier after non-cluster-based char - non extensible but we continue appending modifiers to the current cluster. append current_cluster $component } - #review - # \u1f33e\u1f3fe\u200d\u2f3fe\u200d\u1f33e is 2 clusters - #This is because after first zwj, we applied a modifier - not a valid base. + } else { + #modifier after non-cluster-based char - non extensible but we continue appending modifiers to the current cluster. + append current_cluster $component } - set current_cluster_is_extensible 0 + #review + # \u1f33e\u1f3fe\u200d\u2f3fe\u200d\u1f33e is 2 clusters + #This is because after first zwj, we applied a modifier - not a valid base. + } + set current_cluster_is_extensible 0 + } else { + if {$current_cluster eq ""} { + grapheme_split::start_cluster $component } else { - if {$current_cluster eq ""} { - grapheme_split::start_cluster $component - } else { - #have existing cluster data - if {$current_cluster_is_extensible} { - #assert - if current_cluster_is_extensible then cluster_base should currently be true. - #if the current char is a base - we can append to existing cluster, but if it's not a base, then we start a new cluster even if we had seen a ZWJ before. - if {[regexp {[\U1f600-\U1f64f\U1f300-\U1f5ff\U1f900-\U1f9ff\U1fa70-\U1faff\U1f680-\U1f6ff\U2700-\U27bf\U2600-\u26ff]} $component]} { - append current_cluster $component - set cluster_base 1 - } else { - lappend graphemes $current_cluster - set current_cluster $component - grapheme_split::reset_base - } - set current_cluster_is_extensible 0 - } elseif {$cluster_base_RI} { - #regional indicators can only combine in pairs, and don't combine with modifiers or ZWJs to form longer clusters - so not extensible. - if {[regexp {[\U1f1e6-\U1f1ff]} $component]} { - append current_cluster $component - - #invalidate the base - we can't combine more than 2 RIs in a cluster, and they don't combine with modifiers or ZWJs to form longer clusters. - #we can however add more ZWJs or modifiers to the cluster - but they don't make it extensible for combining with more RIs - grapheme_split::reset_base - } else { - #something else while RI cluster is open - end the current cluster and start a new one with the current char. - lappend graphemes $current_cluster - grapheme_split::start_cluster $component - } - set current_cluster_is_extensible 0 + #have existing cluster data + if {$current_cluster_is_extensible} { + #assert - if current_cluster_is_extensible then cluster_base should currently be true. + #if the current char is a base - we can append to existing cluster, but if it's not a base, then we start a new cluster even if we had seen a ZWJ before. + if {[regexp {[\U1f600-\U1f64f\U1f300-\U1f5ff\U1f900-\U1f9ff\U1fa70-\U1faff\U1f680-\U1f6ff\U2700-\U27bf\U2600-\u26ff]} $component]} { + append current_cluster $component + set cluster_base 1 + } else { + lappend graphemes $current_cluster + set current_cluster $component + set cluster_base 0; set cluster_base_RI 0 ;#grapheme_split::reset_base + } + set current_cluster_is_extensible 0 + } elseif {$cluster_base_RI} { + #regional indicators can only combine in pairs, and don't combine with modifiers or ZWJs to form longer clusters - so not extensible. + if {[regexp {[\U1f1e6-\U1f1ff]} $component]} { + append current_cluster $component + + #invalidate the base - we can't combine more than 2 RIs in a cluster, and they don't combine with modifiers or ZWJs to form longer clusters. + #we can however add more ZWJs or modifiers to the cluster - but they don't make it extensible for combining with more RIs + set cluster_base 0; set cluster_base_RI 0 ;#grapheme_split::reset_base } else { + #something else while RI cluster is open - end the current cluster and start a new one with the current char. lappend graphemes $current_cluster grapheme_split::start_cluster $component } + set current_cluster_is_extensible 0 + } else { + lappend graphemes $current_cluster + grapheme_split::start_cluster $component } } } - if {$current_cluster ne ""} { - lappend graphemes $current_cluster - } + } + if {$current_cluster ne ""} { + lappend graphemes $current_cluster + } + if {$return eq "list"} { + return $graphemes } else { - set graphemes $components + return [dict create list $graphemes last_extensible $current_cluster_is_extensible base $cluster_base RI_base $cluster_base_RI] } - - return $graphemes } namespace eval grapheme_split { proc about {} { diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/console-0.1.1.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/console-0.1.1.tm index b7c4cd7a..913e09ac 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/console-0.1.1.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/console-0.1.1.tm @@ -71,11 +71,6 @@ package require punk::args -#if {"windows" eq $::tcl_platform(platform)} { -# #package require zzzload -# #zzzload::pkg_require twapi -#} - #see https://learn.microsoft.com/en-us/windows/console/classic-vs-vt #https://learn.microsoft.com/en-us/windows/console/creating-a-pseudoconsole-session diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/du-0.1.0.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/du-0.1.0.tm index 8dd91089..ca7f58e9 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/du-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/du-0.1.0.tm @@ -2529,21 +2529,30 @@ namespace eval punk::du { #jmn disable twapi #tailcall du_dirlisting_generic $folderpath {*}$args - package require zzzload - set loadstate [zzzload::pkg_require twapi] - - if {$loadstate ni [list loading failed]} { - #either already loaded by zzload or ordinary package require - package require twapi ;#should be fast once twapi dll loaded in zzzload thread + #package require zzzload + #set loadstate [zzzload::pkg_require twapi] + + #if {$loadstate ni [list loading failed]} { + # #either already loaded by zzload or ordinary package require + # package require twapi ;#should be fast once twapi dll loaded in zzzload thread + # set ::punk::du::has_twapi 1 + # punk::du::active::set_active_function du_dirlisting du_dirlisting_twapi + # tailcall du_dirlisting_twapi $folderpath {*}$args + #} else { + # if {$loadstate eq "failed"} { + # puts stderr "punk::du defaulting to du_dirlisting_generic because twapi load failed" + # punk::du::active::set_active_function du_dirlisting du_dirlisting_generic + # } + # tailcall du_dirlisting_generic $folderpath {*}$args + #} + if {[catch {package require twapi} errM]} { + puts stderr "punk::du defaulting to du_dirlisting_generic because twapi load failed: $errM" + punk::du::active::set_active_function du_dirlisting du_dirlisting_generic + tailcall du_dirlisting_generic $folderpath {*}$args + } else { set ::punk::du::has_twapi 1 punk::du::active::set_active_function du_dirlisting du_dirlisting_twapi tailcall du_dirlisting_twapi $folderpath {*}$args - } else { - if {$loadstate eq "failed"} { - puts stderr "punk::du defaulting to du_dirlisting_generic because twapi load failed" - punk::du::active::set_active_function du_dirlisting du_dirlisting_generic - } - tailcall du_dirlisting_generic $folderpath {*}$args } } default { diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/lib-0.1.6.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/lib-0.1.6.tm index ada0f900..5fecb48d 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/lib-0.1.6.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/lib-0.1.6.tm @@ -138,36 +138,29 @@ tcl::namespace::eval punk::lib::check { if {"windows" ne $::tcl_platform(platform)} { set bug 0 } else { - if {![catch {file tempdir} tmpdir]} { - #tcl 9+ has 'file tempdir' - set testfile [file join $tmpdir "bugtest"] - } else { - #fallback for older tcl versions - use env TEMP/TMP or current directory - set tmpdir "" - foreach e {TEMP TMP} { - if {[info exists ::env($e)] && [file isdirectory ::env($e)]} { - set tmpdir ::env($e) + set tmpdir [punk::lib::tempdir_newfolder] ;#uses 'file tempdir' on tcl9+ or fallback to env vars or current directory on older versions + set testfile [file join $tmpdir "bugtest"] + + try { + set fd [open $testfile w] + puts $fd test + close $fd + set globresult [glob -nocomplain -directory $tmpdir -types f -tail BUGTEST {BUGTES{T}} {[B]UGTEST} {\BUGTEST} BUGTES? BUGTEST*] + if {[file exists $testfile]} { + file delete $testfile + } + foreach r $globresult { + if {$r ne "bugtest"} { + set bug 1 break } } - if {$tmpdir eq ""} { - #no env vars - fallback to current directory - set tmpdir [pwd] + } finally { + if {[file exists $testfile]} { + file delete $testfile } - set testfile [file join $tmpdir "bugtest"] - } - - set fd [open $testfile w] - puts $fd test - close $fd - set globresult [glob -nocomplain -directory $tmpdir -types f -tail BUGTEST {BUGTES{T}} {[B]UGTEST} {\BUGTEST} BUGTES? BUGTEST*] - if {[file exists $testfile]} { - file delete $testfile - } - foreach r $globresult { - if {$r ne "bugtest"} { - set bug 1 - break + if {[file exists $tmpdir]} { + file delete -force $tmpdir } } } @@ -679,7 +672,207 @@ namespace eval punk::lib { } } + namespace eval argdoc { + variable PUNKARGS + lappend PUNKARGS [list { + @id -id ::punk::lib::tempdir + @cmd -name punk::lib::tempdir\ + -summary\ + "Determine an appropriate temp dir for the process we are running under."\ + -help\ + "On windows: + If the process is running under the system account use the modern windows location: %SystemRoot%\SystemTemp + Detection of the system account relies on either twapi, or a combination of the whoami command and the + registry package. + Proceeds with same fallback logic as for other platforms if we fail to detect the system account or its temp location. + + + For other platforms we use the environment variables TMPDIR/TEMP/TMP or fallback to /tmp or /var/tmp if those + env vars aren't set or aren't writable directories. + + Final fallback attempt is the current working directory. + Result is normalized so resulting path will have forward slashes on all platforms. + + Alternatives: see the tcllib fileutil::tempdir function. + " + @values -min 0 -max 0 + }] + } + proc tempdir {} { + set trydirs [list] + if {"windows" eq $::tcl_platform(platform)} { + #review. + #consider also checking for whether running under various service accounts + + if {![catch {package require twapi}]} { + set tok [twapi::open_process_token] ;#first call is a little pricy. + set sid [twapi::get_token_user $tok] + if {$sid eq "S-1-5-18"} { + #system account - use system account temp location + set sysroot [twapi::get_shell_folder csidl_windows] ;#first call is a little pricy. + lappend trydirs [file join $sysroot "SystemTemp"] + } + #if not system account - use env vars as first choice. + } else { + #twapi not available - try to use builtin windows whoami to detect if we're running under system account - but this is less reliable than using twapi to check the process token - so we warn about it. + set whoami_exe [auto_execok whoami] + #test that system32 is somewhere in the whoami path as a basic attempt to avoid non-windows whoami commands that might be present in the path + set whoami_exe_parts [file split $whoami_exe] + if {"system32" in [string tolower $whoami_exe_parts]} { + set whoamiresult [string trim [exec {*}$whoami_exe /USER /FO LIST] \n\r] + set whoamiresult [string map {\r\n \n} $whoamiresult] + set whoamiresult_lines [split $whoamiresult \n] + set sid "" + foreach line $whoamiresult_lines { + if {[string match "SID:*" $line]} { + set sid [lindex $line 1] + break + } + } + set has_registry [expr {![catch {package require registry}]}] + if {$sid eq "S-1-5-18"} { + #system account - use system account temp location + set sysroot "" + if {$has_registry} { + #registry path is case-insensitive. + catch { + set sysroot [registry get {HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows NT\CurrentVersion} SystemRoot] + } + } else { + if {[info exists ::env(SystemRoot)]} { + set sysroot [set ::env(SystemRoot)] + } + } + if {$sysroot ne ""} { + lappend trydirs [file join $sysroot "SystemTemp"] + } + } + #if not system account - use env vars as first choice. + } + } + } + + foreach t {TMPDIR TEMP TMP} { + #TMPDIR is the posix standard as first choice for temp dir env var. + if {[info exists ::env($t)]} { + lappend trydirs $::env($t) + } + } + + if {"windows" ne $::tcl_platform(platform)} { + #suitable for macos,linux and freebsd at least. + lappend trydirs [file join / tmp] [file join / var tmp] + #/usr/tmp is probably not a common location for a temp dir on modern unix-based systems. + } + + foreach d $trydirs { + if {[file isdirectory $d] && [file writable $d]} { + return [file normalize $d] + } + } + + #only even call 'pwd' as a last resort (mildly slow on first call). + set cwd [pwd] + if {[file isdirectory $cwd] && [file writable $cwd]} { + return $cwd + } + + return -code error "punk::lib::tempdir unable to determine a suitable temp directory - tried: $trydirs" + } + + namespace eval argdoc { + variable PUNKARGS + lappend PUNKARGS [list { + @id -id ::punk::lib::tempdir_newfolder + @cmd -name punk::lib::tempdir_newfolder\ + -summary\ + "Create unique folder within temp dir (or cwd as last resort)"\ + -help\ + "Creates a new unique folder within the temp dir determined by punk::lib::tempdir. + The folder is created before returning its full path and will be empty. + The folder is named with a tcl_ prefix followed by a random string. + + See also: 'file tempdir' in tcl 9+ or fileutil::maketempdir from tcllib" + @opts + -dir -type string -default "" -help\ + "Base directory to create the temp folder in - defaults to the result of punk::lib::tempdir" + -prefix -type string -default tcl -help\ + "Prefix for the temp folder name + An underscore is automatically appended to the prefix in the generated folder name. + If prefix is the empty string - then the generated folder name will still be autoprefixed + with tcl_ (consistent with tcl9 'file tempdir')" + @values -min 0 -max 0 + }] + } + proc tempdir_newfolder {args} { + set argd [punk::args::parse $args withid ::punk::lib::tempdir_newfolder] + set opt_dir [dict get $argd opts -dir] + set opt_prefix [dict get $argd opts -prefix] + puts "opt_prefix: $opt_prefix" + if {[llength [file split $opt_prefix]] > 1} { + error "punk::lib::tempdir_newfolder -prefix option should not contain any path separators" + } + if {$opt_prefix eq ""} { + #don't allow empty prefix - for consistency with tcl9 'file tempdir' - which would still prefix with 'tcl_' even if prefix is empty string. + set opt_prefix "tcl" + } + + if {$opt_dir ne ""} { + if {[file isdirectory $opt_dir] && [file writable $opt_dir]} { + set tmpbase [file normalize $opt_dir] + } else { + error "punk::lib::tempdir_newfolder -dir option '$opt_dir' is not a writable directory" + } + } else { + set tmpbase [punk::lib::tempdir] ;#will raise an error if no writable temp dir or cwd found. + } + #assert: tmpbase has no trailing slash - unless it is a root dir (e.g / on unix, or C:/ on windows) + #assert: tmpbase is normalized with forward slashes on all platforms. + + set tcl9_template_base [string trimright $tmpbase "/"] ;#set it to a form that can join along with a forward slash to prefix for tcl 9 'file tempdir' style template. + #tcl9 'file tempdir' separates the prefix in the template from the random string with an underscore. + #now form template by always joining with a slash (even if opt_prefix is empty) + #(avoiding file join and file normalize to ensure template is properly formed) + #whether or not opt_prefix ends with an underscore - another will be added. (by file tempdir, or by our own code if tcl9 'file tempdir' isn't available) + #assert: opt_prefix is not empty string (will have defaulted to 'tcl') and does not contain any path separators. + set tcl9_template "$tcl9_template_base/$opt_prefix" + + + #tcl 9+ has 'file tempdir' + #we don't support the same template as 'file tempdir' + if {[catch {file tempdir $tcl9_template} tmpdir]} { + + set prefix tcl_ ;#todo - accept option: -prefix + + set chars abcddefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789 + set nrand_chars 8 + set maxtries 100 + for {set i 0} {$i < $maxtries} {incr i} { + set dirname ${opt_prefix}_ ;#always add underscore for consistency with tcl9 'file tempdir'. + for {set j 0} {$j < $nrand_chars} {incr j} { + append dirname [string index $chars [expr {int(rand()*62)}]] + } + set path [file join $tmpbase $dirname] + if {[file exists $path]} { + continue + } + if {[catch { + file mkdir $path + if {"windows" ne $::tcl_platform(platform)} { + file attributes $path -permissions 0o700 + } + }]} { + continue + } + return $path + } + return -code error "punk::lib::tempdir_newfolder unable to create unique tempdir in $tmpbase after $maxtries attempts - too many collisions - aborting" + } + #tcl 9 'file tempdir' return. + #normalize because on early tcl 9 versions on windows it can return with mixed forward and backward slashes when a template is supplied with forward slashes. + return [file normalize $tmpdir] + } # == == == == == == == == == == == == == == == == == == == == == == == == == == == == == == == # Maintenance - This is the primary source for tm_version... functions @@ -814,6 +1007,89 @@ namespace eval punk::lib { error "tm_version_required_canonical should have already returned a canonicalised versionspec - or produced an error with reason before this point" } } + proc tm_version_magic {} { + #maintenance instruction: + # This specific 12 character nnnnnn.0a1.0 version number is used in text replacement when installing modules. + # It should not be modified without also considering the impact on existing projects based on punkshell that may have used this version number in their own code or documentation as a placeholder for tm version handling. + # A copy of this is also present in punk::lib. + # Essentially this should probably never be changed - and instead deprecated if we want to stop using it and replaced with a different mechanism/placeholder. + + #tm versioning is not quite the same as semantic versioning - but similarly we should see extremely high major version numbers rarely if ever in real use, + #even over decades of development. + set magicbase 999999 ;#deliberately large so given load-preference when testing! + #we split the literal to avoid the literal appearing here - reduce risk of accidentally converting to a release version + return ${magicbase}.0a1.0 + } + + namespace eval argdoc { + lappend PUNKARGS [list { + @id -id ::punk::lib::tm_split_name + @cmd -name punk::lib::tm_split_name\ + -summary\ + "Split a versioned module name into name and version parts, dropping trailing .tcl/.tm if any."\ + -help\ + "Splits a versioned module name (as present in a filename or namespaced name) into name and version parts, + Ignores any trailing .tm or .tcl file extension. + + If the fullmodulename given is a namespaced name - then the returned modulename will also be namespaced, + but with any leading :: removed. + + Returns a two element list - with the first element being the modulename and the second element being the version. + + Tcl module version numbers are understood with leading zeros in each dotted part, but leading zeros are not canonical. + + This split does not canonicalise the version number. + If the last dash-separated segment of the name doesn't look like a valid version number + - then it is treated as part of the modulename and an empty version string is returned. + e.g + mymod-1.2.3.tm -> mymod 1.2.3 + mymod-1aa2.3.tm -> mymod-1aa2.3 {} + (repeated a is not a valid version segment - so the entire '1aa2.3' is treated as part of the modulename) + + see also: tm_version_canonical + " + @values -min 1 -max 1 + fullmodulename -type string -help\ + "The full module name to split - as present in a filename or namespaced name. E.g: + mymod-1.2.3 + mymod-1.2.3.tm + mymod-1.2.3.tcl + /some/where/mymod-123.0a4.0.tm + mymod + mymod.tm + mymod.tcl + ns1::ns2::mymod-1.2.3 + ::ns1::ns2::mymod" + }] + } + proc tm_split_name {fullmodulename} { + #split modulename (as present in a filename or namespaced name) into name/version ignoring leading namespace path + #ignore trailing .tm .TM if present + #if version doesn't pass validation - treat it as part of the modulename and return empty version string without error + #Up to caller to validate. + set lastpart [namespace tail $fullmodulename] + set lastpart [file tail $lastpart] ;# should be ok to use file tail now that we've ensured no namespace components + if {[string tolower [file extension $fullmodulename]] in {.tcl .tm}} { + set fileparts [split [file rootname $lastpart] -] + } else { + set fileparts [split $lastpart -] + } + if {[tm_version_isvalid [lindex $fileparts end]]} { + set versionsegment [lindex $fileparts end] + set namesegment [join [lrange $fileparts 0 end-1] -];#re-stitch + } else { + set namesegment [join $fileparts -] + set versionsegment "" + } + set base [string trimleft [namespace qualifiers $fullmodulename] :] + if {$base ne ""} { + set modulename "${base}::$namesegment" + } else { + set modulename $namesegment + } + return [list $modulename $versionsegment] + } + # end tm_version... functions # == == == == == == == == == == == == == == == == == == == == == == == == == == == == == == == @@ -4210,6 +4486,9 @@ namespace eval punk::lib { if {[string index $key 0] ne "%"} { set key %$key } + #puts "---key:'$key'" + set key [string map {; \\;} $key] ;#review + #puts "---key:'$key'" #pipeline - use punk patterns. % thisval.= $key= $thisval } diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/cli-0.3.1.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/cli-0.3.1.tm index 793736b8..6ac3cc1e 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/cli-0.3.1.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/cli-0.3.1.tm @@ -499,7 +499,7 @@ namespace eval punk::mix::cli { # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- set opt_punkcheck_eventobj [dict get $opts -punkcheck_eventobj] - set magicversion [punk::mix::util::magic_tm_version] ;#deliberately large so given load-preference when testing + set magicversion [punk::mix::util::tm_version_magic] ;#deliberately large so given load-preference when testing set module_list [list] if {[file tail [file dirname $srcdir]] ne "src"} { diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/commandset/loadedlib-0.1.0.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/commandset/loadedlib-0.1.0.tm index a07aca09..2cc6ff98 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/commandset/loadedlib-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/commandset/loadedlib-0.1.0.tm @@ -54,13 +54,18 @@ namespace eval punk::mix::commandset::loadedlib { if {$opt_refresh} { catch {package require frobznodule666} ;#ensure pkg system has loaded/searched for everything REVIEW - this doesn't result in full scans foreach tm_path [tcl::tm::list] { + #review - todo - adjust punk::path::subfolders to take arguments to do some filtering itself rather than recurse down unnecessary branches. set paths_below [punk::path::subfolders -recursive $tm_path] foreach folder $paths_below { + if {[string match */_build/* $folder]} {continue} set tail [file tail $folder] - if {[string match #modpod-* $tail] || [string match #tarjar-* $tail]} { + if {[string match #tarjar-* $tail]} { + continue + } + if {[string match #modpod-* $tail]} { + #manually do a 'package ifneeded' fore each module found here. continue } - if {[string match */_build/* $folder]} {continue} set relpath [string tolower [punk::path::relative $tm_path $folder]] set modpath [string map {/ ::} $relpath] catch {package require ${modpath}::flobrudder99} diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/commandset/module-0.1.0.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/commandset/module-0.1.0.tm index 4c75b10e..3626d2d0 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/commandset/module-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/commandset/module-0.1.0.tm @@ -362,7 +362,7 @@ namespace eval punk::mix::commandset::module { file mkdir $modulefolder set moduletail [namespace tail $modulename] - set magicversion [punk::mix::util::magic_tm_version] ;#deliberately large so given load-preference when testing + set magicversion [punk::mix::util::tm_version_magic] ;#deliberately large so given load-preference when testing diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/commandset/project-0.1.0.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/commandset/project-0.1.0.tm index 8384197a..9b1263e3 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/commandset/project-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/commandset/project-0.1.0.tm @@ -380,25 +380,25 @@ namespace eval punk::mix::commandset::project { puts stdout ">>> about to call punkcheck::install $layout_path $projectdir" set resultdict [dict create] - set antipaths [list\ - src/doc/*\ - src/doc/include/*\ - src/PROJECT_LAYOUTS_*\ - ] - - #set antiglob_dir [list\ - # _ignore_*\ - #] - set antiglob_dir [list\ - ] - - #default antiglob_dir_core will stop .fossil* from being updated - which is generally desirable as these are likely to be customized + set antipaths [list {*}{ + src/doc/* + src/doc/include/* + src/PROJECT_LAYOUTS_* + }] + + #set exclude_dirsegments [list {*}{ + # _ignore_* + #}] + set exclude_dirsegments [list {*}{ + }] + + #default -exclude-dirsegments_core will stop .fossil* from being updated - which is generally desirable as these are likely to be customized if {$opt_force} { puts stdout "copying layout files - with force applied - overwrite all-targets" - set resultdict [punkcheck::install $layout_path $projectdir -installer project.new -createempty 1 -overwrite ALL-TARGETS -antiglob_paths $antipaths -antiglob_dir $antiglob_dir] + set resultdict [punkcheck::install $layout_path $projectdir -installer project.new -createempty 1 -overwrite ALL-TARGETS -antiglob_paths $antipaths -exclude-dirsegments $exclude_dirsegments] } else { puts stdout "copying layout files - (if source file changed)" - set resultdict [punkcheck::install $layout_path $projectdir -installer project.new -createempty 1 -overwrite installedsourcechanged-targets -antiglob_paths $antipaths -antiglob_dir $antiglob_dir] + set resultdict [punkcheck::install $layout_path $projectdir -installer project.new -createempty 1 -overwrite installedsourcechanged-targets -antiglob_paths $antipaths -exclude-dirsegments $exclude_dirsegments] } puts stdout [punkcheck::summarize_install_resultdict $resultdict] @@ -412,11 +412,11 @@ namespace eval punk::mix::commandset::project { #target folders .fossil-custom and .fossil-settings may not exist. use -createdir 1 to ensure existence. #In this case we need to override the default dir antiglob - as .fossil-xxx folders need to be installed from template if missing, or if target is uncustomized. - ## default_antiglob_dir_core [list "#*" "_aside" ".git" ".fossil*"] - set override_antiglob_dir_core [list #* _aside .git] + ## default_exclude_dirsegments_core [list "#*" "_aside" ".git" ".fossil*"] + set override_exclude_dirsegments_core [list #* _aside .git] if {[file exists $layout_path/.fossil-custom]} { puts stdout "copying layout src/.fossil-custom files (if target missing or uncustomised)" - set resultdict [punkcheck::install $layout_path/.fossil-custom $projectdir/.fossil-custom -createdir 1 -createempty 1 -punkcheck_folder $projectdir -installer project.new -antiglob_dir_core $override_antiglob_dir_core -overwrite SYNCED-TARGETS] + set resultdict [punkcheck::install $layout_path/.fossil-custom $projectdir/.fossil-custom -createdir 1 -createempty 1 -punkcheck_folder $projectdir -installer project.new -exclude-dirsegments_core $override_exclude_dirsegments_core -overwrite SYNCED-TARGETS] puts stdout [punkcheck::summarize_install_resultdict $resultdict] } else { puts stdout "no .fossil-custom in source template - update not required" @@ -424,7 +424,7 @@ namespace eval punk::mix::commandset::project { if {[file exists $layout_path/.fossil-settings]} { puts stdout "copying layout src/.fossil-settings files (if target missing or uncustomised)" - set resultdict [punkcheck::install $layout_path/.fossil-settings $projectdir/.fossil-settings -createdir 1 -createempty 1 -punkcheck_folder $projectdir -installer project.new -antiglob_dir_core $override_antiglob_dir_core -overwrite SYNCED-TARGETS] + set resultdict [punkcheck::install $layout_path/.fossil-settings $projectdir/.fossil-settings -createdir 1 -createempty 1 -punkcheck_folder $projectdir -installer project.new -exclude-dirsegments_core $override_exclude_dirsegments_core -overwrite SYNCED-TARGETS] puts stdout [punkcheck::summarize_install_resultdict $resultdict] } else { puts stdout "no .fossil-settings in source template - update not required" @@ -470,8 +470,8 @@ namespace eval punk::mix::commandset::project { if {[file exists $projectdir/src/modules]} { foreach m $opt_modules { #check if mod-ver.tm file or #modpod-mod-ver folder exist - set tmfile $projectdir/src/modules/$m-[punk::mix::util::magic_tm_version].tm - set podfile $projectdir/src/modules/#modpod-$m-[punk::mix::util::magic_tm_version]/$m-[punk::mix::util::magic_tm_version].tm + set tmfile $projectdir/src/modules/$m-[punk::mix::util::tm_version_magic].tm + set podfile $projectdir/src/modules/#modpod-$m-[punk::mix::util::tm_version_magic]/$m-[punk::mix::util::tm_version_magic].tm set has_tm [file exists $tmfile] set has_pod [file exists $podfile] diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/util-0.1.0.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/util-0.1.0.tm index 7f55005b..8dbe8feb 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/util-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/util-0.1.0.tm @@ -367,7 +367,16 @@ namespace eval punk::mix::util { } #todo - semver conversion/validation for other systems? - proc magic_tm_version {} { + proc tm_version_magic {} { + #maintenance instruction: + # This specific 12 character nnnnnn.0a1.0 version number is used in text replacement when installing modules. + # It should not be modified without also considering the impact on existing projects based on punkshell that may have used this version number in their own code or documentation as a placeholder for tm version handling. + # A copy of this is also present in punk::lib to aid in dependency management. + # These 2 copies should be kept in sync. + # Essentially this should probably never be changed - and instead deprecated if we want to stop using it and replaced with a different mechanism/placeholder. + + #tm versioning is not quite the same as semantic versioning - but similarly we should see extremely high major version numbers rarely if ever in real use, + #even over decades of development. set magicbase 999999 ;#deliberately large so given load-preference when testing! #we split the literal to avoid the literal appearing here - reduce risk of accidentally converting to a release version return ${magicbase}.0a1.0 diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mod-0.1.1.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mod-0.1.1.tm new file mode 100644 index 00000000..e09ff748 --- /dev/null +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mod-0.1.1.tm @@ -0,0 +1,158 @@ +#punkapps app manager +# deck cli + +namespace eval punk::mod::cli { + namespace export help list run + namespace ensemble create + + # namespace ensemble configure [namespace current] -unknown punk::mod::cli::_unknown + if 0 { + proc _unknown {ns args} { + puts stderr "punk::mod::cli::_unknown '$ns' '$args'" + puts stderr "punk::mod::cli::help $args" + puts stderr "arglen:[llength $args]" + punk::mod::cli::help {*}$args + } + } + + #cli must have _init method - usually used to load commandsets lazily + # + variable initialised 0 + proc _init {args} { + variable initialised + if {$initialised} { + return + } + #... + set initialised 1 + } + + proc help {args} { + set basehelp [punk::mix::base help {*}$args] + #namespace export + return $basehelp + } + proc getraw {appname} { + set app_folders [punk::config::configure running apps] + #todo search each app folder + set bases [::list] + set versions [::list] + set mains [::list] + set appinfo [::list bases {} mains {} versions {}] + + foreach containerfolder $app_folders { + lappend bases $containerfolder + if {[file exists $containerfolder]} { + if {[file exists $containerfolder/$appname/main.tcl]} { + #exact match - only return info for the exact one specified + set namematches $appname + set parts [split $appname -] + } else { + set namematches [glob -nocomplain -dir $containerfolder -type d -tail ${appname}-*] + set namematches [lsort $namematches] ;#todo - -ascii? -dictionary? natsort? + } + foreach nm $namematches { + set mainfile $containerfolder/$nm/main.tcl + set parts [split $nm -] + if {[llength $parts] == 1} { + set ver "" + } else { + set ver [lindex $parts end] + } + if {$ver ni $versions} { + lappend versions $ver + lappend mains $ver $mainfile + } else { + puts stderr "punk::apps::app version '$ver' of app '$appname' already encountered at $mainfile. (will use earliest encountered in running-config apps and ignore others of same version)" + } + } + } else { + puts stderr "punk::apps::app missing apps_folder:'$containerfolder' Ensure apps_folder is set in punk::config" + } + } + dict set appinfo versions $versions + #todo - natsort! + set sorted_versions [lsort $versions] + set latest [lindex $sorted_versions 0] + if {$latest eq "" && [llength $sorted_versions] > 1} { + set latest [lindex $sorted_versions 1] + } + dict set appinfo latest $latest + + dict set appinfo bases $bases + dict set appinfo mains $mains + return $appinfo + } + + proc list {{glob *}} { + set apps_folder [punk::config::configure running apps] + if {[file exists $apps_folder]} { + if {[file exists $apps_folder/$glob]} { + #tailcall source $apps_folder/$glob/main.tcl + return $glob + } + set apps [glob -nocomplain -dir $apps_folder -type d -tail $glob] + if {[llength $apps] == 0} { + if {[string first * $glob] <0 && [string first ? $glob] <0} { + #no glob chars supplied - only launch if exact match for name part + set namematches [glob -nocomplain -dir $apps_folder -type d -tail ${glob}-*] + set namematches [lsort $namematches] ;#todo - -ascii? -dictionary? natsort? + if {[llength $namematches] > 0} { + set latest [lindex $namematches end] + lassign $latest nm ver + #tailcall source $apps_folder/$latest/main.tcl + } + } + } + return $apps + } + } + + #todo - way to launch as separate process + # solo-opts only before appname - args following appname are passed to the app + proc run {args} { + set nameposn [lsearch -not $args -*] + if {$nameposn < 0} { + error "punkapp::run unable to determine application name" + } + set appname [lindex $args $nameposn] + set controlargs [lrange $args 0 $nameposn-1] + set appargs [lrange $args $nameposn+1 end] + + set appinfo [punk::mod::cli::getraw $appname] + if {[llength [dict get $appinfo versions]]} { + set ver [dict get $appinfo latest] + puts stdout "info: $appinfo" + set ::argc [llength $appargs] + set ::argv $appargs + source [dict get $appinfo mains $ver] + if {"-hideconsole" in $controlargs} { + puts stderr "attempting console hide" + #todo - something better - a callback when window mapped? + after 500 {::punkapp::hide_console} + } + return $appinfo + } else { + error "punk::mod::cli unable to run '$appname'. main.tcl not found in [dict get $appinfo bases]" + } + } +} + +namespace eval punk::mod::cli { + proc _cli {args} { + #don't use tailcall - base uses info level to determine caller + ::punk::mix::base::_cli {*}$args + } + variable default_command help + package require punk::mix::base + package require punk::overlay + punk::overlay::custom_from_base [namespace current] ::punk::mix::base +} + +package provide punk::mod [namespace eval punk::mod { + variable version + set version 0.1.1 +}] + + + diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/nav/fs-0.1.0.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/nav/fs-0.1.0.tm index 7d85e311..e0f29d66 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/nav/fs-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/nav/fs-0.1.0.tm @@ -847,7 +847,7 @@ tcl::namespace::eval punk::nav::fs { Regardless of whether -nonportable is supplied or not, some characters are not suitable for windows or most other platforms and will be rejected with an error. - An example of this is the null character (\0)." + An example of this is the null character (\\0)." @values -min 1 -max -1 -type string path -type string -multiple 1 -help\ "Path(s) to create. Can be absolute or relative. diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/ns-0.1.0.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/ns-0.1.0.tm index db6acbb4..ad3cd57e 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/ns-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/ns-0.1.0.tm @@ -721,6 +721,22 @@ tcl::namespace::eval punk::ns { } + punk::args::define { + @id -id ::punk::ns::nstree_list + @cmd -name punk::ns::nstree_list\ + -summary\ + ""\ + -help\ + "" + @leaders + location -type path -optional 0 + @opts + -subnslist -type list -default {} -help\ + "" + -allbelow -type boolean -default 1 -help\ + "" + @values -min 0 -max 0 + } #important: add tests for tricky cases - e.g punk::m**::util vs punk::m*::util vs punk::m*::**::util - these should all be able to return different results depending on namespace structure. #e.g punk::m**::util will return punk::mix::util but punk::m*::**::util will not because punk::mix::util is too short to match. Both will return deeper matches such as: punk::mix::commandset::repo::util proc nstree_list {location args} { @@ -775,13 +791,8 @@ tcl::namespace::eval punk::ns { #set parent [nsprefix $ns_absolute] #set tail [nstail $ns_absolute] - #jjj #set allchildren [lsort [nseval $base [list ::namespace children]]] - #set allchildren [lsort [tcl::namespace::eval $base [list ::namespace children]]] - set allchildren [lsort [nseval $base [list ::namespace children]]] - #puts "->base:$base tailparts:$tailparts allchildren: $allchildren" - #puts "->base:$base tailparts:$tailparts childcount: [llength $allchildren]" #** only significant when it is the trailing part of a segment eg ::**::xxx ::a**::xxx if {[llength $tailparts]} { @@ -790,6 +801,7 @@ tcl::namespace::eval punk::ns { set nslist [nstree_list $base -subnslist {} -allbelow 1] } elseif {[regexp {[*]{2}$} $nextglob]} { set nslist [list] + set allchildren [lsort [nseval $base [list ::namespace children]]] lappend nsmatches {*}[lsearch -all -inline -glob $allchildren [nsjoin ${base} $nextglob]] foreach ch $nsmatches { lappend nslist $ch @@ -799,6 +811,7 @@ tcl::namespace::eval punk::ns { } else { #lsearch with -glob ok even if nextglob has no globchars (no discernable speed diff, and earlier parts may have globchars anyway) set nslist [list] + set allchildren [lsort [nseval $base [list ::namespace children]]] lappend nsmatches {*}[lsearch -all -inline -glob $allchildren [nsjoin ${base} $nextglob]] if {[llength $tailparts] >1 || $allbelow} { foreach ch $nsmatches { @@ -812,6 +825,7 @@ tcl::namespace::eval punk::ns { } } else { #puts "nstree_list: no tailparts base:$base" + set allchildren [lsort [nseval $base [list ::namespace children]]] if {$allbelow} { set nsmatches $allchildren set nslist [list] @@ -2134,8 +2148,8 @@ y" {return quirkykeyscript} tcl::dict::set tinfo($target) procoffset 0 tcl::dict::set tinfo($target) level [expr {[::tcl::info::level]+1}] tcl::dict::set tinfo($target) subcmds 0 - puts "enter: $target -- $args" - puts "frame-2: [::tcl::info::frame -2]" + puts stderr "enter: $target -- $args" + #puts stderr "frame-2: [::tcl::info::frame -2]" set _cmdtrace_disabled false } @@ -2481,7 +2495,7 @@ y" {return quirkykeyscript} set line $traceline dict set linedict $target eval_base $traceline dict set linedict $target eval_offset 1 - puts " step type: proc traceline:$traceline ** $args" + puts " step type: proc traceline:$traceline ** $args\x1b\[m" #puts "** $callinfo" if {[dict exists $callinfo cmd]} { #set cmd [string trim [dict get $callinfo cmd]] ;#raw 'unexpanded' script from the stack frame @@ -2504,8 +2518,8 @@ y" {return quirkykeyscript} set eval_base [dict get $linedict $target eval_base] set eval_offset [dict get $linedict $target eval_offset] set line [expr {$eval_base + ($eval_offset-1) + ($traceline-1)}] - puts "stack-- $callinfo" - puts " step type: eval traceline: $traceline -- " + #puts "stack-- $callinfo" + puts stderr " step type: eval traceline: $traceline -- " if {[dict exists $callinfo cmd]} { #set cmd [string trim [dict get $callinfo cmd]] set cmdlist [lindex $args 0] @@ -2627,6 +2641,8 @@ y" {return quirkykeyscript} }] } proc cmdtrace {args} { + #review - displaying argument values has to be done carefully. Small values are ok, but large lists or dicts can be overwhelming. + #Potentially we could apply some heuristics to truncate or summarise them. package require dictn ;#convenience to allow dictn::incr d {key subkey} variable tinfo array unset tinfo @@ -2676,7 +2692,7 @@ y" {return quirkykeyscript} #if the target command has a leading colon (e.g expr alternative :) we can't put a trace directly on a fully qualified name with a triple colon such as ::: #we will need to evaluate in the namespace foreach {tgt_cmd ns nscmd} $resolved_targets { - puts "tracing target: $tgt_cmd whilst running: $origin $arglist" + puts stderr "tracing target: $tgt_cmd whilst running: $origin $arglist" #::tcl::namespace::eval $ns [list ::trace add execution $nscmd enter [list ::punk::ns::_cmdtrace_enter ::punk::ns::linedict $tgt_cmd]] #::tcl::namespace::eval $ns [list ::trace add execution $nscmd enterstep [list ::punk::ns::_cmdtrace_enterstep ::punk::ns::linedict $tgt_cmd]] diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/overlay-0.1.1.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/overlay-0.1.1.tm new file mode 100644 index 00000000..eff01253 --- /dev/null +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/overlay-0.1.1.tm @@ -0,0 +1,192 @@ + + +package require punk::mix::util +package require punk::args + +tcl::namespace::eval ::punk::overlay { + #based *loosely* on: wiki.tcl-lang.org/page/ensemble+extend + # extend an ensemble-like routine with the routines in some namespace + # + # e.g custom_from_base ::punk::mix::cli ::punk::mix::base + # + proc custom_from_base {routine base} { + if {![tcl::string::match ::* $routine]} { + set resolved [uplevel 1 [list ::tcl::namespace::which $routine]] + if {$resolved eq {}} { + error [list {no such routine} $routine] + } + set routine $resolved + } + set routinens [tcl::namespace::qualifiers $routine] + if {$routinens eq {::}} { + set routinens {} + } + set routinetail [tcl::namespace::tail $routine] + + if {![tcl::string::match ::* $base]} { + set base [uplevel 1 [ + list [tcl::namespace::which namespace] current]]::$base + } + + if {![tcl::namespace::exists $base]} { + error [list {no such namespace} $base] + } + + set base [tcl::namespace::eval $base [ + list [tcl::namespace::which namespace] current]] + + + #while 1 { + # set renamed ${routinens}::${routinetail}_[info cmdcount] + # if {[namespace which $renamed] eq {}} break + #} + + tcl::namespace::eval $routine [ + ::list tcl::namespace::ensemble configure $routine -unknown [ + ::list ::apply {{base ensemble subcommand args} { + ::list ${base}::_redirected $ensemble $subcommand + }} $base + ] + ] + + punk::mix::util::namespace_import_pattern_to_namespace_noclobber ::punk::mix::util::* ${routine}::util + #namespace eval ${routine}::util { + #::namespace import ::punk::mix::util::* + #} + punk::mix::util::namespace_import_pattern_to_namespace_noclobber ${base}::lib::* ${routine}::lib + #namespace eval ${routine}::lib [string map [list $base] { + # ::namespace import ::lib::* + #}] + + tcl::namespace::eval ${routine}::lib [tcl::string::map [list $base $routine] { + if {[tcl::namespace::exists ::lib]} { + ::set current_paths [tcl::namespace::path] + if {"" ni $current_paths} { + ::lappend current_paths + } + tcl::namespace::path $current_paths + } + }] + + tcl::namespace::eval $routine { + ::set exportlist [::list] + ::foreach cmd [tcl::info::commands [tcl::namespace::current]::*] { + ::set c [tcl::namespace::tail $cmd] + if {![tcl::string::match _* $c]} { + ::lappend exportlist $c + } + } + tcl::namespace::export {*}$exportlist + } + + return $routine + } + punk::args::define { + @id -id ::punk::overlay::import_commandset + @cmd -name punk::overlay::import_commandset\ + -summary\ + "Import commands into caller's namespace with optional prefix and separator."\ + -help\ + "Import commands that have been exported by another namespace into the caller's + namespace. Usually a prefix and optionally a separator should be used. + This is part of the punk::mix CLI commandset infrastructure - design in flux. + Todo - .toml configuration files for defining CLI configurations." + @values + prefix -type string + separator -type string -help\ + "A string, usually punctuation, to separate the prefix and the command name + of the final imported command. The value \"::\" is disallowed in this context." + cmdnamespace -type string -help\ + "Namespace from which to import commands. Commands are those that have been exported." + } + #load *exported* commands from cmdnamespace into caller's namespace - prefixing each command with $prefix + #Note: commandset may be imported by different CLIs with different bases *at the same time* + #so we don't make commands from the cli or its base available automatically (will generally require fully-qualified commands to use code from cli/base) + #we do load punk::mix::util::* into the util subnamespace even though the commandset might not be loaded in a cli using punk::mix::base i.e punk::mix::util is a common dependency for CLIs. + #commandsets designed to be used with a specific cli/base may choose to do their own import e.g with util::namespace_import_pattern_to_namespace_noclobber and/or set namespace path if they + #want the convenience of using lib:xxx with commands coming from those packages. + #This won't stop the commandset being used with other cli/bases unless the import is done by looking up the callers namespace. + #The basic principle is that the commandset is loaded into the caller(s) with a prefix + #- but commandsets should explicitly package require if they have any backwards dependencies on cli/base (which they may or may not be loaded into) + proc import_commandset {prefix separator cmdnamespace} { + set bad_seps [list "::"] + if {$separator in $bad_seps} { + error "import_commandset invalid separator '$separator'" + } + if {$prefix in $bad_seps} { + error "import_commandset invalid prefix '$prefix'" + } + if {"$prefix$separator" in $bad_seps} { + error "import_commandset invalid prefix/separator combination '$prefix$separator'" + } + if {"[string index $prefix end][string index $separator 0]" in $bad_seps} { + error "import_commandset invalid prefix/separator combination '$prefix$separator'" + } + #review - do we allow prefixes/separators such as a::b? + + #namespace may or may not be a package + # allow with or without leading :: + if {[tcl::string::range $cmdnamespace 0 1] eq "::"} { + set cmdpackage [tcl::string::range $cmdnamespace 2 end] + } else { + set cmdpackage $cmdnamespace + set cmdnamespace ::$cmdnamespace + } + + if {![tcl::namespace::exists $cmdnamespace]} { + #only do package require if the namespace not already present + catch {package require $cmdpackage} pkg_load_info + #recheck + if {![tcl::namespace::exists $cmdnamespace]} { + set prov [package provide $cmdpackage] + if {[tcl::string::length $prov]} { + set provinfo "(package $cmdpackage is present with version $prov)" + } else { + set provinfo "(package $cmdpackage not present)" + } + error "punk::overlay::import_commandset supplied namespace '$cmdnamespace' doesn't exist. $provinfo Pkg_load_result: $pkg_load_info Usage: import_commandset prefix separator namespace" + } + } + + punk::mix::util::namespace_import_pattern_to_namespace_noclobber ::punk::mix::util::* ${cmdnamespace}::util + + #let child namespace 'lib' resolve parent namespace and thus util::xxx + tcl::namespace::eval ${cmdnamespace}::lib [tcl::string::map [list $cmdnamespace] { + ::set nspaths [tcl::namespace::path] + if {"" ni $nspaths} { + ::lappend nspaths + } + tcl::namespace::path $nspaths + }] + + set imported_commands [list] + set imported_tails [list] + set nscaller [uplevel 1 [list tcl::namespace::current]] + if {[catch { + #review - noclobber? + tcl::namespace::eval ${nscaller}::temp_import [list tcl::namespace::import ${cmdnamespace}::*] + foreach cmd [tcl::info::commands ${nscaller}::temp_import::*] { + set cmdtail [tcl::namespace::tail $cmd] + if {$cmdtail eq "_default"} { + set import_as ${nscaller}::${prefix} + } else { + set import_as ${nscaller}::${prefix}${separator}${cmdtail} + } + rename $cmd $import_as + lappend imported_commands $import_as + lappend imported_tails [namespace tail $import_as] + } + #make imported commands exported so they are available to the ensemble + tcl::namespace::eval ${nscaller} [list namespace export {*}$imported_tails] + } errM]} { + puts stderr "Error loading commandset $prefix $separator $cmdnamespace" + puts stderr "err: $errM" + } + return $imported_commands + } +} + +package provide punk::overlay [tcl::namespace::eval punk::overlay { + variable version + set version 0.1.1 +}] diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/path-0.1.0.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/path-0.1.0.tm index aff97595..4527dbb2 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/path-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/path-0.1.0.tm @@ -565,10 +565,45 @@ namespace eval punk::path { end]] } + + ## for comparison + #proc nsglob_as_re {glob} { + # #any segment that is not just * must match exactly one segment in the path + # set pats [list] + # foreach seg [nsparts_cached $glob] { + # switch -exact -- $seg { + # "" { + # lappend pats "" + # } + # * { + # #review - ::g*t will not find ::got:it (won't match single inner colon) - this should be fixed + # #lappend pats {[^:]*} + # #negative lookahead + # #any number of chars not followed by ::, followed by any number of non : + # lappend pats {(?:.(?!::))*[^:]*} + # } + # ** { + # lappend pats {.*} + # } + # default { + # set seg [string map {. [.]} $seg] + # if {[regexp {[*?]} $seg]} { + # #set pat [string map [list ** {.*} * {[^:]*} ? {[^:]}] $seg] + # set pat [string map [list ** {.*} * {(?:.(?!::))*[^:]*} ? {[^:]}] $seg] + # lappend pats "$pat" + # } else { + # lappend pats "$seg" + # } + # } + # } + # } + # return "^[join $pats ::]\$" + #} proc pathglob_as_re {pathglob} { #*** !doctools #[call [fun pathglob_as_re] [arg pathglob]] #[para] Returns a regular expression for matching a path to a glob pattern which can contain glob chars *|? in any segment of the path structure + #[para] Does not support square bracket globs or character classes. #[para] ** matches any number of subdirectories. #[para] e.g /etc/**/*.txt will match any .txt files at any depth below /etc (except directly within /etc itself) #[para] e.g /etc/**.txt will match any .txt files at any depth below /etc @@ -589,7 +624,7 @@ namespace eval punk::path { * {lappend pats {[^/]*}} ** {lappend pats {.*}} default { - set seg [string map [list {^ {\^} $ {\$} [} {\[} ( {\(} \{ \\\{ \\ {\\}] $seg] ;#treat regex characters in the input as literals + set seg [string map [list ^ {\^} $ {\$} \[ {\[} \] {\]} ( {\(} ) {\)} \{ \\\{ \\ {\\}] $seg] ;#treat regex characters (or tcl glob square bracket chars) in the input as literals #set seg [string map [list . {[.]}] $seg] set seg [string map {. [.]} $seg] if {[regexp {[*?]} $seg]} { @@ -603,6 +638,52 @@ namespace eval punk::path { } return "^[join $pats /]\$" } + + punk::args::define { + @id -id ::punk::path::globmatchpath + @cmd -name punk::path::globmatchpath\ + -summary\ + "Match path to *|**|? glob patterns"\ + -help\ + "Return a boolean indicating whether the path matches the specialised glob pattern. + A pattern such as /usr/*/bin will match any path that has /usr as the first segment and bin as the third segment, + with any single segment in between. + A pattern such as /usr/**/bin will match any path that has /usr as the first segment and bin as the last segment, + with 1 or more segments in between (so it will not match /usr/bin). + A pattern such as /usr/** will match any path that has /usr as the first segment, with 1 or more segments + following (so it will not match /usr itself). + A pattern such as **/*.txt will match any path that ends with .txt, with 1 or more leading segments + (so it will not match test.txt or .txt). + A pattern such as ** will match any path. + The glob characters * and ? are the only special characters in the pathglob syntax. + - they are treated as glob characters regardless of where they appear in the pathglob string. + Note that this is different from other Tcl glob contexts where square brackets can be used. + The pathglob syntax treats other characters, including square brackets as literals. + For example, the pattern /usr/te?t will match /usr/test and /usr/text but not /usr/texxt, and the pattern /usr/te*t + will match /usr/test, /usr/teat, and /usr/teeeet but not /usr/te/t. + The pathglob syntax does not support escaping of glob characters - any glob characters in the pathglob are treated + as glob characters. For example, the pattern /usr/* will match any path that has /usr as the first segment and any + single segment as the second segment, but there is no way to specify a pattern that matches any path that has /usr + as the first segment and a literal * as the second segment. + Caller must ensure that file separator is forward slash. (e.g use file normalize on windows) + + options: + -nocase 0|1 (default 0 - case sensitive) + If -nocase is not supplied - default to case sensitive *except for driveletter* + ie - the driveletter alone in paths such as c:/etc will still be case insensitive. (ie c:/ETC/* will match C:/ETC/blah but not C:/etc/blah) + Explicitly specifying -nocase 0 will require the entire case to match including the driveletter. + " + @leaders + pathglob -type string -help "glob pattern to match path against. See [fun pathglob_as_re] for syntax of glob patterns" + path -type string -help "path to match against glob pattern" + @opts + -nocase -type boolean -default 0 -help\ + "case insensitive matching (default false - case sensitive) + - except for driveletter on windows which is always case insensitive + unless -nocase 0 is explicitly specified" + @values -min 0 -max 0 + } + # -id proc globmatchpath {pathglob path args} { #*** !doctools #[call [fun globmatchpath] [arg pathglob] [arg path] [opt {option value...}]] @@ -659,349 +740,689 @@ namespace eval punk::path { return $ismatch } punk::args::define { - @id -id ::punk::path::subfolders - @cmd -name punk::path::subfolders\ + @id -id ::punk::path::subfolders1 + @cmd -name punk::path::subfolders1\ -summary\ - "Listing of directories within supplied path."\ + "Listing of directories below supplied path."\ -help\ "List of folders below path. The resulting list is unsorted." @opts -recursive -type none -help\ "" + -exclude-paths -type list -default {} -help\ + "list of path patterns to exclude from results. + May include * and ** path segments e.g /usr/** + A single /*/ will match any single segment in the path, and a single /**/ will match any number of segments in the path. + + e.g to exclude any path with _aside as a segment in the middle: -exclude-paths **/_aside/** + i.e this would exclude /usr/_aside/etc and /usr/x/_aside/etc but not /usr/x/_aside or _aside/etc + + To exclude all paths with _aside as a segment anywhere: -exclude-paths { **/_aside/** **/_aside _aside/**} + " #todo -depth @values -min 0 -max 1 path -type directory -optional 1 -help\ - "Path of folder. If not supplied current directory is used." + "Path of folder. If not supplied current directory is used. + This may be a relative or absolute path. Relative paths are treated as relative to current directory. + When using relative paths - the result will also be relative paths with the same relative prefix. + (e.g if path is ../test - the results will be ../test/subfolder1 ../test/subfolder2 etc) + Patterns in -exclude-paths are matched against the resulting paths + (so should be written to match the same relative prefix if path is relative)" } - proc subfolders {args} { - set argd [punk::args::parse $args withid ::punk::path::subfolders] + + proc subfolders1 {args} { + #NOTE - this algorithm based on omit_only_patterns and prune_base_patterns was suggested by a 2026 AI model - it is apparent to this programmer that it is inadequate for the purpose. + #e.g consider subfolders1 -recursion -exclude {**/vfs/** **/src/**} + #This can still return something like c:/repo/etc/src/vfs - which should be excluded by the pattern **/src/** + #todo - review and fix properly. + set argd [punk::args::parse $args withid ::punk::path::subfolders1] lassign [dict values $argd] leaders opts values received - set do_recursion [dict exists $received -recursive] + set do_recursion [dict exists $received -recursive] + set exclude_paths [dict get $opts -exclude-paths] + if {"**" in $exclude_paths} { + #if ** is in exclude_paths - then we can skip all glob matching and just return empty list + #This is likely user error - so we'll be loud about it for now but will still return empty list rather than erroring. + #If user code is building exclude_paths dynamically - they can check for this case themselves and avoid the call to subfolders1 to suppress this message. + puts stderr "punk::path::subfolders1 Warning - exclude_paths contains '**' - all paths will be excluded" + return [list] + } if {[dict exists $received path]} { set path [dict get $values path] } else { set path [pwd] } - set folders [glob -nocomplain -directory $path -types d *] + + set all_subfolders [glob -nocomplain -directory $path -types d *] + + + #example of expected exclude_paths pattern behaviour when recursion is enabled: + # **/dirname -> omit /x/y/dirname, but still visit /x/y/dirname/* + + # **/dirname/* -> include /x/y/dirname and /x/y/dirname/a/b but omit directories that are a single level below /x/y/dirname such as /x/y/dirname/a + + #c:/** - would exclude all subfolders below c: but not c: itself + + # **/test/** - would exclude any path with test as a segment and all its subfolders + #- but not paths with test as a segment that is the final segment + + set folders [list] + set recurse_subdirs [list] + + foreach f $all_subfolders { + set include_in_results 1 + set allow_recurse 1 + foreach pat $exclude_paths { + set pat_parts [file split $pat] ;#note file split c:/test gives {c:/ test} but file split **/test gives {** test} + #also note that file split on windows treats forward slashes and backslashes the same. + #by using file split, we gain some flexibility in syntax of paths and patterns, + #but lose the ability to use backslashes as escapes to allow literal glob characters in path segments. + #This is almost always a non-issue on windows since * and ? are not valid in path segments there, and is rarely an issue on unix even though + # * and ? are technically valid in path segments, but it is inadvisable there anyway for compatibility with shells etc. + if {[llength $pat_parts] >= 2 && [lindex $pat_parts end] eq "**"} { + set base_pat [file join {*}[lrange $pat_parts 0 end-1]] + if {[globmatchpath $pat $f]} { + set include_in_results 0 + set allow_recurse 0 + } elseif {[globmatchpath $base_pat $f]} { + set allow_recurse 0 + } + } elseif {[globmatchpath $pat $f]} { + set include_in_results 0 + } + if {!$include_in_results && !$allow_recurse} { + break + } + } + if {$include_in_results} { + lappend folders $f + } + if {$allow_recurse} { + lappend recurse_subdirs $f + } + } if {$do_recursion} { - foreach subdir $folders { - lappend folders {*}[subfolders -recursive $subdir] + foreach subdir $recurse_subdirs { + lappend folders {*}[subfolders1 -exclude-paths $exclude_paths -recursive $subdir] } } return $folders } - #todo - treefolders with similar search caps as treefilenames + namespace eval subfolder_priv { + proc classify_exclude_pattern {pat} { + set parts [file split $pat] + if {[llength $parts] >= 2 && [lindex $parts end] eq "**"} { + set boundary_pat [file join {*}[lrange $parts 0 end-1]] + return [dict create \ + pattern $pat \ + kind subtree \ + boundary_pat $boundary_pat \ + descend_pat $pat] + } + if {[llength $parts] >= 2 && [lindex $parts end] eq "*"} { + return [dict create \ + pattern $pat \ + kind child_only \ + match_pat $pat] + } + return [dict create \ + pattern $pat \ + kind exact \ + match_pat $pat] + } - punk::args::define { - @id -id ::punk::path::treefilenames - -directory -type directory -help\ - "folder in which to begin recursive scan for files." - -call-depth-internal -default 0 -type integer - -sort -type any -default natural -choices {none ascii dictionary natural} - -antiglob_paths -default {} -help\ - "list of path patterns to exclude - may include * and ** path segments e.g - /usr/** (exlude subfolders based at /usr but not - files within /usr itself) - **/_aside (exlude files where _aside is last segment) - **/_aside/* (exclude folders one below an _aside folder) - **/_aside/** (exclude all folders with _aside as a segment)" - -antiglob_files -default {} - @values -min 0 -max -1 -optional 1 -type string - tailglobs -default * -multiple 1 -help\ - "Patterns to match against filename portion (last segment) of each file path - within the directory tree being searched." + proc compile_exclude_rules {exclude_paths} { + set rules [list] + foreach pat $exclude_paths { + lappend rules [classify_exclude_pattern $pat] + } + return $rules + } + + proc match_rule_at_node {rule path} { + set kind [dict get $rule kind] + switch -- $kind { + exact - child_only { + if {[::punk::path::globmatchpath [dict get $rule match_pat] $path]} { + return [dict create include_current 0 recurse_below 1 child_rules [list $rule]] + } + return [dict create include_current 1 recurse_below 1 child_rules [list $rule]] + } + subtree { + set descend_pat [dict get $rule descend_pat] + set boundary_pat [dict get $rule boundary_pat] + if {[::punk::path::globmatchpath $descend_pat $path]} { + return [dict create include_current 0 recurse_below 0 child_rules [list]] + } + if {[::punk::path::globmatchpath $boundary_pat $path]} { + return [dict create include_current 1 recurse_below 0 child_rules [list]] + } + return [dict create include_current 1 recurse_below 1 child_rules [list $rule]] + } + default { + error "Unknown exclude rule kind '$kind'" + } + } + } + + proc walk_subfolders {path rules do_recursion} { + set all_subfolders [glob -nocomplain -directory $path -types d *] + set folders [list] + foreach f $all_subfolders { + set include_current 1 + set recurse_below $do_recursion + set child_rules [list] + foreach rule $rules { + set outcome [match_rule_at_node $rule $f] + if {![dict get $outcome include_current]} { + set include_current 0 + } + if {![dict get $outcome recurse_below]} { + set recurse_below 0 + } + if {$do_recursion} { + lappend child_rules {*}[dict get $outcome child_rules] + } + if {!$include_current && !$recurse_below} { + break + } + } + if {$include_current} { + lappend folders $f + } + if {$do_recursion && $recurse_below} { + lappend folders {*}[walk_subfolders $f $child_rules $do_recursion] + } + } + return $folders + } } - #todo - implement treefiles which acts like dirfiles but allows path globbing in the same way as punk::ns::ns/ - #then review if treefiles can replace dirfiles or if both should exist (dirfiles can have literal glob chars in path segments - but that is a rare usecase) - proc treefilenames {args} { - #*** !doctools - #[call [fun treefilenames] [opt {option value...}] [opt {globpattern...}]] - #[para]basic (glob based) list of filenames matching each pattern in tailglobs - recursive - #[para] options: - #[para] [opt -dir] - #[para] defaults to [lb]pwd[rb] - base path for tree to search - #[para] [opt -antiglob_paths] - #[para] list of path patterns to exclude - may include * and ** path segments e.g /usr/** - #[para]no natsorting - so order is dependent on filesystem + punk::args::define { + @id -id ::punk::path::subfolders + @cmd -name punk::path::subfolders\ + -summary\ + "Listing of directories below supplied path."\ + -help\ + "List of folders below path. + The resulting list is unsorted. + " + @opts + -recursive -type none -help\ + "" + -exclude-paths -type list -default {} -help\ + "list of path patterns to exclude from results. + May include * and ** path segments e.g /usr/** + A single /*/ will match any single segment in the path, and a single /**/ will match any number of segments in the path. - set argd [punk::args::parse $args withid ::punk::path::treefilenames] + e.g to exclude any path with _aside as a segment in the middle: -exclude-paths **/_aside/** + i.e this would exclude /usr/_aside/etc and /usr/x/_aside/etc but not /usr/x/_aside or _aside/etc + + To exclude all paths with _aside as a segment anywhere: -exclude-paths { **/_aside/** **/_aside ./_aside/**} + " + #todo -depth + @values -min 0 -max 1 + path -type directory -optional 1 -help\ + "Path of base folder. If not supplied current directory is used. + This may be a relative or absolute path. Relative paths are treated as relative to current directory. + When using relative paths - the result will also be relative paths with the same relative prefix. + (e.g if path is ../test - the results will be ../test/subfolder1 ../test/subfolder2 etc) + Patterns in -exclude-paths are matched against the resulting paths + (so should be written to match the same relative prefix if path is relative)" + } + + proc subfolders {args} { + set argd [punk::args::parse $args withid ::punk::path::subfolders] lassign [dict values $argd] leaders opts values received - set tailglobs [dict get $values tailglobs] - # -- --- --- --- --- --- --- - set opt_sort [dict get $opts -sort] - set opt_antiglob_paths [dict get $opts -antiglob_paths] - set opt_antiglob_files [dict get $opts -antiglob_files] - set CALLDEPTH [dict get $opts -call-depth-internal] - # -- --- --- --- --- --- --- - # -- --- --- --- --- --- --- - - set files [list] - if {$CALLDEPTH == 0} { - if {$opt_sort eq "natural"} { - package require natsort + set do_recursion [dict exists $received -recursive] + set exclude_paths [dict get $opts -exclude-paths] + if {"**" in $exclude_paths} { + puts stderr "punk::path::subfolders Warning - exclude_paths contains '**' - all paths will be excluded" + return [list] + } + if {[dict exists $received path]} { + set path [dict get $values path] + } else { + set path [pwd] + } + set compiled_rules [subfolder_priv::compile_exclude_rules $exclude_paths] + return [subfolder_priv::walk_subfolders $path $compiled_rules $do_recursion] + } + + namespace eval treefile_priv { + proc _pattern_prefix_viable_parts {pattern_parts path_parts} { + if {![llength $path_parts]} { + return 1 } - #set opts [dict merge $opts [list -directory $opt_dir]] - if {![dict exists $received -directory]} { - set opt_dir [pwd] - } else { - set opt_dir [dict get $opts -directory] + if {![llength $pattern_parts]} { + return 0 } - if {![file isdirectory $opt_dir]} { - return [list] + + set pattern_head [lindex $pattern_parts 0] + set path_head [lindex $path_parts 0] + + if {$pattern_head eq "**"} { + if {[_pattern_prefix_viable_parts [lrange $pattern_parts 1 end] $path_parts]} { + return 1 + } + return [_pattern_prefix_viable_parts $pattern_parts [lrange $path_parts 1 end]] } - } else { - #assume/require to exist in any recursive call - set opt_dir [dict get $opts -directory] + + if {[::punk::path::globmatchpath $pattern_head $path_head]} { + return [_pattern_prefix_viable_parts [lrange $pattern_parts 1 end] [lrange $path_parts 1 end]] + } + return 0 } - #comment out to compare timings with treefilenames_zipfs - if {[string match //zipfs:/* $opt_dir]} { - return [treefilenames_zipfs {*}$args] + proc pattern_prefix_viable {pattern path} { + return [_pattern_prefix_viable_parts [file split $pattern] [file split $path]] } - set skip 0 - foreach anti $opt_antiglob_paths { - if {[globmatchpath $anti $opt_dir]} { - set skip 1 - break + proc pattern_boundary {pattern} { + set parts [file split $pattern] + if {[llength $parts] >= 2 && [lindex $parts end] eq "**"} { + return [file join {*}[lrange $parts 0 end-1]] } - } - if {$skip} { - return [list] + return "" } - #todo - account for vfs where matched path could appear to be a directory but is mounted so could be a desired match? - if {[catch {glob -nocomplain -dir $opt_dir -type f {*}$tailglobs} matches]} { - #we can get for example a permissions error - puts stderr "treefilenames error while listing files in dir $opt_dir\n $matches" - set dirfiles [list] - } else { - set retained [list] - if {[llength $opt_antiglob_files]} { - foreach m $matches { - set skip 0 - set ftail [file tail $m] - foreach anti $opt_antiglob_files { - if {[string match $anti $ftail]} { - set skip 1; break - } - } - if {!$skip} { - lappend retained $m + proc directory_state {glob_paths path inherited_allbelow} { + if {$inherited_allbelow} { + return [dict create include_files 1 recurse_below 1 next_allbelow 1] + } + + set include_files 0 + set recurse_below 0 + set next_allbelow 0 + + foreach gp $glob_paths { + if {[::punk::path::globmatchpath $gp $path]} { + set include_files 1 + set recurse_below 1 + set next_allbelow 1 + break + } + + set boundary [pattern_boundary $gp] + if {$boundary ne "" && [::punk::path::globmatchpath $boundary $path]} { + set recurse_below 1 + set next_allbelow 1 + continue + } + + if {[pattern_prefix_viable $gp $path]} { + set recurse_below 1 + } + } + + return [dict create {*}{ + } include_files $include_files {*}{ + } recurse_below $recurse_below {*}{ + } next_allbelow $next_allbelow {*}{ } + ] + } + + proc child_path_state {glob_paths child_path inherited_allbelow} { + if {$inherited_allbelow} { + return 1 + } + foreach gp $glob_paths { + if {[pattern_prefix_viable $gp $child_path]} { + return 1 } - } else { - set retained $matches } - switch -- $opt_sort { + return 0 + } + + proc _sort_paths {paths sortmode} { + switch -- $sortmode { ascii { - set dirfiles [lsort $retained] + return [lsort $paths] } dictionary { - set dirfiles [lsort -dictionary $retained] + return [lsort -dictionary $paths] } natural { - set dirfiles [natsort::sort $retained] + return [natsort::sort $paths] } default { - set dirfiles $retained + return $paths } } } - lappend files {*}$dirfiles - if {[catch {glob -nocomplain -dir $opt_dir -type d *} dirdirs]} { - puts stderr "treefilenames error while listing subdirs in dir $opt_dir\n $dirdirs" - set dirdirs [list] - } - set okdirs [list] - foreach dir $dirdirs { - set skip 0 - foreach anti $opt_antiglob_paths { - if {[globmatchpath $anti $dir]} { - set skip 1 - break + proc _path_matches_any {patterns path} { + foreach pattern $patterns { + if {[::punk::path::globmatchpath $pattern $path]} { + return 1 } } - if {!$skip} { - lappend okdirs $dir + return 0 + } + + proc _tailbase_relative {tailbase path} { + if {$tailbase eq ""} { + return $path } + return [::punk::path::relative $tailbase $path] } - if {[llength $okdirs]} { - switch -- $opt_sort { - ascii { - set finaldirs [lsort $okdirs] + + proc _tailbase_match_path {tailbase path} { + set match_path [_tailbase_relative $tailbase $path] + if {$match_path eq "."} { + return "" + } + return $match_path + } + + proc _tailbase_relative_list {tailbase paths} { + if {$tailbase eq ""} { + return $paths + } + set relative_paths [list] + foreach path $paths { + lappend relative_paths [_tailbase_relative $tailbase $path] + } + return $relative_paths + } + + proc _retain_files {matches exclude_files sortmode} { + set retained [list] + foreach match $matches { + set skip 0 + set file_tail [file tail $match] + foreach anti $exclude_files { + if {[string match $anti $file_tail]} { + set skip 1 + break + } } - dictionary { - set finaldirs [lsort -dictionary $okdirs] + if {!$skip} { + lappend retained $match } - natural { - set finaldirs [natsort::sort $okdirs] + } + return [_sort_paths $retained $sortmode] + } + + proc _state_from_argd {argd} { + set opts [dict get $argd opts] + set values [dict get $argd values] + set received [dict get $argd received] + + if {[dict exists $received -directory]} { + set directory [dict get $opts -directory] + } else { + set directory [pwd] + } + + set glob_paths [dict get $opts -include-paths] + if {"*" in $glob_paths} { + set glob_paths {*} + } + + set sortmode [dict get $opts -sort] + if {$sortmode eq "natural"} { + package require natsort + } + + return [dict create {*}{ + depth 0 + subvector {} + allbelow 0 + } sort $sortmode {*}{ + } directory $directory {*}{ + } tailbase [dict get $opts -tailbase] {*}{ + } exclude_paths [dict get $opts -exclude-paths] {*}{ + } exclude_files [dict get $opts -exclude-files] {*}{ + } glob_paths $glob_paths {*}{ + } tailglobs [dict get $values tailglobs] {*}{ } - default { - set finaldirs $okdirs + ] + } + + proc walk_treefilenames {state} { + set opt_dir [dict get $state directory] + set opt_tailbase [dict get $state tailbase] + set depth [dict get $state depth] + set subvector [dict get $state subvector] + set callallbelow [dict get $state allbelow] + set opt_sort [dict get $state sort] + set opt_exclude_paths [dict get $state exclude_paths] + set opt_exclude_files [dict get $state exclude_files] + set opt_glob_paths [dict get $state glob_paths] + set tailglobs [dict get $state tailglobs] + + if {![file isdirectory $opt_dir]} { + return [list] + } + if {[string match //zipfs:/* $opt_dir]} { + return [walk_treefilenames_zipfs $state] + } + set opt_dir_match [_tailbase_match_path $opt_tailbase $opt_dir] + if {[_path_matches_any $opt_exclude_paths $opt_dir_match]} { + return [list] + } + + set files [list] + set dir_state [directory_state $opt_glob_paths $opt_dir_match $callallbelow] + if {[dict get $dir_state include_files]} { + if {[catch {glob -nocomplain -dir $opt_dir -type f {*}$tailglobs} matches]} { + puts stderr "treefilenames error while listing files in dir $opt_dir\n $matches" + set dirfiles [list] + } else { + set dirfiles [_retain_files $matches $opt_exclude_files $opt_sort] } + lappend files {*}[_tailbase_relative_list $opt_tailbase $dirfiles] } - foreach dir $finaldirs { - set nextopts [dict merge $opts [list -directory $dir -call-depth-internal [incr CALLDEPTH]]] - lappend files {*}[treefilenames {*}$nextopts {*}$tailglobs] + + if {![dict get $dir_state recurse_below]} { + return $files } - } - return $files - } - proc treefilenames_zipfs {args} { - #seems to be 2 or 3 times faster than treefilenames for //zipfs:/ paths - REVIEW - # is sort order the same? - set argd [punk::args::parse $args withid ::punk::path::treefilenames] - lassign [dict values $argd] leaders opts values received - set tailglobs [dict get $values tailglobs] - # -- --- --- --- --- --- --- - set opt_antiglob_paths [dict get $opts -antiglob_paths] - set opt_antiglob_files [dict get $opts -antiglob_files] - set opt_sort [dict get $opts -sort] - set CALLDEPTH [dict get $opts -call-depth-internal] - # -- --- --- --- --- --- --- - # -- --- --- --- --- --- --- - - set files [list] - if {$CALLDEPTH == 0} { - if {$opt_sort eq "natural"} { - package require natsort + + if {[catch {glob -nocomplain -dir $opt_dir -type d *} dirdirs]} { + puts stderr "treefilenames error while listing subdirs in dir $opt_dir\n $dirdirs" + set dirdirs [list] + } + set okdirs [list] + foreach dir $dirdirs { + if {![_path_matches_any $opt_exclude_paths [_tailbase_match_path $opt_tailbase $dir]]} { + lappend okdirs $dir + } } - #set opts [dict merge $opts [list -directory $opt_dir]] - if {![dict exists $received -directory]} { - set opt_dir [pwd] + + if {$opt_glob_paths eq "*"} { + set matchdirs $okdirs } else { - set opt_dir [dict get $opts -directory] + set matchdirs [list] + foreach dir $okdirs { + if {$callallbelow || [child_path_state $opt_glob_paths [_tailbase_match_path $opt_tailbase $dir] $callallbelow]} { + lappend matchdirs $dir + } + } } - if {![file isdirectory $opt_dir]} { - return [list] + + set finaldirs [_sort_paths $matchdirs $opt_sort] + set childallbelow [expr {$callallbelow || [dict get $dir_state next_allbelow]}] + set nextsubvector [list {*}$subvector [file tail $opt_dir]] + foreach dir $finaldirs { + set child_state [dict merge $state [dict create {*}{} \ + directory $dir \ + depth [expr {$depth + 1}] \ + subvector $nextsubvector \ + allbelow $childallbelow]] + lappend files {*}[walk_treefilenames $child_state] } - } else { - #assume/require to exist in any recursive call - set opt_dir [dict get $opts -directory] - } - if {![string match [zipfs root]* $opt_dir]} { - error "treefilenames_zipfs can only be used on paths beginning with [zipfs root] on this systems" + return $files } - set dir [string trimright $opt_dir "/"] ;#e.g normalize //zipfs:/x/ to //zipfs:/x - set dirlen [string length $dir] - - set skip 0 - foreach anti $opt_antiglob_paths { - if {[globmatchpath $anti $dir]} { - set skip 1 - break + + proc walk_treefilenames_zipfs {state} { + set opt_dir [dict get $state directory] + set opt_tailbase [dict get $state tailbase] + set opt_exclude_paths [dict get $state exclude_paths] + set opt_exclude_files [dict get $state exclude_files] + set opt_glob_paths [dict get $state glob_paths] + set opt_sort [dict get $state sort] + set tailglobs [dict get $state tailglobs] + + if {![string match [zipfs root]* $opt_dir]} { + error "treefilenames_zipfs can only be used on paths beginning with [zipfs root] on this systems" } - } - if {$skip} { - return [list] - } - set subpaths [zipfs list $dir/*] - set dirlist [list] - set skipdirs [list] - set filelist [list] - #process in the order they came - sorting large list more expensive?? review - foreach sub $subpaths { - set tail [string range $sub $dirlen+1 end] ;#dirlen is without trailing slash - set tailparts [file split $tail] - set accum "" - set skipdir 0 - foreach tp [lrange $tailparts 0 end-1] { - append accum "/$tp" - set superpath "${dir}${accum}" - if {$superpath in $skipdirs} { - #subpart already in skipdirs - set skipdir 1 - break - } - if {$superpath ni $dirlist} { - set skip2 0 - foreach anti $opt_antiglob_paths { - if {[globmatchpath $anti $superpath]} { - set skip2 1 + set dir [string trimright $opt_dir "/"] + if {[_path_matches_any $opt_exclude_paths [_tailbase_match_path $opt_tailbase $dir]]} { + return [list] + } + set dirlen [string length $dir] + set subpaths [zipfs list $dir/*] + set dirlist [list] + set skipdirs [list] + set filelist [list] + foreach sub $subpaths { + set tail [string range $sub $dirlen+1 end] + set tailparts [file split $tail] + set accum "" + set skipdir 0 + foreach tailpart [lrange $tailparts 0 end-1] { + append accum "/$tailpart" + set superpath "${dir}${accum}" + if {$superpath in $skipdirs} { + set skipdir 1 + break + } + if {$superpath ni $dirlist} { + if {[_path_matches_any $opt_exclude_paths [_tailbase_match_path $opt_tailbase $superpath]]} { lappend skipdirs $superpath + set skipdir 1 break + } else { + lappend dirlist $superpath } } - if {!$skip2} { - lappend dirlist $superpath - } else { - set skipdir 1 - break - } } - } - if {!$skipdir} { - #process final part of path - append accum "/[lindex $tailparts end]" - set finalpart "${dir}${accum}" - if {$finalpart ni $dirlist} { - if {[file type $finalpart] eq "file"} { - set ftail [lindex $tailparts end] - set match 0 - if {"*" ni $tailglobs} { - foreach tg $tailglobs { - if {[string match $tg $ftail]} { - set match 1 - break + if {!$skipdir} { + append accum "/[lindex $tailparts end]" + set finalpart "${dir}${accum}" + if {$finalpart ni $dirlist} { + if {[file type $finalpart] eq "file"} { + set file_tail [lindex $tailparts end] + set match 0 + if {"*" ni $tailglobs} { + foreach tailglob $tailglobs { + if {[string match $tailglob $file_tail]} { + set match 1 + break + } + } + } else { + set match 1 + } + if {$match} { + if {$opt_glob_paths ne "*"} { + set file_dir_match [_tailbase_match_path $opt_tailbase [file dirname $finalpart]] + set file_dir_state [directory_state $opt_glob_paths $file_dir_match 0] + set match [dict get $file_dir_state include_files] } } - } else { - set match 1 - } - if {$match} { - if {[llength $opt_antiglob_files]} { + if {$match} { set skipfile 0 - foreach anti $opt_antiglob_files { - if {[string match $anti $ftail]} { - set skipfile 1; break + foreach anti $opt_exclude_files { + if {[string match $anti $file_tail]} { + set skipfile 1 + break } } if {!$skipfile} { - lappend filelist $finalpart + lappend filelist [_tailbase_relative $opt_tailbase $finalpart] } - } else { - lappend filelist $finalpart } - } - } else { - if {$finalpart ni $dirlist} { - set skip2 0 - foreach anti $opt_antiglob_paths { - if {[globmatchpath $anti $finalpart]} { - set skip2 1 + } else { + if {$finalpart ni $dirlist} { + if {[_path_matches_any $opt_exclude_paths [_tailbase_match_path $opt_tailbase $finalpart]]} { lappend skipdirs $finalpart - break + } else { + lappend dirlist $finalpart } } - if {!$skip2} { - lappend dirlist $finalpart - } } } } } + return [_sort_paths $filelist $opt_sort] } - switch -- $opt_sort { - ascii { - set finalfilelist [lsort $filelist] - } - dictionary { - set finalfilelist [lsort -dictionary $filelist] - } - natural { - set finalfilelist [natsort::sort $filelist] - } - default { - set finalfilelist $filelist - } + } + + #todo - treefolders with similar search caps as treefilenames + + punk::args::define { + @id -id ::punk::path::treefilenames + @cmd -name punk::path::treefilenames\ + -summary\ + "List of filenames below supplied path."\ + -help\ + "List of filenames below path. + The resulting list is unsorted. + + The path globbing syntax supports *, ** and ? as glob characters in any segment of the path, with the following semantics: + * matches any single segment in the path + ** matches 1 or more segments in the path (so /usr/**/bin will match /usr/x/bin and user/x/y/bin but not /usr/bin ) + ? matches any single character in a single segment of the path (so /usr/te?t will match /usr/test and /usr/text but not /usr/texxt) + " + -directory -type directory -help\ + "folder in which to begin recursive scan for files." + -tailbase -type string -default "" -help\ + "if supplied, only the relative path compared to the tailbase will be returned for each file. + So if tailbase is /usr and a file is found at /usr/x/y/file.txt, the returned path for that file would be x/y/file.txt. + If tailbase is not supplied, the full path to each file will be returned. + + If tailbase is supplied, it should be a prefix of the directory supplied (or the directory itself) + The patterns in -exclude-paths should be written to match the returned paths (i.e with the tailbase prefix removed) if -tailbase is supplied. + If the tailbase is not a prefix of the directory supplied, the resulting paths may have /../ components in them to account for the difference, + but the behaviour is not well defined in this case and it is recommended to ensure tailbase is a prefix of the directory supplied if using -tailbase. + + see: punk::path::relative to compute relative paths + " + -sort -type any -default natural -choices {none ascii dictionary natural} + -exclude-paths -default {} -help\ + "list of path patterns to exclude + may include * and ** path segments e.g + /usr/** (exclude subfolders based at /usr but not + files within /usr itself) + **/_aside (exclude files where _aside is last segment) + **/_aside/* (exclude folders one below an _aside folder) + **/_aside/** (exclude files in all folders with _aside as a segment)" + -exclude-files -default {} + -include-paths -default {**} -help\ + "list of path patterns to include + may include * and ** path segments e.g + /usr/** (include files in subfolders based at /usr but not + files within /usr itself) + **/_aside (include files where _aside is last segment in the folder) + **/_aside/* (include files in folders one below an _aside folder) + **/_aside/** (include all files in folders with _aside as a segment)" + @values -min 0 -max -1 -optional 1 -type string + tailglobs -default * -multiple 1 -help\ + "Patterns to match against filename portion (last segment) of each file path + within the directory tree being searched." + } + + #todo - implement treefiles which acts like dirfiles but allows path globbing in the same way as punk::ns::ns/ + #then review if treefiles can replace dirfiles or if both should exist (dirfiles can have literal glob chars in path segments - but that is a rare usecase) + proc treefilenames {args} { + set argd [punk::args::parse $args withid ::punk::path::treefilenames] + set state [treefile_priv::_state_from_argd $argd] + return [treefile_priv::walk_treefilenames $state] + } + punk::args::set_idalias ::punk::path::treefilenames_zipfs ::punk::path::treefilenames + proc treefilenames_zipfs {args} { + #seems to be 2 or 3 times faster than treefilenames for //zipfs:/ paths - REVIEW + # is sort order the same? + set argd [punk::args::parse $args withid ::punk::path::treefilenames] + set state [treefile_priv::_state_from_argd $argd] + if {![file isdirectory [dict get $state directory]]} { + return [list] } - return $finalfilelist + return [treefile_priv::walk_treefilenames_zipfs $state] } #maint warning - also in punkcheck diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/pipe-1.0.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/pipe-1.0.tm index 034fae01..eae8731c 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/pipe-1.0.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/pipe-1.0.tm @@ -169,8 +169,8 @@ tcl::namespace::eval punk::pipe::lib { #This stops us matching {/@**@x x} vs {/@**@x x} #--- - set rhs [tcl::string::map {: ? * [ ] \\ {"} " " } $rhs] - #review - we don't expect other command-incompatible chars such as colon? + set rhs [tcl::string::map {: ; ? * [ ] \\ {"} " " } $rhs] + #review - we don't expect other command-incompatible chars? return $rhs } @@ -187,6 +187,7 @@ tcl::namespace::eval punk::pipe::lib { #exclude quoted whitespace proc arg_is_script_shaped {arg} { + set arg [string map {\\; ""} $arg] if {[tcl::string::first \n $arg] >= 0} { return 1 } elseif {[tcl::string::first ";" $arg] >= 0} { diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/repo-0.1.1.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/repo-0.1.1.tm index 5fd534dc..049ed2e7 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/repo-0.1.1.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/repo-0.1.1.tm @@ -1817,17 +1817,13 @@ namespace eval punk::repo { error "unimplemented" } - #file normalize is expensive so this is too + #file normalize can be a little expensive so this is too proc norm {path {platform env}} { - #kettle::path::norm - #see also wiki - #full path normalization - - set platform [string tolower $platform] - if {$platform eq "env"} { - set platform $::tcl_platform(platform) - } + #set platform [string tolower $platform] + #if {$platform eq "env"} { + # set platform $::tcl_platform(platform) + #} #No - don't do this sort of path translation here - leave as option for specific utils only such as ./ #Windows volume-relative syntax with specific volume specified is somewhat broken in Tcl - but leading slash volume-relative does work #We shouldn't break it totally just because accessing WSL/mingw paths is slightly more useful @@ -1835,6 +1831,9 @@ namespace eval punk::repo { #return [file dirname [file normalize [punk::unixywindows::towinpath $path]/__]] #} + #kettle::path::norm + #see also wiki + #full path normalization return [file dirname [file normalize $path/__]] } diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punkapp-0.1.1.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punkapp-0.1.1.tm new file mode 100644 index 00000000..2ccf6afa --- /dev/null +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punkapp-0.1.1.tm @@ -0,0 +1,240 @@ +#utilities for punk apps to call + + +namespace eval punkapp { + variable result + variable waiting "no" + proc hide_dot_window {} { + #alternative to wm withdraw . + #see https://wiki.tcl-lang.org/page/wm+withdraw + wm geometry . 1x1+0+0 + wm overrideredirect . 1 + wm transient . + } + proc is_toplevel {w} { + if {![llength [info commands winfo]]} { + return 0 + } + expr {[winfo toplevel $w] eq $w && ![catch {$w cget -menu}]} + } + proc get_toplevels {{w .}} { + if {![llength [info commands winfo]]} { + return [list] + } + set list {} + if {[is_toplevel $w]} { + lappend list $w + } + foreach w [winfo children $w] { + lappend list {*}[get_toplevels $w] + } + return $list + } + + proc make_toplevel_next {prefix} { + set top [get_toplevel_next $prefix] + return [toplevel $top] + } + #possible race condition if multiple calls made without actually creating the toplevel, or gap if highest existing closed in the meantime + #todo - reserve_toplevel_next ? keep list of toplevels considered 'allocated' even if never created or already destroyed? what usecase? + #can call wm withdraw to to reserve newly created toplevel. To stop re-use of existing names after destruction would require a list or at least a record of highest created for each prefix + proc get_toplevel_next {prefix} { + set base [string trim $prefix .] ;# .myapp -> myapp .myapp.somewindow -> myapp.somewindow . -> "" + + + + } + proc exit {{toplevel ""}} { + variable waiting + variable result + variable default_result + set toplevels [get_toplevels] + if {[string length $toplevel]} { + set wposn [lsearch $toplevels $toplevel] + if {$wposn > 0} { + destroy $toplevel + } + } else { + #review + if {[package provide punk::repl::codethread] ne "" && [punk::repl::codethread::is_running]} { + puts stderr "punkapp::exit called without toplevel - showing console" + show_console + return 0 + } else { + puts stderr "punkapp::exit called without toplevel - exiting" + if {$waiting ne "no"} { + if {[info exists result(shell)]} { + set temp [set result(shell)] + unset result(shell) + set waiting $temp + } else { + set waiting "" + } + } else { + ::exit + } + } + } + + set controllable [get_user_controllable_toplevels] + if {![llength $controllable]} { + if {[package provide punk::repl::codethread] ne "" && [punk::repl::codethread::is_running]} { + show_console + } else { + if {$waiting ne "no"} { + if {[info exists result(shell)]} { + set temp [set result(shell)] + unset result(shell) + set waiting $temp + } elseif {[info exists result($toplevel)]} { + set temp [set result($toplevel)] + unset result($toplevel) + set waiting $temp + } elseif {[info exists default_result]} { + set temp $default_result + unset default_result + set waiting $temp + } else { + set waiting "" + } + } else { + ::exit + } + } + } + } + proc close_window {toplevel} { + wm withdraw $toplevel + if {![llength [get_user_controllable_toplevels]]} { + punkapp::exit $toplevel + } + destroy $toplevel + } + proc wait {args} { + variable waiting + variable default_result + if {[dict exists $args -defaultresult]} { + set default_result [dict get $args -defaultresult] + } + foreach t [punkapp::get_toplevels] { + if {[wm protocol $t WM_DELETE_WINDOW] eq ""} { + wm protocol $t WM_DELETE_WINDOW [list punkapp::close_window $t] + } + } + if {[package provide punk::repl::codethread] ne "" && [punk::repl::codethread::is_running]} { + puts stderr "repl eventloop seems to be running - punkapp::wait not required" + } else { + if {$waiting eq "no"} { + set waiting "waiting" + vwait ::punkapp::waiting + return $::punkapp::waiting + } + } + } + + #A window can be 'visible' according to this - but underneath other windows etc + #REVIEW - change name? + proc get_visible_toplevels {{w .}} { + if {![llength [info commands winfo]]} { + return [list] + } + set list [get_toplevels $w] + set mapped [lmap v $list {expr {[winfo ismapped $v] ? $v : {}}}] + set mapped [concat {*}$mapped] ;#ignore {} + set visible [list] + foreach m $mapped { + if {[wm overrideredirect $m] == 0 } { + lappend visible $m + } else { + if {[winfo height $m] >1 && [winfo width $m] > 1} { + #technically even a 1x1 is visible.. but in practice even a 10x10 is hardly likely to be noticeable when overrideredirect == 1 + #as a convention - 1x1 with no controls is used to make a window invisible so we'll treat anything larger as visible + lappend visible $m + } + } + } + return $visible + } + proc get_user_controllable_toplevels {{w .}} { + set visible [get_visible_toplevels $w] + set controllable [list] + foreach v $visible { + if {[wm overrideredirect $v] == 0} { + lappend controllable $v + } + } + #only return visible windows with overrideredirect == 0 because there exists some user control. + #todo - review.. consider checking if position is outside screen areas? Technically controllable.. but not easily + return $controllable + } + proc hide_console {args} { + set opts [dict create -force 0] + if {([llength $args] % 2) != 0} { + error "hide_console expects pairs of arguments. e.g -force 1" + } + #set known_opts [dict keys $defaults] + foreach {k v} $args { + switch -- $k { + -force { + dict set opts $k $v + } + default { + error "Unrecognised options '$k' known options: [dict keys $opts]" + } + } + } + set force [dict get $opts -force] + + if {!$force} { + if {![llength [get_user_controllable_toplevels]]} { + puts stderr "Cannot hide console while no user-controllable windows available" + return 0 + } + } + if {$::tcl_platform(platform) eq "windows"} { + #hide won't work for certain consoles cush as conemu,wezterm - and doesn't really make sense for tabbed windows anyway. + #It would be nice if we could tell the console window to hide just the relevant tab - or the whole window if only one tab present - but this is unlikely to be possible in any standard way. + #an ordinary cmd.exe or pwsh.exe or powershell.exe window can be hidden ok though. + #(but with wezterm - process is cmd.exe - but it has style popup and can't be hidden with a twapi::hide_window call) + package require twapi + set h [twapi::get_console_window] + set pid [twapi::get_window_process $h] + set pinfo [twapi::get_process_info $pid -name] + set pname [dict get $pinfo -name] + set wstyle [twapi::get_window_style $h] + #tclkitsh/tclsh? + if {($pname in [list cmd.exe pwsh.exe powershell.exe] || [string match punk*.exe $pname]) && "popup" ni $wstyle} { + twapi::hide_window $h + return 1 + } else { + puts stderr "punkapp::hide_console unable to hide this type of console window" + return 0 + } + } else { + #todo + puts stderr "punkapp::hide_console unimplemented on this platform (todo)" + return 0 + } + } + + proc show_console {} { + if {$::tcl_platform(platform) eq "windows"} { + package require twapi + if {![catch {set h [twapi::get_console_window]} errM]} { + twapi::show_window $h -activate -normal + } else { + #no console - assume launched from something like wish? + catch {console show} + } + } else { + #todo + puts stderr "punkapp::show_console unimplemented on this platform" + } + } + +} + +package provide punkapp [namespace eval punkapp { + variable version + set version 0.1.1 +}] \ No newline at end of file diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punkcheck-0.1.1.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punkcheck-0.1.1.tm new file mode 100644 index 00000000..bdff666e --- /dev/null +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punkcheck-0.1.1.tm @@ -0,0 +1,2458 @@ +# -*- tcl -*- +# Maintenance Instruction: leave the 999999.xxx.x as is and use 'dev make' or src/make.tcl to update from -buildversion.txt +# +# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. +# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# (C) 2023 +# +# @@ Meta Begin +# Application punkcheck 0.1.0 +# Meta platform tcl +# Meta license +# @@ Meta End + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +##e.g package require frobz + +package require punk::tdl +package require punk::path +package require punk::repo +package require punk::mix::util + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# Punkcheck uses the TDL format which is a list of lists in Tcl format +# It is intended primarily for source build/distribution tracking within a punk project or single filesystem - with relative paths. +# +#see following article regarding the many problems with using mtime for build-decisions: https://apenwarr.ca/log/20181113 +# +namespace eval punkcheck { + namespace export {*}{ + uuid + installtrack + install + install_tm_files + install_non_tm_files + summarize_install_resultdict + } + + #exclude-dir & exclude-file entries match the pattern at any level - should not contain path separators + variable default_excludedirseg_core [list "#*" "_aside" "_build" ".git" ".fossil*"] + variable default_excludefiletail_core "" + + set has_twapi 0 + if {"windows" eq $::tcl_platform(platform)} { + set has_twapi [expr {![catch {package require twapi}]}] + } + if {$has_twapi} { + interp alias "" ::punkcheck::uuid "" ::twapi::new_uuid + } else { + catch {package require uuid} + interp alias "" ::punkcheck::uuid "" ::uuid::uuid generate + } + + proc default_excludedirseg_core {} { + variable default_excludedirseg_core + return $default_excludedirseg_core + } + proc default_excludefiletail_core {} { + variable default_excludefiletail_core + if {$default_excludefiletail_core eq ""} { + set default_excludefiletail_core [list "*.swp" "*[punk::mix::util::tm_version_magic]*" "*-buildversion.txt" ".punkcheck"] + } + return $default_excludefiletail_core + } + + + proc load_records_from_file {punkcheck_file} { + set record_list [list] + if {[file exists $punkcheck_file]} { + set tdlscript [punk::mix::util::fcat $punkcheck_file] + if {[catch { + set record_list [punk::tdl::prettyparse $tdlscript] + } errparse]} { + error "punkcheck::load_records_from_file failed to parse '$punkcheck_file'\n error:$errparse" + } + } + return $record_list + } + proc save_records_to_file {recordlist punkcheck_file {trigger {}} {debugchannel ""}} { + set newtdl [punk::tdl::prettyprint $recordlist] + set linecount [llength [split $newtdl \n]] + + if {$debugchannel ne "" && $trigger ne ""} { + puts $debugchannel "\x1b\[36mSaving [llength $recordlist] records as $linecount lines to file '$punkcheck_file' trigger: \x1b\[32m$trigger\x1b\[m" + } + #puts stdout $newtdl + set fd [open $punkcheck_file w] + chan configure $fd -translation binary + puts -nonewline $fd $newtdl + flush $fd + close $fd + return [list recordcount [llength $recordlist] linecount $linecount] + } + + + #todo - work out way to use same punkcheck file for multiple installers running concurrently. Thread? + #an installtrack objects represents an installation path from sourceroot to targetroot + #The source and target folders should be as specific as possible but it is valid to specify for example c:/ -> c:/ (or / -> /) if source and targets within the installation operation are spread around. + # + set objname [namespace current]::installtrack + if {$objname ni [info commands $objname]} { + package require oolib + + #FILEINFO record - target fileset with body records: INSTALL-RECORD,INSTALL-INPROGRESS,INSTALL-SKIPPED,DELETE-RECORD,DELETE-INPROGRESS,MODIFY-INPROGRESS,MODIFY-RECORD + #each FILEINFO body being a list of SOURCE records + oo::class create targetset { + variable o_targets + variable o_keep_installrecords + variable o_keep_skipped + variable o_keep_inprogress + variable o_records + constructor {args} { + #set o_records [oolib::collection create [namespace current]::recordcollection] + set o_records [list] + + } + + method as_record {} { + dict create {*}{ + } tag FILEINFO {*}{ + } -targets $o_targets {*}{ + } -keep_installrecords $o_keep_installrecords {*}{ + } -keep_skipped $o_keep_skipped {*}{ + } -keep_inprogress $o_keep_inprogress {*}{ + } body $o_records {*}{ + } + } + + #retrieve last completed record for the fileset ie exclude SKIPPED,INSTALL-INPROGRESS,DELETE-INPROGRESS,MODIFY-INPROGRESS + method get_last_record {fileset_record} { + set body [dict_getwithdefault $fileset_record body [list]] + set previous_records [lrange $body 0 end-1] + #get last previous that is tagged INSTALL-RECORD,MODIFY-RECORD,DELETE-RECORD + set revlist [lreverse $previous_records] + foreach rec $revlist { + switch -- [dict get $rec tag] { + INSTALL-RECORD - MODIFY-RECORD - DELETE-RECORD - VIRTUAL-RECORD { + return $rec + } + } + } + return [list] + } + } + + #instances created by an installtrack object in method start_event + #also in installtrack constructor - to represent existing events from the .punkcheck data + oo::class create installevent { + variable o_id + variable o_rel_sourceroot + variable o_rel_targetroot + variable o_ts_begin + variable o_ts_end + variable o_types + variable o_configdict + variable o_targets + variable o_operation + variable o_operation_start_ts + variable o_path_cksum_cache + variable o_fileset_record + variable o_installer ;#parent object + variable o_debugchannel + constructor {installer rel_sourceroot rel_targetroot args} { + set o_installer $installer + set o_debugchannel [$installer get_debugchannel] + set o_operation_start_ts "" + set o_path_cksum_cache [dict create] + set o_operation "" + set defaults [dict create {*}{ + -id "" + -tsbegin "" + -config {} + -tsend "" + -types {} + }] + set opts [dict merge $defaults $args] + if {[dict get $opts -id] eq ""} { + set o_id [punkcheck::uuid] + } else { + set o_id [dict get $opts -id] + } + if {[dict get $opts -tsbegin] eq ""} { + set o_ts_begin [clock microseconds] + } else { + set o_ts_begin [dict get $opts -tsbegin] + } + set o_ts_end [dict get $opts -tsend] + set o_types [dict get $opts -types] + set o_configdict [dict get $opts -config] + + set o_rel_sourceroot $rel_sourceroot + set o_rel_targetroot $rel_targetroot + } + destructor { + #puts "[self] destructor called" + } + method as_record {} { + set begin_seconds [expr {$o_ts_begin / 1000000}] + set tsiso_begin [clock format $begin_seconds -format "%Y-%m-%dT%H:%M:%S"] + if {$o_ts_end ne ""} { + set end_seconds [expr {$o_ts_end / 1000000}] + set tsiso_end [clock format $end_seconds -format "%Y-%m-%dT%H:%M:%S"] + } else { + set tsiso_end "" + } + + dict create {*}{ + } tag EVENT {*}{ + } -tsiso_begin $tsiso_begin {*}{ + } -ts_begin $o_ts_begin {*}{ + } -tsiso_end $tsiso_end {*}{ + } -ts_end $o_ts_end {*}{ + } -id $o_id {*}{ + } -source $o_rel_sourceroot {*}{ + } -targets $o_rel_targetroot {*}{ + } -types $o_types {*}{ + } -config $o_configdict {*}{ + } + } + method get_id {} { + return $o_id + } + method get_operation {} { + return $o_operation + } + method get_targets {} { + return $o_targets + } + method get_targets_exist {} { + set punkcheck_folder [file dirname [$o_installer get_checkfile]] + #puts stdout "### punkcheck glob -dir $punkcheck_folder -tails {*}$o_targets" + #targets can be paths such as punk/mix/commandset/module-0.1.0.tm - glob can search levels below supplied -dir + set existing [glob -nocomplain -dir $punkcheck_folder -tails {*}$o_targets] + + return $existing + } + method end {} { + set o_ts_end [clock microseconds] + } + method targetset_dict {} { + punk::records_as_target_dict [$o_installer get_recordlist] + } + + #related - installfile_begin + #call init before we know if we are going to run the operation vs skip + method targetset_init {operation targetset} { + set known_ops [list QUERY INSTALL MODIFY DELETE VIRTUAL] + if {[string toupper $operation] ni $known_ops} { + error "[self] add_target unknown operation '$operation'. Known operations $known_ops" + } + set o_operation [string toupper $operation] + + if {$o_operation_start_ts ne ""} { + error "[self] targetset_init $o_operation operation already in progress. Use targetset_finished or targetset_complete to finish." + } + set o_operation_start_ts [clock microseconds] + set seconds [expr {$o_operation_start_ts / 1000000}] + set tsiso [clock format $seconds -format "%Y-%m-%dT%H:%M:%S"] + set punkcheck_file [$o_installer get_checkfile] + set punkcheck_folder [file dirname $punkcheck_file] + + set relativepath_targetset [list] + if {$o_operation eq "VIRTUAL"} { + foreach p $targetset { + lappend relativepath_targetset $p + } + } else { + foreach p $targetset { + if {[file pathtype $p] eq "absolute"} { + lappend relativepath_targetset [punkcheck::lib::path_relative $punkcheck_folder $p] + } else { + lappend relativepath_targetset $p + } + } + } + + + set fields [list {*}{ + } -tsiso $tsiso {*}{ + } -ts $o_operation_start_ts {*}{ + } -installer [$o_installer get_name] {*}{ + } -eventid $o_id {*}{ + } + ] + + set o_targets [lsort -dictionary -increasing $relativepath_targetset] ;#exact sort order not critical - but must be consistent + + + set record_list [punkcheck::load_records_from_file $punkcheck_file] + + #--------------------------------------------------------------------------- + #load as dict to test for dupes + #set _targetdict [my targetset_dict] + if {[catch { + set _targetdict [punkcheck::recordlist::records_as_target_dict $record_list] + } errMsg]} { + error "targetset_init operation:$operation error verifying existing records from file $punkcheck_file. Error: $errMsg" + } + #--------------------------------------------------------------------------- + + set extractioninfo [punkcheck::recordlist::extract_or_create_fileset_record $o_targets $record_list] + set o_fileset_record [dict get $extractioninfo record] + set record_list [dict get $extractioninfo recordset] ;#if fileset wasn't present, same as original record_list, otherwise full recordset with the fileset record removed, ready for reinsertion. + set isnew [dict get $extractioninfo isnew] + set oldposition [dict get $extractioninfo oldposition] + unset extractioninfo + + #INSTALL-INPROGRESS will become INSTALL-RECORD or INSTALL-FAILED or INSTALL-SKIPPED upon finalisation + #-installer and -eventid keys are added here + set new_inprogress_record [dict create tag [string toupper $operation]-INPROGRESS {*}$fields -tempcontext [my as_record] body {}] + #set existing_body [dict_getwithdefault $o_fileset_record body [list]] + #todo - look for existing "-INPROGRESS" records - mark as failed or incomplete? + dict lappend o_fileset_record body $new_inprogress_record + + if {$isnew} { + lappend record_list $o_fileset_record + } else { + #set record_list [linsert $record_list[unset record_list] $oldposition $o_fileset_record] + ledit record_list $oldposition -1 $o_fileset_record + } + if {$o_operation ne "QUERY"} { + punkcheck::save_records_to_file $record_list $punkcheck_file "targetset_init $o_operation [llength $targetset] targets" + } + return $o_fileset_record + + } + #operation has been started + #todo - upgrade .punkcheck format to hold more than just list of SOURCE entries in each record. + # - allow arbitrary targetset_startphase targetset_endphase calls to store timestamps and calculate elapsed time + method targetset_started {} { + set punkcheck_folder [file dirname [$o_installer get_checkfile]] + if {$o_operation eq "QUERY"} { + set fileinfo_body [dict get $o_fileset_record body] ;#body of FILEINFO record + set installing_record [lindex $fileinfo_body end] + + set ts_start [dict get $installing_record -ts] + set ts_now [clock microseconds] + set metadata_us [expr {$ts_now - $ts_start}] + + #?? + #JJJ + #dict set installing_record -metadata_us $metadata_us + dict set installing_record -ts_start_transfer $ts_now + + lset fileinfo_body end $installing_record + + return [dict set o_fileset_record body $fileinfo_body] + } else { + #legacy call + #saves to .punkcheck file + return [set o_fileset_record [punkcheck::installfile_started_install $punkcheck_folder $o_fileset_record]] + } + } + method targetset_end {status args} { + set defaults [dict create {*}{ + -note \uFFFF + }] + set known_opts [dict keys $defaults] + if {[llength $args] % 2} { + error "targetset_end arguments after status must be in the form of -flag value pairs. known flags: $known_opts" + } + set opts [dict merge $defaults $args] + if {[dict get $opts -note] eq "\uFFFF"} { + dict unset opts -note + } + + set status [string toupper $status] + set statusdict [dict create OK RECORD SKIPPED SKIPPED FAILED FAILED] + if {$o_operation_start_ts eq ""} { + error "[self] targetset_end $status - no current operation - call targetset_started first" + } + if {$status ni [dict keys $statusdict]} { + error "[self] targetset_end unrecognized status:$status known values: [dict keys $statusdict]" + } + if {![punkcheck::lib::is_file_record_inprogress $o_fileset_record]} { + error "targetset_end $status error: bad fileset_record - expected FILEINFO with last body element *-INPROGRESS" + } + set targetlist [dict get $o_fileset_record -targets] + if {$targetlist ne $o_targets} { + error "targetset_end $status error. targetlist mismatch between file : $targetlist vs $o_targets" + } + set operation_end_ts [clock microseconds] + set elapsed_us [expr {$operation_end_ts - $o_operation_start_ts}] + set file_record_body [dict get $o_fileset_record body] + set installing_record [lindex $file_record_body end] + set punkcheck_file [$o_installer get_checkfile] + set punkcheck_folder [file dirname $punkcheck_file] + set record_list [punkcheck::load_records_from_file $punkcheck_file] + if {[dict exists $installing_record -ts_start_transfer]} { + set ts_start_transfer [dict get $installing_record -ts_start_transfer] + set transfer_us [expr {$operation_end_ts - $ts_start_transfer}] + dict set installing_record -transfer_us $transfer_us + } + if {[dict exists $opts -note]} { + dict set installing_record -note [dict get $opts -note] + } + + dict set installing_record -elapsed_us $elapsed_us + dict unset installing_record -tempcontext + dict set installing_record tag "${o_operation}-[dict get $statusdict $status]" ;# e.g INSTALL-RECORD, INSTALL-SKIPPED + if {$o_operation in [list INSTALL MODIFY] && [dict get $statusdict $status] eq "RECORD"} { + #only calculate and store post operation target cksums on successful INSTALL or MODIFY, doesn't make sense for DELETE or VIRTUAL operations + set new_targets_cksums [list] ;#ordered list of cksums matching targetset order + set cksum_all_opts "" ;#same cksum opts for each target so we store it once + set ts_begin_cksum [clock microseconds] + foreach p $o_targets { + set tgt_cksum_info [punk::mix::base::lib::cksum_path [file join $punkcheck_folder $p]] + lappend new_targets_cksums [dict get $tgt_cksum_info cksum] + if {$cksum_all_opts eq ""} { + set cksum_all_opts [dict get $tgt_cksum_info opts] + } + } + set cksum_us [expr {[clock microseconds] - $ts_begin_cksum}] + dict set installing_record -targets_cksums $new_targets_cksums + dict set installing_record -cksum_all_opts $cksum_all_opts + dict set installing_record -cksum_us $cksum_us + } + lset file_record_body end $installing_record + dict set o_fileset_record body $file_record_body + set o_fileset_record [punkcheck::recordlist::file_record_prune $o_fileset_record] + + set oldrecordinfo [punkcheck::recordlist::get_file_record $targetlist $record_list] + set old_posn [dict get $oldrecordinfo position] + if {$old_posn == -1} { + lappend record_list $o_fileset_record + } else { + lset record_list $old_posn $o_fileset_record + } + if {$o_operation ne "QUERY"} { + punkcheck::save_records_to_file $record_list $punkcheck_file "targetset_end $o_operation $status [llength $o_targets] targets" + } + set o_operation_start_ts "" + set o_operation "" + return $o_fileset_record + } + #can supply empty cksum value + # - that will influence the opts used if there is no existing install record + method targetset_cksumcache_set {path_cksum_dict} { + set o_path_cksum_cache $path_cksum_dict + } + method targetset_cksumcache_configure {path {cksuminfodict {}}} { + if {$cksuminfodict eq {}} { + if {[dict exists $o_path_cksum_cache $path]} { + return [dict get $o_path_cksum_cache $path] + } else { + return + } + } + dict for {k v} $cksuminfodict { + switch -- $k { + cksum - opts {} + default { + error "targetset_cksumcache_configure error. Unknown dict value $k. Allowed values {cksum opts}" + } + } + } + dict set o_path_cksum_cache $path $cksuminfodict + } + method targetset_addsource {source_path} { + set punkcheck_file [$o_installer get_checkfile] + set punkcheck_folder [file dirname $punkcheck_file] + if {[file pathtype $source_path] eq "absolute"} { + set rel_source_path [punkcheck::lib::path_relative $punkcheck_folder $source_path] + } else { + set rel_source_path $source_path + } + + #installfile_add_source_and_fetch_metadata accepts list of {cksum opt } dictionaries - although we only have one per path from our configured cksumcache + if {[dict exists $o_path_cksum_cache $rel_source_path]} { + set path_cksum_caches [list [dict get $o_path_cksum_cache $rel_source_path]] + } else { + set path_cksum_caches [list] + } + set o_fileset_record [punkcheck::installfile_add_source_and_fetch_metadata $punkcheck_folder $rel_source_path $o_fileset_record $path_cksum_caches] + #JJJ - update -metadata_us here? + + } + method targetset_last_complete {} { + #retrieve last completed record for the fileset ie exclude SKIPPED,INSTALL-INPROGRESS,DELETE-INPROGRESS,MODIFY-INPROGRESS + set body [punkcheck::dict_getwithdefault $o_fileset_record body [list]] + set previous_records [lrange $body 0 end] + #get last that is tagged INSTALL-RECORD,MODIFY-RECORD,DELETE-RECORD + set revlist [lreverse $previous_records] + foreach rec $revlist { + if {[dict get $rec tag] in [list "INSTALL-RECORD" "MODIFY-RECORD" "DELETE-RECORD" "VIRTUAL-RECORD"]} { + return $rec + } + } + return [list] + + } + method targetset_source_changes {} { + punkcheck::recordlist::file_install_record_source_changes [lindex [dict get $o_fileset_record body] end] + } + + } + + + oo::class create installtrack { + variable o_name + variable o_tsiso + variable o_ts + variable o_keep_events + variable o_checkfile + variable o_sourceroot + variable o_rel_sourceroot + variable o_targetroot + variable o_rel_targetroot + variable o_record_list + variable o_active_event + variable o_events + variable o_debugchannel + constructor {installername punkcheck_file {debugchannel ""}} { + set o_debugchannel $debugchannel + set o_active_event "" + set o_name $installername + + set o_checkfile [file normalize $punkcheck_file] + set o_sourceroot "" + set o_targetroot "" + set o_rel_sourceroot "" + set o_rel_targetroot "" + set o_record_list [list] + + #todo - validate punkcheck file location further?? + set punkcheck_folder [file dirname $o_checkfile] + if {![file isdirectory $punkcheck_folder]} { + error "[self] constructor error. Folder for punkcheck_file not found - $o_checkfile" + } + + my load_all_records + if {![llength $o_record_list] && $o_debugchannel ne ""} { + puts $o_debugchannel "\x1b\[32mNo existing records found in punkcheck file '$o_checkfile' for installer '$installername'. Starting with empty record list.\x1b\[m" + } else { + #verify no duplicate installer records for this installer. + #JMN + set sanity_dict [dict create] + set insane "" + foreach rec $o_record_list { + if {[dict get $rec tag] eq "INSTALLER"} { + set name [dict get $rec -name] + if {[dict exists $sanity_dict $name]} { + #todo - warn - duplicate record for same targetlist - shouldn't happen as we should be using get_file_record to find existing records + if {$o_debugchannel ne ""} { + puts $o_debugchannel "\x1b\[31mpunkcheck installtrack - multiple INSTALLER records with same name '$name'\x1b\[m" + } + set insane "$name" + break + } + dict set sanity_dict $name {} + } + } + if {$insane ne ""} { + set msg "Sanity check: punkcheck file '$o_checkfile' contains multiple records for INSTALLER -name '$insane'." + append msg \n "This may indicate a problem such as multiple concurrent installtrack instances using the same punkcheck file," + append msg \n " or a previous installtrack instance that did not complete properly." + append msg \n " Do you want to DELETE the .punkcheck file?" + append msg \n " It is safe to delete .punkcheck files, at the cost of loss of history and checksums used to optimize installs." + append msg \n " They are a record of installation events and checksums used to avoid unnecessary reinstalls." + append msg \n " If not confirmed, an error will be raised - likely aborting the current operation." + append msg \n "confirm deletion and continue by regenerating the file, by typing the 3 letters: 'yes'." + set answer [punk::lib::askuser $msg] + if {[string tolower $answer] ne "yes"} { + error "Failing due to sanity check failure. User did not confirm with 'yes'." + } + if {[file exists $o_checkfile] && [file isfile $o_checkfile]} { + file delete $o_checkfile + } + if {[file exists $o_checkfile]} { + error "Failed to delete punkcheck file '$o_checkfile' after sanity check failure. Please investigate and resolve the issue before proceeding." + } + set o_record_list [list] + } else { + if {$o_debugchannel ne ""} { + puts $o_debugchannel "\x1b\[32mSanity check passed: no duplicate INSTALLER records found for installer '$installername' in punkcheck file '$o_checkfile'.\x1b\[m" + } + } + unset sanity_dict + } + + set resultinfo [punkcheck::recordlist::get_installer_record $o_name $o_record_list] + set existing_header_posn [dict get $resultinfo position] + if {$existing_header_posn == -1} { + set this_installer_record [punkcheck::recordlist::new_installer_record $o_name] + #set o_record_list [linsert $o_record_list 0 $this_installer_record] + ledit o_record_list -1 -1 $this_installer_record + } else { + set this_installer_record [dict get $resultinfo record] + } + set o_tsiso [dict get $this_installer_record -tsiso] + set o_ts [dict get $this_installer_record -ts] + set o_keep_events [dict get $this_installer_record -keep_events] + + set o_events [oolib::collection create [namespace current]::eventcollection] + set eventlist [punkcheck::dict_getwithdefault $this_installer_record body [list]] + foreach e $eventlist { + set eobj [punkcheck::installevent create [namespace current]::event_[my events count] [self] [dict get $e -source] [dict get $e -targets] {*}$e] + #$o_events add $e [dict get $e -id] + $o_events add $eobj [dict get $e -id] + } + + } + destructor { + #puts "[self] destructor called" + } + method test {} { + return [self] + } + method get_name {} { + return $o_name + } + method get_checkfile {} { + return $o_checkfile + } + method get_debugchannel {} { + return $o_debugchannel + } + + #call set_source_target before calling start_event/end_event + #each event can have different source->target pairs - but may often have same, so set on installtrack as defaults. Only persisted in event records. + method set_source_target {sourceroot targetroot} { + if {[file pathtype $sourceroot] ne "absolute"} { + error "[self] set_source_target error: sourceroot must be absolute path. Received '$sourceroot'" + } + if {[file pathtype $targetroot] ne "absolute"} { + error "[self] set_source_target error: targetroot must be absolute path. Received '$targetroot'" + } + set punkcheck_folder [file dirname $o_checkfile] + set o_sourceroot $sourceroot + set o_targetroot $targetroot + set o_rel_sourceroot [punkcheck::lib::path_relative $punkcheck_folder $sourceroot] + set o_rel_targetroot [punkcheck::lib::path_relative $punkcheck_folder $targetroot] + return [list $o_rel_sourceroot $o_rel_targetroot] + } + #review/fix to allow multiple installtrack objects on same punkcheck file. + method load_all_records {} { + set o_record_list [punkcheck::load_records_from_file $o_checkfile] + } + + #does not include associated FILEINFO records - as a targetset (FILEINFO record) can be associated with events from multiple installers over time. + #e.g a logfile common to installers, or a separate installer that updates a previous output. + method as_record {} { + set eventrecords [list] + foreach eobj [my events items] { + lappend eventrecords [$eobj as_record] + } + set fields [list {*}{ + } -tsiso $o_tsiso {*}{ + } -ts $o_ts {*}{ + } -name $o_name\ {*}{ + } -keep_events $o_keep_events {*}{ + } body $eventrecords {*}{ + } + ] + set record [dict create tag INSTALLER {*}$fields] + } + #open file and save only own records + method save_all_records {} { + my save_installer_record + #todo - save FILEINFO targetset records + } + method save_installer_record {} { + set file_records [punkcheck::load_records_from_file $o_checkfile] + + set this_installer_record [my as_record] + + set persistedinfo [punkcheck::recordlist::get_installer_record $o_name $file_records] + set existing_header_posn [dict get $persistedinfo position] + if {$existing_header_posn == -1} { + #set file_records [linsert $file_records 0 $this_installer_record] + ledit file_records -1 -1 $this_installer_record + } else { + lset file_records $existing_header_posn $this_installer_record + } + punkcheck::save_records_to_file $file_records $o_checkfile "save_installer_record" + } + method events {args} { + tailcall $o_events {*}$args + } + method start_event {configdict} { + if {$o_active_event ne ""} { + error "[self] start_event error - event already started: $o_active_event" + } + if {$o_rel_sourceroot eq "" || $o_rel_targetroot eq ""} { + error "[self] No configured sourceroot or targetroot. Call [self] set_source_target first" + } + + if {[llength $configdict] %2 != 0} { + error "[self] new_event configdict must have an even number of elements" + } + set resultinfo [punkcheck::recordlist::get_installer_record $o_name $o_record_list] + set existing_header_posn [dict get $resultinfo position] + if {$existing_header_posn == -1} { + error "[self] start_event - installer record missing. installer: $o_name" + } else { + set this_installer_record [dict get $resultinfo record] + } + + set eventobj [punkcheck::installevent create [namespace current]::event_[my events count] [self] $o_rel_sourceroot $o_rel_targetroot -config $configdict] + set eventid [$eventobj get_id] + set event_record [$eventobj as_record] + + set this_installer_record [punkcheck::recordlist::installer_record_add_event $this_installer_record $event_record] + set this_installer_record [punkcheck::recordlist::installer_record_pruneevents $this_installer_record $o_record_list] + + #replace + lset o_record_list $existing_header_posn $this_installer_record + + punkcheck::save_records_to_file $o_record_list $o_checkfile "start_event $eventid" + set o_active_event $eventobj + my events add $eventobj $eventid + return $eventobj + } + method installer_record_from_file {} { + set resultinfo [punkcheck::recordlist::get_installer_record $o_name $o_record_list] + } + method get_recordlist {} { + return $o_recordlist + } + method end_event {} { + if {$o_active_event eq ""} { + error "[self] end_event error - no active event" + } + $o_active_event end + } + method get_event {} { + return $o_active_event + } + } + } + proc start_installer_event {punkcheck_file installername from_fullpath to_fullpath config} { + set eventid [punkcheck::uuid] + if {[file pathtype $from_fullpath] ne "absolute"} { + error "start_installer_event error: from_fullpath must be absolute path. Received '$from_fullpath'" + } + if {[file pathtype $to_fullpath] ne "absolute"} { + error "start_installer_event error: to_fullpath must be absolute path. Received '$to_fullpath'" + } + set punkcheck_folder [file dirname $punkcheck_file] + set rel_source [punkcheck::lib::path_relative $punkcheck_folder $from_fullpath] + set rel_target [punkcheck::lib::path_relative $punkcheck_folder $to_fullpath] + + + set record_list [punkcheck::load_records_from_file $punkcheck_file] + set resultinfo [punkcheck::recordlist::get_installer_record $installername $record_list] + set existing_header_posn [dict get $resultinfo position] + if {$existing_header_posn == -1} { + set this_installer_record [punkcheck::recordlist::new_installer_record $installername] + } else { + set this_installer_record [dict get $resultinfo record] + } + + set event_record [punkcheck::recordlist::new_installer_event_record install {*}{ + -id $eventid + -source $rel_source + -targets $rel_target + -config $config + }] + + set this_installer_record [punkcheck::recordlist::installer_record_add_event $this_installer_record $event_record] + set this_installer_record [punkcheck::recordlist::installer_record_pruneevents $this_installer_record $record_list] + + if {$existing_header_posn == -1} { + #not found - prepend + #set record_list [linsert $record_list 0 $this_installer_record] + ledit record_list -1 -1 $this_installer_record + } else { + #replace + lset record_list $existing_header_posn $this_installer_record + } + + punkcheck::save_records_to_file $record_list $punkcheck_file "start_installer_event $eventid" + return [list eventid $eventid recordset $record_list] + } + #----------------------------------------------- + proc installfile_help {} { + set msg "" + append msg "Call in order:" \n + append msg " start_installer_event (get dict with eventid and recordset keys)" + append msg " installfile_begin (to return a new INSTALLING record) - must pass in a valid eventid" \n + append msg " installfile_add_source_and_fetch_metadata (1+ times to update SOURCE record with checksum/timestamp info from source)" \n + append msg " ( - possibly with same algorithm as previous installrecord)" \n + append msg " ( - todo - search/load metadata for this source from other FILEINFO records for same installer)" \n + append msg "Finalize by calling:" \n + append msg " installfile_started_install" \n + append msg " (install the file e.g file copy)" \n + append msg " installfile_finished_install" \n + append msg " OR" \n + append msg " installfile_skipped_install" \n + } + proc installfile_begin {punkcheck_folder target_relpath installername args} { + if {[llength $args] %2 !=0} { + error "punkcheck installfile_begin args must be name-value pairs" + } + set target_relpath [lsort -dictionary -increasing $target_relpath] ;#exact sort order not critical - but must be consistent + set ts [clock microseconds] + set seconds [expr {$ts / 1000000}] + set tsiso [clock format $seconds -format "%Y-%m-%dT%H:%M:%S"] + set defaults [list {*}{ + } -tsiso $tsiso {*}{ + } -ts $ts {*}{ + } -installer $installername {*}{ + } -eventid unspecified {*}{ + } + ] + set opts [dict merge $defaults $args] + set opt_eventid [dict get $opts -eventid] + + set punkcheck_file [file join $punkcheck_folder/.punkcheck] + set record_list [load_records_from_file $punkcheck_file] + + set resultinfo [punkcheck::recordlist::get_installer_record $installername $record_list] + set installer_record_position [dict get $resultinfo position] + if {$installer_record_position == -1} { + error "installfile_begin error: Failed to retrieve installer record for installer name:'$installername' - ensure start_installer_event has been called with same installer, and -eventid is passed to installfile_begin" + } + set this_installer_record [dict get $resultinfo record] + set events [dict get $this_installer_record body] + set active_event [list] + foreach evt [lreverse $events] { + if {[dict get $evt -id] eq $opt_eventid} { + set active_event $evt + break + } + } + if {![llength $active_event]} { + error "installfile_begin error: eventid $opt_eventid not found for installer '$installername' - aborting" + } + + + set extractioninfo [punkcheck::recordlist::extract_or_create_fileset_record $target_relpath $record_list] + set file_record [dict get $extractioninfo record] + set record_list [dict get $extractioninfo recordset] + set isnew [dict get $extractioninfo isnew] + set oldposition [dict get $extractioninfo oldposition] + unset extractioninfo + + #INSTALL-INPROGRESS will become INSTALL-RECORD or INSTALL-FAILED or INSTALL-SKIPPED upon finalisation + #-installer and -eventid keys are added here + set new_installing_record [dict create tag INSTALL-INPROGRESS {*}$opts -tempcontext $active_event body {}] + #set existing_body [dict_getwithdefault $file_record body [list]] + #todo - look for existing "INSTALL-INPROGRESS" records - mark as failed? + dict lappend file_record body $new_installing_record + + if {$isnew} { + lappend record_list $file_record + } else { + #set record_list [linsert $record_list[unset record_list] $oldposition $file_record] + ledit record_list $oldposition -1 $file_record + } + + save_records_to_file $record_list $punkcheck_file "installfile_begin $installername $opt_eventid $target_relpath" + return $file_record + } + + #todo - ensure that removing a dependency is noticed as a change + #e.g previous installrecord had 2 source records - but we now only depend on one. + #The files we depended on for the previous record haven't changed themselves - but the list of files has (reduced by one) + #cached_cksums is list of dicts with keys cksum & opts + #Will only be used if any opts values present match those from file_record's -cksum_all_opts (in last install record) or first cached_cksum will be used if no last install record values + proc installfile_add_source_and_fetch_metadata {punkcheck_folder source_relpath file_record {cached_cksums {}}} { + if {![lib::is_file_record_inprogress $file_record]} { + error "installfile_add_source_and_fetch_metadata error: bad file_record - expected FILEINFO with last body element *-INPROGRESS ($file_record)" + } + #validate any passed cached_cksums + foreach cacheinfo $cached_cksums { + if {[llength $cacheinfo] % 2 != 0} { + error "installfile_add_source_and_fetch_metadata error.If cached_cksums is supplied, it must be a list of dicts containing keys cksum & opts" + } + dict for {k v} $cacheinfo { + switch -- $k { + cksum {} + opts { + #todo - validate $v keys + } + default { + error "installfile_add_source_and_fetch_metadata error. Unrecognised key $k. Known keys {cksum opts}" + } + } + + } + } + set ts_start [clock microseconds] + set last_installrecord [lib::file_record_get_last_installrecord $file_record] + set prev_ftype "" + set prev_fsize "" + set prev_cksum "" + set prev_cksum_opts "" + if {[llength $last_installrecord]} { + set src [lib::install_record_get_matching_source_record $last_installrecord $source_relpath] + if {[llength $src]} { + if {[dict_getwithdefault $src -path ""] eq $source_relpath} { + set prev_ftype [dict_getwithdefault $src -type ""] + set prev_fsize [dict_getwithdefault $src -size ""] + set prev_cksum [dict_getwithdefault $src -cksum ""] + set prev_cksum_opts [dict_getwithdefault $src -cksum_all_opts ""] + } + } + } + #check that this relpath not already added as child of *-INPROGRESS + set file_record_body [dict_getwithdefault $file_record body [list]] ;#new file_record may have no body + set installing_record [lindex $file_record_body end] + set already_present_record [lib::install_record_get_matching_source_record $installing_record $source_relpath] + if {[llength $already_present_record]} { + error "installfile_add_source_and_fetch_metadata error: source path $source_relpath already exists in the file_record - cannot add again" + } + + set use_cache 0 + if {$prev_cksum_opts ne ""} { + set cksum_opts $prev_cksum_opts + #find first cached_cksum that is compatible with cksum opts used in latest install record + foreach cacheinfo $cached_cksums { + set cachedopts [dict get $cacheinfo opts] + set cache_is_match 1 + dict for {k v} $cachedopts { + if {[dict exists $prev_cksum_opts $k] && $v ne [dict get $prev_cksum_opts $k]} { + set cache_is_match 0 + break + } + } + if {$cache_is_match} { + set use_cache_record $cacheinfo + set use_cache 1 + break + } + } + + } else { + #no cksum opts available from an install record + set cksum_opts "" + #use first entry in cached_cksums if we can + if {[llength $cached_cksums]} { + set use_cache 1 + set use_cache_record [lindex $cached_cksums 0] + } + } + + #todo - accept argument of cached source cksum info (for client calling multiple targets with same source in quick succession e.g when building .vfs kits with multiple runtimes) + #if same cksum_opts - then use cached data instead of checksumming here. + + #allow nonexistant as a source + set fpath [file join $punkcheck_folder $source_relpath] + #windows: file exist + file type = 2ms vs 500ms for 2x glob + set floc [file dirname $fpath] + set fname [file tail $fpath] + set file_set [glob -nocomplain -dir $floc -type f -tails $fname] + set dir_set [glob -nocomplain -dir $floc -type d -tails $fname] + set link_set [glob -nocomplain -dir $floc -type l -tails $fname] + if {[llength $file_set] == 0 && [llength $dir_set] == 0 && [llength $link_set] == 0} { + #could also theoretically exist as less common types, b,c,p,s (block,char,pipe,socket) + #- we don't expect them here - REVIEW - ever possible? + #- installing/examining such things an unlikely usecase and would require special handling anyway. + set ftype "missing" + set fsize "" + } else { + if {[llength $dir_set]} { + set ftype "directory" + set fsize "NA" + } elseif {[llength $link_set]} { + set ftype "link" + set fsize 0 + } else { + set ftype "file" + #todo - optionally use mtime instead of cksum (for files only)? + #mtime is not reliable across platforms and filesystems though.. see article linked at top. + set fsize [file size $fpath] + } + } + + #if {![file exists $fpath]} { + # set ftype "missing" + # set fsize "" + #} else { + # set ftype [file type $fpath] + # if {$ftype eq "directory"} { + # set fsize "NA" + # } else { + # #todo - optionally use mtime instead of cksum (for files only)? + # #mtime is not reliable across platforms and filesystems though.. see article linked at top. + # set fsize [file size $fpath] + # } + #} + #get_relativecksum_from_base and fill_relativecksums_from_base_and_relativepathdict will set cksum to if fpath doesn't exist + if {$use_cache} { + set source_cksum_info [punk::mix::base::lib::fill_relativecksums_from_base_and_relativepathdict $punkcheck_folder [dict create $source_relpath $use_cache_record]] + } else { + set source_cksum_info [punk::mix::base::lib::get_relativecksum_from_base $punkcheck_folder $source_relpath {*}$cksum_opts] + } + + + lassign $source_cksum_info pathkey ckinfo + if {$pathkey ne $source_relpath} { + error "installfile_add_source_and_fetch_metadata error: cksum returned wrong path info '$pathkey' expected '$source_relpath'" + } + set cksum [dict get $ckinfo cksum] + #set cksum_all_opts [dict get $ckinfo cksum_all_opts] + set cksum_all_opts [dict get $ckinfo opts] + if {$cksum ne $prev_cksum || $ftype ne $prev_ftype || $fsize ne $prev_fsize} { + set changed 1 + } else { + set changed 0 + } + set installing_record_sources [dict_getwithdefault $installing_record body [list]] + set ts_now [clock microseconds] ;#gathering metadata - especially checksums on folder can take some time - calc and store elapsed us for time taken to gather metadata + set metadata_us [expr {$ts_now - $ts_start}] + set this_source_record [dict create tag SOURCE -type $ftype -size $fsize -path $source_relpath -cksum $cksum -cksum_all_opts $cksum_all_opts -changed $changed -metadata_us $metadata_us] + lappend installing_record_sources $this_source_record + dict set installing_record body $installing_record_sources + + lset file_record_body end $installing_record + + dict set file_record body $file_record_body + return $file_record + } + + #write back to punkcheck - don't accept recordset - invalid to update anything other than the installing_record at this time + proc installfile_started_install {punkcheck_folder file_record} { + if {![lib::is_file_record_inprogress $file_record]} { + error "installfile_started_install error: bad file_record - expected FILEINFO with last body element *-INPROGRESS" + } + set punkcheck_file [file join $punkcheck_folder/.punkcheck] + set record_list [load_records_from_file $punkcheck_file] + + set file_record_body [dict get $file_record body] + set targetlist [dict get $file_record -targets] + set installing_record [lindex $file_record_body end] + + set ts_start [dict get $installing_record -ts] + set ts_now [clock microseconds] + set metadata_us [expr {$ts_now - $ts_start}] + + dict set installing_record -metadata_us $metadata_us + dict set installing_record -ts_start_transfer $ts_now + + lset file_record_body end $installing_record + + dict set file_record body $file_record_body + + + set getresult [punkcheck::recordlist::get_file_record $targetlist $record_list] + set old_posn [dict get $getresult position] + if {$old_posn == -1} { + lappend record_list $file_record + } else { + lset record_list $old_posn $file_record + } + + save_records_to_file $record_list $punkcheck_file "installfile_started_install [llength $targetlist] targets" + return $file_record + } + proc installfile_finished_install {punkcheck_folder file_record} { + if {![lib::is_file_record_inprogress $file_record]} { + error "installfile_finished_install error: bad file_record - expected FILEINFO with last body element *-INPROGRESS" + } + set punkcheck_file [file join $punkcheck_folder/.punkcheck] + set record_list [load_records_from_file $punkcheck_file] + + set file_record_body [dict get $file_record body] + set targetlist [dict get $file_record -targets] + set installing_record [lindex $file_record_body end] + + set ts_start [dict get $installing_record -ts] + set ts_start_transfer [dict get $installing_record -ts_start_transfer] + set ts_now [clock microseconds] + set elapsed_us [expr {$ts_now - $ts_start}] + set transfer_us [expr {$ts_now - $ts_start_transfer}] + dict set installing_record -transfer_us $transfer_us + dict set installing_record -elapsed_us $elapsed_us + dict unset installing_record -tempcontext + dict set installing_record tag "INSTALL-RECORD" + + lset file_record_body end $installing_record + dict set file_record body $file_record_body + + set file_record [punkcheck::recordlist::file_record_prune $file_record] + + set oldrecordinfo [punkcheck::recordlist::get_file_record $targetlist $record_list] + set old_posn [dict get $oldrecordinfo position] + if {$old_posn == -1} { + lappend record_list $file_record + } else { + lset record_list $old_posn $file_record + } + + save_records_to_file $record_list $punkcheck_file "installfile_finished_install [llength $targetlist] targets" + return $file_record + } + proc installfile_skipped_install {punkcheck_folder file_record} { + if {![lib::is_file_record_inprogress $file_record]} { + set msg "installfile_skipped_install error: bad file_record - expected FILEINFO with last body element *-INPROGRESS" + append msg \n "received:" + append msg \n $file_record + error $msg + } + set punkcheck_file [file join $punkcheck_folder/.punkcheck] + set record_list [load_records_from_file $punkcheck_file] + + set file_record_body [dict get $file_record body] + set targetlist [dict get $file_record -targets] + set installing_record [lindex $file_record_body end] + + set ts_start [dict get $installing_record -ts] + set tsnow [clock microseconds] + set elapsed_us [expr {$tsnow - $ts_start}] + dict set installing_record -elapsed_us $elapsed_us + dict set installing_record tag "INSTALL-SKIPPED" + + lset file_record_body end $installing_record + dict set file_record body $file_record_body + + set file_record [punkcheck::recordlist::file_record_prune $file_record] + + set getresult [punkcheck::recordlist::get_file_record $targetlist $record_list] + set old_posn [dict get $getresult position] + if {$old_posn == -1} { + lappend record_list $file_record + } else { + lset record_list $old_posn $file_record + } + + save_records_to_file $record_list $punkcheck_file "installfile_skipped_install [llength $targetlist] targets" + return $file_record + } + #----------------------------------------------- + #then: file_record_add_installrecord + + namespace eval lib { + set pkg punkcheck + namespace path ::punkcheck + proc is_file_record_inprogress {file_record} { + if {[dict get $file_record tag] ne "FILEINFO"} { + return 0 + } + set installing_record [lindex [dict_getwithdefault $file_record body [list]] end] + if {[dict_getwithdefault $installing_record tag [list]] ni [list QUERY-INPROGRESS INSTALL-INPROGRESS MODIFY-INPROGRESS DELETE-INPROGRESS VIRTUAL-INPROGRESS]} { + return 0 + } + return 1 + } + proc is_file_record_installing {file_record} { + if {[dict get $file_record tag] ne "FILEINFO"} { + return 0 + } + set installing_record [lindex [dict_getwithdefault $file_record body [list]] end] + if {[dict_getwithdefault $installing_record tag [list]] ne "INSTALL-INPROGRESS"} { + return 0 + } + return 1 + } + proc file_record_get_last_installrecord {file_record} { + set body [dict_getwithdefault $file_record body [list]] + set previous_install_records [lrange $body 0 end-1] + #get last previous that is tagged INSTALL-RECORD,MODIFY-RECORD,VIRTUAL-RECORD + #REVIEW DELETERECORD ??? + set revlist [lreverse $previous_install_records] + foreach rec $revlist { + if {[dict get $rec tag] in [list "INSTALL-RECORD" "MODIFY-RECORD" "VIRTUAL-RECORD"]} { + return $rec + } + } + return [list] + } + + #should work on *-INPROGRESS or INSTALL(etc) record - don't restrict tag to INSTALL + proc install_record_get_matching_source_record {install_record source_relpath} { + set body [dict_getwithdefault $install_record body [list]] + foreach src $body { + if {[dict get $src tag] eq "SOURCE"} { + if {[dict_getwithdefault $src -path ""] eq $source_relpath} { + return $src + } + } + } + return [list] + } + + + + #maint warning - also in punk::mix::util + proc path_relative {base dst} { + #see also kettle + # Modified copy of ::fileutil::relative (tcllib) + # Adapted to 8.5 ({*}). + # + # Taking two _directory_ paths, a base and a destination, computes the path + # of the destination relative to the base. + # + # Arguments: + # base The path to make the destination relative to. + # dst The destination path + # + # Results: + # The path of the destination, relative to the base. + + # Ensure that the link to directory 'dst' is properly done relative to + # the directory 'base'. + + #review - check volume info on windows.. UNC paths? + if {[file pathtype $base] ne [file pathtype $dst]} { + return -code error "Unable to compute relation for paths of different pathtypes: [file pathtype $base] vs. [file pathtype $dst], ($base vs. $dst)" + } + + #avoid normalizing if possible - at least for relative paths which we are likely to loop on (file normalize *very* expensive on windows) + set do_normalize 0 + if {[file pathtype $base] eq "relative"} { + #if base is relative so is dst + if {[regexp {[.]{2}} [list $base $dst]]} { + set do_normalize 1 + } + if {[regexp {[.]/} [list $base $dst]]} { + set do_normalize 1 + } + } else { + #case differences in volumes is common on windows + set do_normalize 1 + } + if {$do_normalize} { + set base [file normalize $base] + set dst [file normalize $dst] + } + + set save $dst + set base [file split $base] + set dst [file split $dst] + + while {[lindex $dst 0] eq [lindex $base 0]} { + set dst [lrange $dst 1 end] + set base [lrange $base 1 end] + if {![llength $dst]} {break} + } + + set dstlen [llength $dst] + set baselen [llength $base] + + if {($dstlen == 0) && ($baselen == 0)} { + # Cases: + # (a) base == dst + + set dst . + } else { + # Cases: + # (b) base is: base/sub = sub + # dst is: base = {} + + # (c) base is: base = {} + # dst is: base/sub = sub + + while {$baselen > 0} { + #set dst [linsert $dst 0 ..] + ledit dst -1 -1 .. + incr baselen -1 + } + set dst [file join {*}$dst] + } + + return $dst + } + } + #skip writing punkcheck during checksum/timestamp checks + + #todo - punk::args - fetch from punkcheck::install (with overrides) + proc install_tm_files {srcdir basedir args} { + set defaults [list {*}{ + -glob *.tm + -installer punkcheck::install_tm_files + } -exclude-filetails [list "*[punk::mix::util::tm_version_magic]*"] {*}{ + } + ] + set opts [dict merge $defaults $args] + punkcheck::install $srcdir $basedir {*}$opts + } + proc install_non_tm_files {srcdir basedir args} { + #set keys [dict keys $args] + #adjust the default excludedirseg_core entries so that .fossil-custom, .fossil-settings are copied + set excludedirseg_core [punkcheck::default_excludedirseg_core] + set posn [lsearch $excludedirseg_core ".fossil*"] + if {$posn >=0} { + ledit excludedirseg_core $posn $posn + } + set defaults [list {*}{ + } -glob * {*}{ + } -exclude-filetails [list "*.tm" "*-buildversion.txt" "*.exe"] {*}{ + } -exclude-dirsegments_core $excludedirseg_core {*}{ + } -installer punkcheck::install_non_tm_files {*}{ + } + ] + set opts [dict merge $defaults $args] + punkcheck::install $srcdir $basedir {*}$opts + } + + #for tcl8.6 - tcl8.7+ has dict getwithdefault (dict getdef) + proc dict_getwithdefault {dictValue args} { + if {[llength $args] < 2} { + error {wrong # args: should be "dict_getdef dictionary ?key ...? key default"} + } + set keys [lrange $args 0 end-1] + if {[dict exists $dictValue {*}$keys]} { + return [dict get $dictValue {*}$keys] + } else { + return [lindex $args end] + } + } + lappend PUNKARGS [list { + @id -id ::punkcheck::install + @cmd -name ::punkcheck::install -help\ + "Unidirectional file transfer to possibly non-empty target folder. + This is the simpler form of the API, performing a transfer from one + directory tree to another, copying each file when changes in the source + file are detected. + Changes are detected by content checksum. The first install will record + source checksums in a .punkcheck file (ideally located at the root of the + target folder). Subsequent installs will compare stored checksums with + the current checksums of the source files. + For more advanced install operations, the object command installtrack + can be used to define install operations. e.g when the transfer is not + one-to-one and a target file depends on multiple source files." + @leaders -min 2 -max 2 + srcdir -type directory + tgtdir -type directory + -call-depth-internal -type integer -default 0 -help "(internal recursion tracker)" + -subdirlist -type list -default "" -help "(primarily internal - length generally matching -call-depth-internal)" + -max_depth -type integer -default 1000 -help\ + "Deepest subdirectory - use -1 for no limit." + -createdir -type boolean -default 0 -help\ + "Whether to create the folder at tgtdir. + Any required subdirectories are created regardless of this setting." + -createempty -type boolean -default 0 -help\ + "Whether to create folders at target that had no matches for our glob" + -glob -type string -default "*" -help\ + "Pattern matching for source file(s) to copy. Can be glob based or exact match." + -exclude-filetails_core -default {${[::punkcheck::default_excludefiltail_core]}} + -exclude-filetails -default "" + -exclude-dirsegments_core -default {${[::punkcheck::default_excludedirseg_core]}} + -exclude-dirsegments -default "" + -antiglob_paths -default {} + -overwrite -default no-targets\ + -choices {no-targets newer-targets older-targets all-targets installedsourcechanged-targets synced-targets}\ + -choicecolumns 1\ + -choicelabels { + no-targets "only copy files that are missing at the target" + newer-targets "copy files with older source timestamp over newer + target timestamp and those missing at the target + (a form of 'restore' operation)" + older-targets "copy files with newer source timestamp over older + target timestamp and those missing at the target" + all-targets "copy regardless of timestamp at target" + installedsourcechanged-targets "copy if the target doesn't exist or the source changed" + synced-targets "copy if the target doesn't exist or the source changed + and the target cksum is the same as the last INSTALL-RECORD -targets_cksums entry" + } + -source_checksum -default comparestore -choicecolumns 3 -choices {compare store comparestore false true}\ + -choicelabels { + true "same as comparestore" + } + -punkcheck_folder -default target -choices {target source project} -choicerestricted 0 -help\ + "The location of the .punkcheck file to track installations and checksums. + The default value 'target' is generally recommended. + Can also be an absolute path to a folder." + -punkcheck_records -default "" -help\ + "Empty string or a parsed TDL records structure. + e.g + {tag FILEINFO - ... body { + {tag INSTALL-RECORD - ... body {}} + ... + }... + }" + -installer -default "punkcheck::install" -help\ + "A user nominated string that is stored in the .punkcheck file + This might be the name of a script or installation process." + -progresschannel -default none -type string -help\ + "Name of channel e.g stderr, stdout to which progress messages are written. + This includes the tree-like output consisting of dots (or green U) for each + file processed. As the number of files in a tree is not known beforehand, + it isn't useful for a percentage-based progress meter, but it could potentially + be used to drive a spinner if the textual data is not desired. + Setting to none or an invalid channel will deactivate the output." + }] + ## unidirectional file transfer to possibly non empty folder + #default of -overwrite no-targets will only copy files that are missing at the target + # -overwrite newer-targets will copy files with older source timestamp over newer target timestamp and those missing at the target (a form of 'restore' operation) + # -overwrite older-targets will copy files with newer source timestamp over older target timestamp and those missing at the target + # -overwrite all-targets will copy regardless of timestamp at target + # -overwrite installedsourcechanged-targets will copy if the target doesn't exist or the source changed + # -overwrite synced-targets will copy if the target doesn't exist or the source changed and the target cksum is the same as the last INSTALL-RECORD -targets_cksums entry + # review - timestamps unreliable + # - what about slightly mismatched system clocks and mounted filesystems? caller responsibility to verify first? + # if timestamp exactly equal - should we check content-hash? This is presumably only likely to occur deliberately(maliciously?) + # e.g some process that digitally signs or otherwise modifies a file and preserves update timestmp? + # if such a content-mismatch - what default behaviour and what options would make sense? + # probably it's reasonable that only all-targets would overwrite such files. + # consider -source_fudge_seconds +-X ?, -source_override_timestamp ts ??? etc which only adjust timestamp for calculation purposes? Define a specific need/usecase when reviewing. + # + # valid filetypes for src tgt + # src dir tgt dir + # todo - review and consider enabling symlink src and dst + # no need for src file - as we use -glob with no glob characters to match one source file file + # no ability to target file with different name - keep it simpler and caller will have to use an intermediate folder/file if they need to rename something? + # + # todo - determine what happens if mismatch between file type of a src vs target e.g target has dir matching filename at source + # A pre-scan to determine no such conflict - before attempting to copy anything might provide the most integrity at slight cost in speed. + # REVIEW we should only expect dirs to be created as necessary to hold files? i.e target folder won't be created if no source file matches for that folder + # -source_checksum compare|store|comparestore|false|true where true == comparestore + # -punkcheck_folder target|source|project| target is default and is generally recommended + # -punkcheck_records empty string | parsed TDL records ie {tag xxx k v} structure + # install creates FILEINFO records with a single entry in the -targets field (it is legitimate to have a list of targets for an installation operation - the oo interface supports this) + proc install {srcdir tgtdir args} { + set defaults [list {*}{ + -call-depth-internal 0 + -max_depth 1000 + -subdirlist {} + -createdir 0 + -createempty 0 + -glob * + -exclude-filetails_core "\uFFFF" + -exclude-filetails "" + -exclude-dirsegments_core "\uFFFF" + -exclude-dirsegments {} + -antiglob_paths {} + -overwrite no-targets + -source_checksum comparestore + -punkcheck_folder target + -punkcheck_eventid "\uFFFF" + -punkcheck_records "" + -installer punkcheck::install + -progresschannel none + }] + + if {([llength $args] %2) != 0} { + error "punkcheck::install requires option-style arguments to be in pairs. Received args: $args" + } + foreach {k -} $args { + if {$k ni [dict keys $defaults]} { + error "punkcheck::install unrecognised option '$k' known options: '[dict keys $defaults]'" + } + } + set opts [dict merge $defaults $args] + + #The choice to recurse using the original values of srcdir & tgtdir, and passing the subpath down as a list in -subdirlist seems an odd one. + #(as opposed to a more 'standard' mechanism of adjusting srcdir & tgtdir as we move down the tree) + #It comes from build_modules_from_source_to_base where we need to keep track of position relative to our targetdir starting point to handle submodules e.g pkg::something::mypkg-0.1.tm + #It could have been handled with some other parameter such as -depth, but this -subdirlist mechanism, whilst perhaps not beautiful, is straightforward enough + #and may be less error prone than doing slightly more opaque path manipulations at each recursion level to determine where we started + #For consistency - we'll use the same mechanism in various recursive directory walking procedures such as this one. + set CALLDEPTH [dict get $opts -call-depth-internal] ;#added for extra debug/sanity checking - clearer test for initial function call ie CALLDEPTH = 0 + set max_depth [dict get $opts -max_depth] ;# -1 for no limit + set subdirlist [dict get $opts -subdirlist] ;# generally should be same length as CALLDEPTH - but user could prefill + set fileglob [dict get $opts -glob] + set createdir [dict get $opts -createdir] ;#defaults to zero to help avoid mistakes with initial target dir - required target subdirs are created regardless of this setting + set opt_createempty [dict get $opts -createempty] + set opt_progresschannel [dict get $opts -progresschannel] + if {$opt_progresschannel in {"" none} || [catch {chan configure $opt_progresschannel}]} { + set opt_progresschannel "" + } + + if {$CALLDEPTH == 0} { + #expensive to normalize but we need to do it at least once + set srcdir [file normalize $srcdir] + set tgtdir [file normalize $tgtdir] + if {$createdir} { + file mkdir $tgtdir + } else { + if {![file exists $tgtdir]} { + error "punkcheck::install base target dir:'$tgtdir' doesn't exist (srcdir:$srcdir tgtdir:$tgtdir args:'$args')" + } + } + if {([file type $srcdir] ni [list directory]) || ([file type $tgtdir] ni [list directory])} { + error "punkcheck::install requires source and target dirs to be of type 'directory' type current source: [file type $srcdir] type current target: [file type $tgtdir]" + } + #now the values we build from these will be properly cased + } + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + set opt_excludefiletail_core [dict get $opts -exclude-filetails_core] + if {$opt_excludefiletail_core eq "\uFFFF"} { + set opt_excludefiletail_core [default_excludefiletail_core] + dict set opts -exclude-filetails_core $opt_excludefiletail_core + } + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + set opt_excludefiletail [dict get $opts -exclude-filetails] + #validate no path seps + foreach af $opt_excludefiletail { + if {[llength [file split $af]] > 1} { + error "punkcheck::install received invalid -exclude-filetails entry '$af'. -exclude-filetails entries are meant to match to a file name at any level so cannot contain path separators" + } + } + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + set opt_excludedirseg_core [dict get $opts -exclude-dirsegments_core] + if {$opt_excludedirseg_core eq "\uFFFF"} { + set opt_excludedirseg_core [default_excludedirseg_core] + dict set opts -exclude-dirsegments_core $opt_excludedirseg_core + } + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + set opt_excludedirseg [dict get $opts -exclude-dirsegments] + #validate no path seps + foreach ad $opt_excludedirseg { + if {[llength [file split $ad]] > 1} { + error "punkcheck::install received invalid -exclude-dirsegments entry '$ad'. -exclude-dirsegments entries are meant to match to a directory name at any level so cannot contain path separators" + } + } + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + set opt_antiglob_paths [dict get $opts -antiglob_paths] ;#todo - combine with config file in source tree .punkcheckpublish (?) + #antiglob_paths will usually contain file separators - and may contain glob patterns within each segment + set antiglob_paths_matched [list] + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + set known_whats [list no-targets newer-targets older-targets all-targets installedsourcechanged-targets synced-targets] + set overwrite_what [string tolower [dict get $opts -overwrite]]; #accept any case for value to allow emphasis by caller e.g -overwrite NEWER-TARGETS + if {$overwrite_what ni $known_whats} { + error "punkcheck::install received unrecognised value for -overwrite. Received value '$overwrite_what' vs known values '$known_whats'" + } + if {$overwrite_what in [list newer-targets older-targets]} { + error "punkcheck::install newer-target, older-targets not implemented - sorry" + #TODO - check crossplatform availability of ctime (on windows it still seems to be creation time, but on bsd/linux it's last attribute mod time) + # external pkg? use twapi and ctime only on other platforms? + } + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + set opt_source_checksum [dict get $opts -source_checksum] + if {[string is boolean $opt_source_checksum]} { + if {$opt_source_checksum} { + set opt_source_checksum "comparestore" + } else { + set opt_source_checksum 0 + } + dict set opts -source_checksum $opt_source_checksum + } + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + set opt_punkcheck_folder [dict get $opts -punkcheck_folder] + if {$opt_punkcheck_folder eq "target"} { + set punkcheck_folder $tgtdir + } elseif {$opt_punkcheck_folder eq "source"} { + set punkcheck_folder $srcdir + } elseif {$opt_punkcheck_folder eq "project"} { + set sourceprojectinfo [punk::repo::find_repos $srcdir] + set targetprojectinfo [punk::repo::find_repos $tgtdir] + set srcproj [lindex [dict get $sourceprojectinfo project] 0] + set tgtproj [lindex [dict get $targetprojectinfo project] 0] + if {$srcproj eq $tgtproj} { + set punkcheck_folder $tgtproj + } else { + error "copy_files_from_source_to_target error: Unable to find common project dir for source and target folder - use absolutepath for -punkcheck_folder if source and target are not within same project" + } + } else { + set punkcheck_folder $opt_punkcheck_folder + } + if {$punkcheck_folder ne ""} { + if {[file pathtype $punkcheck_folder] ne "absolute"} { + error "copy_files_from_source_to_target error: -punkcheck_folder '$punkcheck_folder' must be an absolute path, or one of: target|source|project" + } + if {![file isdirectory $punkcheck_folder]} { + error "copy_files_from_source_to_target error: -punkcheck_folder '$punkcheck_folder' not found" + } + } else { + #review - leave empty? use pwd? + } + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + set punkcheck_records [dict get $opts -punkcheck_records] + set punkcheck_records_init $punkcheck_records ;#change-detection + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + set opt_installer [dict get $opts -installer] + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + set opt_punkcheck_eventid [dict get $opts -punkcheck_eventid] + + + + set punkcheck_file [file join $punkcheck_folder/.punkcheck] + + if {$CALLDEPTH == 0} { + set punkcheck_eventid "" + if {$punkcheck_folder ne ""} { + set config $opts + dict unset config -call-depth-internal + dict unset config -max_depth + dict unset config -subdirlist + dict unset config -progresschannel + tcl::dict::for {k v} $config { + if {$v eq "\uFFFF"} { + dict unset config $k + } + } + lassign [punkcheck::start_installer_event $punkcheck_file $opt_installer $srcdir $tgtdir $config] _eventid punkcheck_eventid _recordset punkcheck_records + } + } else { + set punkcheck_eventid $opt_punkcheck_eventid + } + + + + if {$opt_source_checksum != 0} { + #we need to read the file even if only set to store (or we would overwrite entries) + set compare_cksums 1 + } else { + set compare_cksums 0 + } + + if {[string match *store* $opt_source_checksum]} { + set store_source_cksums 1 + } else { + set store_source_cksums 0 + } + + + + + + if {[llength $subdirlist] == 0} { + set current_source_dir $srcdir + set current_target_dir $tgtdir + } else { + set current_source_dir $srcdir/[file join {*}$subdirlist] + set current_target_dir $tgtdir/[file join {*}$subdirlist] + } + + + set relative_target_dir [lib::path_relative $tgtdir $current_target_dir] + if {$relative_target_dir eq "."} { + set relative_target_dir "" + } + set relative_source_dir [lib::path_relative $srcdir $current_source_dir] + if {$relative_source_dir eq "."} { + set relative_source_dir "" + } + set target_relative_to_punkcheck_dir [lib::path_relative $punkcheck_folder $current_target_dir] + if {$target_relative_to_punkcheck_dir eq "."} { + set target_relative_to_punkcheck_dir "" + } + foreach unpub $opt_antiglob_paths { + #puts "testing folder - globmatchpath $unpub $relative_source_dir" + if {[punk::path::globmatchpath $unpub $relative_source_dir]} { + lappend antiglob_paths_matched $current_source_dir + return [list files_copied {} files_skipped {} sources_unchanged {} punkcheck_records $punkcheck_records antiglob_paths_matched $antiglob_paths_matched srcdir $srcdir tgtdir $tgtdir punkcheck_folder $punkcheck_folder] + } + } + + + if {![file exists $current_source_dir]} { + error "punkcheck::install current source dir:'$current_source_dir' doesn't exist (srcdir:$srcdir tgtdir:$tgtdir args:'$args')" + } + + set files_copied [list] + set files_skipped [list] + set sources_unchanged [list] + + + set candidate_list [glob -nocomplain -dir $current_source_dir -type f -tail $fileglob] + set hidden_candidate_list [glob -nocomplain -dir $current_source_dir -types {hidden f} -tail $fileglob] + foreach h $hidden_candidate_list { + if {$h ni $candidate_list} { + lappend candidate_list $h + } + } + set match_list [list] + foreach m $candidate_list { + set suppress 0 + foreach anti [concat $opt_excludefiletail_core $opt_excludefiletail] { + if {[string match $anti $m]} { + #puts stderr "anti: $anti vs m:$m" + set suppress 1 + break + } + } + if {$suppress == 0} { + lappend match_list $m + } + } + + #sample .punkcheck file record (raw form) to make the code clearer + #punk::tdl converts to dict form e.g: tag FILEINFO -targets filename body sublist + #Valid installrecord types are INSTALL-RECORD SKIPPED INSTALL-INPROGRESS, MODIFY-RECORD MODIFY-INPROGRESS DELETE-RECORD DELETE-INPROGRESS + # + #FILEINFO -targets jjjetc-0.1.0.tm -keep_installrecords 2 -keep_skipped 1 -keep_inprogress 2 { + # INSTALL-RECORD -tsiso 2023-09-20T07:30:30 -ts 1695159030266610 -installer punk::mix::cli::build_modules_from_source_to_base -metadata_us 18426 -ts_start_transfer 1695159030285036 -transfer_us 10194 -elapsed_us 28620 { + # SOURCE -type file -path ../src/modules/jjjetc-buildversion.txt -cksum c7c71839c36b3d21c8370fed106192fcd659eca9 -cksum_all_opts {-cksum_content 1 -cksum_meta 0 -cksum_acls 0 -cksum_usetar 0 -cksum_algorithm sha1} -changed 1 -metadata_us 3423 + # SOURCE -type file -path ../src/modules/jjjetc-0.1.1.tm -cksum b646fc2ee88cbd068d2e946fe929b7aea96bd39d -cksum_all_opts {-cksum_content 1 -cksum_meta 0 -cksum_acls 0 -cksum_usetar 0 -cksum_algorithm sha1} -changed 1 -metadata_us 3413 + # } + # INSTALL-SKIPPED -tsiso 2023-09-20T08:14:26 -ts 1695161666087880 -installer punk::mix::cli::build_modules_from_source_to_base -elapsed_us 18914 { + # SOURCE -type file -path ../src/modules/jjjetc-buildversion.txt -cksum c7c71839c36b3d21c8370fed106192fcd659eca9 -cksum_all_opts {-cksum_content 1 -cksum_meta 0 -cksum_acls 0 -cksum_usetar 0 -cksum_algorithm sha1} -changed 0 -metadata_us 3435 + # SOURCE -type file -path ../src/modules/jjjetc-0.1.1.tm -cksum b646fc2ee88cbd068d2e946fe929b7aea96bd39d -cksum_all_opts {-cksum_content 1 -cksum_meta 0 -cksum_acls 0 -cksum_usetar 0 -cksum_algorithm sha1} -changed 0 -metadata_us 3338 + # } + #} + + if {[llength $match_list]} { + #example - target dir has a file where there is a directory at the source + if {[file exists $current_target_dir] && ([file type $current_target_dir] ni [list directory])} { + error "punkcheck::install target subfolder $current_target_dir exists but is not of type 'directory'. Type current target folder: [file type $current_target_dir]" + } + } + + #proc get_relativecksum_from_base_and_fullpath {base fullpath args} + + + #puts stdout "Current target dir: $current_target_dir" + set last_depth "" + foreach m $match_list { + set new_tgt_cksum_info [list] + set relative_target_path [file join $relative_target_dir $m] + set relative_source_path [file join $relative_source_dir $m] + set punkcheck_target_relpath [file join $target_relative_to_punkcheck_dir $m] + set is_antipath 0 + foreach antipath $opt_antiglob_paths { + #puts "testing file - globmatchpath $antipath vs $relative_source_path" + if {[punk::path::globmatchpath $antipath $relative_source_path]} { + lappend antiglob_paths_matched $current_source_dir + set is_antipath 1 + break + } + } + if {$is_antipath} { + continue + } + + set ts_start [clock microseconds] + set seconds [expr {$ts_start / 1000000}] + set ts_start_iso [clock format $seconds -format "%Y-%m-%dT%H:%M:%S"] + + + #puts stdout " rel_target: $punkcheck_target_relpath" + + set fetch_filerec_result [punkcheck::recordlist::get_file_record $punkcheck_target_relpath $punkcheck_records] + #change to use extract_or_create_fileset_record ? + set existing_filerec_posn [dict get $fetch_filerec_result position] + if {$existing_filerec_posn == -1} { + if {$opt_progresschannel ne ""} { + puts stdout "\nNO existing record for $punkcheck_target_relpath" + } + set has_filerec 0 + set new_filerec [dict create tag FILEINFO -targets $punkcheck_target_relpath] + set filerec $new_filerec + } else { + set has_filerec 1 + #puts stdout " TDL existing FILEINFO record for $punkcheck_target_relpath" + #puts stdout " $existing_install_record" + set filerec [dict get $fetch_filerec_result record] + } + set filerec [punkcheck::recordlist::file_record_set_defaults $filerec] + + #new INSTALLREC must be tagged as INSTALL-INPROGRESS to use recordlist::installfile_ method + set new_install_record [dict create tag INSTALL-INPROGRESS -tsiso $ts_start_iso -ts $ts_start -installer $opt_installer -eventid $punkcheck_eventid] + dict lappend filerec body $new_install_record ;#can't use recordlist::file_record_add_installrecord as '*-INPROGRESS' isn't a final tag - so pruning would be mucked up. No need to prune now anyway. + unset new_install_record + + + if {$opt_progresschannel ne ""} { + if {$last_depth ne $CALLDEPTH} { + if {$CALLDEPTH <=1} { + puts -nonewline $opt_progresschannel \n[string repeat " " $CALLDEPTH][file tail $relative_source_dir] + } + flush $opt_progresschannel + ##set last_depth $CALLDEPTH ;# done down below + } + } + + + + set relative_source_path [lib::path_relative $punkcheck_folder $current_source_dir/$m] + #puts stdout " rel_source: $relative_source_path" + #if {[file pathtype $relative_source_path] ne "relative"} { + #REVIEW + #different volume or root + #} + #Note this isn't a recordlist function - so it doesn't purely operate on the records + #this hits the filesystem for the sourcepath - gets checksums/timestamps depending on config. + #It doesn't save to .punkcheck (the only punkcheck::installfile_ method which doesn't) + set ts1 [clock milliseconds] + set filerec [punkcheck::installfile_add_source_and_fetch_metadata $punkcheck_folder $relative_source_path $filerec] + set ts2 [clock milliseconds] + set diff [expr {$ts2 - $ts1}] + if {$diff > 100} { + #todo -errorchannel + set errprefix ">>> punkcheck:" + puts stderr "\n$errprefix performance warning: fetch_metadata for $m took $diff ms." + set lb [lindex [dict get $filerec body] end] + #puts stderr "$errprefix filerec last body record:$lb" + set records [dict get $lb body] + set lr [lindex $records end] + set alg [dict get $lr -cksum_all_opts -cksum_algorithm] + if {$alg eq "sha1"} { + puts stderr "$errprefix cksum_algorithm: sha1 (accelerators: [::sha1::Implementations])" + puts stderr "$errprefix sha1 from: [package ifneeded sha1 [package present sha1]]" + } else { + puts stderr "$errprefix cksum_algorithm: $alg" + } + } + + + + #changeinfo comes from last record in body - which is the record we are working on and so will always exist + set changeinfo [punkcheck::recordlist::file_install_record_source_changes [lindex [dict get $filerec body] end]] + set changed [dict get $changeinfo changed] + set unchanged [dict get $changeinfo unchanged] + + if {[llength $unchanged]} { + lappend sources_unchanged $current_source_dir/$m + } + + set is_skip 0 + set is_new 0 + if {$overwrite_what eq "all-targets"} { + file mkdir $current_target_dir + #-------------------------------------------- + #sometimes we get the error: 'error copying "file1" to "file2": invalid argument' + #-------------------------------------------- + puts stderr "punkcheck: about to: file copy -force $current_source_dir/$m $current_target_dir" + file copy -force $current_source_dir/$m $current_target_dir + lappend files_copied $current_source_dir/$m + } else { + if {![file exists $current_target_dir/$m]} { + #puts stderr "punkcheck: first copy to $current_target_dir/$m " + file mkdir $current_target_dir + puts stderr "punkcheck: about to: file copy $current_source_dir/$m $current_target_dir" + file copy $current_source_dir/$m $current_target_dir + set new_tgt_cksum_info [punk::mix::base::lib::cksum_path $current_target_dir/$m] + lappend files_copied $current_source_dir/$m + incr filecount_new + set is_new 1 + } else { + switch -- $overwrite_what { + installedsourcechanged-targets { + if {[llength $changed]} { + #An unrecorded installation is considered a source change (from unknown/unrecorded source to recorded) + puts -nonewline stderr "punkcheck: about to: file copy -force $current_source_dir/$m $current_target_dir" + set ts1 [clock milliseconds] + file mkdir $current_target_dir + file copy -force $current_source_dir/$m $current_target_dir + set ts2 [clock milliseconds] + puts -nonewline stderr " (copy time [expr {$ts2 - $ts1}] ms)" + set new_tgt_cksum_info [punk::mix::base::lib::cksum_path $current_target_dir/$m] + set ts3 [clock milliseconds] + puts stderr " (cksum time [expr {$ts2 - $ts1}] ms)" + lappend files_copied $current_source_dir/$m + } else { + set is_skip 1 + lappend files_skipped $current_source_dir/$m + } + } + synced-targets { + #disallow overwriting of target that has been modified by some other mechanism + #review + if {[llength $changed]} { + #only overwrite if the target file checksum equals the last installed checksum (ie target is in sync with previous source-set and so hasn't been customized) + set existing_tgt_cksum_info [punk::mix::base::lib::cksum_path $current_target_dir/$m] + set is_target_unmodified_since_install 0 + set target_cksum_compare "unknown" + set latest_install_record [punkcheck::recordlist::file_record_latest_installrecord $filerec] ;#may be no such record - in which case we get an empty list + if {[dict exists $latest_install_record -targets_cksums]} { + set last_install_cksum [dict get $latest_install_record -targets_cksums] ;#in this case we know there is only one as 'install' always uses targetset size of 1. (FILEINFO record per file in source folder) + if {[dict get $existing_tgt_cksum_info cksum] eq $last_install_cksum} { + set is_target_unmodified_since_install 1 + set target_cksum_compare "match" + } else { + set target_cksum_compare "nomatch" + } + } else { + set target_cksum_compare "norecord" + } + if {$is_target_unmodified_since_install} { + file mkdir $current_target_dir + puts stderr "punkcheck: synced-targets about to: file copy -force $current_source_dir/$m $current_target_dir" + file copy -force $current_source_dir/$m $current_target_dir + set new_tgt_cksum_info [punk::mix::base::lib::cksum_path $current_target_dir/$m] + lappend files_copied $current_source_dir/$m + } else { + #either cksum is different or we were unable to verify the record. Either way we can't know if the target is in sync so we must skip it + set is_skip 1 + puts stderr "Skipping file copy $m target $current_target_dir/$m - require synced_target to overwrite - current target cksum compared to previous install: $target_cksum_compare" + lappend files_skipped $current_source_dir/$m + } + } else { + set is_skip 1 + lappend files_skipped $current_source_dir/$m + } + } + default { + set is_skip 1 + puts stderr "Skipping file copy $m target $current_target_dir/$m already exists (use -overwrite all-targets to overwrite)" + #TODO! implement newer-targets older-targets? (note ctimes/mtimes are unreliable - may not be worth implementing) + lappend files_skipped $current_source_dir/$m + } + } + } + } + #target dir was created as necessary if files matched above + #now ensure target dir exists if -createempty true + if {$opt_createempty && ![file exists $current_target_dir]} { + file mkdir $current_target_dir + } + + + + + set ts_now [clock microseconds] + set elapsed_us [expr {$ts_now - $ts_start}] + + #if {$store_source_cksums} { + #} + + set install_records [dict get $filerec body] + set current_install_record [lindex $install_records end] + #change the tag from *-INPROGRESS to INSTALL-RECORD/SKIPPED + if {$is_skip} { + set tag INSTALL-SKIPPED + } else { + set tag INSTALL-RECORD + } + dict set current_install_record tag $tag + dict set current_install_record -elapsed_us $elapsed_us + if {[llength $new_tgt_cksum_info]} { + dict set current_install_record -targets_cksums [list [dict get $new_tgt_cksum_info cksum]] + dict set current_install_record -cksum_all_opts [dict get $new_tgt_cksum_info opts] + } + lset install_records end $current_install_record + dict set filerec body $install_records + set filerec [punkcheck::recordlist::file_record_prune $filerec] ;#prune now that tag is finalized + if {!$has_filerec} { + #not found in original recordlist - append + lappend punkcheck_records $filerec + } else { + lset punkcheck_records $existing_filerec_posn $filerec + } + + + #------------------------------------------------------------ + if {$is_skip} { + set mark . + } else { + if {$is_new} { + set mark \x1b\[32\;1mN\x1b\[m + } else { + #updated + set mark \x1b\[32\;1mU\x1b\[m + } + } + if {$opt_progresschannel ne ""} { + if {$last_depth ne $CALLDEPTH} { + puts -nonewline $opt_progresschannel \n[string repeat " " $CALLDEPTH]$mark + flush $opt_progresschannel + set last_depth $CALLDEPTH + } else { + puts -nonewline $opt_progresschannel $mark + } + } + #------------------------------------------------------------ + + } + + if {$max_depth != -1 && $CALLDEPTH >= $max_depth} { + #don't process any more subdirs + #sometimes deliberately called with max_depth 1 - so don't warn here. review + #puts stderr "punkcheck::install warning - reached max_depth $max_depth" + set subdirs [list] + } else { + set subdirs [glob -nocomplain -dir $current_source_dir -type d -tail *] + set hiddensubdirs [glob -nocomplain -dir $current_source_dir -type {hidden d} -tail *] + foreach h $hiddensubdirs { + switch -- $h { + "." - ".." { + continue + } + default { + if {$h ni $subdirs} { + lappend subdirs $h + } + } + } + } + } + #puts stderr "subdirs: $subdirs" + foreach d $subdirs { + set skipd 0 + foreach dg [concat $opt_excludedirseg_core $opt_excludedirseg] { + if {[string match $dg $d]} { + #puts stdout "SKIPPING FOLDER $d due to excludedirseg-match: $dg " + set skipd 1 + break + } + } + if {$skipd} { + continue + } + + set relative_source_path [file join $relative_source_dir $d] + set is_antipath 0 + foreach antipath $opt_antiglob_paths { + #puts "testing folder - globmatchpath $antipath vs $relative_source_path" + if {[punk::path::globmatchpath $antipath $relative_source_path]} { + lappend antiglob_paths_matched [file join $current_source_dir $d] + #puts stdout "SKIPPING FOLDER $relative_source_path due to antiglob_path-match: $antipath " + set is_antipath 1 + break + } + } + if {$is_antipath} { + continue + } + + #if {![file exists $current_target_dir/$d]} { + # file mkdir $current_target_dir/$d + #} + + + set sub_opts_1 [list {*}{ + } -call-depth-internal [expr {$CALLDEPTH + 1}] {*}{ + } -subdirlist [list {*}$subdirlist $d] {*}{ + } -glob $fileglob {*}{ + } -exclude-filetails_core $opt_excludefiletail_core {*}{ + } -exclude-filetails $opt_excludefiletail {*}{ + } -exclude-dirsegments_core $opt_excludedirseg_core {*}{ + } -exclude-dirsegments $opt_excludedirseg {*}{ + } -overwrite $overwrite_what {*}{ + } -source_checksum $opt_source_checksum {*}{ + } -punkcheck_folder $punkcheck_folder {*}{ + } -punkcheck_eventid $punkcheck_eventid {*}{ + } -punkcheck_records $punkcheck_records {*}{ + } -installer $opt_installer {*}{ + } + ] + set sub_opts [list {*}{ + } -call-depth-internal [expr {$CALLDEPTH + 1}] {*}{ + } -subdirlist [list {*}$subdirlist $d] {*}{ + } -punkcheck_folder $punkcheck_folder {*}{ + } -punkcheck_eventid $punkcheck_eventid {*}{ + } -punkcheck_records $punkcheck_records {*}{ + } -progresschannel $opt_progresschannel {*}{ + } + ] + set sub_opts [dict merge $opts $sub_opts] + set sub_result [punkcheck::install $srcdir $tgtdir {*}$sub_opts] + + lappend files_copied {*}[dict get $sub_result files_copied] + lappend files_skipped {*}[dict get $sub_result files_skipped] + lappend sources_unchanged {*}[dict get $sub_result sources_unchanged] + lappend antiglob_paths_matched {*}[dict get $sub_result antiglob_paths_matched] + set punkcheck_records [dict get $sub_result punkcheck_records] + } + + if {[string match *store* $opt_source_checksum]} { + #puts "subdirlist: $subdirlist" + if {$CALLDEPTH == 0} { + if {[llength $files_copied] || [llength $files_skipped]} { + #puts stdout ">>>>>>>>>>>>>>>>>>>" + set saveresult [punkcheck::save_records_to_file $punkcheck_records $punkcheck_file "install $srcdir to $tgtdir"] + puts stdout "\npunkcheck::install [dict get $saveresult recordcount] records saved as [dict get $saveresult linecount] lines to $punkcheck_file copied: [llength $files_copied] skipped: [llength $files_skipped]" + #puts stdout ">>>>>>>>>>>>>>>>>>>" + } else { + #todo - write db INSTALLER record if -debug true + + } + #puts stdout "sources_unchanged" + #puts stdout "$sources_unchanged" + #puts stdout "- -- --- --- --- ---" + } + } + + return [list files_copied $files_copied files_skipped $files_skipped sources_unchanged $sources_unchanged antiglob_paths_matched $antiglob_paths_matched punkcheck_records $punkcheck_records punkcheck_folder $punkcheck_folder srcdir $srcdir tgtdir $tgtdir] + } + + + lappend PUNKARGS [list { + @id -id ::punkcheck::summarize_install_resultdict + @cmd -name punkcheck::summarize_install_resultdict -help\ + "Emits a string summarizing a punkcheck resultdict, showing + how many items were copied, and the source, target locations" + @opts + -title -type string -default "" + -forcecolour -type boolean -default 0 -help\ + "When true, passes the forcecolour tag to punk::ansi functions. + This enables ANSI sgr colours even when colour + is off. (ignoring env(NO_COLOR)) + To disable colour - ensure the NO_COLOR env var is set, + or use: + namespace eval ::punk::console {variable colour_disabled 1}" + @values -min 1 -max 1 + resultdict -type dict + }] + proc summarize_install_resultdict {args} { + set argd [punk::args::parse $args withid ::punkcheck::summarize_install_resultdict] + lassign [dict values $argd] leaders opts values received + set title [dict get $opts -title] + set forcecolour [dict get $opts -forcecolour] + set resultdict [dict get $values resultdict] + + set has_ansi [expr {![catch {package require punk::ansi}]}] + if {$has_ansi} { + if {$forcecolour} { + set fc "forcecolour" + } else { + set fc "" + } + set R [punk::ansi::a] ;#reset + set LINE_COLOUR [punk::ansi::a+ {*}$forcecolour bold cyan] + set LOW_COLOUR [punk::ansi::a+ {*}$forcecolour bold green] + set HIGH_COLOUR [punk::ansi::a+ {*}$forcecolour bold yellow] + } else { + set R "" + set LINE_COLOUR "" + set LOW_COLOUR "" + set HIGH_COLOUR "" + } + + set msg "" + if {[dict size $resultdict]} { + set copied [dict get $resultdict files_copied] + if {[llength $copied] == 0} { + set HIGHLIGHT $LOW_COLOUR + } else { + set HIGHLIGHT $HIGH_COLOUR + } + set ruler $LINE_COLOUR[string repeat - 78]$R + if {$title ne ""} { + append msg $ruler \n + append msg $title \n + } + append msg $ruler \n + #append msg "[dict keys $resultdict]" \n + set tgtdir [dict get $resultdict tgtdir] + set checkfolder [dict get $resultdict punkcheck_folder] + append msg "${HIGHLIGHT}Copied [llength $copied] files from [dict get $resultdict srcdir] to [dict get $resultdict tgtdir]$R" \n + foreach f $copied { + append msg "COPIED [punkcheck::lib::path_relative $checkfolder $f]" \n + append msg " TO $tgtdir" \n + } + append msg "[llength [dict get $resultdict sources_unchanged]] unchanged source files" \n + append msg "[llength [dict get $resultdict files_skipped]] skipped files" \n + append msg $ruler \n + } + return $msg + } + + namespace eval recordlist { + set pkg punkcheck + namespace path ::punkcheck + + proc records_as_target_dict {record_list} { + set result [dict create] + foreach rec $record_list { + if {[dict get $rec tag] eq "FILEINFO"} { + set tgtlist [dict get $rec -targets] + if {[dict exists $result $tgtlist]} { + #todo - warn - duplicate record for same targetlist - shouldn't happen as we should be using get_file_record to find existing records + error "punkcheck::recordlist::records_as_target_dict - multiple records with same targetlist '$tgtlist'" + } + dict set result $tgtlist $rec + } + } + return $result + } + + + #will only match if same base was used.. and same targetlist + proc get_file_record {targetlist record_list} { + set posn 0 + set found_posn -1 + set record "" + foreach rec $record_list { + if {[dict get $rec tag] eq "FILEINFO"} { + if {[dict get $rec -targets] eq $targetlist} { + set found_posn $posn + set record $rec + break + } + } + incr posn + } + return [list position $found_posn record $record] + } + proc file_install_record_source_changes {install_record} { + #reject INSTALLFAILED items ? + switch -- [dict get $install_record tag] { + "QUERY-INPROGRESS" - + "INSTALL-RECORD" - + "INSTALL-SKIPPED" - + "INSTALL-INPROGRESS" - + "MODIFY-INPROGRESS" - + "MODIFY-RECORD" - + "MODIFY-SKIPPED" - + "VIRTUAL-INPROGRESS" - + "VIRTUAL-RECORD" - + "VIRTUAL-SKIPPED" - + "DELETE-RECORD" - + "DELETE-INPROGRESS" - + "DELETE-SKIPPED" { + } + default { + error "file_install_record_source_changes bad install record: tag '[dict get $install_record tag]' not INSTALL-RECORD|SKIPPED|INSTALL-INPROGRESS|MODIFY-RECORD|MODIFY-INPROGRESS|VIRTUAL-RECORD|VIRTUAL-INPROGRESS|DELETE-RECORD|DELETE-INPROGRESS" + } + } + set source_list [dict_getwithdefault $install_record body [list]] + set changed [list] + set unchanged [list] + foreach src $source_list { + if {[dict exists $src -changed]} { + if {[dict get $src -changed] !=0} { + lappend changed [dict get $src -path] + } else { + lappend unchanged [dict get $src -path] + } + } else { + lappend changed [dict get $src -path] + } + } + return [dict create changed $changed unchanged $unchanged] + } + + #assume only one for name - use first encountered? + proc get_installer_record {name record_list} { + set posn 0 + set found_posns [list] + set record "" + #puts ">>>> checking [llength $record_list] punkcheck records" + foreach rec $record_list { + if {[dict get $rec tag] eq "INSTALLER"} { + if {[dict get $rec -name] eq $name} { + set found_posn $posn + set record $rec + lappend found_posns $posn + } + } + incr posn + } + if {[llength $found_posns] > 1} { + error "punkcheck::recordlist::get_installer_record - multiple installer records with name '$name' found at positions $found_posns" + } elseif {[llength $found_posns] == 0} { + return [list position -1 record ""] + } else { + #single record found + return [list position [lindex $found_posn 0] record $record] + } + + } + + proc new_installer_record {name args} { + if {[llength $args] %2 !=0} { + error "punkcheck new_installer_record args must be name-value pairs" + } + set ts [clock microseconds] + set seconds [expr {$ts / 1000000}] + set tsiso [clock format $seconds -format "%Y-%m-%dT%H:%M:%S"] + + #put -tsiso first so it lines up with -tsiso in event records + set defaults [list {*}{ + } -tsiso $tsiso {*}{ + } -ts $ts {*}{ + } -name $name {*}{ + } -keep_events 5 {*}{ + } + ] + set opts [dict merge $defaults $args] + + #set this_installer_record_list [punk::tdl::prettyparse [list INSTALLER name $opt_installer ts $ts tsiso $tsiso keep_events 5 {}]] + #set this_installer_record [lindex $this_installer_record_list 0] + + set record [dict create tag INSTALLER {*}$opts body {}] + + + return $record + } + proc new_installer_event_record {type args} { + if {[llength $args] %2 !=0} { + error "punkcheck new_installer_event_record args must be name-value pairs" + } + set ts [clock microseconds] + set seconds [expr {$ts / 1000000}] + set tsiso [clock format $seconds -format "%Y-%m-%dT%H:%M:%S"] + set defaults [list {*}{ + } -tsiso $tsiso {*}{ + } -ts $ts {*}{ + } -type $type {*}{ + } + ] + set opts [dict merge $defaults $args] + + set record [dict create tag EVENT {*}$opts] + } + #need to scan entire set if filerecords to check if event is still referenced + proc installer_record_pruneevents {installer_record record_list} { + set keep 5 + if {[dict exists $installer_record -keep_events]} { + set keep [dict get $installer_record -keep_events] + } + + if {[dict exists $installer_record body]} { + set body_items [dict get $installer_record body] + } else { + set body_items [list] + } + set kept_body_items [list] + set kcount 0 + foreach item [lreverse $body_items] { + if {[dict get $item tag] eq "EVENT"} { + incr kcount + if {$keep < 0 || $kcount <= $keep} { + lappend kept_body_items $item + } else { + set eventid "" + if {[dict exists $item -id]} { + set eventid [dict get $item -id] + } + if {$eventid ne "" && $eventid ne "unspecified"} { + #keep if referenced, discard if not, or if eventid empty/unspecified + set is_referenced 0 + foreach rec $record_list { + if {[dict get $rec tag] eq "FILEINFO"} { + if {[dict exists $rec body]} { + foreach install [dict get $rec body] { + if {[dict exists $install -eventid] && [dict get $install -eventid] eq $eventid} { + set is_referenced 1 + break + } + } + } + } + if {$is_referenced} { + break + } + } + if {$is_referenced} { + lappend kept_body_items $item + } + } + } + } else { + lappend kept_body_items $item + } + } + set kept_body_items [lreverse $kept_body_items] + dict set installer_record body $kept_body_items + return $installer_record + } + proc installer_record_add_event {installer_record event} { + if {[dict get $installer_record tag] ne "INSTALLER"} { + error "installer_record_add_event bad installer record: tag not INSTALLER" + } + if {[dict get $event tag] ne "EVENT"} { + error "installer_record_add_event bad event record: tag not EVENT" + } + if {[dict exists $installer_record body]} { + set body_items [dict get $installer_record body] + } else { + set body_items [list] + } + lappend body_items $event + dict set installer_record body $body_items + return $installer_record + } + proc file_record_latest_installrecord {file_record} { + tailcall file_record_latest_operationrecord INSTALL $file_record + } + proc file_record_latest_operationrecord {operation file_record} { + set operation [string toupper $operation] + if {[dict get $file_record tag] ne "FILEINFO"} { + error "file_record_latest_operationrecord bad file_record: tag not FILEINFO" + } + if {![dict exists $file_record body]} { + return [list] + } + set body_items [dict get $file_record body] + foreach item [lreverse $body_items] { + if {[dict get $item tag] eq "$operation-RECORD"} { + return $item + } + } + return [list] + } + + + proc file_record_set_defaults {file_record} { + if {[dict get $file_record tag] ne "FILEINFO"} { + error "file_record_set_defaults bad file_record: tag not FILEINFO" + } + set defaults [list -keep_installrecords 3 -keep_skipped 1 -keep_inprogress 2] + foreach {k v} $defaults { + if {![dict exists $file_record $k]} { + dict set file_record $k $v + } + } + return $file_record + } + + #negative keep_ value will keep all + proc file_record_prune {file_record} { + if {[dict get $file_record tag] ne "FILEINFO"} { + error "file_record_prune bad file_record: tag not FILEINFO" + } + set file_record [file_record_set_defaults $file_record] + set kmap [list -keep_installrecords *-RECORD -keep_skipped *-SKIPPED -keep_inprogress *-INPROGRESS] + foreach {key rtype} $kmap { + set keep [dict get $file_record $key] + if {[dict exists $file_record body]} { + set body_items [dict get $file_record body] + } else { + set body_items [list] + } + set kept_body_items [list] + set kcount 0 + foreach item [lreverse $body_items] { + if {[string match $rtype [dict get $item tag]]} { + incr kcount + if {$keep < 0 || $kcount <= $keep} { + lappend kept_body_items $item + } + } else { + lappend kept_body_items $item + } + } + set kept_body_items [lreverse $kept_body_items] + dict set file_record body $kept_body_items + } + return $file_record + } + + #extract new or existing filerecord for path given + #REVIEW - locking/concurrency + proc extract_or_create_fileset_record {relative_target_paths recordset} { + set fetch_record_result [punkcheck::recordlist::get_file_record $relative_target_paths $recordset] + set existing_posn [dict get $fetch_record_result position] + if {$existing_posn == -1} { + puts stdout "punkcheck NO existing record for $relative_target_paths" + set isnew 1 + set fileset_record [dict create tag FILEINFO -targets $relative_target_paths body {}] + } else { + #set recordset [lreplace $recordset[unset recordset] $existing_posn $existing_posn] + #set recordset [lreplace $recordset[set recordset {}] $existing_posn $existing_posn] + ledit recordset $existing_posn $existing_posn + set isnew 0 + set fileset_record [dict get $fetch_record_result record] + } + return [list record $fileset_record recordset $recordset isnew $isnew oldposition $existing_posn] + } + + } + +} + + + + +namespace eval ::punk::args::register { + #use fully qualified so 8.6 doesn't find existing var in global namespace + lappend ::punk::args::register::NAMESPACES ::punkcheck +} + + + + + + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Ready +package provide punkcheck [namespace eval punkcheck { + set pkg punkcheck + variable version + set version 0.1.1 +}] +return diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punkcheck/cli-0.1.0.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punkcheck/cli-0.1.0.tm index bbf882a0..ed3a5b5e 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punkcheck/cli-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punkcheck/cli-0.1.0.tm @@ -64,7 +64,7 @@ namespace eval punkcheck::cli { #vfs can mask mounted files - so we can't just use 'file type' or glob with -type f ##set files [glob -nocomplain -dir $fullpath -type f *] package require punk::nav::fs - + #TODO - get all files in tree!!! set folderinfo [punk::nav::fs::dirfiles_dict $fullpath] set files [concat [dict get $folderinfo files] [dict get $folderinfo underlayfiles]] @@ -81,7 +81,7 @@ namespace eval punkcheck::cli { foreach p $punkcheck_files { set basedir [file dirname $p] set recordlist [punkcheck::load_records_from_file $p] - set tgt_dict [punkcheck::recordlist::records_as_target_dict $recordlist] + set tgt_dict [punkcheck::recordlist::records_as_target_dict $recordlist] foreach f $files { set relpath [punkcheck::lib::path_relative $basedir $f] @@ -137,13 +137,13 @@ namespace eval punkcheck::cli { } } } - } + } } if {[llength $source_files]} { - append pcheck " source files : [llength $source_files] (changed [llength $source_files_changed])" + append pcheck " source files : [llength $source_files] (changed [llength $source_files_changed])" } if {[llength $source_folders]} { - append pcheck " source folders: [llength $source_folders] (changed [llength $source_folders_changed])" + append pcheck " source folders: [llength $source_folders] (changed [llength $source_folders_changed])" } append pcheck \n @@ -152,7 +152,7 @@ namespace eval punkcheck::cli { } } } - append table "$f $pcheck" \n + append table "$f $pcheck" \n } } } @@ -182,7 +182,7 @@ namespace eval punkcheck::cli { foreach p $punkcheck_files { set basedir [file dirname $p] set recordlist [punkcheck::load_records_from_file $p] - set tgt_dict [punkcheck::recordlist::records_as_target_dict $recordlist] + set tgt_dict [punkcheck::recordlist::records_as_target_dict $recordlist] foreach f $files { set relpath [punkcheck::lib::path_relative $basedir $f] @@ -235,13 +235,13 @@ namespace eval punkcheck::cli { } } } - } + } } if {[llength $source_files]} { - append pcheck " source files : [llength $source_files] (changed [llength $source_files_changed])" + append pcheck " source files : [llength $source_files] (changed [llength $source_files_changed])" } if {[llength $source_folders]} { - append pcheck " source folders: [llength $source_folders] (changed [llength $source_folders_changed])" + append pcheck " source folders: [llength $source_folders] (changed [llength $source_folders_changed])" } append pcheck \n @@ -250,7 +250,7 @@ namespace eval punkcheck::cli { } } } - append table "$f $pcheck" \n + append table "$f $pcheck" \n } } } @@ -259,14 +259,13 @@ namespace eval punkcheck::cli { } - # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ namespace eval punkcheck::cli::lib { namespace path ::punk::mix::util ;#askuser, do_in_path, foreach-file etc proc find_nearest_file {{path {}}} { if {$path eq {}} { set path [pwd] } - set folder [lib::scanup $path lib::is_punkchecked_folder] + set folder [lib::scanup $path lib::is_punkchecked_folder] if {$folder eq ""} { return "" } else { @@ -307,7 +306,6 @@ namespace eval punkcheck::cli::lib { } return {} } - } @@ -320,15 +318,15 @@ namespace eval punkcheck::cli { variable default_command status package require punk::mix::base package require punk::overlay - punk::overlay::custom_from_base [namespace current] ::punk::mix::base + punk::overlay::custom_from_base [namespace current] ::punk::mix::base } # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready +## Ready package provide punkcheck::cli [namespace eval punkcheck::cli { variable version - set version 0.1.0 + set version 0.1.0 }] return diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/shellfilter-0.2.2.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/shellfilter-0.2.2.tm index 6a948593..a841bd6e 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/shellfilter-0.2.2.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/shellfilter-0.2.2.tm @@ -326,18 +326,34 @@ namespace eval shellfilter::chan { #method flush {ch} { # return "" #} + #method flush {transform_handle} { + # #puts stdout "" + # #review - just clear o_encbuf and emit nothing? + # #we wouldn't have a value there if it was convertable from the channel encoding? + # if {[string length $o_encbuf]} { + # #if we have data in the buffer that we haven't been able to convert to a string + # #- then we probably have some kind of encoding mismatch. Is it safer to discard it than to emit garbage chars to the channel or var? + # #REVIEW - log that we are discarding the buffer contents on flush? + # puts stderr "WARNING: flush called on tee_to_var with non-empty buffer. This probably indicates an encoding mismatch between the channel encoding and the encoding expected by the transform. Discarding buffer contents: '$o_encbuf'" + # } + # set clear $o_encbuf + # set o_encbuf "" + # return $clear + #} method flush {transform_handle} { - #puts stdout "" - #review - just clear o_encbuf and emit nothing? - #we wouldn't have a value there if it was convertable from the channel encoding? - if {[string length $o_encbuf]} { - #if we have data in the buffer that we haven't been able to convert to a string - #- then we probably have some kind of encoding mismatch. Is it safer to discard it than to emit garbage chars to the channel or var? - #REVIEW - log that we are discarding the buffer contents on flush? - puts stderr "WARNING: flush called on tee_to_var with non-empty buffer. This probably indicates an encoding mismatch between the channel encoding and the encoding expected by the transform. Discarding buffer contents: '$o_encbuf'" + #puts stderr " $transform_handle o_encbuf: '$o_encbuf' datavars: $o_datavars" + set clear $o_encbuf + if {[catch {tcl::encoding::convertfrom $o_enc $clear} stringdata]} { + #if we can't convert the buffer contents to a string - does it make sense to emit the raw bytes? + # - probably not. + #REVIEW? + return "" } set o_encbuf "" - return "" + foreach v $o_datavars { + append $v $stringdata + } + return $stringdata } method write {ch bytes} { #test with set x [string repeat " \U1f6c8" 2043] @@ -442,16 +458,29 @@ namespace eval shellfilter::chan { # flush $o_localchan # return $clear #} + #method flush {transform_handle} { + # #we wouldn't have a value in o_encbuf if it was convertable from the channel encoding? + # if {[string length $o_encbuf]} { + # #if we have data in the buffer that we haven't been able to convert to a string + # #- then we probably have some kind of encoding mismatch. Is it safer to discard it than to emit garbage chars to the channel or var? + # #REVIEW - log that we are discarding the buffer contents on flush? + # puts stderr "WARNING: flush called on tee_to_pipe with non-empty buffer. This probably indicates an encoding mismatch between the channel encoding and the encoding expected by the transform. Discarding buffer contents: '$o_encbuf'" + # } + # set clear $o_encbuf + # set o_encbuf "" + # return $clear + #} method flush {transform_handle} { - #we wouldn't have a value in o_encbuf if it was convertable from the channel encoding? - if {[string length $o_encbuf]} { - #if we have data in the buffer that we haven't been able to convert to a string - #- then we probably have some kind of encoding mismatch. Is it safer to discard it than to emit garbage chars to the channel or var? - #REVIEW - log that we are discarding the buffer contents on flush? - puts stderr "WARNING: flush called on tee_to_pipe with non-empty buffer. This probably indicates an encoding mismatch between the channel encoding and the encoding expected by the transform. Discarding buffer contents: '$o_encbuf'" + set clear $o_buffered$o_encbuf + if {[catch {tcl::encoding::convertfrom $o_enc $clear} stringdata]} { + #if we can't convert the buffer contents to a string - does it make sense to emit the raw bytes? + # - probably not. + #REVIEW? + return "" } + set o_buffered "" set o_encbuf "" - return "" + return $stringdata } method write {transform_handle bytes} { #set logdata [tcl::encoding::convertfrom $o_enc $bytes] @@ -533,11 +562,24 @@ namespace eval shellfilter::chan { ::shellfilter::log::write $o_logsource $logdata return $bytes } + #method flush {transform_handle} { + # #return "" + # set clear $o_encbuf + # set o_encbuf "" + # #review + # return $clear + #} method flush {transform_handle} { - #return "" - set clear $o_encbuf + set clear $o_buffered$o_encbuf + if {[catch {tcl::encoding::convertfrom $o_enc $clear} stringdata]} { + #if we can't convert the buffer contents to a string - does it make sense to emit the raw bytes? + # - probably not. + #REVIEW? + return "" + } + set o_buffered "" set o_encbuf "" - return $o_encbuf + return $stringdata } method write {ch bytes} { #set logdata [tcl::encoding::convertfrom $o_enc $bytes] @@ -613,9 +655,21 @@ namespace eval shellfilter::chan { my destroy } #clear? + #method flush {transform_handle} { + # #we wouldn't have a value in o_encbuf if it was convertable from the channel encoding? + # if {[string length $o_encbuf]} { + # #if we have data in the buffer that we haven't been able to convert to a string + # #- then we probably have some kind of encoding mismatch. Is it safer to discard it than to emit garbage chars to the log? + # #REVIEW. - we are writing the raw bytes to the log here because we can't convert them to a string. + # #This may be useful for debugging issues, but it may also result in garbage data in the log. + # ::shellfilter::log::write $o_logsource $o_encbuf + # set o_encbuf "" + # } + # return + #} method flush {transform_handle} { - #we wouldn't have a value in o_encbuf if it was convertable from the channel encoding? - if {[string length $o_encbuf]} { + set clear $o_buffered$o_encbuf + if {[catch {tcl::encoding::convertfrom $o_enc $clear} stringdata]} { #if we have data in the buffer that we haven't been able to convert to a string #- then we probably have some kind of encoding mismatch. Is it safer to discard it than to emit garbage chars to the log? #REVIEW. - we are writing the raw bytes to the log here because we can't convert them to a string. @@ -755,6 +809,110 @@ namespace eval shellfilter::chan { } } + + #experimental + #applying this to stdout breaks console query/responses - why? + #- probably because we are splitting graphemes across writes and flushes and the console doesn't know how to handle that? + oo::class create unicode_normalize { + variable o_trecord + variable o_enc + variable o_encbuf + variable o_graphemebuf + variable o_mode + variable o_is_junction + constructor {tf} { + package require punk::ansi + set o_trecord $tf + set o_enc [::tcl::dict::get $tf -encoding] + set o_encbuf "" + set o_graphemebuf "" + set settingsdict [tcl::dict::get $tf -settings] + if {[dict exists $settingsdict -mode]} { + set o_mode [dict get $settingsdict -mode] + if {$o_mode ni {nfc nfd nfkc nfkd none}} { + error "unicode_normalize transform - invalid mode '$o_mode' in settings" + } + if {$o_mode ne "none"} { + #we get dll dependent load errors on windows sometimes - but still seems to work - REVIEW/FIX. + catch {::tcl::unsupported::loadIcu} + } + } else { + #if no mode specified - default to 'none' which just does grapheme splitting without any unicode normalization + set o_mode "none" + } + if {[::tcl::dict::exists $tf -junction]} { + set o_is_junction [::tcl::dict::get $tf -junction] + } else { + set o_is_junction 0 + } + } + method initialize {transform_handle mode} { + return [list initialize write flush finalize] + } + method finalize {transform_handle} { + my destroy + } + method flush {transform_handle} { + #flush seems to do nothing - why? + set clear $o_encbuf[unset o_encbuf] + if {[catch {tcl::encoding::convertfrom $o_enc $clear} stringdata]} { + #if we can't convert the buffer contents to a string - put it back and try again with more data later + #REVIEW? + set o_encbuf $clear + return "" + } + #review + + set graphemes [punk::char::grapheme_split $o_graphemebuf$stringdata] + set outstring [join $graphemes ""] + #puts "outstring: '$outstring' graphemes: $graphemes" + if {$o_mode ne "none"} { + set outstring [::tcl::unsupported::icu::normalize -mode $o_mode $outstring] + } + set o_graphemebuf "" + return [tcl::encoding::convertto $o_enc $outstring] + } + method write {transform_handle bytes} { + set inputbytes $o_encbuf$bytes + set o_encbuf "" + set tail_offset 0 + + if {$inputbytes eq ""} { + #review - do we even get empty writes? + puts stderr "WARNING: write called on unicode_normalize with empty inputbytes. This may be a no-op, but it may also indicate an issue with the upstream transform or channel. Emitting no data for this write." + set stringdata "" + } + + while {$tail_offset < [::tcl::string::length $inputbytes] && [catch {tcl::encoding::convertfrom $o_enc [::tcl::string::range $inputbytes 0 end-$tail_offset]} stringdata]} { + incr tail_offset + } + if {$tail_offset > 0} { + if {$tail_offset < [::tcl::string::length $inputbytes]} { + #stringdata from catch statement must be a valid result + set t [expr {$tail_offset - 1}] + set o_encbuf [::tcl::string::range $inputbytes end-$t end] + } else { + set stringdata "" + set o_encbuf $inputbytes + return "" + } + } + set graphemes [punk::char::grapheme_split $o_graphemebuf$stringdata] + set outstring [join [lrange $graphemes 0 end-1] ""] + set o_graphemebuf [lindex $graphemes end] + + if {$o_mode ne "none"} { + set outstring [::tcl::unsupported::icu::normalize -mode $o_mode $outstring] + } + + return [tcl::encoding::convertto $o_enc $outstring] + } + method meta_is_redirection {} { + return $o_is_junction + } + } + + #a test oo::class create reconvert { variable o_trecord @@ -1114,7 +1272,6 @@ namespace eval shellfilter::chan { # return $emit #} method flush {transform_handle} { - #return "" set clear $o_buffered$o_encbuf if {[catch {tcl::encoding::convertfrom $o_enc $clear} stringdata]} { #if we can't convert the buffer contents to a string - does it make sense to emit the raw bytes? diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/shellrun-0.1.2.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/shellrun-0.1.2.tm new file mode 100644 index 00000000..7a353961 --- /dev/null +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/shellrun-0.1.2.tm @@ -0,0 +1,897 @@ +# vim: set ft=tcl +# +#purpose: handle the run commands that call shellfilter::run +#e.g run,runout,runerr,runx + +package require shellfilter +package require punk::ansi + +#NOTE: the run,runout,runerr,runx commands only produce an error if the command didn't run. +# - If it did run, but there was a non-zero exitcode it is up to the application to check that. +#This is deliberate, but means 'catch' doesn't catch errors within the command itself - the exitcode has to be checked. +#The user can always use exec for different process error semantics (they don't get exitcode with exec) + +namespace eval shellrun { + variable PUNKARGS + variable runout + variable runerr + + #do we need these? + #variable punkout + #variable punkerr + + #some ugly coupling with punk/punk::config for now + #todo - something better + if {[info exists ::punk::config::configdata]} { + set conf_running [punk::config::configure running] + set syslog_stdout [dict get $conf_running syslog_stdout] + set syslog_stderr [dict get $conf_running syslog_stderr] + set logfile_stdout [dict get $conf_running logfile_stdout] + set logfile_stderr [dict get $conf_running logfile_stderr] + } else { + lassign [list "" "" "" ""] syslog_stdout syslog_stderr logfile_stdout logfile_stderr + } + if {"punkshout" ni [shellfilter::stack::items]} { + set outdevice [shellfilter::stack::new punkshout -settings [list -tag "punkshout" -buffering none -raw 1 -syslog $syslog_stdout -file $logfile_stdout]] + set out [dict get $outdevice localchan] + } else { + set out [dict get [shellfilter::stack::item punkshout] device localchan] + } + if {"punksherr" ni [shellfilter::stack::items]} { + set errdevice [shellfilter::stack::new punksherr -settings [list -tag "punksherr" -buffering none -raw 1 -syslog $syslog_stderr -file $logfile_stderr]] + set err [dict get $errdevice localchan] + } else { + set err [dict get [shellfilter::stack::item punksherr] device localchan] + } + + namespace import ::punk::ansi::a+ + namespace import ::punk::ansi::a + + + + + #repltelemetry - additional/alternative display info used in a repl context i.e info directed towards the screen + #todo - package up in repltelemetry module and rewrite proc based on whether the module was found/loaded. + #somewhat strong coupling to punk - but let's try to behave decently if it's not loaded + #The last_run_display is actually intended for the repl - but is resident in the punk namespace with a view to the possibility of a different repl being in use. + proc set_last_run_display {chunklist} { + #chunklist as understood by the + if {![info exists ::punk::repltelemetry_emmitters]} { + namespace eval ::punk { + variable repltelemetry_emmitters + set repltelemetry_emmitters "shellrun" + } + } else { + if {"shellrun" ni $::punk::repltelemetry_emmitters} { + lappend punk::repltelemetry_emmitters "shellrun" + } + } + + #most basic of validity tests here.. just that it is a list (can be empty). We don't want to duplicate or over-constrain the way repls/shells/terminals interpet the info + if {[catch {llength $chunklist} errMsg]} { + error "set_last_run_display expects a list. Value supplied doesn't appear to be a well formed tcl list. '$errMsg'" + } + #todo - + tsv::lappend repl runchunks-[tsv::get repl runid] {*}$chunklist + } + + + + #maintenance: similar used in punk::ns & punk::winrun + #todo - take runopts + aliases as args + #longopts must be passed as a single item ie --timeout=100 not --timeout 100 + proc get_run_opts {arglist} { + if {[catch { + set callerinfo [info level -1] + } errM]} { + set caller "" + } else { + set caller [lindex $callerinfo 0] + } + + #we provide -nonewline even for 'run' even though run doesn't deliver stderr or stdout to the tcl return value + #This is for compatibility with other runX commands, and the difference is also visible when calling from repl. + set known_runopts [list "-echo" "-e" "-nonewline" "-n" "-tcl" "-debug"] + set known_longopts [list "--timeout"] + set known_longopts_msg "" + foreach lng $known_longopts { + append known_longopts_msg "${lng}=val " + } + set aliases [list "-e" "-echo" "-echo" "-echo" "-n" "-nonewline" "-nonewline" "-nonewline" "-tcl" "-tcl" "-debug" "-debug"] ;#include map to self + set runopts [list] + set runoptslong [list] + set cmdargs [list] + + set idx_first_cmdarg [lsearch -not $arglist "-*"] + + set allopts [lrange $arglist 0 $idx_first_cmdarg-1] + set cmdargs [lrange $arglist $idx_first_cmdarg end] + foreach o $allopts { + if {[string match --* $o]} { + lassign [split $o =] flagpart valpart + if {$valpart eq ""} { + error "$caller: longopt $o seems to be missing a value - must be of form --option=value" + } + if {$flagpart ni $known_longopts} { + error "$caller: Unknown runoption $o - known options $known_runopts $known_longopts_msg" + } + lappend runoptslong $flagpart $valpart + } else { + if {$o ni $known_runopts} { + error "$caller: Unknown runoption $o - known options $known_runopts $known_longopts_msg" + } + lappend runopts [dict get $aliases $o] + } + } + return [list runopts $runopts runoptslong $runoptslong cmdargs $cmdargs] + } + + + #todo - investigate cause of punk86 run hanging sometimes. An 'after 500' before exit in the called script fixes the issue. punk87 doesn't seem to be affected. + lappend PUNKARGS [list { + @id -id ::shellrun::run + @leaders -min 0 -max 0 + @opts + -nonewline -type none + -tcl -type none -default 0 + -debug -type none -default 0 + --timeout= -type integer + @values -min 1 -max -1 + cmdname -type string + cmdarg -type any -multiple 1 -optional 1 + }] + proc run {args} { + #set_last_run_display [list] + + #set splitargs [get_run_opts $args] + #set runopts [dict get $splitargs runopts] + #set runoptslong [dict get $splitargs runoptslong] + #set cmdargs [dict get $splitargs cmdargs] + set argd [punk::args::parse $args withid ::shellrun::run] + lassign [dict values $argd] leaders opts values received + + if {[dict exists $received "-nonewline"]} { + set nonewline 1 + } else { + set nonewline 0 + } + #review nonewline does nothing here.. + + set idlist_stderr [list] + #we leave stdout without imposed ansi colouring - because the source may be colourised and because ansi-wrapping a stream at whatever boundaries it comes in at isn't a really nice thing to do. + #stderr might have source colouring - but it usually doesn't seem to, and the visual distiction of red stderr can be very handy for the run command. + #A further enhancement could be to detect well-known options such as --color and/or use a configuration for specific commands that have useful colourised stderr, + #but having an option to configure stderr to red is a compromise. + #Note that the other run commands, runout,runerr, runx don't emit in real-time - so for those commands there may be options to detect and/or post-process stdout and stderr. + #TODO - fix. This has no effect if/when the repl adds an ansiwrap transform + # what we probably want to do is 'aside' that transform for runxxx commands only. + #lappend idlist_stderr [shellfilter::stack::add stderr ansiwrap -settings {-colour {red bold}}] + + set callopts [dict create] + if {[dict exists $received "-tcl"]} { + dict set callopts -tclscript 1 + } + if {[dict exists $received "-debug"]} { + dict set callopts -debug 1 + } + if {[dict exists $received --timeout]} { + dict set callopts -timeout [dict get $opts --timeout] ;#convert to single dash + } + set cmdname [dict get $values cmdname] + if {[dict exists $received cmdarg]} { + set cmdarglist [dict get $values cmdarg] + } else { + set cmdarglist {} + } + set cmdargs [concat $cmdname $cmdarglist] + #--------------------------------------------------------------------------------------------- + set exitinfo [shellfilter::run $cmdargs {*}$callopts -teehandle punksh -inbuffering none -outbuffering none ] + #--------------------------------------------------------------------------------------------- + foreach id $idlist_stderr { + shellfilter::stack::remove stderr $id + } + #puts stderr "shellrun::run exitinfo: $exitinfo" + + flush stderr + flush stdout + + if {[dict exists $exitinfo error]} { + error "[dict get $exitinfo error]\n$exitinfo" + } + + return $exitinfo + } + + lappend PUNKARGS [list { + @id -id ::shellrun::runconsole + @leaders -min 0 -max 0 + @opts + @values -min 1 -max -1 + cmdname -type string + cmdarg -type any -multiple 1 -optional 1 + }] + #run in the way tcl unknown does - but without regard to auto_noexec + proc runconsole {args} { + set argd [punk::args::parse $args withid ::shellrun::runconsole] + lassign [dict values $argd] leaders opts values received + set cmdname [dict get $values cmdname] + if {[dict exists $received cmdarg]} { + set arglist [dict get $values cmdarg] + } else { + set arglist {} + } + + set resolved_cmdname [auto_execok $cmdname] + if {$resolved_cmdname eq ""} { + error "Cannot find path for executable '$cmdname'" + } + set repl_runid [punk::get_repl_runid] + #set ::punk::last_run_display [list] + + set redir ">&@stdout <@stdin" + uplevel 1 [list ::catch [concat exec $redir $resolved_cmdname $arglist] ::tcl::UnknownResult ::tcl::UnknownOptions] + #we can't detect stdout/stderr output from the exec + #for now emit an extra \n on stderr + #todo - there is probably no way around this but to somehow exec in the context of a completely separate console + #This is probably a tricky problem - especially to do cross-platform + # + # - use [dict get $::tcl::UnknownOptions -code] (0|1) exit + if {[dict get $::tcl::UnknownOptions -code] == 0} { + set c green + set m "ok" + } else { + set c yellow + set m "errorCode $::errorCode" + } + set chunklist [list] + lappend chunklist [list "info" "[a $c]$m[a] " ] + if {$repl_runid != 0} { + tsv::lappend repl runchunks-$repl_runid {*}$chunklist + } + + dict incr ::tcl::UnknownOptions -level + return -options $::tcl::UnknownOptions $::tcl::UnknownResult + } + lappend PUNKARGS [list { + @id -id ::shellrun::runout + @leaders -min 0 -max 0 + @opts + -echo -type none + -nonewline -type none + -tcl -type none -default 0 + -debug -type none -default 0 + --timeout= -type integer + @values -min 1 -max -1 + cmdname -type string + cmdarg -type any -multiple 1 -optional 1 + }] + proc runout {args} { + set argd [punk::args::parse $args withid ::shellrun::runout] + lassign [dict values $argd] leaders opts values received + + if {[dict exists $received "-nonewline"]} { + set nonewline 1 + } else { + set nonewline 0 + } + + #set_last_run_display [list] + variable runout + variable runerr + set runout "" + set runerr "" + set RST [a] + + #set splitargs [get_run_opts $args] + #set runopts [dict get $splitargs runopts] + #set cmdargs [dict get $splitargs cmdargs] + + + #puts stdout "RUNOUT cmdargs: $cmdargs" + + #todo add -data boolean and -data lastwrite to -settings with default being -data all + # because sometimes we're only interested in last char (e.g to detect something was output) + + #set outvar_stackid [shellfilter::stack::add commandout tee_to_var -action float -settings {-varname ::runout}] + # + #when not echoing - use float-locked so that the repl's stack is bypassed + if {[dict exists $received "-echo"]} { + set stdout_stackid [shellfilter::stack::add stdout tee_to_var -action float-locked -settings {-varname ::shellrun::runout}] + set stderr_stackid [shellfilter::stack::add stderr tee_to_var -action float-locked -settings {-varname ::shellrun::runerr}] + #set stderr_stackid [shellfilter::stack::add stderr tee_to_var -action sink-locked -settings {-varname ::shellrun::runerr}] + } else { + set stdout_stackid [shellfilter::stack::add stdout var -action float-locked -settings {-varname ::shellrun::runout}] + set stderr_stackid [shellfilter::stack::add stderr var -action float-locked -settings {-varname ::shellrun::runerr}] + } + + set callopts [dict create] + if {[dict exists $received "-tcl"]} { + dict set callopts -tclscript 1 + } + if {[dict exists $received "-debug"]} { + dict set callopts -debug 1 + } + if {[dict exists $received --timeout]} { + dict set callopts -timeout [dict get $opts --timeout] ;#convert to single dash + } + set cmdname [dict get $values cmdname] + if {[dict exists $received cmdarg]} { + set cmdarglist [dict get $values cmdarg] + } else { + set cmdarglist {} + } + set cmdargs [concat $cmdname $cmdarglist] + + #shellfilter::run [lrange $args 1 end] -teehandle punksh -outchan stdout -inbuffering none -outbuffering none -stdinhandler ::repl::repl_handler + set exitinfo [shellfilter::run $cmdargs {*}$callopts -teehandle punksh -inbuffering none -outbuffering none ] + + flush stderr + flush stdout + + shellfilter::stack::remove stdout $stdout_stackid + shellfilter::stack::remove stderr $stderr_stackid + + #shellfilter::stack::remove commandout $outvar_stackid + + if {[dict exists $exitinfo error]} { + if {[dict exists $received "-tcl"]} { + + } else { + #we must raise an error. + #todo - check errorInfo makes sense.. return -code? tailcall? + # + set msg "" + append msg [dict get $exitinfo error] + append msg "\n(add -tcl option to run as a tcl command/script instead of an external command)" + error $msg + } + } + + set chunklist [list] + + #exitcode not part of return value for runout - colourcode appropriately + set n $RST + set c "" + + if {[dict exists $exitinfo exitcode]} { + set code [dict get $exitinfo exitcode] + if {$code == 0} { + set c [a+ green] + } else { + set c [a+ white bold] + } + lappend chunklist [list "info" "$c$exitinfo$n"] + } elseif {[dict exists $exitinfo error]} { + # -tcl (with error) + set c [a+ yellow bold] + lappend chunklist [list "info" "${c}error [dict get $exitinfo error]$n"] + lappend chunklist [list "info" "errorCode [dict get $exitinfo errorCode]"] + #lappend chunklist [list "info" "errorInfo [list [dict get $exitinfo errorInfo]]"] + lappend chunklist [list "info" errorInfo] + lappend chunklist [list "stderr" [dict get $exitinfo errorInfo]] + } else { + # -tcl (without error) + set c [a+ Green white bold] + #lappend chunklist [list "info" "$c$exitinfo$n"] + lappend chunklist [list "info" [punk::ansi::ansiwrap_raw $c \x1b\[m "" $exitinfo]] + } + + + set chunk "[a+ red bold]stderr$RST" + lappend chunklist [list "info" $chunk] + + set chunk "" + if {[string length $::shellrun::runerr]} { + if {$nonewline} { + set e [string trimright $::shellrun::runerr \r\n] + } else { + set e $::shellrun::runerr + } + #append chunk "[a+ red normal]$e$RST\n" + append chunk "[a+ red normal]$e$RST" + } + lappend chunklist [list stderr $chunk] + + + + + lappend chunklist [list "info" "[a+ white bold]stdout$RST"] + set chunk "" + if {[string length $::shellrun::runout]} { + if {$nonewline} { + set o [string trimright $::shellrun::runout \r\n] + } else { + set o $::shellrun::runout + } + append chunk "$o" + } + lappend chunklist [list result $chunk] + + + #set_last_run_display $chunklist + tsv::lappend repl runchunks-[tsv::get repl runid] {*}$chunklist + + if {$nonewline} { + return [string trimright $::shellrun::runout \r\n] + } else { + return $::shellrun::runout + } + } + + lappend PUNKARGS [list { + @id -id ::shellrun::runerr + @leaders -min 0 -max 0 + @opts + -echo -type none + -nonewline -type none + -tcl -type none -default 0 + -debug -type none -default 0 + --timeout= -type integer + @values -min 1 -max -1 + cmdname -type string + cmdarg -type any -multiple 1 -optional 1 + }] + proc runerr {args} { + set argd [punk::args::parse $args withid ::shellrun::runerr] + lassign [dict values $argd] leaders opts values received + + if {[dict exists $received "-nonewline"]} { + set nonewline 1 + } else { + set nonewline 0 + } + + #set_last_run_display [list] + variable runout + variable runerr + set runout "" + set runerr "" + + #set splitargs [get_run_opts $args] + #set runopts [dict get $splitargs runopts] + #set cmdargs [dict get $splitargs cmdargs] + + set callopts [dict create] + if {[dict exists $received "-tcl"]} { + dict set callopts -tclscript 1 + } + if {[dict exists $received "-debug"]} { + dict set callopts -debug 1 + } + if {[dict exists $received --timeout]} { + dict set callopts -timeout [dict get $opts --timeout] ;#convert to single dash + } + set cmdname [dict get $values cmdname] + if {[dict exists $received cmdarg]} { + set cmdarglist [dict get $values cmdarg] + } else { + set cmdarglist {} + } + set cmdargs [concat $cmdname $cmdarglist] + + if {[dict exists $received "-tcl"]} { + append callopts " -tclscript 1" + } + if {[dict exists $received "-echo"]} { + set stderr_stackid [shellfilter::stack::add stderr tee_to_var -action float-locked -settings {-varname ::shellrun::runerr}] + set stdout_stackid [shellfilter::stack::add stdout tee_to_var -action float-locked -settings {-varname ::shellrun::runout}] + } else { + set stderr_stackid [shellfilter::stack::add stderr var -action float-locked -settings {-varname ::shellrun::runerr}] + set stdout_stackid [shellfilter::stack::add stdout var -action float-locked -settings {-varname ::shellrun::runout}] + } + + + set exitinfo [shellfilter::run $cmdargs {*}$callopts -teehandle punksh -inbuffering none -outbuffering none -stdinhandler ::repl::repl_handler] + shellfilter::stack::remove stderr $stderr_stackid + shellfilter::stack::remove stdout $stdout_stackid + + + flush stderr + flush stdout + + #we raise an error because an error during calling is different to collecting stderr from a command, and the caller should be able to wrap in a catch + # to determine something other than just a nonzero exit code or output on stderr. + if {[dict exists $exitinfo error]} { + if {[dict exists $received "-tcl"]} { + + } else { + #todo - check errorInfo makes sense.. return -code? tailcall? + error [dict get $exitinfo error] + } + } + + set chunklist [list] + + set n [a] + set c "" + if {[dict exists $exitinfo exitcode]} { + set code [dict get $exitinfo exitcode] + if {$code == 0} { + set c [a+ green] + } else { + set c [a+ white bold] + } + lappend chunklist [list "info" "$c$exitinfo$n"] + } elseif {[dict exists $exitinfo error]} { + # -tcl (with error) + set c [a+ yellow bold] + lappend chunklist [list "info" "error [dict get $exitinfo error]"] + lappend chunklist [list "info" "errorCode [dict get $exitinfo errorCode]"] + lappend chunklist [list "info" "errorInfo [list [dict get $exitinfo errorInfo]]"] + } else { + # -tcl (without error) + set c [a+ Green white bold] + #lappend chunklist [list "info" "$c$exitinfo$n"] + lappend chunklist [list "info" [punk::ansi::ansiwrap_raw $c "\x1b\[m" "" $exitinfo]] + } + + + lappend chunklist [list "info" "[a+ white bold]stdout[a]"] + set chunk "" + if {[string length $::shellrun::runout]} { + if {$nonewline} { + set o [string trimright $::shellrun::runout \r\n] + } else { + set o $::shellrun::runout + } + append chunk "[a+ white normal]$o[a]\n" ;#this newline is the display output separator - always there whether data has trailing newline or not. + } + lappend chunklist [list stdout $chunk] + + + #set c_stderr [punk::config] + set chunk "[a+ red bold]stderr[a]" + lappend chunklist [list "info" $chunk] + + set chunk "" + if {[string length $::shellrun::runerr]} { + if {$nonewline} { + set e [string trimright $::shellrun::runerr \r\n] + } else { + set e $::shellrun::runerr + } + append chunk "$e" + } + lappend chunklist [list resulterr $chunk] + + + #set_last_run_display $chunklist + tsv::lappend repl runchunks-[tsv::get repl runid] {*}$chunklist + + if {$nonewline} { + return [string trimright $::shellrun::runerr \r\n] + } + return $::shellrun::runerr + } + + + proc runx {args} { + #set_last_run_display [list] + variable runout + variable runerr + set runout "" + set runerr "" + + set splitargs [get_run_opts $args] + set runopts [dict get $splitargs runopts] + set cmdargs [dict get $splitargs cmdargs] + + if {"-nonewline" in $runopts} { + set nonewline 1 + } else { + set nonewline 0 + } + + #shellfilter::stack::remove stdout $::repl::id_outstack + + if {"-echo" in $runopts} { + #float to ensure repl transform doesn't interfere with the output data + set stderr_stackid [shellfilter::stack::add stderr tee_to_var -action float -settings {-varname ::shellrun::runerr}] + set stdout_stackid [shellfilter::stack::add stdout tee_to_var -action float -settings {-varname ::shellrun::runout}] + } else { + #set stderr_stackid [shellfilter::stack::add stderr var -action sink-locked -settings {-varname ::shellrun::runerr}] + #set stdout_stackid [shellfilter::stack::add stdout var -action sink-locked -settings {-varname ::shellrun::runout}] + + #float above the repl's tee_to_var to deliberately block it. + #a var transform is naturally a junction point because there is no flow-through.. + # - but mark it with -junction 1 just to be explicit + set stderr_stackid [shellfilter::stack::add stderr var -action float-locked -junction 1 -settings {-varname ::shellrun::runerr}] + set stdout_stackid [shellfilter::stack::add stdout var -action float-locked -junction 1 -settings {-varname ::shellrun::runout}] + } + + set callopts "" + if {"-tcl" in $runopts} { + append callopts " -tclscript 1" + } + #set exitinfo [shellfilter::run $cmdargs -teehandle punksh -inbuffering none -outbuffering none -stdinhandler ::repl::repl_handler] + set exitinfo [shellfilter::run $cmdargs {*}$callopts -teehandle punksh -inbuffering none -outbuffering none] + + shellfilter::stack::remove stdout $stdout_stackid + shellfilter::stack::remove stderr $stderr_stackid + + + flush stderr + flush stdout + + if {[dict exists $exitinfo error]} { + if {"-tcl" in $runopts} { + + } else { + #todo - check errorInfo makes sense.. return -code? tailcall? + error [dict get $exitinfo error] + } + } + + #set x [shellfilter::stack::add stdout var -action sink-locked -settings {-varname ::repl::runxoutput}] + + set chunk "" + if {[string length $::shellrun::runout]} { + if {$nonewline} { + set o [string trimright $::shellrun::runout \r\n] + } else { + set o $::shellrun::runout + } + set chunk $o + } + set chunklist [list] + lappend chunklist [list "info" " "] + lappend chunklist [list "result" stdout] ;#key 'stdout' forms part of the resulting dictionary output + lappend chunklist [list "info" "[a+ white bold]stdout[a]"] + lappend chunklist [list result $chunk] ;#value corresponding to 'stdout' key in resulting dict + + + lappend chunklist [list "info" " "] + set chunk "[a+ red bold]stderr[a]" + lappend chunklist [list "result" $chunk] + lappend chunklist [list "info" stderr] + + set chunk "" + if {[string length $::shellrun::runerr]} { + if {$nonewline} { + set e [string trimright $::shellrun::runerr \r\n] + } else { + set e $::shellrun::runerr + } + set chunk $e + } + #stderr is part of the result + lappend chunklist [list "resulterr" $chunk] + + + + set n [a] + set c "" + if {[dict exists $exitinfo exitcode]} { + set code [dict get $exitinfo exitcode] + if {$code == 0} { + set c [a+ green] + } else { + set c [a+ yellow bold] + } + lappend chunklist [list "info" " "] + lappend chunklist [list "result" exitcode] + lappend chunklist [list "info" "exitcode $code"] + lappend chunklist [list "result" "$c$code$n"] + set exitdict [list exitcode $code] + } elseif {[dict exists $exitinfo result]} { + # presumably from a -tcl call + set val [dict get $exitinfo result] + lappend chunklist [list "info" " "] + lappend chunklist [list "result" result] + lappend chunklist [list "info" result] + lappend chunklist [list "result" $val] + set exitdict [list result $val] + } elseif {[dict exists $exitinfo error]} { + # -tcl call with error + #set exitdict [dict create] + lappend chunklist [list "info" " "] + lappend chunklist [list "result" error] + lappend chunklist [list "info" error] + lappend chunklist [list "result" [dict get $exitinfo error]] + + lappend chunklist [list "info" " "] + lappend chunklist [list "result" errorCode] + lappend chunklist [list "info" errorCode] + lappend chunklist [list "result" [dict get $exitinfo errorCode]] + + lappend chunklist [list "info" " "] + lappend chunklist [list "result" errorInfo] + lappend chunklist [list "info" errorInfo] + lappend chunklist [list "result" [dict get $exitinfo errorInfo]] + + set exitdict $exitinfo + } else { + #review - if no exitcode or result. then what is it? + lappend chunklist [list "info" exitinfo] + set c [a+ yellow bold] + lappend chunklist [list result "$c$exitinfo$n"] + set exitdict [list exitinfo $exitinfo] + } + + #set_last_run_display $chunklist + tsv::lappend repl runchunks-[tsv::get repl runid] {*}$chunklist + + #set ::repl::result_print 0 + #return [lindex [list [list stdout $::runout stderr $::runerr {*}$exitinfo] [shellfilter::stack::remove stdout $x][puts -nonewline stdout $pretty][set ::repl::output ""]] 0] + + + if {$nonewline} { + return [list {*}$exitdict stdout [string trimright $::shellrun::runout \r\n] stderr [string trimright $::shellrun::runerr \r\n]] + } + #always return exitinfo $code at beginning of dict (so that punk unknown can interpret the exit code as a unix-style bool if double evaluated) + return [list {*}$exitdict stdout $::shellrun::runout stderr $::shellrun::runerr] + } + + #an experiment + # + #run as raw string instead of tcl-list - no variable subst etc + # + #dummy repl_runraw that repl will intercept + proc repl_runraw {args} { + error "runraw: only available in repl as direct call - not from script" + } + #we can only call runraw with a single (presumably braced) string if we want to use it from both repl and tcl scripts (why? todo with unbalanced quotes/braces?) + proc runraw {commandline} { + #runraw fails as intended - because we can't bypass exec/open interference quoting :/ + #set_last_run_display [list] + variable runout + variable runerr + set runout "" + set runerr "" + + #return [shellfilter::run [lrange $args 1 end] -teehandle punksh -inbuffering none -outbuffering none -stdinhandler ::repl::repl_handler] + puts stdout ">>runraw got: $commandline" + + #run always echoes anyway.. as we aren't diverting stdout/stderr off for capturing + #for consistency with other runxxx commands - we'll just consume it. (review) + + set reallyraw 1 + if {$reallyraw} { + set wordparts [regexp -inline -all {\S+} $commandline] + set runwords $wordparts + } else { + #shell style args parsing not suitable for windows where we can't assume matched quotes etc. + package require string::token::shell + set parts [string token shell -indices -- $commandline] + puts stdout ">>shellparts: $parts" + set runwords [list] + foreach p $parts { + set ptype [lindex $p 0] + set pval [lindex $p 3] + if {$ptype eq "PLAIN"} { + lappend runwords [lindex $p 3] + } elseif {$ptype eq "D:QUOTED"} { + set v {"} + append v $pval + append v {"} + lappend runwords $v + } elseif {$ptype eq "S:QUOTED"} { + set v {'} + append v $pval + append v {'} + lappend runwords $v + } + } + } + + puts stdout ">>runraw runwords: $runwords" + set runwords [lrange $runwords 1 end] + + puts stdout ">>runraw runwords: $runwords" + #set args [lrange $args 1 end] + #set runwords [lrange $wordparts 1 end] + + set known_runopts [list "-echo" "-e" "-terminal" "-t"] + set aliases [list "-e" "-echo" "-echo" "-echo" "-t" "-terminal" "-terminal" "-terminal"] ;#include map to self + set runopts [list] + set cmdwords [list] + set idx_first_cmdarg [lsearch -not $runwords "-*"] + set runopts [lrange $runwords 0 $idx_first_cmdarg-1] + set cmdwords [lrange $runwords $idx_first_cmdarg end] + + foreach o $runopts { + if {$o ni $known_runopts} { + error "runraw: Unknown runoption $o" + } + } + set runopts [lmap o $runopts {dict get $aliases $o}] + + set cmd_as_string [join $cmdwords " "] + puts stdout ">>cmd_as_string: $cmd_as_string" + + if {"-terminal" in $runopts} { + #fake terminal using 'script' command. + #not ideal: smushes stdout & stderr together amongst other problems + set tcmd [shellfilter::get_scriptrun_from_cmdlist_dquote_if_not $cmdwords] + puts stdout ">>tcmd: $tcmd" + set exitinfo [shellfilter::run $tcmd -teehandle punksh -inbuffering line -outbuffering none ] + set exitinfo "exitcode not-implemented" + } else { + set exitinfo [shellfilter::run $cmdwords -teehandle punksh -inbuffering line -outbuffering none ] + } + + if {[dict exists $exitinfo error]} { + #todo - check errorInfo makes sense.. return -code? tailcall? + error [dict get $exitinfo error] + } + set code [dict get $exitinfo exitcode] + if {$code == 0} { + set c [a+ green] + } else { + set c [a+ white bold] + } + puts stderr $c + return $exitinfo + } + + proc sh_run {args} { + set splitargs [get_run_opts $args] + set runopts [dict get $splitargs runopts] + set cmdargs [dict get $splitargs cmdargs] + #e.g sh -c "ls -l *" + #we pass cmdargs to sh -c as a list, not individually + tailcall shellrun::run {*}$runopts sh -c $cmdargs + } + proc sh_runout {args} { + set splitargs [get_run_opts $args] + set runopts [dict get $splitargs runopts] + set cmdargs [dict get $splitargs cmdargs] + tailcall shellrun::runout {*}$runopts sh -c $cmdargs + } + proc sh_runerr {args} { + set splitargs [get_run_opts $args] + set runopts [dict get $splitargs runopts] + set cmdargs [dict get $splitargs cmdargs] + tailcall shellrun::runerr {*}$runopts sh -c $cmdargs + } + proc sh_runx {args} { + set splitargs [get_run_opts $args] + set runopts [dict get $splitargs runopts] + set cmdargs [dict get $splitargs cmdargs] + tailcall shellrun::runx {*}$runopts sh -c $cmdargs + } +} + +namespace eval shellrun { + interp alias {} run {} shellrun::run + interp alias {} sh_run {} shellrun::sh_run + interp alias {} runout {} shellrun::runout + interp alias {} sh_runout {} shellrun::sh_runout + interp alias {} runerr {} shellrun::runerr + interp alias {} sh_runerr {} shellrun::sh_runerr + interp alias {} runx {} shellrun::runx + interp alias {} sh_runx {} shellrun::sh_runx + + interp alias {} runc {} shellrun::runconsole + interp alias {} runraw {} shellrun::runraw + + + #the shortened versions deliberately don't get pretty output from the repl + interp alias {} r {} shellrun::run + interp alias {} ro {} shellrun::runout + interp alias {} re {} shellrun::runerr + interp alias {} rx {} shellrun::runx + + +} + +namespace eval shellrun { + proc test_cffi {} { + package require test_cffi + cffi::Wrapper create ::shellrun::kernel32 [file join $env(windir) system32 Kernel32.dll] + ::shellrun::kernel32 stdcall CreateProcessA + #todo - stuff. + return ::shellrun::kernel32 + } + +} +namespace eval ::punk::args::register { + #use fully qualified so 8.6 doesn't find existing var in global namespace + lappend ::punk::args::register::NAMESPACES ::shellrun +} + + +package provide shellrun [namespace eval shellrun { + variable version + set version 0.1.2 +}] diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/zipper-0.14.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/zipper-0.14.tm index 7f7817f1ddce7fa6abfdea66e3c84636d1fe44cd..f1e5eeaed33aed457f26c1fe55bdad783c7406eb 100644 GIT binary patch delta 2479 zcmV;g2~hUNO~_5K6&ew1hr(P@d(l3$2><}W9RL6#lRPFRlS>*{e>jN!xiSksP^6ZA zM4$9xp;B5O5U$$0`$dvwq+^|FKhmER`C+KyEPdb)p-w?MmKO)xJDKXz5#(#>r`jJw zj!D>lHujBbKh2Ur9&Rl0Lp`CDstYq#lO$ENO7SF~k{>^0Gyaez;6go0@>EEZHk8ej z#i8VNh!t8f$*Ib)Q<;u+oT(K0&>~g-93mW-j5WYhe)yP|Ge1S4pZSiHlcSRCaf`Ld zd;pnD?MlQ`QWi@M(}%eNX7Qd;>B6ky#dN$;?CoM&W`xne_7lZ6{2f89lgv2*+rMzC5I9Z@%%>+#e?QnB%1rdVIE&LqolRxW*`3a;ux^_l{+z?fLi><8 zT5pc@owaN4ue6%!UF+8RLrS}apJthPA?)Zf9@DDC{uYI z6gm@FgcZAUJ(sK};ii_ZnE3MLO9Z!9OIYry#L_TRQN(XY+pm$gXuT<)9tJZ6D$?&n zPjdk4ac;^|KQ@t{v0!85P-N7eis8Y6Tc z7^xR0v06ns26?BpX>AS@f0Jq0XKfS|oX#`qZ?-X;&@hOS;ErQx?q?u_wLN#UKKe*U zb2%G0Yf4byP-kVL+nxb#9 z&zoIc4F-0{-0kRk=IgHqC!4zTS)Rr;j5M6q6UH8s8MW{%Yw22&B`geAg)!E7tncT- zy3+x`&=VE4i8VZX?N#g4FLtR2T|IWTfDMv3G$X1xW#k*9r;xL-suguGvRKKZzZ`zJ zevJ~tNg5K5Q3@V7e_PJE+8GWj4ttv+!C?vM*&pkP75x23h`oGLGH>&)MDEuFXnI!U zPpRLu&cgy5ASUV1&Ad)mP;19=+Pne>-sYi{M@`#kTg(S$k=Wj$xAp1Ir13fAhs08P;&F3$F%0~SBZ@vndQ3qYJUy>urVT%7OP&TbyKG2BMhPS$;Hy{g-0dAwQHH|9 zNwmu{BG5K|ymdrZzYo}wVWEND-+sT_SA2> z#6F!$keu31e`1Ed18qn*Ma-rlEEz<(Bz1XfO=-(3G^$z!3iCyz16vT#&k4ff1}VH? zf$(Peg{|dD#_WDO)4zd9Fa$e^T-xSL7%3T@7Cb4)DC@1dL_` zM;XN@qX)8QB-Ghz_q!i&1~=yftorx;^ZwvseA%xj(gk-tMd9xZT{(6&&p!{I8C+Ux zV=lC&cR$j4K<9McN3P&MaM;t$x`vEIktg}i#*kM_&>n}ISI-vsCt0d??IO5le!^~W z{+t@1e~l!gb*dfXTqEVPHMi{Nl0AGnOyXm1?BJpqal_cGx5=$EUT6kyS$Lc?<_j7$ zLi>@obJceIegS-&cvP8+{t(K0i8hh;_IvO)?lyPs$X`Gy^-Hv`4`1+a$cU`s4a3LG~*IWXD2MM&Fa6dBWke$kbglSWo`;_WI;EE!(4O ze^Krgy};)S{J-4gCfgy`iWU=S`fyE`aL}sjY8E*caMn6ro9GT%cYExv-br4J{^tlc zPxpj4{Yg>&>x4@+*Pj#dc3WpxxA1Fav08QdlkFI!qJ3{OGpf|n8}hH$ zFu+fOL!J)B3AuTw*Zj)$pGsS-#qCw+jZIAI5pWL;@$((p7YWdKCbk4oC*4$ec@`FFMjDGPF z+Ag0v8b;-L)Kd~&`o8U=8D-W!>BN*HPfgy>$opo!E3ENfA=*f zZ4RKe<$(ErOA7HV+g5wE9X&n_ReIE0YaCEgk~Kx+y~Q?lsn4>mXjiDzT6P3Ss+L-< zDhA*F{q-B-(DS(~=QMYD^US8XXZ_1YFTTec&aF3CU$~@a8}Tns5O;rBZ*NQ1ehnKp z)UlX3>jPjpp-RJ`?zKV7u(+FMe<+e883MQ)>k%?$>%# zoog1!JM!~5nDJQE4t?i7PA;~2YfIp#(`8@y7dc`sM|%4WPw$k5(#~hTh6~uma%8si z*Yp1Q1*|P6b2puzs#u}M*~t$d3^E;`*?E64ELix#oj+AT>6aV_DZAbIf1l<1@?~w* zI!qRl7ltcEju|ovp%+(v9#+dFnGy`=PcWS7V<_kD))9xJ#cHJQ$L<6 zw_-r>?{gmrsFz9Tu_|>D;-dja}D%TLI+8x$vk{twMrR0p+oL zU$ZP%SUPruqau}+dpQRb;e$%D@6aWAKlLjOd0SA+gCL#y_ t{{sL30Rpo_B-#NDYlp&IQG3xova$!P!p delta 2469 zcmV;W30n5ZO~y^I6&exR2)tY<;pJen2><}V9RL6#lRhRTlS>*{e^~gzoj+ByNRy=w z6@Ai+g-WS^Hn=!Ai2b=TSfNNQ{it}iJ|JARclV1V%}B>O(|)8sDe}Wm#aa5mA3~ji zZ7eSiws$hsr6b7K(oeNNhK!T2{cP+T)qa{Kfjrz;;)i-dD^(X}tR_jSXqDngJS9JV z$Y%T@OTdMCl;o+9Vd->o`*>^Z{hbpF@P>lCcJ`$`2p& za^|Nf^fTXaa&lCXJ#Mi!nGYb7iQM>UFw;xbV-jb3WKs9KW%*WvLP{(DfdZ^sCFvdZ zj`NI6G8ZFLlXV*-f4fnjjMb(koYUfmiV(X3&3wE5jK$(jvC&Bkd6_)8&yqZ1_$W@= zG%d+4Yh!2*eJ4p2B`fkN)RPJJ#~B_Dg`Sir;e+Sz`nTfs^XL0(dv#IPk zyVIE!)@}2{pK~}_Xdg01>&=nAvv%$Ml~ywy%mBunvcMKtQR%vnh+km6(-+ia8ZA zPMnw6=|#lFe;p$RWh$?OLT3Vtuwr+v=aTg#+|<$)6JNf3iQx8X3Clf|SQ=(3iumnl z`!(_wtvBVFE82dQ8W|p9;oQO-(+go)3K2)bHMeCmU#u z&o_e&P0DqgbbW-w`XjxiH-xw#BMZlPe%BBSE)0ty9iql{yWYp%;KlR)$<@`16Z#Kz zy|-6af0z8pd$Va;Q}iwNd9$ml!NBgAyB%H6eEs#{WK)+u%hQ;Kk%rTH!q{UnqZXcJ zEnQ2pgoWX%FvdEM_5EB}cRBzVdZMB>v4&@_y=tBM#V!@0tH;h3ut5@sW<)iojC^DC z6mk|;wW1D27Atx5m%|U&uTf$+Nkif>O2GqXf6F;nJHuhcVQ(`eI4mJO`(r(^g1;XL zv6oLu=55}U$o-lCP0xz_DfOGyd01cr#6%r~NXJD6U^xMB zf4-O_!y3+&oWCEF&W;U*3NU6hq&7`8hJl}PMA4^6k10rlr{|T-wBaXh$v^x-oUs|rNRTA-YqgsMP+8`IJ z@f%l)xoP6tHpd#niZ1nf_}Tf}@D;)4mPy>EiVNOS-8zmgFS|l4Wotw|&lTuee@Z^& ziu{DWtKrMQ0iM^KfYFTLD5Ln)^g#CfggRU8e)r?e;O3lwRsX(!-XC0yFZ=aGy5O#- zDEytFE61+p`RBnigG*~|%!StU?nhb==$y{`$QAqt4tu&;*N~AY@+9Bc81iZf+T(EZ z>e&MSBumwO zHo29?3(epy3y*Wgd_jXoXg~6HuG)^@FMw|ok1A8qA3}LA(I(Q~eh=Qp-R906`3oqe zJ}P|U#bF~>N=rAdfBI3b%DeZhh`Zh>6Qp{f1VKHyHcqXv^eAG2Zs)^w=VZ4y*LC5WG?R=&m@}SOs-!QJcT@Wgb~okY zZyvIew2mj}Tr`RWa`1#t!N_=GLl*;&_6XR0n}pX^e_TH$$bN-@>{v+3=zB6WPdJ&f5VUZ4D?WqWijf6Be07x;XE|ChVmWIN7Ed$KPk$8op7n<`g0=QZtLvo7JjWPR;x~bvK@m|wC`37BJMpf?Kv-f;p0kw z$C;r2`6rU9EkF2E%jg#`q3!ayvr+lKaM`+V7GrQ)x6eAaGGx6)1Km`nX|9;9GK>m? zS~HDWvyS`X6};BUe{)}R(&hkaTMn52x1RubP42!#Ie}*DCk|BV*u^u5~woaT7 zKa#n1hbbIZ_cT^K-cIw_*tuqrydyu4gBg!i?a+7b#s;u?dzL?kir;lxHasgKn|=Il)ISq|?!8wAHMO zIb@MG^3R*J1`@Rq=lb6_XHV>Gvp(2t_L{J6k7%5iTCT%F_9C4-*R-+g+HWg> z+&C8=b*fcJa4MiYmhWqpZ $pkgname $cond] { if {![catch {package require } returnver]} { - tsv::set zzzload_pkg $returnver + tsv::set zzzload_pkg $returnver } else { tsv::set zzzload_pkg "failed" } @@ -85,7 +88,7 @@ namespace eval zzzload { } } proc pkg_wait {pkgname} { - if {[set ver [package provide twapi]] ne ""} { + if {[set ver [package provide $pkgname]] ne ""} { return $ver } @@ -116,22 +119,10 @@ namespace eval zzzload { } - - - - - - - - - - - - # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready +## Ready package provide zzzload [namespace eval zzzload { variable version - set version 0.1.0 + set version 0.1.0 }] return \ No newline at end of file diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/make.tcl b/src/project_layouts/custom/_project/punk.shell-0.1/src/make.tcl index 25ba66ae..917cd4d7 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/make.tcl +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/make.tcl @@ -2093,12 +2093,16 @@ if {$::punkboot::command in {project packages modules}} { #install .tm *and other files* puts stdout "VENDORMODULES$which: copying from $sourcefolder/$vf to $target_module_folder (if source file changed)" - set resultdict [punkcheck::install $sourcefolder/$vf $target_module_folder\ - -installer make.tcl\ - -overwrite installedsourcechanged-targets\ - -antiglob_paths {README.md AGENTS.md **/AGENTS.md include_modules.config}\ - -progresschannel stdout\ - ] + set resultdict [punkcheck::install $sourcefolder/$vf $target_module_folder {*}{ + -installer make.tcl + -overwrite installedsourcechanged-targets + -progresschannel stdout + -exclude-filetails {AGENTS.md include_modules.config} + -antiglob_paths {README.md} + }] + # -antiglob_paths {README.md AGENTS.md **/AGENTS.md include_modules.config} + #-exclude-filetails {AGENTS.md include_modules.config} + #-antiglob_paths {README.md} puts stdout [punkcheck::summarize_install_resultdict $resultdict] } if {![llength $vendormodulefolders]} { diff --git a/src/vfs/_vfscommon.vfs/modules/packagetest-0.1.7.tm b/src/vfs/_vfscommon.vfs/modules/packagetest-0.1.7.tm index 658d45a4e571209317a9621e1b6a1f037186fe5f..6dd409dd571e3e98c66026d9dd56bb000142799b 100644 GIT binary patch delta 5971 zcmV-Z7p&;IUa(`Z6&emwywqH~wv|ig761V7Uy~ymHh*h#+eVV#`70(QQ%V$rvYfly zUB>ptn>bn3#!kv|?mkc`76=SUtngs)kVLci->k zbIu)B_z`{%M(mvzCIwHt#OLfP$&0M?i!e>5EaKiBXT_ScztP|1;o)KOz`UG=IrEZ$ zl{sf;n}0ZbV6k`0&sdtVJo7K`#{}UQDJwUDS8%q>(wM#6+^$|bi!zLYJD%k*#-w;C z1|z`X7Z?kG`Dv1e0nY$(n5>w`{&D?1LVb7jk>$lU;w%b%oc3Kx+W zCQSUOL~P+3wvNKZGxqToK8Oi8(xyyq*~as4y%lE}-=uk1q}dk7{OT+C@2LNw@fY8H z$zD8v@gKyKZ@*>lcmX`%t1yAzZ#Emi)5Ez@V-fYwCzq4I;5=gEP2?4Tbj=8C#BOp5n(D56^sLP zfQtkYw@?rzyo~==h8Z_0#>cmOd!J@O&II)gpXX&*h;Psz8yV=~&yAOPE^|(t$o5ny zp8O2TdKdEh3U(@=2x2tC*r!~mZr`O~P&P$gbu*_9EeIx_#+ z5OE>&Kz1B{;(>e9^#>wP8_H0@I|2xD1oyKACcWMR8BJ zng2j%mw@5P0cn0(Z!qf9sqQz!j$VJo5oRf-$=DvXJcI!}e1HY8X=|7+Oy){M-Bu%p*W`27l5cQ)zbZ zHC%%dm_*T1=+Jj*MmC%+%Y?e+53ivWiLTZc?MemC=NST9G_ZgsC|L zU=ao%6hO%DNNzA?vx@A(3nK=R3_fw4v5aH{;E!vbup~_!Fj5;(bD9mU`G{)}E+Otf z|DcRs?V*I0qh-y}F-hx2(0?&Ffxv=ch=dk|K7mAPXyOhbNtm(p9$pC}Dqcel zDKUpjdBMML!+<^=_^ip)bc#_O@V;v5$JEwAMlf4b=B#~XC#c^ULD28c2t=B`734KEu4Q|k?m4YUcm2@)}efcRRrqUcdx3 z$D1_9dnYH*qkKy?x{$$~X*vwv3&3#Owtc6{&$q_WPkju!d$+ZQ;)eegv8kt zVle&7@zW?RGsu=ekeyH9+LzwP1plUC0Gg+(i72N8mGdMo?iOfRZ+D_2a*>;jk%X_7OJsfqRrN0+kT9)PuYU z`<1GF{(XQBm12<=Hp3PcAb~q6g8S)I%0ath#c;->oLk7T1Dav%hcOX_EG@9Ep&~W* zlYdanMQAvuzRk2mYp^qG53dZMEoLO}6>k4d!AHzGDR9}ig-d(p2{;^o@O;@09WL|+-L}{QjA4n$ZptjZ z3UJd&53A3+f^Z?w;GMAqp0n91N*9nWrGFT|MVJ&gBvut(A|MOklSYt3*Ks1#4FZ#_ zKs&}2c$d9;#hy3Wdst!UTRrO__K}THL{8XSmD8Acu|*6pou!GOBD>_Bq6CwXirl*1 zS#?NDNR(r#fs$KK8$S^Thk05VEHq+}(u%75abiXFdx2kj?0gf2s`QNH&FwL}n15>l z-E0Pvj-?2<)f|}1J%4RP$h-u?*RcWrITov(%S)GiGs<|J-f?yeR7p2XOM#?=hkZ~HV-zkRMTqBurGjKK z9PHAy!i&5-4_C?I{`fDAXpC-!NPo^qw@!NOr@QZ%17jXokn%h^Q-)___J8Go3Rc1-r&+%YH6 z>ZNPc++!|<^sI5EFy0!9VpwQVHlb`wRu!-)kuV-_imf?mlSh)%WjZQJ+J9h{)UBXG zl9)-odnD)DPwE!hGG@1_{_~jYgM1$`FMxcf6m>`?ky@OAOW>X}NBvp+u?y$C+?! zjR}0lC^7Ad-irw>VF&nIF}%J?qyi&5d%C20>r?50bI){5Ukg)*kzwFz(E(l z0$~l6@z>)a45!1=_XM~KOa=LQH;jJOF{4CXw`;0Wr9@iRdL~%q7l@sNY>^P!{9t(Z zM=RV>#_rE!KN=~H-JkGClgf;SCf=ieFL?sw10X@Qx;Cyi^+dZ z{^nF=XtSQ0f3Fj$e!4XMt|&XyYf~Vwi!|qytb;AnLx5jhhN}{gab%Nvzl7h*KI0mQ zTCxWW%JU&h!bYQ}wNU1@0*W0i1t9_&=iGl3Q0&+Nv~tV3xyxR&>TzwTRuI_3Ht8RB z=X(QmS0azAhq+Pbs((+Fm&M*j!uuTFeqM#8T_v-zfLO=YCwsIzv|#&H^TGZ|D4HAR z`wn)GjY4OWm&Z_GmV4)z;>{On0E$4RCh@fbBiE>0p*QXUKvc38fW+710g)id#Az93 zIO|{G;=G6<#Y)Cr%vpsridkpKCpArUWy71Bhs(vy&CTrc=6~j!uV38U#03Aw96+~; z?RIq}Vaf%S;mr&tdI7c$S6pt~SMa9*iYCzD#vS&dr$N=wgMVTRv;*i#kn`ruO14%C zU}df5mD^%-XAskvF+$nISb&|MFl(pL(J`R-?pg;wA$QAovmRKNVo2or`WedH*P51y znr+7orLs_B1%K9OQCda$193sWQ88y@EY0h#9(RnyDmct#UPV3iGRKIo>c7e3URs{L zusyrT%SF90ar64utB-H5*={ETEl9X+@^)a|K};o4FsrT4P|*ZNrowV=h7jW_V3LW2 z3xm6Zfz^`et&qB?V=rbN7@%I@Jh$XWBb^7pSct#P0)LOxvPQm6?{%J+ai0HuU@6v! zQXB3PV`EK-rO-(Kv~9(3GGt@1$Lyuu8jPC3h$Mh|b&S*2W7{J+sbfpoZQocG>Dkp| z-`zv8#dJy%*lt?e-D5Vj?GDhp1g>HBATs`~j7+r$}$ZOj=`WC=1+hGDCNkr=n5yN5c*kT7UZrBoweyJcDQoW9P z*3WTRU^BrbwYNrcihvCJW?Gw#_A31&R_o2FwFgZVN80PzlBK#y2LuQM^Ntm9dS?%^ zhQ#$DrIFOE%M)wUXAmod!O8tK$8tFadWVSJAAc~rRwO@D#zLhK6)z5;JGKMeTUm%D zN%Uk`{5Hm5!;7JNpaMx zUVpywECbs-G-_P}-dP3ktXe-slkbb_X;0*(e!9B;c$|~Mmi;~og9h3q zhFdV%f=6kxLJclbYlr`5Zp@M9L%Sz&Ud8d(Y3SqHA>|vm-BWy_xAbqi_&4_pOO)X( zLmmaV10+bh+-B=J27tm(#(+h*fl)3iq=E zV9#&u^M!*@BG|R~t{TalsJ{`8b9fnFWWj>GU3U$FycuXFPsHx6rAv#fnxNj*)_>NC z7}=?}II*NTpQ*OfX~sc_?r^cce=TMy3JQdAmZpXHS&6LxOhVreNNnRGI7te*cNBi& z9eH94d;wC-3v!?bMnU4B*W;EfLuUsDH7tk26AC*@!d7f7>`*rqX67o_ zqM+BZHxzBHd}`eh9gprLbZK1M7JqlBk5H{~uMF=Wy$qj&f54SbhmECWw6j2z=Q?@FUL&OR4PBct`0$VsQo>d|LQoAonvF4i43nalz5x7nmTsR`^8cXZ z=fkh>kIQ|aVQ+r%p-l9tm4BsDAtS#Lsg1Soui!ytUaR(~6sa(t-W@ndBLcJoC=~#+ zKg6Z}Efc%Z4Mgk-a7W(t^cj{u0Cr>rP?<1!se)f^Q|bx_l<^aXAPZV`IId#pv`dys z;@eoSnXE*SgKjhdOEzd$;bXe_1PE&{&a_@P7Ip6N zq^}TXqF%PFpEn#4emNS^dvUPBIQxmJr~5stqau%wbq-JYGb;NNrq2MbZ7}s7T#C%4 zI8w^$>T^+)LCaS#7k?aPLMF6Utf2YaJiBEC{UR4{9n`WVcXOGQ8@(k8rZ%X2TwGK^ z(w+a`CfQc5nmd_JJ=JtdLf&!6s3U0~*lU#Le1UQ8-Vv;98t5F&#}S0s;y_32(;M54 zZW*|oR{CrXatv~oN{HBYRa>UM2J0Acj7K3M2Lvn&sE~s^)qh_bI9{g&s?L;{3qu@8 z8{@E5mX;edurVGY#uK|_n8iuhE!YS==tfBCcyJ7g(@P9ZT-zmrE`fTTi99JX zkckzrCfAM|e0sFCNc9)ssKK@6a)))2a2-P6iXh&UkhAkeE=a4>5(*=j=T&|o z?@R&&3ja&HFN>miMa78|d8lHz_Hqqeo{8>WPOD+!_J6I`)WFK5^Rt=UP}fz>+q?Vj zO-!GSO_;q$Ga`=r=W#WsNDIJu%N8K5wXdqPUTvW zX0TdRDT@lYB9)Gcpa?9uJSIPUw18{fi{?W6>H^X|DbS(2Br1TphbnPLnV!y)Tu)6^ z;wGx92Y-upWZbAiY6D`_PJ5w@B#02Bx5%SBkgwQea-moIF7#2eNv9jH?TAaWSRr;y z;a3|y(aCiWjzI0@LT2MQZ8dm5m|jy{11-(_5im)`{(xF09<)l*dvVOF!j(v%17U5~ z37VQ_@;WuT4#-I6Y}?zOJW?508ICS#XR?@(-G8%jMb&}j?>R*z{VqVl*0D>^w$P}y zZ$kj@-z-7cq-EwC$5Twqo_B5B91ITBcE!XUINDKd-cQQ{o?z(dvZ3>uy;9*Ufrq&N3u4BZj|FVhfVldVbFfrF?lMO{|NNiR&)-cyzqag7 zCpM6`lUJBDk~19m2T&>uQ{CPJm%S*lC_4E&_h|WEFO!RS#3Md-n;|{D|^*0UMh5f+nv|0 zL+QE@rla1WYBu6>l~wI>73&$D=0$VHeKeg%0S5*Q>t%=f?#bE}u?}4dYg|%jFn_Oh zc#rOh-Jf`E<*D~lUX$*5kOShSK7ZH+m9#JY32&)1S%&L-=5IO#@jI@dR5zN6=Hed8 zicQr;l#~Q}bc1hJsJgehFR|xFN-gEpF8v)*A$A@%@8H7SYWJt?!Z)`u_HDqg7SLL| zU6dtTsN>3G!oux1iKn297p>b+5`X?sw0Cw&?4W~d?V-`CSR~1+;MIF7j1$pB0oVJzrq^XgEQ#mFsi}r%;py?S*6FocnX5OmSf4gekUaMc4g)MIL&M$G_ zJMcg{;_ge-#ZAZm3s6e|0u%rg0000808+fvT)VcFOXn5<0PtUv;x1AKGZz2=003qE BV7>qV delta 5341 zcmV<36e8=eW4d0j6&eu{88KWnt(Zx16aWA}Qvd)ilW8$Af7LwwciT3Szw56+CFXh8 z3FSDwuT`_zdXu#0w@um?yLUgxe0mfK$y`&UN|3e{J^k-DGXO!51S!dN@7?*ekwgH4 znZbMm;E1`WF3W=$KL;cB$&ZqpCw>xecA1DgD}p>qlL?Etf6rNd%h_M(Z~XZ9IDTZl zV3A;c60$;Ye|EB7MUQOd-|-WcW=v$k8U7d}{5)mFI`nhS7FoJtZ`XIrckaB1;_#kl z0_GU!kNIE(IQ#;00k9xVL=^H2AV&NWBzP!2&;FbIy1i zEu(oXr-_mvE)ZMzhP~rx{)%1S!3Qw`XIdA@9b5asoxkKPRKv`rLkq%+TxzT&PM|#r*?dE^ zf4M}aC`urUwP;a29-&X(t)<>KgR#&wi?g?O(tNHI$C_Nt6fdmQji{VJETZfwb?AMXkqu{yBB5b|9JHxPvb&*8AzwsEM4fS=s69`^l)31rW1R3r znwk>;7Gv;10fhRFB1F^4O8!N2dLkUm}btjW}5f>9mtzUmsRsIQBRV79Kzz2))xW?;I<;U)Ui5P6eg zq!ob7Nqgw)04jnY6ucwwpf>cRY+q;TJ(5oGBzp@ydv`LZb%k{Rre+{pe-MQsFEL2N zsnFv}X9=7FX`gel$F;%aWzfSIAc};Tdm9C}(AW@|+GucWpiMALl87+`#Mi1Pt?QVi zViCdOk6T#R7L2V5=sB0BA|!fI`rf&3m7Khr>3~4gKwU0M&cfWjjAR~x=35Xmb`m9v zRI%X%v>-3Cq&_@J;jt*Q}8I5 zy8?v2g%AIceXE<1N+8}UP`@atNTe2IHKm)>`ZC7HOQvLWqq+>6v&>InO}cfrVY#0iJooA1AD5qh1SNU@kBc8avg?mm z*AxbUFghhKe+`yQ9Fsq^QnW;sEP$kMr)GQz@siN6Jage?$RH8pSyn@=^7JJZ6-n=S!V0@4q1_; zl(E;_{VW5cftXhv*ml>Vt6W@jr7O->a#@DDSgA80f1=w0Fgf{hY4!zEwiCK(`}wy) zUBW4(m|-z*2GV=Wro}qu_dEulu{DAU0|AsYr!|iM#)iYDl-XxkKZM>v!U$AC*isMj z#_U(B_5}|iI#h~9TG$L*Sbzj>l?d)86D0@jffd6Uj|I1oV+S40g4J_(T9FlQixQ+T!`Ps@}D|j!U^+ly7 zT^`7h5bM|mK`wg4|WGa(cC!Qb+Fqp;)W(K523(}o@Qv`XY&*s^OP*N{91ug ze<`0Q^~T!+h$27^Zf;ft|Hhm^_gM|CAV&(O%1?$jQ&{LZ*g8yLZoI$3UkOll zfets`un#>As)io?v$8c`Y_uXS1vrp=@F-!Oo6Ywd3gM zm{5NAtdm=3-C3W4z&8AAU5X)k=^JM#b6;=DxSD;PhEiE5u>$L}D6JT`P5I7dT@FJTuP!~T1$80XpW)5oZ>WLh7e8_FgbE=4<`2p1FI#`JBuLAkcB+5=`v2| z%uQ0P?Zj9xbQ`gkZ30=q3E>l?zf;e%&!%dMQ^en9fk$PQAa2u#vhoB9Nl2T=Bl@RpD~97Ce{O@40+oq*n@za$* zoJL7Zk^((_^HQm;5Exy91rW6=XwwFAj&jbIT2R-2ad{e{?E|_VZS8 zRsH?EigN5Gxm1>_6{iTuuy3Wc*=QHNo>2TUm)0IMRUB!ThZIY7mktOJ28xaX6Sdic ztRZoI$jF#rw=PetO`k!m6b4rWw|s?#RtWU=5xd)CcCAQ$QyPmhg{XM32VKVwbZ2ED ztQ}fkv5rA@syW#3Y}gT@f9jluhI$ObkMq6&6b~3hk6o@`3xdqsH3Hq8xt|5MR1&d( zv=$&N*ckoUcT}y1KT`Q{*p>+1n;B*c!KqRXetugh^uelf0>(i%IgmIMrqIF zrGC1+x<1TFVb6Xag+T*ty5No`oAWqLmZ-sbY8~)@%#FFqd}#M1kAJzrZ5jnY&zABH z+&z_FsFnUr=l|qEZizD7Ma1I}3#wt-DE zGx=3%&4QiE6A1ESbUFqRdjxxaXJ0Rzgc3oSdUtnHIZ=NnoTsx>nOiJm7A(ozcGn=t zn}KHXL~e#GJla{%1P%LY4Xp!aYEW-+VnJ&@E&EO;83!Q(e^Ul?_Yaf>1;RK>(_H?n z#8v_(q3;JIcSQ(Jl0xnsM_+kIp4bAPgB0_e9O#}|kT@7+FPZc?#eRC}rwn-(htS!9 zK@H1}2+LmBDJ5*l9BGHTsW3Cw6;*8=7`5mPMVpChr8{!q!GokOIkjD;ePg6*IlVHx zJCIkFfDHTtf1Vj}nWHSDodvQy*NH$GtZU93v3S}E_lur7xzr&S4LehZA`?@&nlAEFSA5r14~ zm9CU|5`p$!zS(u_`3P;31TyEiD7d*xo6@*- znlN=oDbS}~(ynlzG=B0-aZbAqhgB@ycFD3-c^OuhIG@%NvmW$Gg6LR!p7SiB$^ZpE z>MStj#+dor7nWE`0S6uqm-2)gI+6kOvon-Xe^wOx$QWM-$K$>lXj%Wq(_EmbK>_Rr z@ontajF+;=K^FwUk`0zGp**vrp^N%oR{KE)T^HLT(j--8HuTh%o1;%yQ>BdW&20BOUaR4ELnTgABrO)OhhahLEgveu8 zwQcGvu#PducoY(HK)|wr3OUGg{k4JPf9+&YbykYGG{m8@F)mwXX|YBFyTUX1cmSRZ zvpiV70ULqmMrp_^eHIaNhb)B<3NJzf$;BEkN1p|F>Rx^)yGj`ejkWTroJuGi4e0VS zYUCZv8`f32y3RY~VJQ+1%OtD3j-cHM`VzHv;LefiWV=J|=B z-JCql0p|^ygS6g}JWy1D05x_+qJ#MEgxx$7``;H|K3{(RaiaE$G=s}cl_IZzm!t-1 z5r-%ObFOZk44*9ETKD3a)V{iabT0}F=q`y$VBWq;+(D+Nvn1D3Q&qUhf2!)18SM02jt-cSd@Ei;7TOW1=_aj1Wipd^>zZf zU27zBw&QKj9;pnh3`du=e>GW5$nKa^QMG6LdqxpSzY9>Xb?nk}EHtj2+mOKf4@(d> zX^{oII#pm|_PXof=3ua=wksEI+i!uZ!~1EG!xIcWJvMaTv5Prg#L833H1W=r`@`i= zA15`QoH>i`DruAinHk?E#p)WqP_eb&#wn+!*wUDAhbIp{iRE5{f7VCe$1h)g{(^OE zphtomJ{i_cLLz#TsCyK2Fya!7rl(tmM{DsOsm-~cg?PjL5WzJPBEA zIm3y60Hwk(wNv``f1|8|8kmD>{bX@TX2gWCE?LofjV9UYLF|bNU*DX>XI+>a;$aN@ zl<>*5Iv;c#H14Z(w_fCdr7BfCmNm25ah{!drxYuD)hS*obb;HQ)ovGd-LLGZca$|7 zc~@~+yQ^ruqtkqEgK@pH^OoAcfMI=ih<=qz?Tt$=y<^FEf9Hq6yxLtsdhOEg$hW{8 z`jyjRM^1)&pJY*Rk28sRl%!|EHO@GmlD8s&~+R^PhntX zAnP=$(Y6b3^$kNYFk`;wHwaRNo@f<*=PU0@g~2!DK+**v${{K*-)gAV;HkPOfi%>y z#KWeISO95im9{i%Ks@4xaG^P16DBWlly3H%}^7V1 diff --git a/src/vfs/_vfscommon.vfs/modules/packagetest-0.1.8.tm b/src/vfs/_vfscommon.vfs/modules/packagetest-0.1.8.tm new file mode 100644 index 0000000000000000000000000000000000000000..5ab00010b2b5f414f3b827e86433879339478f1c GIT binary patch literal 12718 zcmch6cRZEh|F>Ns8QG)TNGV&x&WLOxlzp7R;W&pgtdLcdnM%^2B9xJ`A{mvDk+eu9 zGl?iA4LsL34@-83_91Z) zj(|X+iI6uD?TyBx&?s5R67565644|G4c35Ht`sbejKxD>FNP!y5r~j4hNP+riy{*s zF9HQmhWy-Nq2Q4>kifj?L`Ym4M@AFz2r||ejSGM%cz7R)0Fm7hWC-m~CL)kzGzt>; zBA~npC>d`A(i7o^mhnXsNmv3N!Vqwx&t*Kb?_eck|v~1 z_M-l=#3U>RI%tnXkdf}tL8>$H1fmxLhYdtS_E2{t_tTIG+GiA@g;yq8ccIGc_GZXe1d#SR2w=DY~%hs2PmIq49121thc` zAq@>k9xNuJ$rK_UIvBj%+sn7<{MXwwA^Sy#|4m8wL^xnD6iH|=vlxC2f8ZtBkc7@Z z7wA9|K+K9uRyK9v;Dal_#t?{T1gL+1pc!-!Uc6btU+S-pTeMtf1xT1PWIilZ1evcg zSm<9XY+)A;lr(_uIY0TYXd}FIWkXheI-dtC`fP>V5MPE>aPE@;mIIU`Kz?WliNJ#_ zhC2mNmPqg>VgW$o0+uNYdlH94kkHO^!0SvxyLqAU0C4PKfWx~1WW*8te%0CUdI2^4 zm+G982Wk|6D2$;bs^gZ)BO`IDs$?&?O_0bdh+2pt4(aR#i-9DT3to=)@L8}?)Gdpw zpU?#Khh&ac!R((xtVg3{Kqz1~ z1$V-QMzZXTUjA&Rve9hQ+K`@lT_!p@xm^uUfv*K$nbMG3sx2a*eL)=MR`Rf8F>{|XsM9- zopY#36}GYv6al}94CfWJX%Ro$1QaghBJSMkK%>Nd!QW7IcR|a^cVj5*c!X zsjnBzM8G!+jY9;GAi%)=uy_=~j|6$+5M+RXfN}%+iYMS@s67e+OpsbxvwiL`YX=)a z=cRZ7{uBUO6c94!eK|Q009dy<1`9e4cn&HA0pdyaBM?2Qe0MnyT#{^5zkuF=0@N4s zL<5EGmnX>IVO2~{ZZ4JNKzh#=nizz~!UYX}%?bZoVo}oo1)3a|jE1x=4CgazQG)&| z@_AQ7elP%l`vH+m0rw&JHiRdD(0QY%K9QMkm2(00#1s6$ePl`Q!YN9ikRdWLfa*B% z%HDxBqgKxR6=lWfz>DCI_%eU};;GOt@BFKd0ocK}IJ6gR4+->U_-yig=n;?~kpN=s zMnRKE&}IaYjKzTa9t1!U0ryk5Fu|1tM1E23f}9~y(9o`x(`rs_ptv^$umZ7vsQ){r z|Mb9rBH{0j1|Ui#n*Ozq{L&W03<6hKK!33R)CLZm=)&c4xoW>c^2@ki;ad5&xuC$p zH`Qw-GJwM0cTf_ze`;!KE=t{bY=zX}uz*|e?|RULFrdwWOTGi%6{O<4NvbRDUA$>t z5Q&0BqS0W=-~g}*=39%A{CB?nE=TB>c}wrK3+62TUSgUqjO;MrQ@q`X2o#k$f@ud4 z)HN2MAAo<5c5|SQ!Gas%9QeY8{O^O7(~AWa{{Chzri(Ltc^Ki=y{u)!e)!eD!L;Ll zOtU2}m=g#sM3)*4814Vd!{-AJB1a9{Tu%Y5&wkNQ$A3F-3D{8Za~iFn&p#_5`TxEp{9Tp(2| zYAbH0BMaFAzCooiNI>*KJB58ir3GGKR0BT%jwC@cU=j(MA9y#HIDpy!k_}S@611E< z!ezO<@FeD@KfeLypCtwFU%=u&82c}){=)`9<;Ns9NbGms!jsouVt$bY;I}#R7BUum zFC;eTpdbt8>J6q22w#B3)Oq3DsP>P+-vTl%e9zAbynq^@ip2~ufNIT+c;`eep6nus zAU%JHmzj4vwT9q4o%21&R_gc|1-S+Q=7^_&;LneEy{U)`VnwaMU!@3NeQ;nbAp7^? zgSGub(|te=b#M%(%Mf5ofL6ev2dB*!47hs1BmziBEX;>t+WmX1yckFqs*gHN_6CN6 zf}9^S1A?}o>c17710f0E$`!L3w&9<30xy6+)O#ihvR|l?g)78@7SQs9{p*3Sy#FBM z|KD^P_^{tfThC*;1O_1SpC$HBg<(1W9}pcrW@S|W`5{{>!`S^b~6d6{pP9vU1x zKVkWEGClu4432*QAN>D2ziI^JGyve=Lr(zNXJpm2&sk$erOFyam+g3>lE2H%hH_laDbF7=JJF9%) zX`R^vqVFz?%{;4F4Rgm`#uInnoa!#9cpFA5Ph+Tet2~?Y1Oq0p{NQ(u1P)TGu+0=l z2%G-Md0t6I^V|2{j%;a+$^9H7Z+b<#_qDLw{nVRP?cM!7J%~@$x6d6`nMevfrQ+sx zRyoL}(68y?{?tPC3Ayolh8|w2tvkbPy-S+gQz~D+%y&|YQH%{&yD%VMm*KyeNxZs; zmyad%8#XD5_8|>1B{!vhCS+PeC)n@H@qzn0dZn3zFK9JwRCh!Rxx8g0$Lw_CkgeS; zT{5C6{Vej!9<8t+*gGvOBIYh9$J#@U+s?+y1tfnAwKL3CnW&7EQSRGY#>{)1PtxRP z_HJB{U`c%KeWl5dJetvKl-sYE;5+Lk2$kG!{M{J=`!hOu>VFPzof^xYz4(#0JGjwF z{m@6}dnX80=rMm<^*7h#!@3DO1gjt4y|ov~@#W#B(ASQ>w1MH0WR&M!S{a3v1e2^!{i<+Xg}Yp`M3vrvqe3X6G6v z_ieuLll4I$@24NkzFX2(yKbxP$a2WWcW1g-?9g+fC}pw9tlr9Uu`s+$XwfI{# zJ~l>&-ADAZmakAqZ&|L003hd0|z>aveY`zPMt6!fV2crjwH72V^Es4~_QeVS*8 zp?W^%rDqQ9aXTH_(@2XAu_MS2KhF7}cK(x^oa^J99ES>8JF!Kr@L6r*von|Z+4Xa6v$z(8 zsa@O(>pQmHA%Zhy_an=pHb1QXj&m|ik>vyZ>87TfEo;4)rxZu1lB-$y*9qkW$y? zeT(*Fmlge>HJcvmGI`7*lYk%HlS{Wb;Vu zw>X)tHp#?3mQsi^4ydUj+zr(fp2}@}LO!-vc>IpXaQ%~K+WPYLR)e_#MYs4_uITdkf=(XblZc_1(K4^S@i*5BMf$VFUz0$FxM-2vP z-JK#*3UA6ExRSKiEuB&C%*HPt44D%q6t`#@M^n)Hy=w{^WNut{jcwH9^mccmw{}CF ze}mX)!oirJLUPrb@|+qM>3IHqyXBgD_Kd^4Qrt(|!gH^XAKTg2O`+~*#NyE>5Tuj0 zQ2CUiLydlh{BkbgsePsbeU&G;hW6gsDCpSW(z;EUX^at-sKZ$<#47nNif2~M$WJlE z1|jR*l2h*>sMCvMR!Er{n8Kb+=0_Pr4Q7R}LPcpKnrm(-yRfRC`(#}4I-C=|aa9=m z`MuJY)i$?rAAr>h?+jX7ym%zUIbQ0~;BIb5)w^PvDl{Aeey-6Y!|u43d@_Jk1n zBatJbn?-;fI<{xE9$!pz$GMJD924AlItNr@llx|7{#_vXQw7sj>flBdq`ZDI1!Y0NyL!7DI%?)8Vm z&JC7nQcabY4Vt}KRiefrdq#E){|x;-_M(F(q7s1@%nEv*(MVD92TZkxcv;Ii%0i_g zpso_y%`zICq3y$}=_S2ndXLh)yNcG=SfuvVrE->^>J#uX@;}3?ZKuQISw|Xs{c~b? zIw4)6dwQZJfzVlB`h0^FD;+{;tCN8AnRwHgHj_u|t#8mI-8p;aqv$>3TSo>`x#V=1 z!uTHE5O6(}WxIc${B~ETleF}u#6;$(${7qK=6c}OX|a2k!s6Hr59T^O{29NF{P>Mj zBdgL6;~vrv=NR0p*U;7zClx2ZACzmVc83P7=}Wpwhb&Kcwvz968p&E`$DC577b};c zu}YNV#q4rx_tjDI+BLf)+gSPVdXn^Di+131oDE(qq+WcSUrjt)o?XjOu=M-K?hfyc zlZro9pZ!s-VZ;|^wAy}H`*q~B(NoP?O|2-SLIakw2o{#a>htSsrpa3d(q9$2f?n1t z)89ecB0qUIC0Zw$Xa94H;{rbnvj@etowMr3*j?J*ai%!RmZ^6P@hDSoSU>>giiY?J{=v@z(ux4?A((nJfmUEn~aIOqhi@ zuQAJUBr=X0iZ@(*uYCL+Q<$Mmx^N%!?Ix#6*N10EG;-xX=Ut$%|7g(PEVgMR?*X>? zc83^KN^ARWi{p-;%=U&i8tCC2$8uFOHcC7we4^Eumlc;59dTDZkCjJ2!2qjgJ)>NB z>3d~$frjs$qdL}s`kw|TQyiO%L-9Kz4C^f;yFA#M2QF0YC{H0_d*~3zq9Yc{=13>@ zw9Df>bX77YCrK&+3g60&Ayd@h>4q3qT9gxA&-;$hS)rJxtpk}&clgojW@E}~Ojk1m zuViYq*WA_2j#gmiO%%IFso36hU zXYyy8iV6D>UY3l8_7^x8HfhF$M#zTJ*Gg83hZiYI>n$O+S>8)glDCfrC+Dj2W@K?s?dIQmj6+@T1~s*H>(VV z%Vv^S)$=8#3cfRWSbKcAaYg#V4c-&87k)m?F?xhC-9GEIY40={``vMGVD|GYEf-#F zs}y3D)s-lkx8sO|se3XbSJL&Q>>$EL$F_m$VUsY~T z-)1(gcz{9D7RKk9PrCcLKbpKY7%_d^V%yHvufiiDg7;e`w)K!EV(q(Xb}}o09uayEY7d|IYv5<@40!qp4o?Ycp?HxH3L-+iQ3D8@-Qq z)m{ZRq;$*sd=bCcdq&F5XeT|5FP8Pu1;bU1eNJ{4Dz9r)G&Jc|D)>x%e|{~2P|%6r zL@(1&?)AynWmMZ_<6ik|d5y*eFqkd!y6>%s zLKZ$8$$TXcn_3es5gJH|ef$jBC9aZ#G=AsRy`TSGXD70|N4M}k*@&|PZ`aj>+)+Hr z-loQwkC=oMXY%^lue;i?N!j|>#}y&lcgTG4Vh*gJV-w#f85VTM&*8-ei$Ole2*w6a zd$sR8HF8}DIx)lD?@c-GBE~vgc@^+4I9U$mKmwMP@t2-G^x5yCRI{U1*Mx#if>)k^4J*&m4JHvEj*PqVYm{IaHjgM=aFw*3Gy2Y~8u7 zt~^nqyj}B+xWxt*_4soV1Em>O8*D>INZazquL)tgh1Re4nshF8R*zJ=hyMYh^7x zqh{Uk&Bq6ID>nIH?tgra9qRioIv`j!U=?(+^fRG+YTZ{Bq7O)!uHB;&G3EuLsv6aa(Im+U+v8w8yX8QI3BokxN;}wi-F3FS*zRC+*bYH z(`s2>d_zk$h>VBt>6g4ZDYh-&Qz`PpA<;WVc?WKg3cc)tVp}&suIpSL5=JKuM_7n; z6w?$4G@i?@;)o~tOF5%z!f!kJtqs4;?=ES6k1apbcxzs2`s%(L5Rxo$hr8xB)R`L*`q4>qB~l16)~xXf2yr zi0P~JwR_W__a&Q@zspP$>pvi(>$Zw%yL8lDE@m~OS{t17h{aBB%;1*im(ri#*tyPz0)RYf4uQ`!* z-n(k3@jQnx@zHgqr>tKdX7}HW)Ns0Swtu(e*(WUWn-cT;LNB-QD|&KdhE!=>CRO65 z=nuTG5Fw@-i7SqbGGk|h`O+17*PYF6=RUQG!~N?u-XD044HvyQwfYASn@ah%_r6%; zb$1U`Zz1m~UF+iYnp?S9-A{Qass@wl_&A4^=H_S3odddz$Mi>5iJa0uUE~|DaOGH< zU2l7=;59;olX%AGwT@>Mrp6OFENgAlbu89uq{b-(v!1wg`VP%cN-{pp=F@C?|J%C- zV+l>c=?Fr|$BQPP8&73gii%fp;kB@`fjC_e{bp{Oo4f91 z&d6}7wXfYhvc`MQ>o1@AlQkK9QH&O6Y?U$5-)5?W}9=)-1edS$x^%!tPo|;ToDs#G@Csc6)K+ zu0g^==HETiug)awvCy)b=ImJ8+qJ*oOz!UE5%}%2#yi|?dXVMQ468lmT8o@^@=!i} zEGl4kyW~`oo2DYf5uzgS=%7zot@7;At64uZu3Z*ONTjfte^c7>gX_ventU($FPaX= znlqIx9}ExQ+MW@2l*4ef^<)Z* zu8@IX-*xNcWWjCM6+|TJtSV3`_pu!^9jnzx^c^p}qu-aPhLVc3@IT0v=zt&B&tln- zz#KD%vXv6Qc*jOF=OQuZvgWIfNPz&Bz9Uz|f10GQ1*IFb8Tx4s8Ab^vr&qYoWY=li*iY8;E+eE&f0K@D=Sp~I_<;j&?Y z=Z~sODJCA}zApJZUN9)IsMz2O@0;wJ;sIg=CCOV@=gl$bb#mg(3BCS2^t7zOHE}Lx z@szjLA);fZbPUY1#uaigmjd+eALRc%ZyeiFNC(A+0#aGegi!S={~Ekcpn@ zr$07i5%Ua`_RCy7smJJW+~}>I1p|+R$f*sQcGbln^hg(jDYWk{tRHG~*|Nn##W?7*`zt@5aF?PU`h&E7GVg{C!^|4i;| z3ut*QJw6#NmTAHzcg#Da?EAaXqPi0?A8%9`2}p)u>Pijy4@JuD!;O~uwC5O>Y-4)a z*BasXZ8%-~{pGRIsCByzRjcl36R%#oVeNZKQI1N(eih~yd_Ii&kDn5bZ1Vg_n`I!my>AwmU_)1hDx7VYU|}tdio<@YITEW zQKPB*qhyb4m)){0#a8Y19>4n^%x{-}dQu@(VE9$Nf%c$+MI)ndjq>|Dx9)po|LRN!X=`TkCy&!J@!9NZ>&|}l z?!g!Tu=4FW+r{@|#~WJ~_qM&7sXN)YLZmw$&6* zwz*qNC!wszhc&qCj=Eo>8DVnl;`q!C0P{wl{`MEXZ}RTAq^xUB8GE-j+~VRMyTjc9 z=B1W=w_CZAWLNKv-y7h=U2!g=e)tkiyTzWvQKo{0H0@6sYI20Qc=Zp~__lp!y>j$| zaIhM|`hAsSG5-2fxfY$$fU(nM6T<$Gu+LY$;og$ISw;(ETDtW#e;=8HsrjPM|89V8 UVa&(`Z>9zR9Kg2%FZ}EO06j*}rvLx| literal 0 HcmV?d00001 diff --git a/src/vfs/_vfscommon.vfs/modules/punk-0.1.1.tm b/src/vfs/_vfscommon.vfs/modules/punk-0.1.1.tm index c2fdce0e..e3ba36b4 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk-0.1.1.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk-0.1.1.tm @@ -7719,7 +7719,7 @@ namespace eval punk { } namespace eval argdoc { - set DYN_ANTIGLOB_PATHS {${[punk::args::resolved_def -types opts ::punk::path::treefilenames -antiglob_paths]}} + set DYN_ANTIGLOB_PATHS {${[punk::args::resolved_def -types opts ::punk::path::treefilenames -exclude-paths]}} punk::args::define { @dynamic @id -id ::punk::LOC @@ -7737,11 +7737,11 @@ namespace eval punk { @opts -return -default showdict -choices {dict showdict} -dir -default "\uFFFF" - -exclude_dupfiles -default 1 -type boolean + -no-dupfiles -default 1 -type boolean + -no-punctlines -default 1 -type boolean ${$DYN_ANTIGLOB_PATHS} - -antiglob_files -default "" -type list -help\ + -exclude-files -default "" -type list -help\ "Exclude if file tail matches any of these patterns" - -exclude_punctlines -default 1 -type boolean -show_largest -default 0 -type integer -help\ "Report the top largest linecount files. The value represents the number of files @@ -7769,16 +7769,16 @@ namespace eval punk { set opt_dir [pwd] ;#pwd can take over a ms on windows in a not terribly deep path even with SSDs - so as a general rule we don't use it in the original defaults list } # -- --- --- --- --- --- - set opt_exclude_dupfiles [dict get $opts -exclude_dupfiles] - set opt_exclude_punctlines [dict get $opts -exclude_punctlines] ;#exclude lines that consist purely of whitespace and the chars in -punctchars + set opt_no_dupfiles [dict get $opts -no-dupfiles] + set opt_no_punctlines [dict get $opts -no-punctlines] ;#exclude lines that consist purely of whitespace and the chars in -punctchars set opt_punctchars [dict get $opts -punctchars] set opt_largest [dict get $opts -show_largest] - set opt_antiglob_paths [dict get $opts -antiglob_paths] - set opt_antiglob_files [dict get $opts -antiglob_files] + set opt_exclude_paths [dict get $opts -exclude-paths] + set opt_exclude_files [dict get $opts -exclude-files] # -- --- --- --- --- --- - set filepaths [punk::path::treefilenames -dir $opt_dir -antiglob_paths $opt_antiglob_paths -antiglob_files $opt_antiglob_files {*}$searchspecs] + set filepaths [punk::path::treefilenames -dir $opt_dir -exclude-paths $opt_exclude_paths -exclude-files $opt_exclude_files {*}$searchspecs] set loc 0 set dupfileloc 0 set seentails [dict create] @@ -7792,7 +7792,7 @@ namespace eval punk { set notes "" if {$has_hashfunc} { set dupfilemech sha1 - if {$opt_exclude_punctlines} { + if {$opt_no_punctlines} { append notes "checksums are on content stripped of whitespace lines,trailing whitespace, and pure punct lines. Does not indicate file contents equal.\n" } else { append notes "checksums are on content stripped of whitespace lines and trailing whitespace. Does not indicate file contents equal.\n" @@ -7814,7 +7814,7 @@ namespace eval punk { continue } set lines [linelist -line {trimright} -block {trimall} $contents] - if {!$opt_exclude_punctlines} { + if {!$opt_no_punctlines} { set floc [llength $lines] set comparedlines $lines } else { @@ -7852,7 +7852,7 @@ namespace eval punk { incr dupfileloc $floc } } - if {!$isdupfile || ($isdupfile && !$opt_exclude_dupfiles)} { + if {!$isdupfile || ($isdupfile && !$opt_no_dupfiles)} { incr loc $floc incr purepunctlines $fpurepunctlines } @@ -7881,11 +7881,11 @@ namespace eval punk { ] dupfileloc $dupfileloc {*}[ ] dupinfo $dupinfo {*}[ ] extensions $extensions {*}[ - # purepunctuationlines key only retained if punctuation lines are excluded from count by opt_exclude_punctlines + # purepunctuationlines key only retained if punctuation lines are excluded from count by opt_no_punctlines ] purepunctuationlines $purepunctlines {*}[ ] notes $notes {*}[ ]] - if {!$opt_exclude_punctlines} { + if {!$opt_no_punctlines} { dict unset result purepunctuationlines } diff --git a/src/vfs/_vfscommon.vfs/modules/punk/ansi-0.1.1.tm b/src/vfs/_vfscommon.vfs/modules/punk/ansi-0.1.1.tm index 407782ff..53ffd420 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/ansi-0.1.1.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/ansi-0.1.1.tm @@ -10349,8 +10349,9 @@ tcl::namespace::eval punk::ansi::ansistring { set hack [tcl::dict::create] tcl::dict::set hack BOM1 [list \uFEFF "${obm}\U1f4a3$cbm"] ;#byte order mark/ ZWNBSP (ZWNBSP usage generally deprecated) - a picture of a bomb(2wide glyph) tcl::dict::set hack ZWSP [list \u200B "${obm}ZWSP$cbm"] - tcl::dict::set hack ZWNJ [list \u200D "${obm}ZWNJ$cbm"] ;#zero width non-joiner. + tcl::dict::set hack ZWNJ [list \u200C "${obm}ZWNJ$cbm"] ;#zero width non-joiner. tcl::dict::set hack ZWJ [list \u200D "${obm}ZWJ$cbm"] + tcl::dict::set hack CGJ [list \u034F "${obm}CGJ$cbm"] ;#combining grapheme joiner (MISNOMER) - zero width, but semantically important in some contexts - for example in indic scripts - where it can affect the shaping of the preceding character(s) #review - other boms? Encoding dependent? diff --git a/src/vfs/_vfscommon.vfs/modules/punk/args-0.2.1.tm b/src/vfs/_vfscommon.vfs/modules/punk/args-0.2.1.tm index 1ff7fd37..24c2ddf7 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/args-0.2.1.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/args-0.2.1.tm @@ -9086,7 +9086,7 @@ tcl::namespace::eval punk::args { } if {!([tcl::string::first " " $a]>=0 || [tcl::string::first \t $a]>=0 || [tcl::string::last \n $a]>=0)} { if {$OPT_ANY} { - #exlude argument with whitespace from being a possible option e.g dict + #exclude argument with whitespace from being a possible option e.g dict #todo - passthrough of unrecognised --longopt=xxx without looking for following flag-value set eposn [string first = $a] if {$eposn > 2 && [string match --* $a]} { diff --git a/src/vfs/_vfscommon.vfs/modules/punk/char-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/punk/char-0.1.0.tm index 9ec42b88..349cc3b7 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/char-0.1.0.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/char-0.1.0.tm @@ -3033,13 +3033,15 @@ tcl::namespace::eval punk::char { #This still leaves a whole class of clusters.. korean etc unhandled :/ #todo - tk::startOfCluster / tk::endOfCluster - try to get it brought into Tcl #https://core.tcl-lang.org/tcl/tktview/a4c7eeaf63 - proc grapheme_split {text} { + proc grapheme_split {text {return list}} { #we should treat \r\n as a single grapheme cluster (as tk::endOfCluster does) set components [list] set csplits [combiner_split $text] foreach {pt combiners} [lrange $csplits 0 end-1] { set clist [split $pt ""] - lset clist end [tcl::string::cat [lindex $clist end] $combiners] + #review + #lset clist end [tcl::string::cat [lindex $clist end] $combiners] + ledit clist end end [tcl::string::cat [lindex $clist end] $combiners] lappend components {*}$clist #lappend components {*}[lrange $clist 0 end-1] #lappend components [tcl::string::cat [lindex $clist end] $combiners] @@ -3183,7 +3185,11 @@ tcl::namespace::eval punk::char { if {$current_cluster ne ""} { lappend graphemes $current_cluster } - return $graphemes + if {$return eq "list"} { + return $graphemes + } else { + return [dict create list $graphemes last_extensible $current_cluster_is_extensible base $cluster_base RI_base $cluster_base_RI] + } } namespace eval grapheme_split { proc about {} { diff --git a/src/vfs/_vfscommon.vfs/modules/punk/lib-0.1.6.tm b/src/vfs/_vfscommon.vfs/modules/punk/lib-0.1.6.tm index b393fdaa..5fecb48d 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/lib-0.1.6.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/lib-0.1.6.tm @@ -138,36 +138,29 @@ tcl::namespace::eval punk::lib::check { if {"windows" ne $::tcl_platform(platform)} { set bug 0 } else { - if {![catch {file tempdir} tmpdir]} { - #tcl 9+ has 'file tempdir' - set testfile [file join $tmpdir "bugtest"] - } else { - #fallback for older tcl versions - use env TEMP/TMP or current directory - set tmpdir "" - foreach e {TEMP TMP} { - if {[info exists ::env($e)] && [file isdirectory ::env($e)]} { - set tmpdir ::env($e) + set tmpdir [punk::lib::tempdir_newfolder] ;#uses 'file tempdir' on tcl9+ or fallback to env vars or current directory on older versions + set testfile [file join $tmpdir "bugtest"] + + try { + set fd [open $testfile w] + puts $fd test + close $fd + set globresult [glob -nocomplain -directory $tmpdir -types f -tail BUGTEST {BUGTES{T}} {[B]UGTEST} {\BUGTEST} BUGTES? BUGTEST*] + if {[file exists $testfile]} { + file delete $testfile + } + foreach r $globresult { + if {$r ne "bugtest"} { + set bug 1 break } } - if {$tmpdir eq ""} { - #no env vars - fallback to current directory - set tmpdir [pwd] + } finally { + if {[file exists $testfile]} { + file delete $testfile } - set testfile [file join $tmpdir "bugtest"] - } - - set fd [open $testfile w] - puts $fd test - close $fd - set globresult [glob -nocomplain -directory $tmpdir -types f -tail BUGTEST {BUGTES{T}} {[B]UGTEST} {\BUGTEST} BUGTES? BUGTEST*] - if {[file exists $testfile]} { - file delete $testfile - } - foreach r $globresult { - if {$r ne "bugtest"} { - set bug 1 - break + if {[file exists $tmpdir]} { + file delete -force $tmpdir } } } @@ -679,7 +672,207 @@ namespace eval punk::lib { } } + namespace eval argdoc { + variable PUNKARGS + lappend PUNKARGS [list { + @id -id ::punk::lib::tempdir + @cmd -name punk::lib::tempdir\ + -summary\ + "Determine an appropriate temp dir for the process we are running under."\ + -help\ + "On windows: + If the process is running under the system account use the modern windows location: %SystemRoot%\SystemTemp + Detection of the system account relies on either twapi, or a combination of the whoami command and the + registry package. + Proceeds with same fallback logic as for other platforms if we fail to detect the system account or its temp location. + + + For other platforms we use the environment variables TMPDIR/TEMP/TMP or fallback to /tmp or /var/tmp if those + env vars aren't set or aren't writable directories. + + Final fallback attempt is the current working directory. + Result is normalized so resulting path will have forward slashes on all platforms. + + Alternatives: see the tcllib fileutil::tempdir function. + " + @values -min 0 -max 0 + }] + } + proc tempdir {} { + set trydirs [list] + if {"windows" eq $::tcl_platform(platform)} { + #review. + #consider also checking for whether running under various service accounts + + if {![catch {package require twapi}]} { + set tok [twapi::open_process_token] ;#first call is a little pricy. + set sid [twapi::get_token_user $tok] + if {$sid eq "S-1-5-18"} { + #system account - use system account temp location + set sysroot [twapi::get_shell_folder csidl_windows] ;#first call is a little pricy. + lappend trydirs [file join $sysroot "SystemTemp"] + } + #if not system account - use env vars as first choice. + } else { + #twapi not available - try to use builtin windows whoami to detect if we're running under system account - but this is less reliable than using twapi to check the process token - so we warn about it. + set whoami_exe [auto_execok whoami] + #test that system32 is somewhere in the whoami path as a basic attempt to avoid non-windows whoami commands that might be present in the path + set whoami_exe_parts [file split $whoami_exe] + if {"system32" in [string tolower $whoami_exe_parts]} { + set whoamiresult [string trim [exec {*}$whoami_exe /USER /FO LIST] \n\r] + set whoamiresult [string map {\r\n \n} $whoamiresult] + set whoamiresult_lines [split $whoamiresult \n] + set sid "" + foreach line $whoamiresult_lines { + if {[string match "SID:*" $line]} { + set sid [lindex $line 1] + break + } + } + set has_registry [expr {![catch {package require registry}]}] + if {$sid eq "S-1-5-18"} { + #system account - use system account temp location + set sysroot "" + if {$has_registry} { + #registry path is case-insensitive. + catch { + set sysroot [registry get {HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows NT\CurrentVersion} SystemRoot] + } + } else { + if {[info exists ::env(SystemRoot)]} { + set sysroot [set ::env(SystemRoot)] + } + } + if {$sysroot ne ""} { + lappend trydirs [file join $sysroot "SystemTemp"] + } + } + #if not system account - use env vars as first choice. + } + } + } + + foreach t {TMPDIR TEMP TMP} { + #TMPDIR is the posix standard as first choice for temp dir env var. + if {[info exists ::env($t)]} { + lappend trydirs $::env($t) + } + } + + if {"windows" ne $::tcl_platform(platform)} { + #suitable for macos,linux and freebsd at least. + lappend trydirs [file join / tmp] [file join / var tmp] + #/usr/tmp is probably not a common location for a temp dir on modern unix-based systems. + } + + foreach d $trydirs { + if {[file isdirectory $d] && [file writable $d]} { + return [file normalize $d] + } + } + + #only even call 'pwd' as a last resort (mildly slow on first call). + set cwd [pwd] + if {[file isdirectory $cwd] && [file writable $cwd]} { + return $cwd + } + + return -code error "punk::lib::tempdir unable to determine a suitable temp directory - tried: $trydirs" + } + + namespace eval argdoc { + variable PUNKARGS + lappend PUNKARGS [list { + @id -id ::punk::lib::tempdir_newfolder + @cmd -name punk::lib::tempdir_newfolder\ + -summary\ + "Create unique folder within temp dir (or cwd as last resort)"\ + -help\ + "Creates a new unique folder within the temp dir determined by punk::lib::tempdir. + The folder is created before returning its full path and will be empty. + The folder is named with a tcl_ prefix followed by a random string. + + See also: 'file tempdir' in tcl 9+ or fileutil::maketempdir from tcllib" + @opts + -dir -type string -default "" -help\ + "Base directory to create the temp folder in - defaults to the result of punk::lib::tempdir" + -prefix -type string -default tcl -help\ + "Prefix for the temp folder name + An underscore is automatically appended to the prefix in the generated folder name. + If prefix is the empty string - then the generated folder name will still be autoprefixed + with tcl_ (consistent with tcl9 'file tempdir')" + @values -min 0 -max 0 + }] + } + proc tempdir_newfolder {args} { + set argd [punk::args::parse $args withid ::punk::lib::tempdir_newfolder] + set opt_dir [dict get $argd opts -dir] + set opt_prefix [dict get $argd opts -prefix] + puts "opt_prefix: $opt_prefix" + if {[llength [file split $opt_prefix]] > 1} { + error "punk::lib::tempdir_newfolder -prefix option should not contain any path separators" + } + if {$opt_prefix eq ""} { + #don't allow empty prefix - for consistency with tcl9 'file tempdir' - which would still prefix with 'tcl_' even if prefix is empty string. + set opt_prefix "tcl" + } + + if {$opt_dir ne ""} { + if {[file isdirectory $opt_dir] && [file writable $opt_dir]} { + set tmpbase [file normalize $opt_dir] + } else { + error "punk::lib::tempdir_newfolder -dir option '$opt_dir' is not a writable directory" + } + } else { + set tmpbase [punk::lib::tempdir] ;#will raise an error if no writable temp dir or cwd found. + } + #assert: tmpbase has no trailing slash - unless it is a root dir (e.g / on unix, or C:/ on windows) + #assert: tmpbase is normalized with forward slashes on all platforms. + + set tcl9_template_base [string trimright $tmpbase "/"] ;#set it to a form that can join along with a forward slash to prefix for tcl 9 'file tempdir' style template. + #tcl9 'file tempdir' separates the prefix in the template from the random string with an underscore. + #now form template by always joining with a slash (even if opt_prefix is empty) + #(avoiding file join and file normalize to ensure template is properly formed) + #whether or not opt_prefix ends with an underscore - another will be added. (by file tempdir, or by our own code if tcl9 'file tempdir' isn't available) + #assert: opt_prefix is not empty string (will have defaulted to 'tcl') and does not contain any path separators. + set tcl9_template "$tcl9_template_base/$opt_prefix" + + + #tcl 9+ has 'file tempdir' + #we don't support the same template as 'file tempdir' + if {[catch {file tempdir $tcl9_template} tmpdir]} { + + set prefix tcl_ ;#todo - accept option: -prefix + + set chars abcddefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789 + set nrand_chars 8 + set maxtries 100 + for {set i 0} {$i < $maxtries} {incr i} { + set dirname ${opt_prefix}_ ;#always add underscore for consistency with tcl9 'file tempdir'. + for {set j 0} {$j < $nrand_chars} {incr j} { + append dirname [string index $chars [expr {int(rand()*62)}]] + } + set path [file join $tmpbase $dirname] + if {[file exists $path]} { + continue + } + if {[catch { + file mkdir $path + if {"windows" ne $::tcl_platform(platform)} { + file attributes $path -permissions 0o700 + } + }]} { + continue + } + return $path + } + return -code error "punk::lib::tempdir_newfolder unable to create unique tempdir in $tmpbase after $maxtries attempts - too many collisions - aborting" + } + #tcl 9 'file tempdir' return. + #normalize because on early tcl 9 versions on windows it can return with mixed forward and backward slashes when a template is supplied with forward slashes. + return [file normalize $tmpdir] + } # == == == == == == == == == == == == == == == == == == == == == == == == == == == == == == == # Maintenance - This is the primary source for tm_version... functions @@ -814,6 +1007,89 @@ namespace eval punk::lib { error "tm_version_required_canonical should have already returned a canonicalised versionspec - or produced an error with reason before this point" } } + proc tm_version_magic {} { + #maintenance instruction: + # This specific 12 character nnnnnn.0a1.0 version number is used in text replacement when installing modules. + # It should not be modified without also considering the impact on existing projects based on punkshell that may have used this version number in their own code or documentation as a placeholder for tm version handling. + # A copy of this is also present in punk::lib. + # Essentially this should probably never be changed - and instead deprecated if we want to stop using it and replaced with a different mechanism/placeholder. + + #tm versioning is not quite the same as semantic versioning - but similarly we should see extremely high major version numbers rarely if ever in real use, + #even over decades of development. + set magicbase 999999 ;#deliberately large so given load-preference when testing! + #we split the literal to avoid the literal appearing here - reduce risk of accidentally converting to a release version + return ${magicbase}.0a1.0 + } + + namespace eval argdoc { + lappend PUNKARGS [list { + @id -id ::punk::lib::tm_split_name + @cmd -name punk::lib::tm_split_name\ + -summary\ + "Split a versioned module name into name and version parts, dropping trailing .tcl/.tm if any."\ + -help\ + "Splits a versioned module name (as present in a filename or namespaced name) into name and version parts, + Ignores any trailing .tm or .tcl file extension. + + If the fullmodulename given is a namespaced name - then the returned modulename will also be namespaced, + but with any leading :: removed. + + Returns a two element list - with the first element being the modulename and the second element being the version. + + Tcl module version numbers are understood with leading zeros in each dotted part, but leading zeros are not canonical. + + This split does not canonicalise the version number. + If the last dash-separated segment of the name doesn't look like a valid version number + - then it is treated as part of the modulename and an empty version string is returned. + e.g + mymod-1.2.3.tm -> mymod 1.2.3 + mymod-1aa2.3.tm -> mymod-1aa2.3 {} + (repeated a is not a valid version segment - so the entire '1aa2.3' is treated as part of the modulename) + + see also: tm_version_canonical + " + @values -min 1 -max 1 + fullmodulename -type string -help\ + "The full module name to split - as present in a filename or namespaced name. E.g: + mymod-1.2.3 + mymod-1.2.3.tm + mymod-1.2.3.tcl + /some/where/mymod-123.0a4.0.tm + mymod + mymod.tm + mymod.tcl + ns1::ns2::mymod-1.2.3 + ::ns1::ns2::mymod" + }] + } + proc tm_split_name {fullmodulename} { + #split modulename (as present in a filename or namespaced name) into name/version ignoring leading namespace path + #ignore trailing .tm .TM if present + #if version doesn't pass validation - treat it as part of the modulename and return empty version string without error + #Up to caller to validate. + set lastpart [namespace tail $fullmodulename] + set lastpart [file tail $lastpart] ;# should be ok to use file tail now that we've ensured no namespace components + if {[string tolower [file extension $fullmodulename]] in {.tcl .tm}} { + set fileparts [split [file rootname $lastpart] -] + } else { + set fileparts [split $lastpart -] + } + if {[tm_version_isvalid [lindex $fileparts end]]} { + set versionsegment [lindex $fileparts end] + set namesegment [join [lrange $fileparts 0 end-1] -];#re-stitch + } else { + set namesegment [join $fileparts -] + set versionsegment "" + } + set base [string trimleft [namespace qualifiers $fullmodulename] :] + if {$base ne ""} { + set modulename "${base}::$namesegment" + } else { + set modulename $namesegment + } + return [list $modulename $versionsegment] + } + # end tm_version... functions # == == == == == == == == == == == == == == == == == == == == == == == == == == == == == == == diff --git a/src/vfs/_vfscommon.vfs/modules/punk/mix/cli-0.3.1.tm b/src/vfs/_vfscommon.vfs/modules/punk/mix/cli-0.3.1.tm index 793736b8..6ac3cc1e 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/mix/cli-0.3.1.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/mix/cli-0.3.1.tm @@ -499,7 +499,7 @@ namespace eval punk::mix::cli { # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- set opt_punkcheck_eventobj [dict get $opts -punkcheck_eventobj] - set magicversion [punk::mix::util::magic_tm_version] ;#deliberately large so given load-preference when testing + set magicversion [punk::mix::util::tm_version_magic] ;#deliberately large so given load-preference when testing set module_list [list] if {[file tail [file dirname $srcdir]] ne "src"} { diff --git a/src/vfs/_vfscommon.vfs/modules/punk/mix/commandset/module-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/punk/mix/commandset/module-0.1.0.tm index 4c75b10e..3626d2d0 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/mix/commandset/module-0.1.0.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/mix/commandset/module-0.1.0.tm @@ -362,7 +362,7 @@ namespace eval punk::mix::commandset::module { file mkdir $modulefolder set moduletail [namespace tail $modulename] - set magicversion [punk::mix::util::magic_tm_version] ;#deliberately large so given load-preference when testing + set magicversion [punk::mix::util::tm_version_magic] ;#deliberately large so given load-preference when testing diff --git a/src/vfs/_vfscommon.vfs/modules/punk/mix/commandset/project-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/punk/mix/commandset/project-0.1.0.tm index 8384197a..9b1263e3 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/mix/commandset/project-0.1.0.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/mix/commandset/project-0.1.0.tm @@ -380,25 +380,25 @@ namespace eval punk::mix::commandset::project { puts stdout ">>> about to call punkcheck::install $layout_path $projectdir" set resultdict [dict create] - set antipaths [list\ - src/doc/*\ - src/doc/include/*\ - src/PROJECT_LAYOUTS_*\ - ] - - #set antiglob_dir [list\ - # _ignore_*\ - #] - set antiglob_dir [list\ - ] - - #default antiglob_dir_core will stop .fossil* from being updated - which is generally desirable as these are likely to be customized + set antipaths [list {*}{ + src/doc/* + src/doc/include/* + src/PROJECT_LAYOUTS_* + }] + + #set exclude_dirsegments [list {*}{ + # _ignore_* + #}] + set exclude_dirsegments [list {*}{ + }] + + #default -exclude-dirsegments_core will stop .fossil* from being updated - which is generally desirable as these are likely to be customized if {$opt_force} { puts stdout "copying layout files - with force applied - overwrite all-targets" - set resultdict [punkcheck::install $layout_path $projectdir -installer project.new -createempty 1 -overwrite ALL-TARGETS -antiglob_paths $antipaths -antiglob_dir $antiglob_dir] + set resultdict [punkcheck::install $layout_path $projectdir -installer project.new -createempty 1 -overwrite ALL-TARGETS -antiglob_paths $antipaths -exclude-dirsegments $exclude_dirsegments] } else { puts stdout "copying layout files - (if source file changed)" - set resultdict [punkcheck::install $layout_path $projectdir -installer project.new -createempty 1 -overwrite installedsourcechanged-targets -antiglob_paths $antipaths -antiglob_dir $antiglob_dir] + set resultdict [punkcheck::install $layout_path $projectdir -installer project.new -createempty 1 -overwrite installedsourcechanged-targets -antiglob_paths $antipaths -exclude-dirsegments $exclude_dirsegments] } puts stdout [punkcheck::summarize_install_resultdict $resultdict] @@ -412,11 +412,11 @@ namespace eval punk::mix::commandset::project { #target folders .fossil-custom and .fossil-settings may not exist. use -createdir 1 to ensure existence. #In this case we need to override the default dir antiglob - as .fossil-xxx folders need to be installed from template if missing, or if target is uncustomized. - ## default_antiglob_dir_core [list "#*" "_aside" ".git" ".fossil*"] - set override_antiglob_dir_core [list #* _aside .git] + ## default_exclude_dirsegments_core [list "#*" "_aside" ".git" ".fossil*"] + set override_exclude_dirsegments_core [list #* _aside .git] if {[file exists $layout_path/.fossil-custom]} { puts stdout "copying layout src/.fossil-custom files (if target missing or uncustomised)" - set resultdict [punkcheck::install $layout_path/.fossil-custom $projectdir/.fossil-custom -createdir 1 -createempty 1 -punkcheck_folder $projectdir -installer project.new -antiglob_dir_core $override_antiglob_dir_core -overwrite SYNCED-TARGETS] + set resultdict [punkcheck::install $layout_path/.fossil-custom $projectdir/.fossil-custom -createdir 1 -createempty 1 -punkcheck_folder $projectdir -installer project.new -exclude-dirsegments_core $override_exclude_dirsegments_core -overwrite SYNCED-TARGETS] puts stdout [punkcheck::summarize_install_resultdict $resultdict] } else { puts stdout "no .fossil-custom in source template - update not required" @@ -424,7 +424,7 @@ namespace eval punk::mix::commandset::project { if {[file exists $layout_path/.fossil-settings]} { puts stdout "copying layout src/.fossil-settings files (if target missing or uncustomised)" - set resultdict [punkcheck::install $layout_path/.fossil-settings $projectdir/.fossil-settings -createdir 1 -createempty 1 -punkcheck_folder $projectdir -installer project.new -antiglob_dir_core $override_antiglob_dir_core -overwrite SYNCED-TARGETS] + set resultdict [punkcheck::install $layout_path/.fossil-settings $projectdir/.fossil-settings -createdir 1 -createempty 1 -punkcheck_folder $projectdir -installer project.new -exclude-dirsegments_core $override_exclude_dirsegments_core -overwrite SYNCED-TARGETS] puts stdout [punkcheck::summarize_install_resultdict $resultdict] } else { puts stdout "no .fossil-settings in source template - update not required" @@ -470,8 +470,8 @@ namespace eval punk::mix::commandset::project { if {[file exists $projectdir/src/modules]} { foreach m $opt_modules { #check if mod-ver.tm file or #modpod-mod-ver folder exist - set tmfile $projectdir/src/modules/$m-[punk::mix::util::magic_tm_version].tm - set podfile $projectdir/src/modules/#modpod-$m-[punk::mix::util::magic_tm_version]/$m-[punk::mix::util::magic_tm_version].tm + set tmfile $projectdir/src/modules/$m-[punk::mix::util::tm_version_magic].tm + set podfile $projectdir/src/modules/#modpod-$m-[punk::mix::util::tm_version_magic]/$m-[punk::mix::util::tm_version_magic].tm set has_tm [file exists $tmfile] set has_pod [file exists $podfile] diff --git a/src/vfs/_vfscommon.vfs/modules/punk/mix/util-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/punk/mix/util-0.1.0.tm index 7f55005b..8dbe8feb 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/mix/util-0.1.0.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/mix/util-0.1.0.tm @@ -367,7 +367,16 @@ namespace eval punk::mix::util { } #todo - semver conversion/validation for other systems? - proc magic_tm_version {} { + proc tm_version_magic {} { + #maintenance instruction: + # This specific 12 character nnnnnn.0a1.0 version number is used in text replacement when installing modules. + # It should not be modified without also considering the impact on existing projects based on punkshell that may have used this version number in their own code or documentation as a placeholder for tm version handling. + # A copy of this is also present in punk::lib to aid in dependency management. + # These 2 copies should be kept in sync. + # Essentially this should probably never be changed - and instead deprecated if we want to stop using it and replaced with a different mechanism/placeholder. + + #tm versioning is not quite the same as semantic versioning - but similarly we should see extremely high major version numbers rarely if ever in real use, + #even over decades of development. set magicbase 999999 ;#deliberately large so given load-preference when testing! #we split the literal to avoid the literal appearing here - reduce risk of accidentally converting to a release version return ${magicbase}.0a1.0 diff --git a/src/vfs/_vfscommon.vfs/modules/punk/ns-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/punk/ns-0.1.0.tm index 99981784..ad3cd57e 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/ns-0.1.0.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/ns-0.1.0.tm @@ -721,6 +721,22 @@ tcl::namespace::eval punk::ns { } + punk::args::define { + @id -id ::punk::ns::nstree_list + @cmd -name punk::ns::nstree_list\ + -summary\ + ""\ + -help\ + "" + @leaders + location -type path -optional 0 + @opts + -subnslist -type list -default {} -help\ + "" + -allbelow -type boolean -default 1 -help\ + "" + @values -min 0 -max 0 + } #important: add tests for tricky cases - e.g punk::m**::util vs punk::m*::util vs punk::m*::**::util - these should all be able to return different results depending on namespace structure. #e.g punk::m**::util will return punk::mix::util but punk::m*::**::util will not because punk::mix::util is too short to match. Both will return deeper matches such as: punk::mix::commandset::repo::util proc nstree_list {location args} { diff --git a/src/vfs/_vfscommon.vfs/modules/punk/path-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/punk/path-0.1.0.tm index b5593d12..4527dbb2 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/path-0.1.0.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/path-0.1.0.tm @@ -740,10 +740,10 @@ namespace eval punk::path { return $ismatch } punk::args::define { - @id -id ::punk::path::subfolders - @cmd -name punk::path::subfolders\ + @id -id ::punk::path::subfolders1 + @cmd -name punk::path::subfolders1\ -summary\ - "Listing of directories within supplied path."\ + "Listing of directories below supplied path."\ -help\ "List of folders below path. The resulting list is unsorted." @@ -771,20 +771,20 @@ namespace eval punk::path { (so should be written to match the same relative prefix if path is relative)" } - proc subfolders {args} { + proc subfolders1 {args} { #NOTE - this algorithm based on omit_only_patterns and prune_base_patterns was suggested by a 2026 AI model - it is apparent to this programmer that it is inadequate for the purpose. - #e.g consider subfolders -recursion -exclude {**/vfs/** **/src/**} + #e.g consider subfolders1 -recursion -exclude {**/vfs/** **/src/**} #This can still return something like c:/repo/etc/src/vfs - which should be excluded by the pattern **/src/** #todo - review and fix properly. - set argd [punk::args::parse $args withid ::punk::path::subfolders] + set argd [punk::args::parse $args withid ::punk::path::subfolders1] lassign [dict values $argd] leaders opts values received set do_recursion [dict exists $received -recursive] set exclude_paths [dict get $opts -exclude-paths] if {"**" in $exclude_paths} { #if ** is in exclude_paths - then we can skip all glob matching and just return empty list #This is likely user error - so we'll be loud about it for now but will still return empty list rather than erroring. - #If user code is building exclude_paths dynamically - they can check for this case themselves and avoid the call to subfolders to suppress this message. - puts stderr "punk::path::subfolders Warning - exclude_paths contains '**' - all paths will be excluded" + #If user code is building exclude_paths dynamically - they can check for this case themselves and avoid the call to subfolders1 to suppress this message. + puts stderr "punk::path::subfolders1 Warning - exclude_paths contains '**' - all paths will be excluded" return [list] } if {[dict exists $received path]} { @@ -806,49 +806,32 @@ namespace eval punk::path { # **/test/** - would exclude any path with test as a segment and all its subfolders #- but not paths with test as a segment that is the final segment - - set omit_only_patterns [list] - set prune_base_patterns [list] - foreach pat $exclude_paths { - set pat_parts [file split $pat] ;#note file split c:/test gives {c:/ test} but file split **/test gives {** test} - #also note that file split on windows treats forward slashes and backslashes the same. - #by using file split, we gain some flexibility in syntax of paths and patterns, - #but lose the ability to use backslashes as escapes to allow literal glob characters in path segments. - #This is almost always a non-issue on windows since * and ? are not valid in path segments there, and is rarely an issue on unix even though - # * and ? are technically valid in path segments, but it is inadvisable there anyway for compatibility with shells etc. - if {[llength $pat_parts] >= 2 && [lindex $pat_parts end] eq "**"} { - #** at end of pattern - e.g /dir/etc/** - #Convert ".../" to base "...", and prune descendants of that base. - lappend prune_base_patterns [file join {*}[lrange $pat_parts 0 end-1]] - } else { - lappend omit_only_patterns $pat - } - } - set folders [list] set recurse_subdirs [list] foreach f $all_subfolders { set include_in_results 1 set allow_recurse 1 - foreach pat $omit_only_patterns { - if {[globmatchpath $pat $f]} { - set include_in_results 0 - break - } - } - if {$allow_recurse && [llength $prune_base_patterns]} { - foreach base_pat $prune_base_patterns { - #prune both the matched base node and its decendants. - if {[globmatchpath $base_pat $f]} { - set allow_recurse 0 - break - } - if {[globmatchpath "${base_pat}/**" $f]} { + foreach pat $exclude_paths { + set pat_parts [file split $pat] ;#note file split c:/test gives {c:/ test} but file split **/test gives {** test} + #also note that file split on windows treats forward slashes and backslashes the same. + #by using file split, we gain some flexibility in syntax of paths and patterns, + #but lose the ability to use backslashes as escapes to allow literal glob characters in path segments. + #This is almost always a non-issue on windows since * and ? are not valid in path segments there, and is rarely an issue on unix even though + # * and ? are technically valid in path segments, but it is inadvisable there anyway for compatibility with shells etc. + if {[llength $pat_parts] >= 2 && [lindex $pat_parts end] eq "**"} { + set base_pat [file join {*}[lrange $pat_parts 0 end-1]] + if {[globmatchpath $pat $f]} { set include_in_results 0 set allow_recurse 0 - break + } elseif {[globmatchpath $base_pat $f]} { + set allow_recurse 0 } + } elseif {[globmatchpath $pat $f]} { + set include_in_results 0 + } + if {!$include_in_results && !$allow_recurse} { + break } } if {$include_in_results} { @@ -860,392 +843,586 @@ namespace eval punk::path { } if {$do_recursion} { foreach subdir $recurse_subdirs { - lappend folders {*}[subfolders -exclude-paths $exclude_paths -recursive $subdir] + lappend folders {*}[subfolders1 -exclude-paths $exclude_paths -recursive $subdir] } } - - #if {[llength $exclude_paths]} { - # set folders [list] - # foreach f $all_subfolders { - # set skip 0 - # foreach pat $exclude_paths { - # #review - this is slightly too simplistic. - # # for exclusion pattern **/dirname - # # this will exclude any path with dirname as final segment - but it will also exclude any path with dirname as a segment anywhere in the path - which is not intended. - # #puts stderr "Checking exclude pat '$pat' against '$f'" - # if {[globmatchpath $pat $f]} { - # set skip 1 - # break - # } - # } - # if {!$skip} { - # lappend folders $f - # } - # } - #} else { - # set folders $all_subfolders - #} - #if {$do_recursion} { - # foreach subdir $folders { - # lappend folders {*}[subfolders -exclude-paths $exclude_paths -recursive $subdir] - # } - #} return $folders } - #todo - treefolders with similar search caps as treefilenames + namespace eval subfolder_priv { + proc classify_exclude_pattern {pat} { + set parts [file split $pat] + if {[llength $parts] >= 2 && [lindex $parts end] eq "**"} { + set boundary_pat [file join {*}[lrange $parts 0 end-1]] + return [dict create \ + pattern $pat \ + kind subtree \ + boundary_pat $boundary_pat \ + descend_pat $pat] + } + if {[llength $parts] >= 2 && [lindex $parts end] eq "*"} { + return [dict create \ + pattern $pat \ + kind child_only \ + match_pat $pat] + } + return [dict create \ + pattern $pat \ + kind exact \ + match_pat $pat] + } + + proc compile_exclude_rules {exclude_paths} { + set rules [list] + foreach pat $exclude_paths { + lappend rules [classify_exclude_pattern $pat] + } + return $rules + } + + proc match_rule_at_node {rule path} { + set kind [dict get $rule kind] + switch -- $kind { + exact - child_only { + if {[::punk::path::globmatchpath [dict get $rule match_pat] $path]} { + return [dict create include_current 0 recurse_below 1 child_rules [list $rule]] + } + return [dict create include_current 1 recurse_below 1 child_rules [list $rule]] + } + subtree { + set descend_pat [dict get $rule descend_pat] + set boundary_pat [dict get $rule boundary_pat] + if {[::punk::path::globmatchpath $descend_pat $path]} { + return [dict create include_current 0 recurse_below 0 child_rules [list]] + } + if {[::punk::path::globmatchpath $boundary_pat $path]} { + return [dict create include_current 1 recurse_below 0 child_rules [list]] + } + return [dict create include_current 1 recurse_below 1 child_rules [list $rule]] + } + default { + error "Unknown exclude rule kind '$kind'" + } + } + } + + proc walk_subfolders {path rules do_recursion} { + set all_subfolders [glob -nocomplain -directory $path -types d *] + set folders [list] + foreach f $all_subfolders { + set include_current 1 + set recurse_below $do_recursion + set child_rules [list] + foreach rule $rules { + set outcome [match_rule_at_node $rule $f] + if {![dict get $outcome include_current]} { + set include_current 0 + } + if {![dict get $outcome recurse_below]} { + set recurse_below 0 + } + if {$do_recursion} { + lappend child_rules {*}[dict get $outcome child_rules] + } + if {!$include_current && !$recurse_below} { + break + } + } + if {$include_current} { + lappend folders $f + } + if {$do_recursion && $recurse_below} { + lappend folders {*}[walk_subfolders $f $child_rules $do_recursion] + } + } + return $folders + } + } punk::args::define { - @id -id ::punk::path::treefilenames - @cmd -name punk::path::treefilenames\ + @id -id ::punk::path::subfolders + @cmd -name punk::path::subfolders\ -summary\ - "List of filenames below supplied path."\ + "Listing of directories below supplied path."\ -help\ - "List of filenames below path. - The resulting list is unsorted." - -directory -type directory -help\ - "folder in which to begin recursive scan for files." - -call-depth-internal -default 0 -type integer -help "internal use only - caller should not specify - used to track depth of recursive calls for internal logic" - -call-subvector -default {} -type list -help "internal use only - caller should not specify - used to track path vector of recursive calls for internal logic" - -call-allbelow -default 1 -type boolean -help "internal use only - caller should not specify - used to track whether we are in a subtree below a match for glob_paths (which means we can skip glob matching and antiglob_paths checks and just include all files below here)" - -sort -type any -default natural -choices {none ascii dictionary natural} - -antiglob_paths -default {} -help\ - "list of path patterns to exclude - may include * and ** path segments e.g - /usr/** (exclude subfolders based at /usr but not - files within /usr itself) - **/_aside (exclude files where _aside is last segment) - **/_aside/* (exclude folders one below an _aside folder) - **/_aside/** (exclude all folders with _aside as a segment)" - -antiglob_files -default {} - -glob_paths -default {*} -help\ - "list of path patterns to include - may include * and ** path segments e.g - /usr/** (include subfolders based at /usr but not - files within /usr itself) - **/_aside (include files where _aside is last segment) - **/_aside/* (include folders one below an _aside folder) - **/_aside/** (include all folders with _aside as a segment)" - @values -min 0 -max -1 -optional 1 -type string - tailglobs -default * -multiple 1 -help\ - "Patterns to match against filename portion (last segment) of each file path - within the directory tree being searched." - } + "List of folders below path. + The resulting list is unsorted. + " + @opts + -recursive -type none -help\ + "" + -exclude-paths -type list -default {} -help\ + "list of path patterns to exclude from results. + May include * and ** path segments e.g /usr/** + A single /*/ will match any single segment in the path, and a single /**/ will match any number of segments in the path. - #todo - implement treefiles which acts like dirfiles but allows path globbing in the same way as punk::ns::ns/ - #then review if treefiles can replace dirfiles or if both should exist (dirfiles can have literal glob chars in path segments - but that is a rare usecase) - proc treefilenames {args} { - #*** !doctools - #[call [fun treefilenames] [opt {option value...}] [opt {globpattern...}]] - #[para]basic (glob based) list of filenames matching each pattern in tailglobs - recursive - #[para] options: - #[para] [opt -dir] - #[para] defaults to [lb]pwd[rb] - base path for tree to search - #[para] [opt -antiglob_paths] - #[para] list of path patterns to exclude - may include * and ** path segments e.g /usr/** - #[para]no natsorting - so order is dependent on filesystem + e.g to exclude any path with _aside as a segment in the middle: -exclude-paths **/_aside/** + i.e this would exclude /usr/_aside/etc and /usr/x/_aside/etc but not /usr/x/_aside or _aside/etc - set argd [punk::args::parse $args withid ::punk::path::treefilenames] + To exclude all paths with _aside as a segment anywhere: -exclude-paths { **/_aside/** **/_aside ./_aside/**} + " + #todo -depth + @values -min 0 -max 1 + path -type directory -optional 1 -help\ + "Path of base folder. If not supplied current directory is used. + This may be a relative or absolute path. Relative paths are treated as relative to current directory. + When using relative paths - the result will also be relative paths with the same relative prefix. + (e.g if path is ../test - the results will be ../test/subfolder1 ../test/subfolder2 etc) + Patterns in -exclude-paths are matched against the resulting paths + (so should be written to match the same relative prefix if path is relative)" + } + + proc subfolders {args} { + set argd [punk::args::parse $args withid ::punk::path::subfolders] lassign [dict values $argd] leaders opts values received - set tailglobs [dict get $values tailglobs] - # -- --- --- --- --- --- --- - set opt_sort [dict get $opts -sort] - set opt_antiglob_paths [dict get $opts -antiglob_paths] - set opt_glob_paths [dict get $opts -glob_paths] - set opt_antiglob_files [dict get $opts -antiglob_files] - - set CALLDEPTH [dict get $opts -call-depth-internal] - set callsubvector [dict get $opts -call-subvector] - set callallbelow [dict get $opts -call-allbelow] ;#whether to return matches longer than the matched glob-path - # -- --- --- --- --- --- --- - # -- --- --- --- --- --- --- - if {"*" in $opt_glob_paths} { - #if we have a * in the default glob_paths - then any other entries are redundant. - set opt_glob_paths {*} + set do_recursion [dict exists $received -recursive] + set exclude_paths [dict get $opts -exclude-paths] + if {"**" in $exclude_paths} { + puts stderr "punk::path::subfolders Warning - exclude_paths contains '**' - all paths will be excluded" + return [list] } + if {[dict exists $received path]} { + set path [dict get $values path] + } else { + set path [pwd] + } + set compiled_rules [subfolder_priv::compile_exclude_rules $exclude_paths] + return [subfolder_priv::walk_subfolders $path $compiled_rules $do_recursion] + } - set files [list] - if {$CALLDEPTH == 0} { - if {$opt_sort eq "natural"} { - package require natsort - } - #set opts [dict merge $opts [list -directory $opt_dir]] - if {[dict exists $received -directory]} { - set opt_dir [dict get $opts -directory] - } else { - - set opt_dir [pwd] + namespace eval treefile_priv { + proc _pattern_prefix_viable_parts {pattern_parts path_parts} { + if {![llength $path_parts]} { + return 1 } - if {![file isdirectory $opt_dir]} { - return [list] + if {![llength $pattern_parts]} { + return 0 } + set pattern_head [lindex $pattern_parts 0] + set path_head [lindex $path_parts 0] - } else { - #assume/require to exist in any recursive call - set opt_dir [dict get $opts -directory] + if {$pattern_head eq "**"} { + if {[_pattern_prefix_viable_parts [lrange $pattern_parts 1 end] $path_parts]} { + return 1 + } + return [_pattern_prefix_viable_parts $pattern_parts [lrange $path_parts 1 end]] + } + + if {[::punk::path::globmatchpath $pattern_head $path_head]} { + return [_pattern_prefix_viable_parts [lrange $pattern_parts 1 end] [lrange $path_parts 1 end]] + } + return 0 } - #comment out to compare timings with treefilenames_zipfs - if {[string match //zipfs:/* $opt_dir]} { - return [treefilenames_zipfs {*}$args] + proc pattern_prefix_viable {pattern path} { + return [_pattern_prefix_viable_parts [file split $pattern] [file split $path]] } - set skip 0 - foreach anti $opt_antiglob_paths { - if {[globmatchpath $anti $opt_dir]} { - set skip 1 - break + proc pattern_boundary {pattern} { + set parts [file split $pattern] + if {[llength $parts] >= 2 && [lindex $parts end] eq "**"} { + return [file join {*}[lrange $parts 0 end-1]] } - } - if {$skip} { - return [list] + return "" } - #todo - account for vfs where matched path could appear to be a directory but is mounted so could be a desired match? - if {[catch {glob -nocomplain -dir $opt_dir -type f {*}$tailglobs} matches]} { - #we can get for example a permissions error - puts stderr "treefilenames error while listing files in dir $opt_dir\n $matches" - set dirfiles [list] - } else { - set retained [list] - if {[llength $opt_antiglob_files]} { - foreach m $matches { - set skip 0 - set ftail [file tail $m] - foreach anti $opt_antiglob_files { - if {[string match $anti $ftail]} { - set skip 1; break - } - } - if {!$skip} { - lappend retained $m + proc directory_state {glob_paths path inherited_allbelow} { + if {$inherited_allbelow} { + return [dict create include_files 1 recurse_below 1 next_allbelow 1] + } + + set include_files 0 + set recurse_below 0 + set next_allbelow 0 + + foreach gp $glob_paths { + if {[::punk::path::globmatchpath $gp $path]} { + set include_files 1 + set recurse_below 1 + set next_allbelow 1 + break + } + + set boundary [pattern_boundary $gp] + if {$boundary ne "" && [::punk::path::globmatchpath $boundary $path]} { + set recurse_below 1 + set next_allbelow 1 + continue + } + + if {[pattern_prefix_viable $gp $path]} { + set recurse_below 1 + } + } + + return [dict create {*}{ + } include_files $include_files {*}{ + } recurse_below $recurse_below {*}{ + } next_allbelow $next_allbelow {*}{ } + ] + } + + proc child_path_state {glob_paths child_path inherited_allbelow} { + if {$inherited_allbelow} { + return 1 + } + foreach gp $glob_paths { + if {[pattern_prefix_viable $gp $child_path]} { + return 1 } - } else { - set retained $matches } - switch -- $opt_sort { + return 0 + } + + proc _sort_paths {paths sortmode} { + switch -- $sortmode { ascii { - set dirfiles [lsort $retained] + return [lsort $paths] } dictionary { - set dirfiles [lsort -dictionary $retained] + return [lsort -dictionary $paths] } natural { - set dirfiles [natsort::sort $retained] + return [natsort::sort $paths] } default { - set dirfiles $retained + return $paths } } } - lappend files {*}$dirfiles - if {[catch {glob -nocomplain -dir $opt_dir -type d *} dirdirs]} { - puts stderr "treefilenames error while listing subdirs in dir $opt_dir\n $dirdirs" - set dirdirs [list] - } - set okdirs [list] - foreach dir $dirdirs { - set skip 0 - foreach anti $opt_antiglob_paths { - if {[globmatchpath $anti $dir]} { - set skip 1 - break + proc _path_matches_any {patterns path} { + foreach pattern $patterns { + if {[::punk::path::globmatchpath $pattern $path]} { + return 1 } } - if {!$skip} { - lappend okdirs $dir + return 0 + } + + proc _tailbase_relative {tailbase path} { + if {$tailbase eq ""} { + return $path } + return [::punk::path::relative $tailbase $path] } - if {$opt_glob_paths eq {*}} { - set matchdirs $okdirs - } else { - #** only significant when it is the trailing part of a segment eg /**/xxx /a**/xxx + proc _tailbase_match_path {tailbase path} { + set match_path [_tailbase_relative $tailbase $path] + if {$match_path eq "."} { + return "" + } + return $match_path + } + proc _tailbase_relative_list {tailbase paths} { + if {$tailbase eq ""} { + return $paths + } + set relative_paths [list] + foreach path $paths { + lappend relative_paths [_tailbase_relative $tailbase $path] + } + return $relative_paths + } - set matchdirs [list] - foreach dir $okdirs { - foreach gp $opt_glob_paths { - if {[globmatchpath $gp $dir] || [globmatchpath "$gp/**" $dir]} { - lappend matchdirs $dir + proc _retain_files {matches exclude_files sortmode} { + set retained [list] + foreach match $matches { + set skip 0 + set file_tail [file tail $match] + foreach anti $exclude_files { + if {[string match $anti $file_tail]} { + set skip 1 + break } } + if {!$skip} { + lappend retained $match + } } + return [_sort_paths $retained $sortmode] } - if {[llength $matchdirs]} { - switch -- $opt_sort { - ascii { - set finaldirs [lsort $matchdirs] + + proc _state_from_argd {argd} { + set opts [dict get $argd opts] + set values [dict get $argd values] + set received [dict get $argd received] + + if {[dict exists $received -directory]} { + set directory [dict get $opts -directory] + } else { + set directory [pwd] + } + + set glob_paths [dict get $opts -include-paths] + if {"*" in $glob_paths} { + set glob_paths {*} + } + + set sortmode [dict get $opts -sort] + if {$sortmode eq "natural"} { + package require natsort + } + + return [dict create {*}{ + depth 0 + subvector {} + allbelow 0 + } sort $sortmode {*}{ + } directory $directory {*}{ + } tailbase [dict get $opts -tailbase] {*}{ + } exclude_paths [dict get $opts -exclude-paths] {*}{ + } exclude_files [dict get $opts -exclude-files] {*}{ + } glob_paths $glob_paths {*}{ + } tailglobs [dict get $values tailglobs] {*}{ } - dictionary { - set finaldirs [lsort -dictionary $matchdirs] + ] + } + + proc walk_treefilenames {state} { + set opt_dir [dict get $state directory] + set opt_tailbase [dict get $state tailbase] + set depth [dict get $state depth] + set subvector [dict get $state subvector] + set callallbelow [dict get $state allbelow] + set opt_sort [dict get $state sort] + set opt_exclude_paths [dict get $state exclude_paths] + set opt_exclude_files [dict get $state exclude_files] + set opt_glob_paths [dict get $state glob_paths] + set tailglobs [dict get $state tailglobs] + + if {![file isdirectory $opt_dir]} { + return [list] + } + if {[string match //zipfs:/* $opt_dir]} { + return [walk_treefilenames_zipfs $state] + } + set opt_dir_match [_tailbase_match_path $opt_tailbase $opt_dir] + if {[_path_matches_any $opt_exclude_paths $opt_dir_match]} { + return [list] + } + + set files [list] + set dir_state [directory_state $opt_glob_paths $opt_dir_match $callallbelow] + if {[dict get $dir_state include_files]} { + if {[catch {glob -nocomplain -dir $opt_dir -type f {*}$tailglobs} matches]} { + puts stderr "treefilenames error while listing files in dir $opt_dir\n $matches" + set dirfiles [list] + } else { + set dirfiles [_retain_files $matches $opt_exclude_files $opt_sort] } - natural { - set finaldirs [natsort::sort $matchdirs] + lappend files {*}[_tailbase_relative_list $opt_tailbase $dirfiles] + } + + if {![dict get $dir_state recurse_below]} { + return $files + } + + if {[catch {glob -nocomplain -dir $opt_dir -type d *} dirdirs]} { + puts stderr "treefilenames error while listing subdirs in dir $opt_dir\n $dirdirs" + set dirdirs [list] + } + set okdirs [list] + foreach dir $dirdirs { + if {![_path_matches_any $opt_exclude_paths [_tailbase_match_path $opt_tailbase $dir]]} { + lappend okdirs $dir } - default { - set finaldirs $matchdirs + } + + if {$opt_glob_paths eq "*"} { + set matchdirs $okdirs + } else { + set matchdirs [list] + foreach dir $okdirs { + if {$callallbelow || [child_path_state $opt_glob_paths [_tailbase_match_path $opt_tailbase $dir] $callallbelow]} { + lappend matchdirs $dir + } } } + + set finaldirs [_sort_paths $matchdirs $opt_sort] + set childallbelow [expr {$callallbelow || [dict get $dir_state next_allbelow]}] + set nextsubvector [list {*}$subvector [file tail $opt_dir]] foreach dir $finaldirs { - set nextopts [dict merge $opts [list -directory $dir -call-depth-internal [incr CALLDEPTH]]] - lappend files {*}[treefilenames {*}$nextopts {*}$tailglobs] + set child_state [dict merge $state [dict create {*}{} \ + directory $dir \ + depth [expr {$depth + 1}] \ + subvector $nextsubvector \ + allbelow $childallbelow]] + lappend files {*}[walk_treefilenames $child_state] } + return $files } - return $files - } - proc treefilenames_zipfs {args} { - #seems to be 2 or 3 times faster than treefilenames for //zipfs:/ paths - REVIEW - # is sort order the same? - set argd [punk::args::parse $args withid ::punk::path::treefilenames] - lassign [dict values $argd] leaders opts values received - set tailglobs [dict get $values tailglobs] - # -- --- --- --- --- --- --- - set opt_antiglob_paths [dict get $opts -antiglob_paths] - set opt_antiglob_files [dict get $opts -antiglob_files] - set opt_sort [dict get $opts -sort] - set CALLDEPTH [dict get $opts -call-depth-internal] - # -- --- --- --- --- --- --- - # -- --- --- --- --- --- --- - - set files [list] - if {$CALLDEPTH == 0} { - if {$opt_sort eq "natural"} { - package require natsort - } - #set opts [dict merge $opts [list -directory $opt_dir]] - if {![dict exists $received -directory]} { - set opt_dir [pwd] - } else { - set opt_dir [dict get $opts -directory] + + proc walk_treefilenames_zipfs {state} { + set opt_dir [dict get $state directory] + set opt_tailbase [dict get $state tailbase] + set opt_exclude_paths [dict get $state exclude_paths] + set opt_exclude_files [dict get $state exclude_files] + set opt_glob_paths [dict get $state glob_paths] + set opt_sort [dict get $state sort] + set tailglobs [dict get $state tailglobs] + + if {![string match [zipfs root]* $opt_dir]} { + error "treefilenames_zipfs can only be used on paths beginning with [zipfs root] on this systems" } - if {![file isdirectory $opt_dir]} { + set dir [string trimright $opt_dir "/"] + if {[_path_matches_any $opt_exclude_paths [_tailbase_match_path $opt_tailbase $dir]]} { return [list] } - } else { - #assume/require to exist in any recursive call - set opt_dir [dict get $opts -directory] - } - if {![string match [zipfs root]* $opt_dir]} { - error "treefilenames_zipfs can only be used on paths beginning with [zipfs root] on this systems" - } - set dir [string trimright $opt_dir "/"] ;#e.g normalize //zipfs:/x/ to //zipfs:/x - set dirlen [string length $dir] - - set skip 0 - foreach anti $opt_antiglob_paths { - if {[globmatchpath $anti $dir]} { - set skip 1 - break - } - } - if {$skip} { - return [list] - } - set subpaths [zipfs list $dir/*] - set dirlist [list] - set skipdirs [list] - set filelist [list] - #process in the order they came - sorting large list more expensive?? review - foreach sub $subpaths { - set tail [string range $sub $dirlen+1 end] ;#dirlen is without trailing slash - set tailparts [file split $tail] - set accum "" - set skipdir 0 - foreach tp [lrange $tailparts 0 end-1] { - append accum "/$tp" - set superpath "${dir}${accum}" - if {$superpath in $skipdirs} { - #subpart already in skipdirs - set skipdir 1 - break - } - if {$superpath ni $dirlist} { - set skip2 0 - foreach anti $opt_antiglob_paths { - if {[globmatchpath $anti $superpath]} { - set skip2 1 + set dirlen [string length $dir] + set subpaths [zipfs list $dir/*] + set dirlist [list] + set skipdirs [list] + set filelist [list] + foreach sub $subpaths { + set tail [string range $sub $dirlen+1 end] + set tailparts [file split $tail] + set accum "" + set skipdir 0 + foreach tailpart [lrange $tailparts 0 end-1] { + append accum "/$tailpart" + set superpath "${dir}${accum}" + if {$superpath in $skipdirs} { + set skipdir 1 + break + } + if {$superpath ni $dirlist} { + if {[_path_matches_any $opt_exclude_paths [_tailbase_match_path $opt_tailbase $superpath]]} { lappend skipdirs $superpath + set skipdir 1 break + } else { + lappend dirlist $superpath } } - if {!$skip2} { - lappend dirlist $superpath - } else { - set skipdir 1 - break - } } - } - if {!$skipdir} { - #process final part of path - append accum "/[lindex $tailparts end]" - set finalpart "${dir}${accum}" - if {$finalpart ni $dirlist} { - if {[file type $finalpart] eq "file"} { - set ftail [lindex $tailparts end] - set match 0 - if {"*" ni $tailglobs} { - foreach tg $tailglobs { - if {[string match $tg $ftail]} { - set match 1 - break + if {!$skipdir} { + append accum "/[lindex $tailparts end]" + set finalpart "${dir}${accum}" + if {$finalpart ni $dirlist} { + if {[file type $finalpart] eq "file"} { + set file_tail [lindex $tailparts end] + set match 0 + if {"*" ni $tailglobs} { + foreach tailglob $tailglobs { + if {[string match $tailglob $file_tail]} { + set match 1 + break + } } + } else { + set match 1 } - } else { - set match 1 - } - if {$match} { - if {[llength $opt_antiglob_files]} { + if {$match} { + if {$opt_glob_paths ne "*"} { + set file_dir_match [_tailbase_match_path $opt_tailbase [file dirname $finalpart]] + set file_dir_state [directory_state $opt_glob_paths $file_dir_match 0] + set match [dict get $file_dir_state include_files] + } + } + if {$match} { set skipfile 0 - foreach anti $opt_antiglob_files { - if {[string match $anti $ftail]} { - set skipfile 1; break + foreach anti $opt_exclude_files { + if {[string match $anti $file_tail]} { + set skipfile 1 + break } } if {!$skipfile} { - lappend filelist $finalpart + lappend filelist [_tailbase_relative $opt_tailbase $finalpart] } - } else { - lappend filelist $finalpart } - } - } else { - if {$finalpart ni $dirlist} { - set skip2 0 - foreach anti $opt_antiglob_paths { - if {[globmatchpath $anti $finalpart]} { - set skip2 1 + } else { + if {$finalpart ni $dirlist} { + if {[_path_matches_any $opt_exclude_paths [_tailbase_match_path $opt_tailbase $finalpart]]} { lappend skipdirs $finalpart - break + } else { + lappend dirlist $finalpart } } - if {!$skip2} { - lappend dirlist $finalpart - } } } } } + return [_sort_paths $filelist $opt_sort] } - switch -- $opt_sort { - ascii { - set finalfilelist [lsort $filelist] - } - dictionary { - set finalfilelist [lsort -dictionary $filelist] - } - natural { - set finalfilelist [natsort::sort $filelist] - } - default { - set finalfilelist $filelist - } + } + + #todo - treefolders with similar search caps as treefilenames + + punk::args::define { + @id -id ::punk::path::treefilenames + @cmd -name punk::path::treefilenames\ + -summary\ + "List of filenames below supplied path."\ + -help\ + "List of filenames below path. + The resulting list is unsorted. + + The path globbing syntax supports *, ** and ? as glob characters in any segment of the path, with the following semantics: + * matches any single segment in the path + ** matches 1 or more segments in the path (so /usr/**/bin will match /usr/x/bin and user/x/y/bin but not /usr/bin ) + ? matches any single character in a single segment of the path (so /usr/te?t will match /usr/test and /usr/text but not /usr/texxt) + " + -directory -type directory -help\ + "folder in which to begin recursive scan for files." + -tailbase -type string -default "" -help\ + "if supplied, only the relative path compared to the tailbase will be returned for each file. + So if tailbase is /usr and a file is found at /usr/x/y/file.txt, the returned path for that file would be x/y/file.txt. + If tailbase is not supplied, the full path to each file will be returned. + + If tailbase is supplied, it should be a prefix of the directory supplied (or the directory itself) + The patterns in -exclude-paths should be written to match the returned paths (i.e with the tailbase prefix removed) if -tailbase is supplied. + If the tailbase is not a prefix of the directory supplied, the resulting paths may have /../ components in them to account for the difference, + but the behaviour is not well defined in this case and it is recommended to ensure tailbase is a prefix of the directory supplied if using -tailbase. + + see: punk::path::relative to compute relative paths + " + -sort -type any -default natural -choices {none ascii dictionary natural} + -exclude-paths -default {} -help\ + "list of path patterns to exclude + may include * and ** path segments e.g + /usr/** (exclude subfolders based at /usr but not + files within /usr itself) + **/_aside (exclude files where _aside is last segment) + **/_aside/* (exclude folders one below an _aside folder) + **/_aside/** (exclude files in all folders with _aside as a segment)" + -exclude-files -default {} + -include-paths -default {**} -help\ + "list of path patterns to include + may include * and ** path segments e.g + /usr/** (include files in subfolders based at /usr but not + files within /usr itself) + **/_aside (include files where _aside is last segment in the folder) + **/_aside/* (include files in folders one below an _aside folder) + **/_aside/** (include all files in folders with _aside as a segment)" + @values -min 0 -max -1 -optional 1 -type string + tailglobs -default * -multiple 1 -help\ + "Patterns to match against filename portion (last segment) of each file path + within the directory tree being searched." + } + + #todo - implement treefiles which acts like dirfiles but allows path globbing in the same way as punk::ns::ns/ + #then review if treefiles can replace dirfiles or if both should exist (dirfiles can have literal glob chars in path segments - but that is a rare usecase) + proc treefilenames {args} { + set argd [punk::args::parse $args withid ::punk::path::treefilenames] + set state [treefile_priv::_state_from_argd $argd] + return [treefile_priv::walk_treefilenames $state] + } + punk::args::set_idalias ::punk::path::treefilenames_zipfs ::punk::path::treefilenames + proc treefilenames_zipfs {args} { + #seems to be 2 or 3 times faster than treefilenames for //zipfs:/ paths - REVIEW + # is sort order the same? + set argd [punk::args::parse $args withid ::punk::path::treefilenames] + set state [treefile_priv::_state_from_argd $argd] + if {![file isdirectory [dict get $state directory]]} { + return [list] } - return $finalfilelist + return [treefile_priv::walk_treefilenames_zipfs $state] } #maint warning - also in punkcheck diff --git a/src/vfs/_vfscommon.vfs/modules/punkcheck-0.1.1.tm b/src/vfs/_vfscommon.vfs/modules/punkcheck-0.1.1.tm index c44f5b71..bdff666e 100644 --- a/src/vfs/_vfscommon.vfs/modules/punkcheck-0.1.1.tm +++ b/src/vfs/_vfscommon.vfs/modules/punkcheck-0.1.1.tm @@ -41,9 +41,9 @@ namespace eval punkcheck { summarize_install_resultdict } - #antiglob_dir & antiglob_file entries match the pattern at any level - should not contain path separators - variable default_antiglob_dir_core [list "#*" "_aside" "_build" ".git" ".fossil*"] - variable default_antiglob_file_core "" + #exclude-dir & exclude-file entries match the pattern at any level - should not contain path separators + variable default_excludedirseg_core [list "#*" "_aside" "_build" ".git" ".fossil*"] + variable default_excludefiletail_core "" set has_twapi 0 if {"windows" eq $::tcl_platform(platform)} { @@ -56,16 +56,16 @@ namespace eval punkcheck { interp alias "" ::punkcheck::uuid "" ::uuid::uuid generate } - proc default_antiglob_dir_core {} { - variable default_antiglob_dir_core - return $default_antiglob_dir_core + proc default_excludedirseg_core {} { + variable default_excludedirseg_core + return $default_excludedirseg_core } - proc default_antiglob_file_core {} { - variable default_antiglob_file_core - if {$default_antiglob_file_core eq ""} { - set default_antiglob_file_core [list "*.swp" "*[punk::mix::util::magic_tm_version]*" "*-buildversion.txt" ".punkcheck"] + proc default_excludefiletail_core {} { + variable default_excludefiletail_core + if {$default_excludefiletail_core eq ""} { + set default_excludefiletail_core [list "*.swp" "*[punk::mix::util::tm_version_magic]*" "*-buildversion.txt" ".punkcheck"] } - return $default_antiglob_file_core + return $default_excludefiletail_core } @@ -1268,7 +1268,7 @@ namespace eval punkcheck { set defaults [list {*}{ -glob *.tm -installer punkcheck::install_tm_files - } -antiglob_file [list "*[punk::mix::util::magic_tm_version]*"] {*}{ + } -exclude-filetails [list "*[punk::mix::util::tm_version_magic]*"] {*}{ } ] set opts [dict merge $defaults $args] @@ -1276,18 +1276,17 @@ namespace eval punkcheck { } proc install_non_tm_files {srcdir basedir args} { #set keys [dict keys $args] - #adjust the default antiglob_dir_core entries so that .fossil-custom, .fossil-settings are copied - set antiglob_dir_core [punkcheck::default_antiglob_dir_core] - set posn [lsearch $antiglob_dir_core ".fossil*"] + #adjust the default excludedirseg_core entries so that .fossil-custom, .fossil-settings are copied + set excludedirseg_core [punkcheck::default_excludedirseg_core] + set posn [lsearch $excludedirseg_core ".fossil*"] if {$posn >=0} { - #set antiglob_dir_core [lreplace $antiglob_dir_core $posn $posn] - set antiglob_dir_core [lreplace $antiglob_dir_core[set antiglob_dir_core {}] $posn $posn] + ledit excludedirseg_core $posn $posn } set defaults [list {*}{ - } -glob * {*}{ - } -antiglob_file [list "*.tm" "*-buildversion.txt" "*.exe"] {*}{ - } -antiglob_dir_core $antiglob_dir_core {*}{ - } -installer punkcheck::install_non_tm_files {*}{ + } -glob * {*}{ + } -exclude-filetails [list "*.tm" "*-buildversion.txt" "*.exe"] {*}{ + } -exclude-dirsegments_core $excludedirseg_core {*}{ + } -installer punkcheck::install_non_tm_files {*}{ } ] set opts [dict merge $defaults $args] @@ -1334,10 +1333,10 @@ namespace eval punkcheck { "Whether to create folders at target that had no matches for our glob" -glob -type string -default "*" -help\ "Pattern matching for source file(s) to copy. Can be glob based or exact match." - -antiglob_file_core -default {${[::punkcheck::default_antiglob_file_core]}} - -antiglob_file -default "" - -antiglob_dir_core -default {${[::punkcheck::default_antiglob_dir_core]}} - -antiglob_dir -default "" + -exclude-filetails_core -default {${[::punkcheck::default_excludefiltail_core]}} + -exclude-filetails -default "" + -exclude-dirsegments_core -default {${[::punkcheck::default_excludedirseg_core]}} + -exclude-dirsegments -default "" -antiglob_paths -default {} -overwrite -default no-targets\ -choices {no-targets newer-targets older-targets all-targets installedsourcechanged-targets synced-targets}\ @@ -1417,10 +1416,10 @@ namespace eval punkcheck { -createdir 0 -createempty 0 -glob * - -antiglob_file_core "\uFFFF" - -antiglob_file "" - -antiglob_dir_core "\uFFFF" - -antiglob_dir {} + -exclude-filetails_core "\uFFFF" + -exclude-filetails "" + -exclude-dirsegments_core "\uFFFF" + -exclude-dirsegments {} -antiglob_paths {} -overwrite no-targets -source_checksum comparestore @@ -1475,31 +1474,31 @@ namespace eval punkcheck { #now the values we build from these will be properly cased } # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- - set opt_antiglob_file_core [dict get $opts -antiglob_file_core] - if {$opt_antiglob_file_core eq "\uFFFF"} { - set opt_antiglob_file_core [default_antiglob_file_core] - dict set opts -antiglob_file_core $opt_antiglob_file_core + set opt_excludefiletail_core [dict get $opts -exclude-filetails_core] + if {$opt_excludefiletail_core eq "\uFFFF"} { + set opt_excludefiletail_core [default_excludefiletail_core] + dict set opts -exclude-filetails_core $opt_excludefiletail_core } # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- - set opt_antiglob_file [dict get $opts -antiglob_file] + set opt_excludefiletail [dict get $opts -exclude-filetails] #validate no path seps - foreach af $opt_antiglob_file { + foreach af $opt_excludefiletail { if {[llength [file split $af]] > 1} { - error "punkcheck::install received invalid -antiglob_file entry '$af'. -antiglob_file entries are meant to match to a file name at any level so cannot contain path separators" + error "punkcheck::install received invalid -exclude-filetails entry '$af'. -exclude-filetails entries are meant to match to a file name at any level so cannot contain path separators" } } # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- - set opt_antiglob_dir_core [dict get $opts -antiglob_dir_core] - if {$opt_antiglob_dir_core eq "\uFFFF"} { - set opt_antiglob_dir_core [default_antiglob_dir_core] - dict set opts -antiglob_dir_core $opt_antiglob_dir_core + set opt_excludedirseg_core [dict get $opts -exclude-dirsegments_core] + if {$opt_excludedirseg_core eq "\uFFFF"} { + set opt_excludedirseg_core [default_excludedirseg_core] + dict set opts -exclude-dirsegments_core $opt_excludedirseg_core } # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- - set opt_antiglob_dir [dict get $opts -antiglob_dir] + set opt_excludedirseg [dict get $opts -exclude-dirsegments] #validate no path seps - foreach ad $opt_antiglob_dir { + foreach ad $opt_excludedirseg { if {[llength [file split $ad]] > 1} { - error "punkcheck::install received invalid -antiglob_dir entry '$ad'. -antiglob_dir entries are meant to match to a directory name at any level so cannot contain path separators" + error "punkcheck::install received invalid -exclude-dirsegments entry '$ad'. -exclude-dirsegments entries are meant to match to a directory name at any level so cannot contain path separators" } } # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- @@ -1655,7 +1654,7 @@ namespace eval punkcheck { set match_list [list] foreach m $candidate_list { set suppress 0 - foreach anti [concat $opt_antiglob_file_core $opt_antiglob_file] { + foreach anti [concat $opt_excludefiletail_core $opt_excludefiletail] { if {[string match $anti $m]} { #puts stderr "anti: $anti vs m:$m" set suppress 1 @@ -1970,9 +1969,9 @@ namespace eval punkcheck { #puts stderr "subdirs: $subdirs" foreach d $subdirs { set skipd 0 - foreach dg [concat $opt_antiglob_dir_core $opt_antiglob_dir] { + foreach dg [concat $opt_excludedirseg_core $opt_excludedirseg] { if {[string match $dg $d]} { - #puts stdout "SKIPPING FOLDER $d due to antiglob_dir-match: $dg " + #puts stdout "SKIPPING FOLDER $d due to excludedirseg-match: $dg " set skipd 1 break } @@ -2002,19 +2001,19 @@ namespace eval punkcheck { set sub_opts_1 [list {*}{ - } -call-depth-internal [expr {$CALLDEPTH + 1}] {*}{ - } -subdirlist [list {*}$subdirlist $d] {*}{ - } -glob $fileglob {*}{ - } -antiglob_file_core $opt_antiglob_file_core {*}{ - } -antiglob_file $opt_antiglob_file {*}{ - } -antiglob_dir_core $opt_antiglob_dir_core {*}{ - } -antiglob_dir $opt_antiglob_dir {*}{ - } -overwrite $overwrite_what {*}{ - } -source_checksum $opt_source_checksum {*}{ - } -punkcheck_folder $punkcheck_folder {*}{ - } -punkcheck_eventid $punkcheck_eventid {*}{ - } -punkcheck_records $punkcheck_records {*}{ - } -installer $opt_installer {*}{ + } -call-depth-internal [expr {$CALLDEPTH + 1}] {*}{ + } -subdirlist [list {*}$subdirlist $d] {*}{ + } -glob $fileglob {*}{ + } -exclude-filetails_core $opt_excludefiletail_core {*}{ + } -exclude-filetails $opt_excludefiletail {*}{ + } -exclude-dirsegments_core $opt_excludedirseg_core {*}{ + } -exclude-dirsegments $opt_excludedirseg {*}{ + } -overwrite $overwrite_what {*}{ + } -source_checksum $opt_source_checksum {*}{ + } -punkcheck_folder $punkcheck_folder {*}{ + } -punkcheck_eventid $punkcheck_eventid {*}{ + } -punkcheck_records $punkcheck_records {*}{ + } -installer $opt_installer {*}{ } ] set sub_opts [list {*}{ diff --git a/src/vfs/_vfscommon.vfs/modules/shellfilter-0.2.2.tm b/src/vfs/_vfscommon.vfs/modules/shellfilter-0.2.2.tm index 6a948593..a841bd6e 100644 --- a/src/vfs/_vfscommon.vfs/modules/shellfilter-0.2.2.tm +++ b/src/vfs/_vfscommon.vfs/modules/shellfilter-0.2.2.tm @@ -326,18 +326,34 @@ namespace eval shellfilter::chan { #method flush {ch} { # return "" #} + #method flush {transform_handle} { + # #puts stdout "" + # #review - just clear o_encbuf and emit nothing? + # #we wouldn't have a value there if it was convertable from the channel encoding? + # if {[string length $o_encbuf]} { + # #if we have data in the buffer that we haven't been able to convert to a string + # #- then we probably have some kind of encoding mismatch. Is it safer to discard it than to emit garbage chars to the channel or var? + # #REVIEW - log that we are discarding the buffer contents on flush? + # puts stderr "WARNING: flush called on tee_to_var with non-empty buffer. This probably indicates an encoding mismatch between the channel encoding and the encoding expected by the transform. Discarding buffer contents: '$o_encbuf'" + # } + # set clear $o_encbuf + # set o_encbuf "" + # return $clear + #} method flush {transform_handle} { - #puts stdout "" - #review - just clear o_encbuf and emit nothing? - #we wouldn't have a value there if it was convertable from the channel encoding? - if {[string length $o_encbuf]} { - #if we have data in the buffer that we haven't been able to convert to a string - #- then we probably have some kind of encoding mismatch. Is it safer to discard it than to emit garbage chars to the channel or var? - #REVIEW - log that we are discarding the buffer contents on flush? - puts stderr "WARNING: flush called on tee_to_var with non-empty buffer. This probably indicates an encoding mismatch between the channel encoding and the encoding expected by the transform. Discarding buffer contents: '$o_encbuf'" + #puts stderr " $transform_handle o_encbuf: '$o_encbuf' datavars: $o_datavars" + set clear $o_encbuf + if {[catch {tcl::encoding::convertfrom $o_enc $clear} stringdata]} { + #if we can't convert the buffer contents to a string - does it make sense to emit the raw bytes? + # - probably not. + #REVIEW? + return "" } set o_encbuf "" - return "" + foreach v $o_datavars { + append $v $stringdata + } + return $stringdata } method write {ch bytes} { #test with set x [string repeat " \U1f6c8" 2043] @@ -442,16 +458,29 @@ namespace eval shellfilter::chan { # flush $o_localchan # return $clear #} + #method flush {transform_handle} { + # #we wouldn't have a value in o_encbuf if it was convertable from the channel encoding? + # if {[string length $o_encbuf]} { + # #if we have data in the buffer that we haven't been able to convert to a string + # #- then we probably have some kind of encoding mismatch. Is it safer to discard it than to emit garbage chars to the channel or var? + # #REVIEW - log that we are discarding the buffer contents on flush? + # puts stderr "WARNING: flush called on tee_to_pipe with non-empty buffer. This probably indicates an encoding mismatch between the channel encoding and the encoding expected by the transform. Discarding buffer contents: '$o_encbuf'" + # } + # set clear $o_encbuf + # set o_encbuf "" + # return $clear + #} method flush {transform_handle} { - #we wouldn't have a value in o_encbuf if it was convertable from the channel encoding? - if {[string length $o_encbuf]} { - #if we have data in the buffer that we haven't been able to convert to a string - #- then we probably have some kind of encoding mismatch. Is it safer to discard it than to emit garbage chars to the channel or var? - #REVIEW - log that we are discarding the buffer contents on flush? - puts stderr "WARNING: flush called on tee_to_pipe with non-empty buffer. This probably indicates an encoding mismatch between the channel encoding and the encoding expected by the transform. Discarding buffer contents: '$o_encbuf'" + set clear $o_buffered$o_encbuf + if {[catch {tcl::encoding::convertfrom $o_enc $clear} stringdata]} { + #if we can't convert the buffer contents to a string - does it make sense to emit the raw bytes? + # - probably not. + #REVIEW? + return "" } + set o_buffered "" set o_encbuf "" - return "" + return $stringdata } method write {transform_handle bytes} { #set logdata [tcl::encoding::convertfrom $o_enc $bytes] @@ -533,11 +562,24 @@ namespace eval shellfilter::chan { ::shellfilter::log::write $o_logsource $logdata return $bytes } + #method flush {transform_handle} { + # #return "" + # set clear $o_encbuf + # set o_encbuf "" + # #review + # return $clear + #} method flush {transform_handle} { - #return "" - set clear $o_encbuf + set clear $o_buffered$o_encbuf + if {[catch {tcl::encoding::convertfrom $o_enc $clear} stringdata]} { + #if we can't convert the buffer contents to a string - does it make sense to emit the raw bytes? + # - probably not. + #REVIEW? + return "" + } + set o_buffered "" set o_encbuf "" - return $o_encbuf + return $stringdata } method write {ch bytes} { #set logdata [tcl::encoding::convertfrom $o_enc $bytes] @@ -613,9 +655,21 @@ namespace eval shellfilter::chan { my destroy } #clear? + #method flush {transform_handle} { + # #we wouldn't have a value in o_encbuf if it was convertable from the channel encoding? + # if {[string length $o_encbuf]} { + # #if we have data in the buffer that we haven't been able to convert to a string + # #- then we probably have some kind of encoding mismatch. Is it safer to discard it than to emit garbage chars to the log? + # #REVIEW. - we are writing the raw bytes to the log here because we can't convert them to a string. + # #This may be useful for debugging issues, but it may also result in garbage data in the log. + # ::shellfilter::log::write $o_logsource $o_encbuf + # set o_encbuf "" + # } + # return + #} method flush {transform_handle} { - #we wouldn't have a value in o_encbuf if it was convertable from the channel encoding? - if {[string length $o_encbuf]} { + set clear $o_buffered$o_encbuf + if {[catch {tcl::encoding::convertfrom $o_enc $clear} stringdata]} { #if we have data in the buffer that we haven't been able to convert to a string #- then we probably have some kind of encoding mismatch. Is it safer to discard it than to emit garbage chars to the log? #REVIEW. - we are writing the raw bytes to the log here because we can't convert them to a string. @@ -755,6 +809,110 @@ namespace eval shellfilter::chan { } } + + #experimental + #applying this to stdout breaks console query/responses - why? + #- probably because we are splitting graphemes across writes and flushes and the console doesn't know how to handle that? + oo::class create unicode_normalize { + variable o_trecord + variable o_enc + variable o_encbuf + variable o_graphemebuf + variable o_mode + variable o_is_junction + constructor {tf} { + package require punk::ansi + set o_trecord $tf + set o_enc [::tcl::dict::get $tf -encoding] + set o_encbuf "" + set o_graphemebuf "" + set settingsdict [tcl::dict::get $tf -settings] + if {[dict exists $settingsdict -mode]} { + set o_mode [dict get $settingsdict -mode] + if {$o_mode ni {nfc nfd nfkc nfkd none}} { + error "unicode_normalize transform - invalid mode '$o_mode' in settings" + } + if {$o_mode ne "none"} { + #we get dll dependent load errors on windows sometimes - but still seems to work - REVIEW/FIX. + catch {::tcl::unsupported::loadIcu} + } + } else { + #if no mode specified - default to 'none' which just does grapheme splitting without any unicode normalization + set o_mode "none" + } + if {[::tcl::dict::exists $tf -junction]} { + set o_is_junction [::tcl::dict::get $tf -junction] + } else { + set o_is_junction 0 + } + } + method initialize {transform_handle mode} { + return [list initialize write flush finalize] + } + method finalize {transform_handle} { + my destroy + } + method flush {transform_handle} { + #flush seems to do nothing - why? + set clear $o_encbuf[unset o_encbuf] + if {[catch {tcl::encoding::convertfrom $o_enc $clear} stringdata]} { + #if we can't convert the buffer contents to a string - put it back and try again with more data later + #REVIEW? + set o_encbuf $clear + return "" + } + #review + + set graphemes [punk::char::grapheme_split $o_graphemebuf$stringdata] + set outstring [join $graphemes ""] + #puts "outstring: '$outstring' graphemes: $graphemes" + if {$o_mode ne "none"} { + set outstring [::tcl::unsupported::icu::normalize -mode $o_mode $outstring] + } + set o_graphemebuf "" + return [tcl::encoding::convertto $o_enc $outstring] + } + method write {transform_handle bytes} { + set inputbytes $o_encbuf$bytes + set o_encbuf "" + set tail_offset 0 + + if {$inputbytes eq ""} { + #review - do we even get empty writes? + puts stderr "WARNING: write called on unicode_normalize with empty inputbytes. This may be a no-op, but it may also indicate an issue with the upstream transform or channel. Emitting no data for this write." + set stringdata "" + } + + while {$tail_offset < [::tcl::string::length $inputbytes] && [catch {tcl::encoding::convertfrom $o_enc [::tcl::string::range $inputbytes 0 end-$tail_offset]} stringdata]} { + incr tail_offset + } + if {$tail_offset > 0} { + if {$tail_offset < [::tcl::string::length $inputbytes]} { + #stringdata from catch statement must be a valid result + set t [expr {$tail_offset - 1}] + set o_encbuf [::tcl::string::range $inputbytes end-$t end] + } else { + set stringdata "" + set o_encbuf $inputbytes + return "" + } + } + set graphemes [punk::char::grapheme_split $o_graphemebuf$stringdata] + set outstring [join [lrange $graphemes 0 end-1] ""] + set o_graphemebuf [lindex $graphemes end] + + if {$o_mode ne "none"} { + set outstring [::tcl::unsupported::icu::normalize -mode $o_mode $outstring] + } + + return [tcl::encoding::convertto $o_enc $outstring] + } + method meta_is_redirection {} { + return $o_is_junction + } + } + + #a test oo::class create reconvert { variable o_trecord @@ -1114,7 +1272,6 @@ namespace eval shellfilter::chan { # return $emit #} method flush {transform_handle} { - #return "" set clear $o_buffered$o_encbuf if {[catch {tcl::encoding::convertfrom $o_enc $clear} stringdata]} { #if we can't convert the buffer contents to a string - does it make sense to emit the raw bytes? diff --git a/src/vfs/_vfscommon.vfs/modules/test/overtype-1.7.4.tm b/src/vfs/_vfscommon.vfs/modules/test/overtype-1.7.4.tm index 43361b674b78d3eb322d020c66fc9d10a389aa40..16a627f134cde5090d7f832f5deb9f6606455527 100644 GIT binary patch delta 1960 zcmV;Z2Uqy9ZN+V{6&exvz0_PZoyX}m2LJ%i761S!lfN`5lTI27e{FBuHW2>qUvaPv zxXmi3-TSn*Xx0@&x3wsmZeLu(pe5R2BU36#Iq?Gj_dQ3wShDOkSUMqzW4_!S@1A?^ zr~w5h0l6sQ&)$Gu38kIXLPwHbYU@lMIhE>=5-HY_+=Zl{{4>73z8+tbu%s*r9aC;4 zWx2kz7cxm`6w5WOf5fF6QEF(e^eNBr0Fg^6&tl;uElj$i$JyobX)w=K60fDP&^C70 z4z{e)I8UHcuCfHHL-L|+wmG#XI*ny?Sxwo~wbXHHypq#mpFOQ+XT?D9aQtxm&DgDa z0|mlIBsEqpe=xcOOentmn0LlRP&@zqjZ$y>v`ugG5-+7-rdq%IM zgAe3VX?#D+e=^u97y!h_4#N}?a+^%jqwx>pZy7JVp1lmaSHusnRE<}z^A9}QQ1L>? zz246LkGV31`+gjMAM|<<5{6o=q{SK;hH@>EeG_haEOsr7670A)f4%J2@B`h=P8n|n&n)aLO3VEC` zXK!BaAAMMvS&jTmgDZu!+ZTUiU+Y|m9Mn52Hh02 zSk4Rhe?CdCq=`T(x4~sKIunV)7F$3q5m^Qzt7mDFD8Q#Mt$LoR*nbB2?B6RRb-#U@ zetSn1PTs|b+lOnP0#IxAzO}3Wj-hLFg|(iRYF8C}y3?_p7UtJ}Bky2D5ix97KiDl` zc~Nd1_#exBoc97=Z32{|3Xd~y{LOaHBSyO1f9OMb?yYN!^01q^G*gl7iW(@rNSWSO zU|I{wHcyb=!pKq!_#31Q(iUc}oDpV&a=``UUZPOkgfU`6mvUq8x8yRnc%3ug-O{A3 zX0mfkl%qyyHw{B1Wnt#*WZIF{I)z6`dky?6MRY+68aC9n&sy6hRMIrTe;+QUoy8SA zf7{B@ByfE*LIYvLLRdMLNWDZ-?@lr$?4MFg^0pm-v-ksWfg*>#qUHvm1s%mgAQ+|I z5vc{rb*vVss*Ii@3d&ZT6(54gB(a>X!{!O5$B@!i=&@3Z;k5i!+Q_KP8+bC^_I5a@ z;4V)?&dzhSF960kMhXIvXrx5$(!lo%e_(qCCLfGSi@&%*-Yq+unhxk>QiICF5UooX zI-sJ42L7%N;IU$=Be`5XuBN6#%+!V#z1K%WygSREWv_CKT>9u=`kxo`cUhQ^iW$NW zt+Rz;S(I-f9hC=unp1hrlg3LoS{GrK9Tdt zD}!HCc)Qhlo?}T&j@X5 zF40S{MK#d0yn?`X$RIUM)-s;)Od!zxFOzg`DX2Qr!Zo`lDyX46+?_HEn=;F-okS@8 zdgL-NEX*s`>^fSyVWCadf9c#?Yt=gj*iXSIl9}@zhR<0v@fA$C%$7kSFe2x>mT)0@ z5RI!pt}*{0?ezxM%#BU9UgU^CvDIhPTyi0SdDg!dX|(#jfFaOr*ZWwZhVY$` z?}$k0Bl*1J^n`^kb;%S(l)VTPl35}JT187KAGMsDp-M`%Zgh>ee~Hx5=pQh!ybPUe zhh8tInKzE_-ow%g@1=P7Fjpo^2c!B(8nAC777Vs zQ+}s~%dNC}AQ$$xldcej^w+i7or;JrmQZ+b-^)%zDvO9KRxku?~zl_9JX4fws(Tr{1>={5%d u0MC<7HD>~X2a{nnCzIYaP6DkOlVLR{lioE9lk+q>lbbdW20j}A0000+O5HgC delta 1916 zcmV-?2ZQ*^5k+LK4R$=inUQ z%&14fVL&cQ__Nca6QQ(|TIfj98*QD*Bd1awQX<7dlDm-fn}3Ga*Vn^q5|)%Dp<~Le zq%7B$_Ch8J4Pv>VxwwCn14<1|ls@7;ULbNQjL`SiVE~_njw2(SZjTdrM(AlGEcU&w44~GwjKMdWx z(*yHUTnHLRskSPX2I?z4BSF8Py<&||-n=L4mJpw)NNSv%Vs(FJBujH3n`gqQiAt1P z(v@---ZbxFM;WDdX(4+EDKFDlmaH=)r_vZ1`%@)XOOentkt7o}QgrOF5X>mq|p^Ts_P?(veIF0hT z)XoRY-GtuW|E-hPS!x{JoQvS|=x{~!gtJfs9|{~R_XTX9q*u~JK!Mu?Qnfl3i2{i& zVj~e*2IPOKcj-J)fQLf0>Up7J{~6%3d$07=LGw1z{2c9gR1+U zp~>b7XFZP8rYZn%En_t*)UWME-oWr8e7K=~Z+(FIMY(kVY#j4`-g0 zZ&q6tG1BEm?@COsU6Yj$yRl0%71=hcp3>8l@pyj@XtdyL^TeSd8CgmJ-~vT~vcgQ1 zGr}x^?~M5O5`}6cj1fz^luLWi;LBj(WsVW=md=}E&ew*Ca)7#aqcB8L7HW1^QU2*>GCEk~T6b^9ml0R-JX6Q*f7OgU{M>wJi{gaf}p1M56N% zxl03I;DPoWn0zrRHU91jd9$o_+B85blQw^#JPgrmgrP%J)S-dDbGo5cj8#yzCz-3q z)!4KPnws%NAM{=yuP^g=*A9Q!M2gMo$TcFg~d&um9N24$3Q~Ihw z_jTtK^(^pT+RoXX4nZlZ)VF=LX+u5l#xjovTez>5<-ZTQ}3y9^4zN2p;$2Q{hLy z&^+Y(q`)^z-FD7-k=?zt(LCPWD&3BfyQwDBo$vPl%^vra&M(ls*{JS-xb0^(sxfbe ziba41(M1Z#vm0b(w|TfaZ{69qa^>Btx=Dw(6M-fQCWstbCwlZ1in8X?UJZYmMR|mN z9NJ?|!EiK(J(@oTA zO`5gnH3Dp>U=+#B`4+?HEV_UADonV{mQErdBImo7Fd>={jbR;g%x9#%UP7CRkqae? zW(C{R93Ci0eMU_r7ZRvv{hN%9Uf&lmIJ#+i?<>?09twF#L`v_;=QXA$%zUOxq$s@X zS)h=N6DiOuT1xq<<=z-oQmVy9+jtvK?e+c+1I1DcMjb9bZ54H#3dNj6(I2m2S z5&w&N?YX@7<-vSwsBLC&ec2-GdR+cE+?Vtz2ZO0Xg4mSbLSed0001k CdAF+o diff --git a/src/vfs/_vfscommon.vfs/modules/test/runtestmodules.tcl b/src/vfs/_vfscommon.vfs/modules/test/runtestmodules.tcl index 3d46cea0..47ee5d7c 100644 --- a/src/vfs/_vfscommon.vfs/modules/test/runtestmodules.tcl +++ b/src/vfs/_vfscommon.vfs/modules/test/runtestmodules.tcl @@ -14,53 +14,96 @@ if {$modules_posn < 0} { } set modules_base [string range $script_dir 0 $modules_posn-1] if {[file tail $modules_base] eq "src"} { + set test_type "unbuilt" set project_root [file dirname $modules_base] } else { + set test_type "installed" set project_root $modules_base } + puts stderr "runtestmodules.tcl project_root: $project_root" -#use the unbuilt modules/libraries under development rather than the installed versions. -#The unbuilt modules should have a higher version number (such as the magic version number 999999.0a1.0) than any installed versions to ensure they are preferred. -tcl::tm::add [file normalize $project_root/src/modules] -tcl::tm::add [file normalize $project_root/src/modules_tcl$tcl_major] -tcl::tm::add [file normalize $project_root/src/vendormodules] -tcl::tm::add [file normalize $project_root/src/vendormodules_tcl$tcl_major] -# add 'package ifneeded' definitions for unbuilt #modpod modules. -#first gather subdirectories of modules that contain #modpod-*-999999.0a1.0 in their name - these should be the unbuilt versions of zip based modules. -#set subfolders [punk::path::subfolders -recursive [file normalize $project_root/src/modules] -match */#modpod-*-999999.0a1.0] -#'punk::path::subfolders' currently only supports negative matching with -exclude, so we have to filter for the positive match ourselves. -set subfolders [punk::path::subfolders -recursive [file normalize $project_root/src/modules] -exclude {**/_build/** **/_build}] -foreach sub $subfolders { - #In most cases we could use string match - but the * within modpod-*-999999.0a1.0 could match a forward slash which could then match some other file under a #modpod- folder structure, - #so we use globmatchpath which treats * as matching any characters except path separators. - if {[globmatchpath "**/#modpod-*-999999.0a1.0" $sub]} { - set modname [file tail $sub] - set modname [string range $modname 8 end-12] ;#strip off #modpod- and -999999.0a1.0 - set modpath [file join $sub "$modname-999999.0a1.0.tm"] - #!!!! - #todo - calculate fully qualified module name based on path relative to the modules folder we added to the tcl::tm path. - if {[file exists $modpath]} { - puts stderr "runtestmodules.tcl adding package ifneeded for modpod module $modname at path $modpath" - package ifneeded $modname 999999.0a1.0 [list source $modpath] - } else { - puts stderr "runtestmodules.tcl warning: expected mod.tcl not found for modpod module $modname at path $modpath" + +#review - punk::path may itself be a module under test. +#we should ideally be independent of the modules under test. +#same goes for punk and punk::args. +package require punk::path + + +if {$test_type eq "unbuilt"} { + #use the unbuilt modules/libraries under development rather than the installed versions. + #The unbuilt modules should have a higher version number (such as the magic version number 999999.0a1.0) than any installed versions to ensure they are preferred. + tcl::tm::add [file normalize $project_root/src/modules] + tcl::tm::add [file normalize $project_root/src/modules_tcl$tcl_major] + tcl::tm::add [file normalize $project_root/src/vendormodules] + tcl::tm::add [file normalize $project_root/src/vendormodules_tcl$tcl_major] + #when running against unbuilt modules - we want to ensure that the unbuilt versions of any modules are used rather than any installed versions - so we add package ifneeded definitions for the unbuilt versions of any modules that are present. + # add 'package ifneeded' definitions for unbuilt #modpod modules. + #first gather subdirectories of modules that contain #modpod-*-999999.0a1.0 in their name - these should be the unbuilt versions of zip based modules. + #set subfolders [punk::path::subfolders -recursive [file normalize $project_root/src/modules] -match */#modpod-*-999999.0a1.0] + #'punk::path::subfolders' currently only supports negative matching with -exclude, so we have to filter for the positive match ourselves. + set subfolders [punk::path::subfolders -recursive -exclude {**/_build/** **/_build} [file normalize $project_root/src/modules]] + foreach sub $subfolders { + #In most cases we could use string match - but the * within modpod-*-999999.0a1.0 could match a forward slash which could then match some other file under a #modpod- folder structure, + #so we use globmatchpath which treats * as matching any characters except path separators. + if {[punk::path::globmatchpath "**/#modpod-*-999999.0a1.0" $sub]} { + set modname [file tail $sub] + set modname [string range $modname 8 end-13] ;#strip off #modpod- and -999999.0a1.0 + set modpath [file join $sub "$modname-999999.0a1.0.tm"] + #calculate fully qualified module name based on path relative to the modules folder we added to the tcl::tm path. + set relpath [punk::path::relative $project_root/src/modules [file dirname $sub]] + if {$relpath eq "."} { + set relpath "" + set fullmodname $modname + } else { + set components [file split $relpath] + set fullmodname [join $components ::]::$modname + } + #!!!! + #todo - review whether we also need to add the path to the module's folder to the auto_path to ensure that any 'package require' calls within the module will find the unbuilt version of any dependencies. + #we probably do need to do this - otherwise if there is an installed version of a dependency it could be loaded instead of the unbuilt version which is likely not what we want when running tests against unbuilt modules. + + if {[file exists $modpath]} { + puts stderr "runtestmodules.tcl adding package ifneeded for modpod module $fullmodname at path $modpath" + package ifneeded $modname 999999.0a1.0 [list source $modpath] + } else { + puts stderr "runtestmodules.tcl warning: expected mod.tcl not found for modpod module $fullmodname at path $modpath" + } + } + } + #exit 1 + + set libdir [file normalize $project_root/src/lib] + set libvdir [file normalize $project_root/src/lib/tcl$tcl_major] + set libvldir [file normalize $project_root/src/vendorlib] + set libvlvdir [file normalize $project_root/src/vendorlib_tcl$tcl_major] + foreach d [list $libdir $libvdir $libvldir $libvlvdir] { + if {$d ni $::auto_path} { + lappend ::auto_path $d } } -} + #------------------------------------ + puts stderr "runtestmodules.tcl ::auto_path: $::auto_path" + puts stderr "runtestmodules.tcl tcl::tm::list: [tcl::tm::list]" +} else { + tcl::tm::add [file normalize $project_root/modules] + tcl::tm::add [file normalize $project_root/modules_tcl$tcl_major] + tcl::tm::add [file normalize $project_root/vendormodules] + tcl::tm::add [file normalize $project_root/vendormodules_tcl$tcl_major] -set libdir [file normalize $project_root/src/lib] -set libvdir [file normalize $project_root/src/lib/tcl$tcl_major] -set libvldir [file normalize $project_root/src/vendorlib] -set libvlvdir [file normalize $project_root/src/vendorlib_tcl$tcl_major] -foreach d [list $libdir $libvdir $libvldir $libvlvdir] { - if {$d ni $::auto_path} { - lappend ::auto_path $d + set libdir [file normalize $project_root/lib] + set libvdir [file normalize $project_root/lib/tcl$tcl_major] + set libvldir [file normalize $project_root/vendorlib] + set libvlvdir [file normalize $project_root/vendorlib_tcl$tcl_major] + foreach d [list $libdir $libvdir $libvldir $libvlvdir] { + if {$d ni $::auto_path} { + lappend ::auto_path $d + } } + #------------------------------------ + puts stderr "runtestmodules.tcl ::auto_path: $::auto_path" + puts stderr "runtestmodules.tcl tcl::tm::list: [tcl::tm::list]" } -#------------------------------------ -puts stderr "runtestmodules.tcl ::auto_path: $::auto_path" -puts stderr "runtestmodules.tcl tcl::tm::list: [tcl::tm::list]" package require punk