From 37bbe92cf87ee607648ad361b3dc4f2a7db756f4 Mon Sep 17 00:00:00 2001 From: Julian Noble Date: Fri, 31 Oct 2025 17:09:30 +1100 Subject: [PATCH] fix some overtype issues, fix modpod and libunknown global var pollution --- .../{modpod-0.1.3.tm => modpod-0.1.5.tm} | 94 +- .../modules/overtype-1.7.1.tm} | 668 +- src/bootsupport/modules/pattern-1.2.4.tm | 1285 --- src/bootsupport/modules/patterncmd-1.2.4.tm | 645 -- src/bootsupport/modules/patternlib-1.2.6.tm | 2590 ------ .../modules/patternpredator2-1.2.4.tm | 754 -- src/bootsupport/modules/punk/args-0.2.1.tm | 4 +- src/bootsupport/modules/punk/lib-0.1.2.tm | 4533 ---------- .../modules/punk/mix/templates-0.1.3.tm | Bin 0 -> 70519 bytes src/bootsupport/modules/punk/repl-0.1.2.tm | 180 +- src/bootsupport/modules/punk/zip-0.1.0.tm | 761 -- src/bootsupport/modules/shellfilter-0.1.9.tm | 3209 ------- src/bootsupport/modules/uuid-1.0.7.tm | 245 - src/bootsupport/modules/uuid-1.0.8.tm | 246 - src/bootsupport/modules/zipper-0.14.tm | Bin 0 -> 9910 bytes src/modules/modpodtest-buildversion.txt | 2 +- src/modules/punk/args-999999.0a1.0.tm | 4 +- .../punk/mix/templates-buildversion.txt | 2 +- src/modules/punk/repl-999999.0a1.0.tm | 180 +- src/modules/zipper-buildversion.txt | 2 +- .../src/bootsupport/modules/modpod-0.1.5.tm} | 94 +- .../bootsupport/modules/overtype-1.7.1.tm} | 668 +- .../bootsupport/modules/punk/args-0.2.1.tm | 4 +- .../modules/punk/mix/templates-0.1.3.tm | Bin 0 -> 70519 bytes .../bootsupport/modules/punk/repl-0.1.2.tm | 180 +- .../src/bootsupport/modules/zipper-0.14.tm | Bin 0 -> 9910 bytes .../src/bootsupport/modules/modpod-0.1.5.tm} | 94 +- .../src/bootsupport/modules/overtype-1.7.1.tm | 4772 ++++++++++ .../bootsupport/modules/punk/args-0.2.1.tm | 4 +- .../modules/punk/mix/templates-0.1.3.tm | Bin 0 -> 70519 bytes .../bootsupport/modules/punk/repl-0.1.2.tm | 180 +- .../src/bootsupport/modules/zipper-0.14.tm | Bin 0 -> 9910 bytes src/vendormodules/metaface-1.2.5.tm | 6411 -------------- .../{modpod-0.1.4.tm => modpod-0.1.5.tm} | 174 +- src/vendormodules/overtype-1.7.1.tm | 4772 ++++++++++ src/vendormodules/patterncmd-0.1.tm | 639 -- src/vendormodules/patterncmd-1.2.4.tm | 645 -- src/vendormodules/patternpredator1-1.0.tm | 664 -- src/vendormodules/patternpredator2-1.2.4.tm | 754 -- src/vendormodules/tarjar-2.4.1.tm | Bin 114688 -> 0 bytes src/vendormodules/tarjar-2.4.2.tm | Bin 118784 -> 0 bytes .../_vfscommon.vfs/modules/modpod-0.1.4.tm | 673 -- .../_vfscommon.vfs/modules/modpod-0.1.5.tm | 677 ++ .../modules/modpodtest-0.1.1.tm | Bin 0 -> 9410 bytes .../_vfscommon.vfs/modules/overtype-1.7.1.tm | 4772 ++++++++++ .../modules/packageTest-0.1.0.tm | Bin 8506 -> 0 bytes .../modules/packageTest-0.1.1.tm | Bin 11509 -> 0 bytes .../modules/packageTest-0.1.2.tm | Bin 11871 -> 0 bytes .../modules/packageTest-0.1.3.tm | Bin 11953 -> 0 bytes .../_vfscommon.vfs/modules/pattern-1.2.4.tm | 1285 --- .../_vfscommon.vfs/modules/patterncmd-0.1.tm | 639 -- .../modules/patterncmd-1.2.4.tm | 645 -- .../modules/patternpredator1-1.0.tm | 664 -- .../modules/patternpredator2-1.2.4.tm | 754 -- .../_vfscommon.vfs/modules/punk-0.1.tm.txt | 7672 ----------------- .../_vfscommon.vfs/modules/punk/args-0.2.1.tm | 4 +- .../modules/punk/mix/templates-0.1.3.tm | Bin 0 -> 70519 bytes .../_vfscommon.vfs/modules/punk/repl-0.1.2.tm | 180 +- .../modules/shellfilter-0.1.9.tm | 3209 ------- src/vfs/_vfscommon.vfs/modules/tarjar-2.3.tm | Bin 114176 -> 0 bytes .../_vfscommon.vfs/modules/tarjar-2.4.1.tm | Bin 114688 -> 0 bytes .../_vfscommon.vfs/modules/tarjar-2.4.2.tm | Bin 118784 -> 0 bytes src/vfs/_vfscommon.vfs/modules/uuid-1.0.7.tm | 245 - src/vfs/_vfscommon.vfs/modules/zipper-0.12.tm | Bin 9440 -> 0 bytes src/vfs/_vfscommon.vfs/modules/zipper-0.14.tm | Bin 0 -> 9910 bytes 65 files changed, 16354 insertions(+), 40524 deletions(-) rename src/bootsupport/modules/{modpod-0.1.3.tm => modpod-0.1.5.tm} (92%) rename src/{vfs/_vfscommon.vfs/modules/overtype-1.6.6.tm => bootsupport/modules/overtype-1.7.1.tm} (96%) delete mode 100644 src/bootsupport/modules/pattern-1.2.4.tm delete mode 100644 src/bootsupport/modules/patterncmd-1.2.4.tm delete mode 100644 src/bootsupport/modules/patternlib-1.2.6.tm delete mode 100644 src/bootsupport/modules/patternpredator2-1.2.4.tm delete mode 100644 src/bootsupport/modules/punk/lib-0.1.2.tm create mode 100644 src/bootsupport/modules/punk/mix/templates-0.1.3.tm delete mode 100644 src/bootsupport/modules/punk/zip-0.1.0.tm delete mode 100644 src/bootsupport/modules/shellfilter-0.1.9.tm delete mode 100644 src/bootsupport/modules/uuid-1.0.7.tm delete mode 100644 src/bootsupport/modules/uuid-1.0.8.tm create mode 100644 src/bootsupport/modules/zipper-0.14.tm rename src/{vfs/_vfscommon.vfs/modules/modpod-0.1.3.tm => project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/modpod-0.1.5.tm} (92%) rename src/{vendormodules/overtype-1.6.6.tm => project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/overtype-1.7.1.tm} (96%) create mode 100644 src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/templates-0.1.3.tm create mode 100644 src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/zipper-0.14.tm rename src/{vendormodules/modpod-0.1.3.tm => project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/modpod-0.1.5.tm} (92%) create mode 100644 src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/overtype-1.7.1.tm create mode 100644 src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/templates-0.1.3.tm create mode 100644 src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/zipper-0.14.tm delete mode 100644 src/vendormodules/metaface-1.2.5.tm rename src/vendormodules/{modpod-0.1.4.tm => modpod-0.1.5.tm} (80%) create mode 100644 src/vendormodules/overtype-1.7.1.tm delete mode 100644 src/vendormodules/patterncmd-0.1.tm delete mode 100644 src/vendormodules/patterncmd-1.2.4.tm delete mode 100644 src/vendormodules/patternpredator1-1.0.tm delete mode 100644 src/vendormodules/patternpredator2-1.2.4.tm delete mode 100644 src/vendormodules/tarjar-2.4.1.tm delete mode 100644 src/vendormodules/tarjar-2.4.2.tm delete mode 100644 src/vfs/_vfscommon.vfs/modules/modpod-0.1.4.tm create mode 100644 src/vfs/_vfscommon.vfs/modules/modpod-0.1.5.tm create mode 100644 src/vfs/_vfscommon.vfs/modules/modpodtest-0.1.1.tm create mode 100644 src/vfs/_vfscommon.vfs/modules/overtype-1.7.1.tm delete mode 100644 src/vfs/_vfscommon.vfs/modules/packageTest-0.1.0.tm delete mode 100644 src/vfs/_vfscommon.vfs/modules/packageTest-0.1.1.tm delete mode 100644 src/vfs/_vfscommon.vfs/modules/packageTest-0.1.2.tm delete mode 100644 src/vfs/_vfscommon.vfs/modules/packageTest-0.1.3.tm delete mode 100644 src/vfs/_vfscommon.vfs/modules/pattern-1.2.4.tm delete mode 100644 src/vfs/_vfscommon.vfs/modules/patterncmd-0.1.tm delete mode 100644 src/vfs/_vfscommon.vfs/modules/patterncmd-1.2.4.tm delete mode 100644 src/vfs/_vfscommon.vfs/modules/patternpredator1-1.0.tm delete mode 100644 src/vfs/_vfscommon.vfs/modules/patternpredator2-1.2.4.tm delete mode 100644 src/vfs/_vfscommon.vfs/modules/punk-0.1.tm.txt create mode 100644 src/vfs/_vfscommon.vfs/modules/punk/mix/templates-0.1.3.tm delete mode 100644 src/vfs/_vfscommon.vfs/modules/shellfilter-0.1.9.tm delete mode 100644 src/vfs/_vfscommon.vfs/modules/tarjar-2.3.tm delete mode 100644 src/vfs/_vfscommon.vfs/modules/tarjar-2.4.1.tm delete mode 100644 src/vfs/_vfscommon.vfs/modules/tarjar-2.4.2.tm delete mode 100644 src/vfs/_vfscommon.vfs/modules/uuid-1.0.7.tm delete mode 100644 src/vfs/_vfscommon.vfs/modules/zipper-0.12.tm create mode 100644 src/vfs/_vfscommon.vfs/modules/zipper-0.14.tm diff --git a/src/bootsupport/modules/modpod-0.1.3.tm b/src/bootsupport/modules/modpod-0.1.5.tm similarity index 92% rename from src/bootsupport/modules/modpod-0.1.3.tm rename to src/bootsupport/modules/modpod-0.1.5.tm index 540a1696..63875951 100644 --- a/src/bootsupport/modules/modpod-0.1.3.tm +++ b/src/bootsupport/modules/modpod-0.1.5.tm @@ -7,7 +7,7 @@ # (C) 2024 # # @@ Meta Begin -# Application modpod 0.1.3 +# Application modpod 0.1.5 # Meta platform tcl # Meta license # @@ Meta End @@ -17,7 +17,7 @@ # doctools header # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #*** !doctools -#[manpage_begin modpod_module_modpod 0 0.1.3] +#[manpage_begin modpod_module_modpod 0 0.1.5] #[copyright "2024"] #[titledesc {Module API}] [comment {-- Name section and table of contents description --}] #[moddesc {-}] [comment {-- Description at end of page heading --}] @@ -63,38 +63,11 @@ package require punk::args #*** !doctools #[section API] -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# oo::class namespace -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -namespace eval modpod::class { - #*** !doctools - #[subsection {Namespace modpod::class}] - #[para] class definitions - if {[info commands [namespace current]::interface_sample1] eq ""} { - #*** !doctools - #[list_begin enumerated] - - # oo::class create interface_sample1 { - # #*** !doctools - # #[enum] CLASS [class interface_sample1] - # #[list_begin definitions] - - # method test {arg1} { - # #*** !doctools - # #[call class::interface_sample1 [method test] [arg arg1]] - # #[para] test method - # puts "test: $arg1" - # } - - # #*** !doctools - # #[list_end] [comment {-- end definitions interface_sample1}] - # } - - #*** !doctools - #[list_end] [comment {--- end class enumeration ---}] - } -} -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#changes +#0.1.5 - Reduce pollution of global namespace with procs,variables +#0.1.4 - when mounting with vfs::zip (because zipfs not available) - mount relative to executable folder instead of module dir +# (given just a module name it's easier to find exepath than look at package ifneeded script to get module path) # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ # Base namespace @@ -124,13 +97,6 @@ namespace eval modpod { - #proc sample1 {p1 args} { - # #*** !doctools - # #[call [fun sample1] [arg p1] [opt {?option value...?}]] - # #[para]Description of sample1 - # return "ok" - #} - #old tar connect mechanism - review - not needed? proc connect {args} { puts stderr "modpod::connect--->>$args" @@ -351,24 +317,23 @@ namespace eval modpod::lib { set opt_offsettype [dict get $argd opts -offsettype] + #mount_stub should not pollute global namespace. set mount_stub [string map [list %offsettype% $opt_offsettype] { #zip file with Tcl loader prepended. Requires either builtin zipfs, or vfs::zip to mount while zipped. #Alternatively unzip so that extracted #modpod-package-version folder is in same folder as .tm file. #generated using: modpod::lib::make_zip_modpod -offsettype %offsettype% - if {[catch {file normalize [info script]} modfile]} { + if {[catch {file normalize [info script]}]} { error "modpod zip stub error. Unable to determine module path. (possible safe interp restrictions?)" } - if {$modfile eq "" || ![file exists $modfile]} { - error "modpod zip stub error. Unable to determine module path" - } - set moddir [file dirname $modfile] - set mod_and_ver [file rootname [file tail $modfile]] - lassign [split $mod_and_ver -] moduletail version - if {[file exists $moddir/#modpod-$mod_and_ver]} { - source $moddir/#modpod-$mod_and_ver/$mod_and_ver.tm - } else { - #determine module namespace so we can mount appropriately - proc intersect {A B} { + apply {{modfile} { + if {$modfile eq "" || ![file exists $modfile]} { + error "modpod zip stub error. Unable to determine module path" + } + set moddir [file dirname $modfile] + set exedir [file dirname [file normalize [info nameofexecutable]]] + set mod_and_ver [file rootname [file tail $modfile]] + lassign [split $mod_and_ver -] moduletail version + set do_intersect {{A B} { if {[llength $A] == 0} {return {}} if {[llength $B] == 0} {return {}} if {[llength $B] > [llength $A]} { @@ -384,12 +349,13 @@ namespace eval modpod::lib { } } return $res - } + }} + #determine module namespace so we can mount appropriately set lcase_tmfile_segments [string tolower [file split $moddir]] set lcase_modulepaths [string tolower [tcl::tm::list]] foreach lc_mpath $lcase_modulepaths { set mpath_segments [file split $lc_mpath] - if {[llength [intersect $lcase_tmfile_segments $mpath_segments]] == [llength $mpath_segments]} { + if {[llength [apply $do_intersect $lcase_tmfile_segments $mpath_segments]] == [llength $mpath_segments]} { set tail_segments [lrange [file split $moddir] [llength $mpath_segments] end] ;#use properly cased tail break } @@ -429,27 +395,29 @@ namespace eval modpod::lib { } } # #modpod-$mod_and_ver subdirectory always present in the archive so it can be conveniently extracted and run in that form - source //zipfs:/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm + uplevel 1 [list source //zipfs:/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm] } else { #fallback to slower vfs::zip #NB. We don't create the intermediate dirs - but the mount still works - if {![file exists $moddir/$mount_at]} { + + if {![file exists $exedir/$mount_at]} { if {[catch {package require vfs::zip} errM]} { set msg "Unable to load vfs::zip package to mount module $mod_and_ver (and zipfs not available either)" append msg \n "If neither zipfs or vfs::zip are available - the module can still be loaded by manually unzipping the file $modfile in place." append msg \n "The unzipped data will all be contained in a folder named #modpod-$mod_and_ver in the same parent folder as $modfile" error $msg } else { - set fd [vfs::zip::Mount $modfile $moddir/$mount_at] - if {![file exists $moddir/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm]} { - vfs::zip::Unmount $fd $moddir/$mount_at + set fd [vfs::zip::Mount $modfile $exedir/$mount_at] + if {![file exists $exedir/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm]} { + vfs::zip::Unmount $fd $exedir/$mount_at error "Unable to find $mod_and_ver.tm in $modfile for module $fullpackage" } } } - source $moddir/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm + uplevel 1 [list source $exedir/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm] } - } + }} [file normalize [info script]] + #zipped data follows }] #todo - test if supplied zipfile has #modpod-loadcript.tcl or some other script/executable before even creating? @@ -700,7 +668,7 @@ namespace eval modpod::system { package provide modpod [namespace eval modpod { variable pkg modpod variable version - set version 0.1.3 + set version 0.1.5 }] return diff --git a/src/vfs/_vfscommon.vfs/modules/overtype-1.6.6.tm b/src/bootsupport/modules/overtype-1.7.1.tm similarity index 96% rename from src/vfs/_vfscommon.vfs/modules/overtype-1.6.6.tm rename to src/bootsupport/modules/overtype-1.7.1.tm index b4e59ec6..18fa78ea 100644 --- a/src/vfs/_vfscommon.vfs/modules/overtype-1.6.6.tm +++ b/src/bootsupport/modules/overtype-1.7.1.tm @@ -7,9 +7,9 @@ # (C) Julian Noble 2003-2023 # # @@ Meta Begin -# Application overtype 1.6.6 +# Application overtype 1.7.1 # Meta platform tcl -# Meta license BSD +# Meta license BSD # @@ Meta End @@ -17,10 +17,10 @@ # doctools header # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #*** !doctools -#[manpage_begin overtype_module_overtype 0 1.6.6] +#[manpage_begin overtype_module_overtype 0 1.7.1] #[copyright "2024"] #[titledesc {overtype text layout - ansi aware}] [comment {-- Name section and table of contents description --}] -#[moddesc {overtype text layout}] [comment {-- Description at end of page heading --}] +#[moddesc {overtype text layout}] [comment {-- Description at end of page heading --}] #[require overtype] #[keywords module text ansi] #[description] @@ -30,7 +30,7 @@ #*** !doctools #[section Overview] -#[para] overview of overtype +#[para] overview of overtype #[subsection Concepts] #[para] - @@ -41,7 +41,7 @@ #*** !doctools #[subsection dependencies] -#[para] packages used by overtype +#[para] packages used by overtype #[list_begin itemized] package require Tcl 8.6- @@ -81,23 +81,23 @@ package require punk::assertion #[section API] -#Julian Noble - 2003 +#Julian Noble - 2003 #Released under standard 'BSD license' conditions. # #todo - ellipsis truncation indicator for center,right -#v1.4 2023-07 - naive ansi color handling - todo - fix tcl::string::range +#v1.4 2023-07 - naive ansi color handling - todo - fix tcl::string::range # - need to extract and replace ansi codes? tcl::namespace::eval overtype { namespace import ::punk::assertion::assert - punk::assertion::active true + punk::assertion::active true namespace path ::punk::lib - namespace export * - variable default_ellipsis_horizontal "..." ;#fallback - variable default_ellipsis_vertical "..." + namespace export * + variable default_ellipsis_horizontal "..." ;#fallback + variable default_ellipsis_vertical "..." tcl::namespace::eval priv { proc _init {} { upvar ::overtype::default_ellipsis_horizontal e_h @@ -110,14 +110,14 @@ tcl::namespace::eval overtype { #set e [format %c 0x2504] ;#punk::char::charshort boxd_ltdshhz - Box Drawings Light Triple Dash Horizontal #if {![catch {package require punk::char}]} { - # set e [punk::char::charshort boxd_ltdshhz] + # set e [punk::char::charshort boxd_ltdshhz] #} } } priv::_init } proc overtype::about {} { - return "Simple text formatting. Author JMN. BSD-License" + return "Simple text formatting. Author JMN. BSD-License" } tcl::namespace::eval overtype { @@ -126,8 +126,8 @@ tcl::namespace::eval overtype { variable escape_terminals #single "final byte" in the range 0x40–0x7E (ASCII @A–Z[\]^_`a–z{|}~). tcl::dict::set escape_terminals CSI [list @ \\ ^ _ ` | ~ 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 "\{" "\}"] - #tcl::dict::set escape_terminals CSI [list J K m n A B C D E F G s u] ;#basic - tcl::dict::set escape_terminals OSC [list \007 \033\\] ;#note mix of 1 and 2-byte terminals + #tcl::dict::set escape_terminals CSI [list J K m n A B C D E F G s u] ;#basic + tcl::dict::set escape_terminals OSC [list \007 \033\\] ;#note mix of 1 and 2-byte terminals #self-contained 2 byte ansi escape sequences - review more? variable ansi_2byte_codes_dict @@ -157,29 +157,29 @@ proc overtype::string_columns {text} { } #todo - consider a way to merge overtype::left/centre/right -#These have similar algorithms/requirements - and should be refactored to be argument-wrappers over a function called something like overtype::renderblock +#These have similar algorithms/requirements - and should be refactored to be argument-wrappers over a function called something like overtype::renderblock #overtype::renderblock could render the input to a defined (possibly overflowing in x or y) rectangle overlapping the underlay. #(i.e not even necessariy having it's top left within the underlay) tcl::namespace::eval overtype::priv { } -#could return larger than renderwidth +#could return larger than renderwidth proc _get_row_append_column {row} { #obsolete? - upvar outputlines outputlines + upvar outputlines outputlines set idx [expr {$row -1}] if {$row <= 1 || $row > [llength $outputlines]} { return 1 } else { - upvar opt_expand_right expand_right - upvar renderwidth renderwidth + upvar opt_expand_right expand_right + upvar renderwidth renderwidth set existinglen [punk::ansi::printing_length [lindex $outputlines $idx]] set endpos [expr {$existinglen +1}] if {$expand_right} { return $endpos } else { if {$endpos > $renderwidth} { - return $renderwidth + 1 + return [expr {$renderwidth + 1}] } else { return $endpos } @@ -190,7 +190,7 @@ proc _get_row_append_column {row} { tcl::namespace::eval overtype { #*** !doctools #[subsection {Namespace overtype}] - #[para] Core API functions for overtype + #[para] Core API functions for overtype #[list_begin definitions] @@ -201,14 +201,14 @@ tcl::namespace::eval overtype { #The overlay may just be an ansi-colourised block - or may contain ansi cursor movements and cursor save/restore calls - in which case the apparent length and width of the overlay can't be determined as if it was a block of text. #This is a single-shot rendering of strings - ie there is no way to chain another call containing a cursor-restore to previously rendered output and have it know about any cursor-saves in the first call. # a cursor start position other than top-left is a possible addition to consider. - #see editbuf in punk::repl for a more stateful ansi-processor. Both systems use loops over overtype::renderline + #see editbuf in punk::repl for a more stateful ansi-processor. Both systems use loops over overtype::renderline proc renderspace {args} { #*** !doctools #[call [fun overtype::renderspace] [arg args] ] - #[para] usage: ?-transparent [lb]0|1[rb]? ?-expand_right [lb]1|0[rb]? ?-ellipsis [lb]1|0[rb]? ?-ellipsistext ...? undertext overtext + #[para] usage: ?-transparent [lb]0|1[rb]? ?-expand_right [lb]1|0[rb]? ?-ellipsis [lb]1|0[rb]? ?-ellipsistext ...? undertext overtext - # @c overtype starting at left (overstrike) - # @c can/should we use something like this?: 'format "%-*s" $len $overtext + # @c overtype starting at left (overstrike) + # @c can/should we use something like this?: 'format "%-*s" $len $overtext variable default_ellipsis_horizontal if {[llength $args] < 2} { @@ -257,9 +257,9 @@ tcl::namespace::eval overtype { # it does not necessarily mean the viewport grows. (which further implies need for horizontal scrolling) # - it does need to be within some concept of terminal width - as columns must be addressable by ansi sequences. # - This implies the -width option value must grow if it is tied to the concept of renderspace terminal width! REVIEW. - # - further implication is that if expand_right grows the virtual renderspace terminal width - + # - further implication is that if expand_right grows the virtual renderspace terminal width - # then some sort of reflow/rerender needs to be done for preceeding lines? - # possibly not - as expand_right is distinct from a normal terminal-width change event, + # possibly not - as expand_right is distinct from a normal terminal-width change event, # expand_right being primarily to support other operations such as textblock::table #todo - viewport width/height as separate concept to terminal width/height? @@ -269,14 +269,14 @@ tcl::namespace::eval overtype { -looplimit - -width - -height - -startcolumn - -bias - -ellipsis - -ellipsistext - -ellipsiswhitespace - -transparent - -exposed1 - -exposed2 - -experimental - -expand_right - -appendlines - - -reverse_mode - -crm_mode - -insert_mode + - -reverse_mode - -crm_mode - -insert_mode - -cp437 - -info - -console { tcl::dict::set opts $k $v } -wrap - -autowrap_mode { #temp alias -autowrap_mode for consistency with renderline - #todo - + #todo - tcl::dict::set opts -wrap $v } default { @@ -286,8 +286,8 @@ tcl::namespace::eval overtype { } #set opts [tcl::dict::merge $defaults $argsflags] # -- --- --- --- --- --- - #review - expand_left for RTL text? - set opt_expand_right [tcl::dict::get $opts -expand_right] + #review - expand_left for RTL text? + set opt_expand_right [tcl::dict::get $opts -expand_right] #for repl - standard output line indicator is a dash - todo, add a different indicator for a continued line. set opt_width [tcl::dict::get $opts -width] set opt_height [tcl::dict::get $opts -height] @@ -304,7 +304,7 @@ tcl::namespace::eval overtype { set opt_insert_mode [tcl::dict::get $opts -insert_mode] ##### # review -wrap should map onto DECAWM terminal mode - the wrap 2 idea may not fit in with this?. - set opt_autowrap_mode [tcl::dict::get $opts -wrap] + set opt_autowrap_mode [tcl::dict::get $opts -wrap] #??? wrap 1 is hard wrap cutting word at exact column, or 1 column early for 2w-glyph, wrap 2 is for language-based word-wrap algorithm (todo) ##### # -- --- --- --- --- --- @@ -330,7 +330,6 @@ tcl::namespace::eval overtype { } } # ---------------------------- - set underblock [tcl::string::map {\r\n \n} $underblock] set overblock [tcl::string::map {\r\n \n} $overblock] @@ -342,9 +341,9 @@ tcl::namespace::eval overtype { #only non-cursor affecting and non-width occupying ANSI codes should be present. #ie SGR codes and perhaps things such as PM - although generally those should have been pushed to the application already #renderwidth & renderheight were originally used with reference to rendering into a 'column' of output e.g a table column - before cursor row/col was implemented. - + if {$opt_width eq "\uFFEF" || $opt_height eq "\uFFEF"} { - lassign [blocksize $underblock] _w renderwidth _h renderheight + lassign [blocksize $underblock] _w renderwidth _h renderheight if {$opt_width ne "\uFFEF"} { set renderwidth $opt_width } @@ -368,9 +367,9 @@ tcl::namespace::eval overtype { #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 + set vtstate $initial_state - # -- --- --- --- + # -- --- --- --- #REVIEW - do we need ansi resets in the underblock? if {$underblock eq ""} { set underlines [lrepeat $renderheight ""] @@ -386,16 +385,16 @@ tcl::namespace::eval overtype { # #lines_as_list -ansiresets 1 will do nothing if -ansiresets 1 isn't specified - REVIEW # set underlines [lines_as_list -ansiresets 1 $underblock] #} - # -- --- --- --- + # -- --- --- --- #todo - reconsider the 'line' as the natural chunking mechanism for the overlay. - #In practice an overlay ANSI stream can be a single line with ansi moves/restores etc - or even have no moves or newlines, just relying on wrapping at the output renderwidth + #In practice an overlay ANSI stream can be a single line with ansi moves/restores etc - or even have no moves or newlines, just relying on wrapping at the output renderwidth #In such cases - we process the whole shebazzle for the first output line - only reducing by the applied amount at the head each time, reprocessing the long tail each time. #(in cases where there are interline moves or cursor jumps anyway) #This works - but doesn't seem efficient. #On the other hand.. maybe it depends on the data. For simpler files it's more efficient than splitting first - #a hack until we work out how to avoid infinite loops... + #a hack until we work out how to avoid infinite loops... # set looplimit [tcl::dict::get $opts -looplimit] if {$looplimit eq "\uFFEF"} { @@ -434,7 +433,7 @@ tcl::namespace::eval overtype { } } 3 { - #it turns out line based chunks are faster than the above.. probably because some of those end up doing the regex splitting twice + #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 { @@ -462,23 +461,23 @@ tcl::namespace::eval overtype { - set replay_codes_underlay [tcl::dict::create 1 ""] + set replay_codes_underlay [tcl::dict::create 1 ""] #lappend replay_codes_overlay "" set replay_codes_overlay "[punk::ansi::a]" set unapplied "" - set cursor_saved_position [tcl::dict::create] + set cursor_saved_position [tcl::dict::create] set cursor_saved_attributes "" - set outputlines $underlines + 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] + # set col [_get_row_append_column $row] #} else { - set col $opt_startcolumn + set col $opt_startcolumn #} set instruction_stats [tcl::dict::create] @@ -492,9 +491,9 @@ tcl::namespace::eval overtype { if {![tcl::string::length $overtext]} { incr loop continue - } + } #puts "----->[ansistring VIEW -lf 1 -vt 1 -nul 1 $overtext]<----" - set undertext [lindex $outputlines [expr {$row -1}]] + set undertext [lindex $outputlines [expr {$row -1}]] set renderedrow $row #renderline pads each underaly line to width with spaces and should track where end of data is @@ -505,7 +504,7 @@ tcl::namespace::eval overtype { 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 - + #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\ -cp437 $opt_cp437\ @@ -534,7 +533,7 @@ tcl::namespace::eval overtype { # - review - the answer is probably that we don't need to - it is set/reset only during application of overtext #Note carefully the difference betw overflow_right and unapplied. - #overflow_right may need to be included in next run before the unapplied data + #overflow_right may need to be included in next run before the unapplied data #overflow_right most commonly has data when in insert_mode set rendered [tcl::dict::get $rinfo result] set overflow_right [tcl::dict::get $rinfo overflow_right] @@ -557,7 +556,7 @@ tcl::namespace::eval overtype { puts stderr "---->[ansistring VIEW $replay_codes_overlay] rendered: $rendered" #review #JMN3 - set existing_reverse_state 0 + set existing_reverse_state 0 #split_codes_single is single esc sequence - but could have multiple sgr codes within one esc sequence #e.g \x1b\[0;31;7m has a reset,colour red and reverse set codeinfo [punk::ansi::codetype::sgr_merge [list $replay_codes_overlay] -info 1] @@ -609,7 +608,7 @@ tcl::namespace::eval overtype { #todo - handle potential insertion mode as above for cursor restore? #keeping separate branches for debugging - review and merge as appropriate when stable set instruction_type [lindex $instruction 0] ;#some instructions have params - tcl::dict::incr instruction_stats $instruction_type + tcl::dict::incr instruction_stats $instruction_type switch -- $instruction_type { reset { #reset the 'renderspace terminal' (not underlying terminal) @@ -630,7 +629,7 @@ tcl::namespace::eval overtype { } else { puts stderr "renderspace end of input line - has unapplied: [ansistring VIEW $unapplied] (review)" } - set col $opt_startcolumn + set col $opt_startcolumn } up { @@ -644,7 +643,7 @@ tcl::namespace::eval overtype { #puts stderr "up $post_render_row" #puts stderr "$rinfo" - #puts stdout "1 row:$row col $col" + #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 @@ -652,18 +651,18 @@ tcl::namespace::eval overtype { 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 + #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 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 col $renderwidth } } - - #puts stdout "2 row:$row col $col" + + #puts stdout "2 row:$row col $col" #puts stdout "-----------------------" #puts stdout $rinfo #flush stdout @@ -680,7 +679,7 @@ tcl::namespace::eval overtype { lappend outputlines "" } } - set row $post_render_row + set row $post_render_row set col $post_render_col } else { if {$post_render_row > [llength $outputlines]} { @@ -692,12 +691,12 @@ tcl::namespace::eval overtype { lappend outputlines "" } } - set existingdata [lindex $outputlines [expr {$post_render_row -1}]] + 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 col $renderwidth } } @@ -711,7 +710,7 @@ tcl::namespace::eval overtype { set 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 + #lset replay_codes_overlay [expr $overidx+1] $cursor_saved_attributes set replay_codes_overlay [tcl::dict::get $rinfo replay_codes_overlay]$cursor_saved_attributes #set replay_codes_overlay $cursor_saved_attributes set cursor_saved_position [tcl::dict::create] @@ -728,7 +727,7 @@ tcl::namespace::eval overtype { #wrap before restore? - possible effect on saved cursor position #this overflow data has previously been rendered so has no cursor movements or further save/restore operations etc #we can just insert another call to renderline to solve this.. ? - #It would perhaps be more properly handled as a queue of instructions from our initial renderline call + #It would perhaps be more properly handled as a queue of instructions from our initial renderline call #we don't need to worry about overflow next call (?)- but we should carry forward our gx and ansi stacks puts stdout ">>>[a+ red bold]overflow_right during restore_cursor[a]" @@ -743,7 +742,7 @@ tcl::namespace::eval overtype { $overflow_right\ ] set foldline [tcl::dict::get $sub_info result] - tcl::dict::set vtstate insert_mode [tcl::dict::get $sub_info insert_mode] ;#probably not needed..? + tcl::dict::set vtstate insert_mode [tcl::dict::get $sub_info insert_mode] ;#probably not needed..? tcl::dict::set vtstate autowrap_mode [tcl::dict::get $sub_info autowrap_mode] ;#nor this.. linsert outputlines $renderedrow $foldline #review - row & col set by restore - but not if there was no save.. @@ -791,8 +790,8 @@ tcl::namespace::eval overtype { 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 - + " " - - - _ - ! - @ - # - $ - % - ^ - & - * - = - + - : - . - , - / - | - ? - + 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 } @@ -816,21 +815,21 @@ tcl::namespace::eval overtype { #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] - + } lf_start { - #raw newlines + #raw newlines # ---------------------- #test with fruit.ans #test - treating as newline below... #append rendered $overflow_right #set overflow_right "" set row $renderedrow - incr row + incr row if {$row > [llength $outputlines]} { lappend outputlines "" } - set col $opt_startcolumn + set col $opt_startcolumn # ---------------------- } lf_mid { @@ -842,7 +841,7 @@ tcl::namespace::eval overtype { set unapplied "" set row $post_render_row #set col $post_render_col - set col $opt_startcolumn + set col $opt_startcolumn if {$row > [llength $outputlines]} { lappend outputlines {*}[lrepeat 1 ""] } @@ -862,22 +861,22 @@ tcl::namespace::eval overtype { if {[tcl::dict::get $vtstate autowrap_mode]} { set outputlines [linsert $outputlines $renderedrow $overflow_right] set overflow_right "" - set row [expr {$renderedrow + 2}] + set 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 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 add "" set addlen $visualwidth foreach g $graphemes { set w [overtype::grapheme_width_cached $g] @@ -885,9 +884,9 @@ tcl::namespace::eval overtype { append add $g incr addlen $w } else { - set filled 1 + set filled 1 break - } + } } append rendered $add } @@ -901,7 +900,7 @@ tcl::namespace::eval overtype { } } set row $post_render_row - set col $opt_startcolumn + set col $opt_startcolumn if {$row > [llength $outputlines]} { lappend outputlines {*}[lrepeat 1 ""] } @@ -911,7 +910,7 @@ tcl::namespace::eval overtype { append rendered $overflow_right set overflow_right "" set row $post_render_row - set col $opt_startcolumn + set col $opt_startcolumn if {$row > [llength $outputlines]} { lappend outputlines {*}[lrepeat 1 ""] } @@ -936,12 +935,12 @@ tcl::namespace::eval overtype { set row $post_render_row #set row $renderedrow - #incr row + #incr row #only add newline if we're at the bottom if {$row > [llength $outputlines]} { lappend outputlines {*}[lrepeat 1 ""] } - set col $opt_startcolumn + set col $opt_startcolumn } newlines_above { @@ -956,7 +955,7 @@ tcl::namespace::eval overtype { set col $post_render_col if {$insert_lines_above > 0} { set row $renderedrow - set outputlines [linsert $outputlines $renderedrow-1 {*}[lrepeat $insert_lines_above ""]] + set outputlines [linsert $outputlines $renderedrow-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 #? set row $post_render_row #can renderline tell us? } @@ -977,7 +976,7 @@ tcl::namespace::eval overtype { #} #puts [textblock::join $lhs $rhs] - #rendered + #rendered append rendered $overflow_right # @@ -989,7 +988,7 @@ tcl::namespace::eval overtype { lappend outputlines {*}[lrepeat $insert_lines_below ""] } incr row $insert_lines_below - set col $opt_startcolumn + set col $opt_startcolumn } } else { set row $post_render_row @@ -1002,12 +1001,12 @@ tcl::namespace::eval overtype { lappend outputlines "" } } else { - set existingdata [lindex $outputlines [expr {$post_render_row -1}]] + 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 col $renderwidth } } } @@ -1016,7 +1015,7 @@ tcl::namespace::eval overtype { #doesn't seem to be used by fruit.ans testfile #used by dzds.ans #note that cursor_forward may move deep into the next line - or even span multiple lines !TODO - set c $renderwidth + set c $renderwidth set r $post_render_row if {$post_render_col > $renderwidth} { set i $c @@ -1028,10 +1027,10 @@ tcl::namespace::eval overtype { lappend outputlines "" } } - set c $opt_startcolumn + set c $opt_startcolumn } else { incr c - } + } incr i } set col $c @@ -1039,7 +1038,7 @@ tcl::namespace::eval overtype { #why are we getting this instruction then? puts stderr "wrapmoveforward - test" set r [expr {$post_render_row +1}] - set c $post_render_col + set c $post_render_col } set row $r set col $c @@ -1048,7 +1047,7 @@ tcl::namespace::eval overtype { set c $renderwidth set r $post_render_row if {$post_render_col < 1} { - set c 1 + set c 1 set i $c while {$i >= $post_render_col} { if {$c == 0} { @@ -1083,7 +1082,7 @@ tcl::namespace::eval overtype { } else { set col $post_render_col #set unapplied "" ;#this seems wrong? - #set unapplied [tcl::string::range $unapplied 1 end] + #set unapplied [tcl::string::range $unapplied 1 end] #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' @@ -1102,7 +1101,7 @@ tcl::namespace::eval overtype { #we need to run the reduced unapplied on the same line - further graphemes will just overflow again, but codes or control chars could trigger jumps to other lines set overflow_handled 1 - #handled by dropping overflow if any + #handled by dropping overflow if any } } overflow_splitchar { @@ -1129,7 +1128,7 @@ tcl::namespace::eval overtype { } } else { set overflow_handled 1 - #handled by dropping entire overflow if any + #handled by dropping entire overflow if any if {$renderwidth < 2} { set idx 0 set triggering_grapheme_index -1 @@ -1167,7 +1166,7 @@ tcl::namespace::eval overtype { if {!$opt_expand_right && ![tcl::dict::get $vtstate autowrap_mode]} { - #not allowed to overflow column or wrap therefore we get overflow data to truncate + #not allowed to overflow column or wrap therefore we get overflow data to truncate if {[tcl::dict::get $opts -ellipsis]} { set show_ellipsis 1 if {!$opt_ellipsiswhitespace} { @@ -1205,7 +1204,7 @@ tcl::namespace::eval overtype { if {$opt_appendlines} { lappend outputlines $rendered } else { - #? + #? lset outputlines [expr {$renderedrow-1}] $rendered } } @@ -1254,7 +1253,7 @@ tcl::namespace::eval overtype { append debugmsg "${Y}[string repeat - [string length $sep_header]]$RST" \n puts stdout $debugmsg - #todo - config regarding error dumps rather than just dumping in working dir + #todo - config regarding error dumps rather than just dumping in working dir set fd [open [pwd]/error_overtype.txt w] puts $fd $debugmsg close $fd @@ -1262,10 +1261,10 @@ tcl::namespace::eval overtype { break } } - + set result [join $outputlines \n] if {!$opt_info} { - return $result + return $result } else { #emit to debug window like basictelnet does? make debug configurable as syslog or even a telnet server to allow on 2nd window? #append result \n$instruction_stats\n @@ -1288,7 +1287,7 @@ tcl::namespace::eval overtype { if {[llength $args] < 2} { error {usage: ?-transparent [0|1]? ?-bias [left|right]? ?-overflow [1|0]? undertext overtext} } - + foreach {underblock overblock} [lrange $args end-1 end] break #todo - vertical vs horizontal overflow for blocks @@ -1330,9 +1329,9 @@ tcl::namespace::eval overtype { set underlines [split $underblock \n] #set renderwidth [tcl::mathfunc::max {*}[lmap v $underlines {punk::ansi::printing_length $v}]] - lassign [blocksize $underblock] _w renderwidth _h renderheight + lassign [blocksize $underblock] _w renderwidth _h renderheight set overlines [split $overblock \n] - lassign [blocksize $overblock] _w overblock_width _h overblock_height + lassign [blocksize $overblock] _w overblock_width _h overblock_height set under_exposed_max [expr {$renderwidth - $overblock_width}] if {$under_exposed_max > 0} { #background block is wider @@ -1360,7 +1359,7 @@ tcl::namespace::eval overtype { } set replay_codes_underlay "" set replay_codes_overlay "" - foreach undertext $underlines overtext $overlines { + foreach undertext $underlines overtext $overlines { set overtext_datalen [punk::ansi::printing_length $overtext] set ulen [punk::ansi::printing_length $undertext] if {$ulen < $renderwidth} { @@ -1469,17 +1468,17 @@ tcl::namespace::eval overtype { set opt_exposed2 [tcl::dict::get $opts -exposed2] set opt_align [tcl::dict::get $opts -align] # -- --- --- --- --- --- - + set underblock [tcl::string::map {\r\n \n} $underblock] set overblock [tcl::string::map {\r\n \n} $overblock] set underlines [split $underblock \n] - lassign [blocksize $underblock] _w renderwidth _h renderheight + lassign [blocksize $underblock] _w renderwidth _h renderheight set overlines [split $overblock \n] #set overblock_width [tcl::mathfunc::max {*}[lmap v $overlines {punk::ansi::printing_length $v}]] - lassign [blocksize $overblock] _w overblock_width _h overblock_height + lassign [blocksize $overblock] _w overblock_width _h overblock_height set under_exposed_max [expr {max(0,$renderwidth - $overblock_width)}] - set left_exposed $under_exposed_max + set left_exposed $under_exposed_max @@ -1491,7 +1490,7 @@ tcl::namespace::eval overtype { } set replay_codes_underlay "" set replay_codes_overlay "" - foreach undertext $underlines overtext $overlines { + foreach undertext $underlines overtext $overlines { set overtext_datalen [punk::ansi::printing_length $overtext] set ulen [punk::ansi::printing_length $undertext] if {$ulen < $renderwidth} { @@ -1503,17 +1502,17 @@ tcl::namespace::eval overtype { set odiff [expr {$overblock_width - $overtext_datalen}] switch -- $opt_align { left { - set startoffset 0 + set startoffset 0 } right { - set startoffset $odiff + set startoffset $odiff } default { set half [expr {$odiff / 2}] #set lhs [string repeat { } $half] #set righthalf [expr {$odiff - $half}] ;#remainder - may be one more - so we are biased left #set rhs [string repeat { } $righthalf] - set startoffset $half + set startoffset $half } } } else { @@ -1524,7 +1523,7 @@ tcl::namespace::eval overtype { set overtext $replay_codes_overlay$overtext set overflowlength [expr {$overtext_datalen - $renderwidth}] - if {$overflowlength > 0} { + if {$overflowlength > 0} { #raw overtext wider than undertext column set rinfo [renderline\ -info 1\ @@ -1555,7 +1554,7 @@ tcl::namespace::eval overtype { } lappend outputlines $rendered } else { - #padded overtext + #padded overtext #lappend outputlines [renderline -insert_mode 0 -transparent $opt_transparent -startcolumn [expr {$left_exposed + 1}] $undertext $overtext] #Note - we still need overflow(exapnd_right) here - as although the overtext is short - it may oveflow due to the startoffset set rinfo [renderline -info 1 -insert_mode 0 -transparent $opt_transparent -expand_right $opt_overflow -startcolumn [expr {$left_exposed + 1 + $startoffset}] $undertext $overtext] @@ -1622,15 +1621,15 @@ tcl::namespace::eval overtype { set opt_blockalign "centre" } # -- --- --- --- --- --- - + set underblock [tcl::string::map {\r\n \n} $underblock] set overblock [tcl::string::map {\r\n \n} $overblock] set underlines [split $underblock \n] - lassign [blocksize $underblock] _w renderwidth _h renderheight + lassign [blocksize $underblock] _w renderwidth _h renderheight set overlines [split $overblock \n] #set overblock_width [tcl::mathfunc::max {*}[lmap v $overlines {punk::ansi::printing_length $v}]] - lassign [blocksize $overblock] _w overblock_width _h overblock_height + lassign [blocksize $overblock] _w overblock_width _h overblock_height set under_exposed_max [expr {max(0,$renderwidth - $overblock_width)}] switch -- $opt_blockalign { @@ -1638,7 +1637,7 @@ tcl::namespace::eval overtype { set left_exposed 0 } right { - set left_exposed $under_exposed_max + set left_exposed $under_exposed_max } centre { if {$under_exposed_max > 0} { @@ -1674,7 +1673,7 @@ tcl::namespace::eval overtype { } set replay_codes_underlay "" set replay_codes_overlay "" - foreach undertext $underlines overtext $overlines { + foreach undertext $underlines overtext $overlines { set overtext_datalen [punk::ansi::printing_length $overtext] set ulen [punk::ansi::printing_length $undertext] if {$ulen < $renderwidth} { @@ -1686,17 +1685,17 @@ tcl::namespace::eval overtype { set odiff [expr {$overblock_width - $overtext_datalen}] switch -- $opt_textalign { left { - set startoffset 0 + set startoffset 0 } right { - set startoffset $odiff + set startoffset $odiff } default { set half [expr {$odiff / 2}] #set lhs [string repeat { } $half] #set righthalf [expr {$odiff - $half}] ;#remainder - may be one more - so we are biased left #set rhs [string repeat { } $righthalf] - set startoffset $half + set startoffset $half } } } else { @@ -1707,7 +1706,7 @@ tcl::namespace::eval overtype { set overtext $replay_codes_overlay$overtext set overflowlength [expr {$overtext_datalen - $renderwidth}] - if {$overflowlength > 0} { + if {$overflowlength > 0} { #raw overtext wider than undertext column set rinfo [renderline -info 1 -insert_mode 0 -transparent $opt_transparent -exposed1 $opt_exposed1 -exposed2 $opt_exposed2 -expand_right $opt_overflow -startcolumn [expr {1 + $startoffset}] $undertext $overtext] set replay_codes [tcl::dict::get $rinfo replay_codes] @@ -1755,7 +1754,7 @@ tcl::namespace::eval overtype { } lappend outputlines $rendered } else { - #padded overtext + #padded overtext #lappend outputlines [renderline -insert_mode 0 -transparent $opt_transparent -startcolumn [expr {$left_exposed + 1}] $undertext $overtext] #Note - we still need expand_right here - as although the overtext is short - it may oveflow due to the startoffset set rinfo [renderline -info 1 -insert_mode 0 -transparent $opt_transparent -expand_right $opt_overflow -startcolumn [expr {$left_exposed + 1 + $startoffset}] $undertext $overtext] @@ -1775,8 +1774,8 @@ tcl::namespace::eval overtype { variable optimise_ptruns 10 ;# can be set to zero to disable the ptruns branches # ## ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### - # renderline written from a left-right line orientation perspective as a first-shot at getting something useful. - # ultimately right-to-left, top-to-bottom and bottom-to-top are probably needed. + # renderline written from a left-right line orientation perspective as a first-shot at getting something useful. + # ultimately right-to-left, top-to-bottom and bottom-to-top are probably needed. # ## ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### # # @@ -1791,7 +1790,7 @@ tcl::namespace::eval overtype { #*** !doctools #[call [fun overtype::renderline] [arg args] ] #[para] renderline is the core engine for overtype string processing (frames & textblocks), and the raw mode commandline repl for the Tcl Punk Shell - #[para] It is also a central part of an ansi (micro) virtual terminal-emulator of sorts + #[para] It is also a central part of an ansi (micro) virtual terminal-emulator of sorts #[para] This system does a half decent job at rendering 90's ANSI art to manipulable colour text blocks that can be joined & framed for layout display within a unix or windows terminal #[para] Renderline helps maintain ANSI text styling reset/replay codes so that the styling of one block doesn't affect another. #[para] Calling on the punk::ansi library - it can coalesce codes to keep the size down. @@ -1799,7 +1798,7 @@ tcl::namespace::eval overtype { #[para] renderline is part of the Unicode and ANSI aware Overtype system which 'renders' a block of text onto a static underlay #[para] The underlay is generally expected to be an ordered set of lines or a rectangular text block analogous to a terminal screen - but it can also be ragged in line length, or just blank. #[para] The overlay couuld be similar - in which case it may often be used to overwrite a column or section of the underlay. - #[para] The overlay could however be a sequence of ANSI-laden text that jumps all over the place. + #[para] The overlay could however be a sequence of ANSI-laden text that jumps all over the place. # #[para] renderline itself only deals with a single line - or sometimes a single character. It is generally called from a loop that does further terminal-like or textblock processing. #[para] By suppyling the -info 1 option - it can return various fields indicating the state of the render. @@ -1867,7 +1866,7 @@ tcl::namespace::eval overtype { set opt_width [tcl::dict::get $opts -width] set opt_etabs [tcl::dict::get $opts -etabs] set opt_expand_right [tcl::dict::get $opts -expand_right] - set opt_colstart [tcl::dict::get $opts -startcolumn] ;#lhs limit for overlay - an offset to cursor_column - first visible column is 1. 0 or < 0 are before the start of the underlay + set opt_colstart [tcl::dict::get $opts -startcolumn] ;#lhs limit for overlay - an offset to cursor_column - first visible column is 1. 0 or < 0 are before the start of the underlay set opt_colcursor [tcl::dict::get $opts -cursor_column];#start cursor column relative to overlay set opt_row_context [tcl::dict::get $opts -cursor_row] if {[string length $opt_row_context]} { @@ -1875,7 +1874,7 @@ tcl::namespace::eval overtype { error "overtype::renderline -cursor_row must be empty for unspecified/unknown or a non-zero positive integer. received: '$opt_row_context'" } } - # -- --- --- --- --- --- --- --- --- --- --- --- + # -- --- --- --- --- --- --- --- --- --- --- --- #The _mode flags correspond to terminal modes that can be set/reset via escape sequences (e.g DECAWM wraparound mode) set opt_insert_mode [tcl::dict::get $opts -insert_mode];#should usually be 1 for each new line in editor mode but must be initialised to 1 externally (review) #default is for overtype @@ -1886,7 +1885,7 @@ tcl::namespace::eval overtype { # -- --- --- --- --- --- --- --- --- --- --- --- set temp_cursor_saved [tcl::dict::get $opts -cursor_restore_attributes] - set cp437_glyphs [tcl::dict::get $opts -cp437] + set cp437_glyphs [tcl::dict::get $opts -cp437] set cp437_map [tcl::dict::create] if {$cp437_glyphs} { set cp437_map [set ::punk::ansi::cp437_map] @@ -1896,7 +1895,7 @@ tcl::namespace::eval overtype { tcl::dict::unset cp437_map \n } - set opt_transparent [tcl::dict::get $opts -transparent] + set opt_transparent [tcl::dict::get $opts -transparent] if {$opt_transparent eq "0"} { set do_transparency 0 } else { @@ -1941,7 +1940,7 @@ tcl::namespace::eval overtype { if {!$opt_etabs} { if {[string first \t $under] >= 0} { #set under [textutil::tabify::untabify2 $under] - set under [textutil::tabify::untabifyLine $under $tw] + set under [textutil::tabify::untabifyLine $under $tw] } if {[string first \t $over] >= 0} { #set overdata [textutil::tabify::untabify2 $over] @@ -1972,7 +1971,7 @@ tcl::namespace::eval overtype { set pm_list [list] set i_u -1 ;#underlay may legitimately be empty - set undercols [list] + set undercols [list] set u_codestack [list] #u_gx_stack probably isn't really a stack - I don't know if g0 g1 can stack or not - for now we support only g0 anyway set u_gx_stack [list] ;#separate stack for g0 (g1 g2 g3?) graphics on and off (DEC special graphics) @@ -1990,12 +1989,12 @@ tcl::namespace::eval overtype { set p1 [tcl::string::index $pt 0] set hex [format %x [scan $p1 %c]] ;#punk::char::char_hex set re [tcl::string::cat {^[} \\U$hex {]+$}] - set is_ptrun [regexp $re $pt] + set is_ptrun [regexp $re $pt] } if {$is_ptrun} { #switch -- $p1 { - # " " - - - _ - ! - @ - # - $ - % - ^ - & - * - = - + - : - . - , - / - | - ? - - # 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 - + # " " - - - _ - ! - @ - # - $ - % - ^ - & - * - = - + - : - . - , - / - | - ? - + # 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 { # set width 1 # } @@ -2014,7 +2013,7 @@ tcl::namespace::eval overtype { set ptlen [string length $pt] if {$width <= 1} { #review - 0 and 1? - incr i_u $ptlen + incr i_u $ptlen lappend understacks {*}[lrepeat $ptlen $u_codestack] lappend understacks_gx {*}[lrepeat $ptlen $u_gx_stack] lappend undercols {*}[lrepeat $ptlen $p1] @@ -2023,7 +2022,7 @@ tcl::namespace::eval overtype { set 2ptlen [expr {$ptlen * 2}] lappend understacks {*}[lrepeat $2ptlen $u_codestack] lappend understacks_gx {*}[lrepeat $2ptlen $u_gx_stack] - set l [concat {*}[lrepeat $ptlen [list $p1 ""]] + set l [concat {*}[lrepeat $ptlen [list $p1 ""]]] lappend undercols {*}$l unset l } @@ -2034,8 +2033,8 @@ tcl::namespace::eval overtype { #.. but even 0.5uS per char (grapheme_width_cached) adds up quickly when stitching lots of lines together. #todo - test decimal value instead, compare performance 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 - + " " - - - _ - ! - @ - # - $ - % - ^ - & - * - = - + - : - . - , - / - | - ? - + 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 { set width 1 } @@ -2050,24 +2049,24 @@ tcl::namespace::eval overtype { set width [grapheme_width_cached $grapheme] #we still want most controls and other zero-length codepoints such as \u200d (zero width joiner) to stay zero-length #we substitute lone ESC that weren't captured within ANSI context as a debugging aid to see malformed ANSI - #todo - default to off and add a flag (?) to enable this substitution + #todo - default to off and add a flag (?) to enable this substitution set sub_stray_escapes 0 if {$sub_stray_escapes && $width == 0} { if {$grapheme eq "\x1b"} { set gvis [ansistring VIEW $grapheme] ;#can only use with graphemes that have a single replacement char.. set grapheme $gvis - set width 1 + set width 1 } } } } } - + #set width [grapheme_width_cached $grapheme] incr i_u lappend understacks $u_codestack lappend understacks_gx $u_gx_stack - + lappend undercols $grapheme if {$width > 1} { #presumably there are no triple-column or wider unicode chars.. until the aliens arrive.(?) @@ -2084,7 +2083,7 @@ tcl::namespace::eval overtype { } #underlay should already have been rendered and not have non-sgr codes - but let's retain the check for them and not stack them if other codes are here - #only stack SGR (graphics rendition) codes - not title sets, cursor moves etc + #only stack SGR (graphics rendition) codes - not title sets, cursor moves etc #keep any remaining PMs in place if {$code ne ""} { set c1c2 [tcl::string::range $code 0 1] @@ -2099,13 +2098,13 @@ tcl::namespace::eval overtype { switch -- $leadernorm { 7CSI - 8CSI { - #need to exclude certain leaders after the lb e.g < for SGR 1006 mouse + #need to exclude certain leaders after the lb e.g < for SGR 1006 mouse #REVIEW - what else could end in m but be mistaken as a normal SGR code here? set maybemouse "" if {[tcl::string::index $c1c2 0] eq "\x1b"} { set maybemouse [tcl::string::index $code 2] } - + if {$maybemouse ne "<" && [tcl::string::index $code end] eq "m"} { if {[punk::ansi::codetype::is_sgr_reset $code]} { set u_codestack [list "\x1b\[m"] @@ -2131,7 +2130,7 @@ tcl::namespace::eval overtype { } 7PMX - 7SOS { #we can have PMs or SOS (start of string) in the underlay - though mostly the PMs should have been processed.. - #attach the PM/SOS (entire ANSI sequence) to the previous grapheme! + #attach the PM/SOS (entire ANSI sequence) to the previous grapheme! #It should not affect the size - but terminal display may get thrown out if terminal doesn't support them. #note that there may in theory already be ANSI stored - we don't assume it was a pure grapheme string @@ -2143,7 +2142,7 @@ tcl::namespace::eval overtype { } lset undercols end $graphemeplus #The grapheme_width_cached function will be called on this later - and doesn't account for ansi. - #we need to manually cache the item with it's proper width + #we need to manually cache the item with it's proper width variable grapheme_widths #stripped and plus version keys pointing to same length dict set grapheme_widths $graphemeplus [grapheme_width_cached [::punk::ansi::ansistrip $graphemeplus]] @@ -2160,11 +2159,11 @@ tcl::namespace::eval overtype { #} elseif {[punk::ansi::codetype::has_sgr_leadingreset $code]} { #} elseif {[punk::ansi::codetype::is_sgr $code]} { #} else { - # #leave SGR stack as is + # #leave SGR stack as is # if {[punk::ansi::codetype::is_gx_open $code]} { # } elseif {[punk::ansi::codetype::is_gx_close $code]} { - # } - #} + # } + #} } #consider also if there are other codes that should be stacked..? } @@ -2207,7 +2206,7 @@ tcl::namespace::eval overtype { lappend understacks $u_codestack lappend understacks_gx $u_gx_stack } else { - #in case overlay onto emptystring as underlay + #in case overlay onto emptystring as underlay lappend understacks [list] lappend understacks_gx [list] } @@ -2244,20 +2243,20 @@ tcl::namespace::eval overtype { #todo - detect plain ascii no-ansi input line (aside from leading ansi reset) #will that allow some optimisations? - + #todo - detect repeated transparent char in overlay #regexp {^(.)\1+$} ;#backtracking regexp - relatively slow. # - try set c [string index $data 0]; regexp [string map [list %c% $c] {^[%c%]+$}] $data - #we should be able to optimize to pass through the underlay?? + #we should be able to optimize to pass through the underlay?? #??? set colcursor $opt_colstart #TODO - make a little virtual column object - #we need to refer to column1 or columnmin? or columnmax without calculating offsets due to to startcolumn + #we need to refer to column1 or columnmin? or columnmax without calculating offsets due to to startcolumn #need to lock-down what start column means from perspective of ANSI codes moving around - the offset perspective is unclear and a mess. - #set re_diacritics {[\u0300-\u036f]+|[\u1ab0-\u1aff]+|[\u1dc0-\u1dff]+|[\u20d0-\u20ff]+|[\ufe20-\ufe2f]+} + #set re_diacritics {[\u0300-\u036f]+|[\u1ab0-\u1aff]+|[\u1dc0-\u1dff]+|[\u20d0-\u20ff]+|[\ufe20-\ufe2f]+} #as at 2024-02 punk::char::grapheme_split uses these - not aware of more complex graphemes set overstacks [list] @@ -2266,8 +2265,8 @@ tcl::namespace::eval overtype { set o_codestack [list]; #SGR codestack (not other codes such as movement,insert key etc) set o_gxstack [list] set pt_overchars "" - set i_o 0 - set overlay_grapheme_control_list [list] ;#tag each with g, sgr or other. 'other' are things like cursor-movement or insert-mode or codes we don't recognise/use + set i_o 0 + set overlay_grapheme_control_list [list] ;#tag each with g, sgr or other. 'other' are things like cursor-movement or insert-mode or codes we don't recognise/use #experiment set overlay_grapheme_control_stacks [list] foreach {pt code} $overmap { @@ -2284,32 +2283,32 @@ tcl::namespace::eval overtype { if {$optimise_ptruns && [tcl::string::length $pt] >= $optimise_ptruns} { set p1 [tcl::string::index $pt 0] set re [tcl::string::cat {^[} \\U[format %x [scan $p1 %c]] {]+$}] - set is_ptrun [regexp $re $pt] + set is_ptrun [regexp $re $pt] #leading only? we would have to check for graphemes at the trailing boundary? #set re [tcl::string::cat {^[} \\U[format %x [scan $p1 %c]] {]+}] - #set is_ptrun [regexp -indices $re $pt runrange] + #set is_ptrun [regexp -indices $re $pt runrange] #if {$is_ptrun && 1} { #} } if {$is_ptrun} { - #review - in theory a run over a certain length won't be part of some grapheme combo (graphemes can be long e.g 44?, but not as runs(?)) + #review - in theory a run over a certain length won't be part of some grapheme combo (graphemes can be long e.g 44?, but not as runs(?)) #could be edge cases for runs at line end? (should be ok as we include trailing \n in our data) set len [string length $pt] set g_element [list g $p1] #lappend overstacks {*}[lrepeat $len $o_codestack] #lappend overstacks_gx {*}[lrepeat $len $o_gxstack] - #incr i_o $len + #incr i_o $len #lappend overlay_grapheme_control_list {*}[lrepeat $len [list g $p1]] #lappend overlay_grapheme_control_stacks {*}[lrepeat $len $o_codestack] set pi 0 - incr i_o $len + incr i_o $len while {$pi < $len} { lappend overstacks $o_codestack lappend overstacks_gx $o_gxstack - lappend overlay_grapheme_control_list $g_element + lappend overlay_grapheme_control_list $g_element lappend overlay_grapheme_control_stacks $o_codestack incr pi } @@ -2317,7 +2316,7 @@ tcl::namespace::eval overtype { foreach grapheme [punk::char::grapheme_split $pt] { lappend overstacks $o_codestack lappend overstacks_gx $o_gxstack - incr i_o + incr i_o lappend overlay_grapheme_control_list [list g $grapheme] lappend overlay_grapheme_control_stacks $o_codestack } @@ -2334,7 +2333,7 @@ tcl::namespace::eval overtype { } else { lappend overstacks $o_codestack lappend overstacks_gx $o_gxstack - incr i_o + incr i_o lappend overlay_grapheme_control_list [list g $grapheme] lappend overlay_grapheme_control_stacks $o_codestack } @@ -2345,7 +2344,7 @@ tcl::namespace::eval overtype { } } - #only stack SGR (graphics rendition) codes - not title sets, cursor moves etc + #only stack SGR (graphics rendition) codes - not title sets, cursor moves etc #order of if-else based on assumptions: # that pure resets are fairly common - more so than leading resets with other info # that non-sgr codes are not that common, so ok to check for resets before verifying it is actually SGR at all. @@ -2358,7 +2357,7 @@ tcl::namespace::eval overtype { } #else crm_mode could be set either way from options if {$crm_mode && $code ne "\x1b\[00001E"} { - #treat the code as type 'g' like above - only allow through codes to reset mode REVIEW for now just \x1b\[3l ? + #treat the code as type 'g' like above - only allow through codes to reset mode REVIEW for now just \x1b\[3l ? #we need to somehow convert further \n in the graphical rep to an instruction for newline that will bypass further crm_mode processing or we would loop. set code_as_pt [ansistring VIEW -nul 1 -lf 1 -vt 1 -ff 1 $code] #split using standard split for first foreach loop - grapheme based split when processing 2nd foreach loop @@ -2366,7 +2365,7 @@ tcl::namespace::eval overtype { set codeparts [list] ;#list of 2-el lists each element {crmcontrol } or {g } foreach c $chars { if {$c eq "\n"} { - #use CNL (cursor next line) \x1b\[00001E ;#leading zeroes ok for this processor - used as debugging aid to distinguish + #use CNL (cursor next line) \x1b\[00001E ;#leading zeroes ok for this processor - used as debugging aid to distinguish lappend codeparts [list crmcontrol "\x1b\[00001E"] } else { if {[llength $codeparts] > 0 && [lindex $codeparts end 0] eq "g"} { @@ -2383,11 +2382,11 @@ tcl::namespace::eval overtype { lassign $record rtype rval switch -exact -- $rtype { g { - append pt_overchars $rval + append pt_overchars $rval foreach grapheme [punk::char::grapheme_split $rval] { lappend overstacks $o_codestack lappend overstacks_gx $o_gxstack - incr i_o + incr i_o lappend overlay_grapheme_control_list [list g $grapheme] lappend overlay_grapheme_control_stacks $o_codestack } @@ -2401,7 +2400,7 @@ tcl::namespace::eval overtype { } } else { lappend overlay_grapheme_control_stacks $o_codestack - #there will always be an empty code at end due to foreach on 2 vars with odd-sized list ending with pt (overmap coming from perlish split) + #there will always be an empty code at end due to foreach on 2 vars with odd-sized list ending with pt (overmap coming from perlish split) if {[punk::ansi::codetype::is_sgr_reset $code]} { set o_codestack [list "\x1b\[m"] ;#reset better than empty list - fixes some ansi art issues lappend overlay_grapheme_control_list [list sgr $code] @@ -2423,7 +2422,7 @@ tcl::namespace::eval overtype { } elseif {[regexp {\x1b8|\x1b\[u} $code]} { #experiment #cursor_restore - for the replays - set o_codestack [list $temp_cursor_saved] + set o_codestack [list $temp_cursor_saved] lappend overlay_grapheme_control_list [list other $code] } else { #review @@ -2460,18 +2459,18 @@ tcl::namespace::eval overtype { #potential problem - combinining diacritics directly following control chars like \r \b # -- --- --- - #we need to initialise overflow_idx before any potential row-movements - as they need to perform a loop break and force in_excess to 1 + #we need to initialise overflow_idx before any potential row-movements - as they need to perform a loop break and force in_excess to 1 if {$opt_expand_right} { #expand_right true means we can have lines as long as we want, but either way there can be excess data that needs to be thrown back to the calling loop. #we currently only support horizontal expansion to the right (review regarding RTL text!) set overflow_idx -1 } else { - #expand_right zero - we can't grow beyond our column width - so we get ellipsis or truncation + #expand_right zero - we can't grow beyond our column width - so we get ellipsis or truncation if {$opt_width ne "\uFFEF"} { set overflow_idx [expr {$opt_width}] } else { - #review - this is also the cursor position when adding a char at end of line? - set overflow_idx [expr {[llength $undercols]}] ;#index at which we would be *in* overflow a row move may still override it + #review - this is also the cursor position when adding a char at end of line? + set overflow_idx [expr {[llength $undercols]}] ;#index at which we would be *in* overflow a row move may still override it } } # -- --- --- @@ -2483,21 +2482,21 @@ tcl::namespace::eval overtype { set insert_lines_above 0 ;#return key set insert_lines_below 0 - set instruction "" + set instruction "" - # -- --- --- + # -- --- --- #cursor_save_dec, cursor_restore_dec etc set cursor_restore_required 0 - set cursor_saved_attributes "" + set cursor_saved_attributes "" set cursor_saved_position "" - # -- --- --- + # -- --- --- #set idx 0 ;# line index (cursor - 1) #set idx [expr {$opt_colstart + $opt_colcursor} -1] #idx is the per column output index set idx [expr {$opt_colcursor -1}] ;#don't use opt_colstart here - we have padded and won't start emitting until idx reaches opt_colstart-1 - #cursor_column is usually one above idx - but we have opt_colstart which is like a margin - todo: remove cursor_column from the following loop and calculate it's offset when breaking or at end. + #cursor_column is usually one above idx - but we have opt_colstart which is like a margin - todo: remove cursor_column from the following loop and calculate it's offset when breaking or at end. #(for now we are incrementing/decrementing both in sync - which is a bit silly) set cursor_column $opt_colcursor @@ -2507,9 +2506,9 @@ tcl::namespace::eval overtype { #movements only occur within the overlay range. #an underlay is however not necessary.. e.g - #renderline -expand_right 1 "" data + #renderline -expand_right 1 "" data - #set re_mode {\x1b\[\?([0-9]*)(h|l)} ;#e.g DECAWM + #set re_mode {\x1b\[\?([0-9]*)(h|l)} ;#e.g DECAWM #set re_col_move {\x1b\[([0-9]*)(C|D|G)$} #set re_row_move {\x1b\[([0-9]*)(A|B)$} #set re_both_move {\x1b\[([0-9]*)(?:;){0,1}([0-9]*)H$} ;# or "f" ? @@ -2525,19 +2524,19 @@ tcl::namespace::eval overtype { #puts "-->overflow_idx: $overflow_idx" for {set gci 0} {$gci < [llength $overlay_grapheme_control_list]} {incr gci} { set gc [lindex $overlay_grapheme_control_list $gci] - lassign $gc type item - + lassign $gc type item + #emit plaintext chars first using existing SGR codes from under/over stack as appropriate #then check if the following code is a cursor movement within the line and adjust index if so #foreach ch $overlay_graphemes {} switch -- $type { - g { - set ch $item - #crm_mode affects both graphic and control + g { + set ch $item + #crm_mode affects both graphic and control if {0 && $crm_mode} { set chars [ansistring VIEW -nul 1 -lf 2 -vt 2 -ff 2 $ch] set chars [string map [list \n "\x1b\[00001E"] $chars] - if {[llength [split $chars ""]] > 1} { + if {[llength [split $chars ""]] > 1} { priv::render_unapplied $overlay_grapheme_control_list $gci #prefix the unapplied controls with the string version of this control set unapplied_list [linsert $unapplied_list 0 {*}[split $chars ""]] @@ -2548,19 +2547,19 @@ tcl::namespace::eval overtype { set ch $chars } } - incr idx_over; #idx_over (until unapplied reached anyway) is per *grapheme* in the overlay - not per col. + incr idx_over; #idx_over (until unapplied reached anyway) is per *grapheme* in the overlay - not per col. if {($idx < ($opt_colstart -1))} { incr idx [grapheme_width_cached $ch] continue } - #set within_undercols [expr {$idx <= [llength $undercols]-1}] ;#within our active data width + #set within_undercols [expr {$idx <= [llength $undercols]-1}] ;#within our active data width set within_undercols [expr {$idx <= $renderwidth-1}] #https://www.enigma.com/resources/blog/the-secret-world-of-newline-characters #\x85 NEL in the c1 control set is treated by some terminal emulators (e.g Hyper) as a newline, #on some it's invisble but doesn't change the line, on some it's a visible glyph of width 1. #This is hard to process in any standard manner - but I think the Hyper behaviour of doing what it was intended is perhaps most reasonable - #We will map it to the same behaviour as lf here for now... but we need also to consider the equivalent ANSI sequence: \x1bE + #We will map it to the same behaviour as lf here for now... but we need also to consider the equivalent ANSI sequence: \x1bE set chtest [tcl::string::map [list \n \x85 \b \r \v \x7f ] $ch] #puts --->chtest:$chtest @@ -2572,13 +2571,13 @@ tcl::namespace::eval overtype { #puts "---a at col 1" #linefeed at column 1 #leave the overflow_idx ;#? review - set instruction lf_start ;#specific instruction for newline at column 1 + set instruction lf_start ;#specific instruction for newline at column 1 priv::render_unapplied $overlay_grapheme_control_list $gci break } elseif {$overflow_idx != -1 && $idx == $overflow_idx} { #linefeed after final column - #puts "---c at overflow_idx=$overflow_idx" - incr cursor_row + #puts "---c at overflow_idx=$overflow_idx" + incr cursor_row set overflow_idx $idx ;#override overflow_idx even if it was set to -1 due to expand_right = 1 set instruction lf_overflow ;#only special treatment is to give it it's own instruction in case caller needs to handle differently priv::render_unapplied $overlay_grapheme_control_list $gci @@ -2587,7 +2586,7 @@ tcl::namespace::eval overtype { #linefeed occurred in middle or at end of text #puts "---mid-or-end-text-linefeed idx:$idx overflow_idx:$overflow_idx" if {$insert_mode == 0} { - incr cursor_row + incr cursor_row if {$idx == -1 || $overflow_idx > $idx} { #don't set overflow_idx higher if it's already set lower and we're adding graphemes to overflow set overflow_idx $idx ;#override overflow_idx even if it was set to -1 due to expand_right = 1 @@ -2596,10 +2595,10 @@ tcl::namespace::eval overtype { priv::render_unapplied $overlay_grapheme_control_list $gci break } else { - incr cursor_row + incr cursor_row #don't adjust the overflow_idx priv::render_unapplied $overlay_grapheme_control_list $gci - set instruction lf_mid + set instruction lf_mid break ;# could have overdata following the \n - don't keep processing } } @@ -2608,15 +2607,15 @@ tcl::namespace::eval overtype { "" { #will we want/need to use raw for keypresses in terminal? (terminal with LNM in standard reset mode means enter= this is the usual config for terminals) #So far we are assuming the caller has translated to and handle above.. REVIEW. - + #consider also the old space-carriagereturn softwrap convention used in some terminals. - #In the context of rendering to a block of text - this works similarly in that the space gets eaten so programs emitting space-cr at the terminal width col will pretty much get what they expect. + #In the context of rendering to a block of text - this works similarly in that the space gets eaten so programs emitting space-cr at the terminal width col will pretty much get what they expect. set idx [expr {$opt_colstart -1}] set cursor_column $opt_colstart ;#? } "" { - #literal backspace char - not necessarily from keyboard - #review - backspace effect on double-width chars - we are taking a column-editing perspective in overtype + #literal backspace char - not necessarily from keyboard + #review - backspace effect on double-width chars - we are taking a column-editing perspective in overtype #(important for -transparent option - hence replacement chars for half-exposed etc) #review - overstrike support as per nroff/less (generally considered an old technology replaced by unicode mechanisms and/or ansi SGR) if {$idx > ($opt_colstart -1)} { @@ -2633,19 +2632,19 @@ tcl::namespace::eval overtype { } } "" { - #literal del character - some terminals send just this for what is generally expected to be a destructive backspace + #literal del character - some terminals send just this for what is generally expected to be a destructive backspace #We instead treat this as a pure delete at current cursor position - it is up to the repl or terminal to remap backspace key to a sequence that has the desired effect. priv::render_delchar $idx } "" { - #end processing this overline. rest of line is remainder. cursor for column as is. + #end processing this overline. rest of line is remainder. cursor for column as is. #REVIEW - this theoretically depends on terminal's vertical tabulation setting (name?) #e.g it could be configured to jump down 6 rows. #On the other hand I've seen indications that some modern terminal emulators treat it pretty much as a linefeed. #todo? incr cursor_row set overflow_idx $idx - #idx_over has already been incremented as this is both a movement-control and in some sense a grapheme + #idx_over has already been incremented as this is both a movement-control and in some sense a grapheme priv::render_unapplied $overlay_grapheme_control_list $gci set instruction vt break @@ -2667,12 +2666,12 @@ tcl::namespace::eval overtype { #change the overflow_idx set overflow_idx $idx incr idx - incr idx_over -1 ;#set overlay grapheme index back one so that sgr stack from previous overlay grapheme used + incr idx_over -1 ;#set overlay grapheme index back one so that sgr stack from previous overlay grapheme used priv::render_unapplied $overlay_grapheme_control_list [expr {$gci-1}] ;#note $gci-1 instead of just gci #throw back to caller's loop - add instruction to caller as this is not the usual case #caller may for example choose to render a single replacement char to this line and omit the grapheme, or wrap it to the next line set instruction overflow_splitchar - break + break } elseif {$owidth > 2} { #? tab? #TODO! @@ -2682,7 +2681,7 @@ tcl::namespace::eval overtype { } elseif {$idx >= $overflow_idx} { #REVIEW set next_gc [lindex $overlay_grapheme_control_list $gci+1] ;#next grapheme or control - lassign $next_gc next_type next_item + lassign $next_gc next_type next_item if {$autowrap_mode || $next_type ne "g"} { set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci-1]] #set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] @@ -2698,13 +2697,13 @@ tcl::namespace::eval overtype { #without this branch - renderline would be called with overtext reducing only by one grapheme per call #processing a potentially long overtext each time (ie - very slow) set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] - #JMN4 + #JMN4 } } } else { #review. - #overflow_idx = -1 + #overflow_idx = -1 #This corresponds to expand_right being true (at least until overflow_idx is in some cases forced to a value when throwing back to calling loop) } @@ -2723,7 +2722,7 @@ tcl::namespace::eval overtype { #JMN set uwidth [grapheme_width_cached $g] if {[lindex $outcols $idx] eq ""} { - #2nd col of 2-wide char in underlay + #2nd col of 2-wide char in underlay incr idx incr cursor_column } elseif {$uwidth == 0} { @@ -2737,11 +2736,11 @@ tcl::namespace::eval overtype { if {$owidth > 1} { incr idx incr cursor_column - } + } } elseif {$uwidth > 1} { if {[grapheme_width_cached $ch] == 1} { if {!$insert_mode} { - #normal singlewide transparent overlay onto double-wide underlay + #normal singlewide transparent overlay onto double-wide underlay set next_pt_overchar [tcl::string::index $pt_overchars $idx_over+1] ;#lookahead of next plain-text char in overlay if {$next_pt_overchar eq ""} { #special-case trailing transparent - no next_pt_overchar @@ -2752,7 +2751,7 @@ tcl::namespace::eval overtype { incr idx incr cursor_column } else { - #next overlay char is not transparent.. first-half of underlying 2wide char is exposed + #next overlay char is not transparent.. first-half of underlying 2wide char is exposed #priv::render_addchar $idx $opt_exposed1 [tcl::dict::get $overstacks $idx_over] [tcl::dict::get $overstacks_gx $idx_over] $insert_mode priv::render_addchar $idx $opt_exposed1 [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode incr idx @@ -2781,27 +2780,27 @@ tcl::namespace::eval overtype { } else { set uwidth [grapheme_width_cached $idxchar] } - if {$within_undercols} { + if {$within_undercols} { if {$idxchar eq ""} { #2nd col of 2wide char in underlay if {!$insert_mode} { - priv::render_addchar $idx $ch [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] 0 - #JMN - this has to expose if our startposn chopped an underlay - but not if we already overwrote the first half of the widechar underlay grapheme + priv::render_addchar $idx $ch [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] 0 + #JMN - this has to expose if our startposn chopped an underlay - but not if we already overwrote the first half of the widechar underlay grapheme #e.g renderline \uFF21\uFF21--- a\uFF23\uFF23 #vs # renderline -startcolumn 2 \uFF21---- \uFF23 if {[lindex $outcols $idx-1] != ""} { #verified it's an empty following a filled - so it's a legit underlay remnant (REVIEW - when would it not be??) #reset previous to an exposed 1st-half - but leave understacks code as is - priv::render_addchar [expr {$idx-1}] $opt_exposed1 [lindex $understacks $idx-1] [lindex $understacks_gx $idx-1] 0 + priv::render_addchar [expr {$idx-1}] $opt_exposed1 [lindex $understacks $idx-1] [lindex $understacks_gx $idx-1] 0 } incr idx } else { set prevcolinfo [lindex $outcols $idx-1] - #for insert mode - first replace the empty 2ndhalf char with exposed2 before shifting it right + #for insert mode - first replace the empty 2ndhalf char with exposed2 before shifting it right #REVIEW - this leaves a replacement character permanently in our columns.. but it is consistent regarding length (?) #The alternative is to disallow insertion at a column cursor that is at 2nd half of 2wide char - #perhaps by inserting after the char - this may be worthwhile - but may cause other surprises + #perhaps by inserting after the char - this may be worthwhile - but may cause other surprises #It is perhaps best avoided at another level and try to make renderline do exactly as it's told #the advantage of this 2w splitting method is that the inserted character ends up in exactly the column we expect. priv::render_addchar $idx $opt_exposed2 [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] 0 ;#replace not insert @@ -2870,7 +2869,7 @@ tcl::namespace::eval overtype { } else { #2wide over 2wide priv::render_addchar $idx $ch [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode - incr idx 2 + incr idx 2 incr cursor_column 2 } @@ -2902,7 +2901,7 @@ tcl::namespace::eval overtype { #prefix the unapplied controls with the string version of this control set unapplied_list [linsert $unapplied_list 0 {*}[split $chars ""]] set unapplied [join $unapplied_list ""] - + break } } @@ -2919,8 +2918,8 @@ tcl::namespace::eval overtype { set c1 [tcl::string::index $code 0] set c1c2c3 [tcl::string::range $code 0 2] - #set re_ST_open {(?:\033P|\u0090|\033X|\u0098|\033\^|\u009e|\033_|\u009f)} - #tcl 8.7 - faster to use inline list than to store it in a local var outside of loop. + #set re_ST_open {(?:\033P|\u0090|\033X|\u0098|\033\^|\u009e|\033_|\u009f)} + #tcl 8.7 - faster to use inline list than to store it in a local var outside of loop. #(somewhat surprising) set leadernorm [tcl::string::range [tcl::string::map [list\ \x1b\[< 1006\ @@ -2932,9 +2931,9 @@ tcl::namespace::eval overtype { \x1b\] 7OSC\ \x9d 8OSC\ \x1b 7ESC\ - ] $c1c2c3] 0 3] ;#leadernorm is 1st 1,2 or 3 chars mapped to 4char normalised indicator - or is original first chars (1,2 or 3 len) + ] $c1c2c3] 0 3] ;#leadernorm is 1st 1,2 or 3 chars mapped to 4char normalised indicator - or is original first chars (1,2 or 3 len) - #we leave the tail of the code unmapped for now + #we leave the tail of the code unmapped for now switch -- $leadernorm { 1006 { #https://invisible-island.net/xterm/ctlseqs/ctlseqs.html @@ -2956,7 +2955,7 @@ tcl::namespace::eval overtype { } 7MAP { #map to another type of code to share implementation branch - set codenorm $leadernorm[tcl::string::range $code 1 end] + set codenorm $leadernorm[tcl::string::range $code 1 end] } 7ESC { #set codenorm [tcl::string::cat $leadernorm [tcl::string::range $code 1 end]] @@ -2968,7 +2967,7 @@ tcl::namespace::eval overtype { default { puts stderr "Sequence detected as ANSI, but not handled in leadernorm switch. code: [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" #we haven't made a mapping for this - #could in theory be 1,2 or 3 in len + #could in theory be 1,2 or 3 in len #although we shouldn't be getting here if the regexp for ansi codes is kept in sync with our switch branches set codenorm $code } @@ -2984,7 +2983,7 @@ tcl::namespace::eval overtype { #shouldn't really get here or need this branch if ansi splitting was done correctly puts stderr "overtype::renderline ESC Y recognised as vt52 move, but incorrect parameters length ([string length $params] vs expected 2) [ansistring VIEW -lf 1 -vt 1 -nul 1 $code] not implemented codenorm:[ansistring VIEW -lf 1 -vt 1 -nul 1 $codenorm]" } - set line [tcl::string::index $params 5] + set line [tcl::string::index $params 5] set column [tcl::string::index $params 1] set r [expr {[scan $line %c] -31}] set c [expr {[scan $column %c] -31}] @@ -3023,7 +3022,7 @@ tcl::namespace::eval overtype { #Row move - up set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] #todo - lassign [split $param {;}] num modifierkey + lassign [split $param {;}] num modifierkey if {$modifierkey ne ""} { puts stderr "modifierkey:$modifierkey" } @@ -3040,12 +3039,12 @@ tcl::namespace::eval overtype { priv::render_unapplied $overlay_grapheme_control_list $gci set instruction up #retain cursor_column - break + break } B { #CUD - Cursor Down #Row move - down - lassign [split $param {;}] num modifierkey + lassign [split $param {;}] num modifierkey set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] #move down if {$modifierkey ne ""} { @@ -3055,11 +3054,11 @@ tcl::namespace::eval overtype { incr cursor_row $num - incr idx_over ;#idx_over hasn't encountered a grapheme and hasn't advanced yet + incr idx_over ;#idx_over hasn't encountered a grapheme and hasn't advanced yet priv::render_unapplied $overlay_grapheme_control_list $gci set instruction down #retain cursor_column - break + break } C { #CUF - Cursor Forward @@ -3068,13 +3067,13 @@ tcl::namespace::eval overtype { #todo - consider right-to-left cursor mode (e.g Hebrew).. some day. #cursor forward #right-arrow/move forward - lassign [split $param {;}] num modifierkey + lassign [split $param {;}] num modifierkey if {$modifierkey ne ""} { puts stderr "modifierkey:$modifierkey" } if {$num eq ""} {set num 1} - - #todo - retrict to moving 1 position past datalen? restrict to column width? + + #todo - retrict to moving 1 position past datalen? restrict to column width? #should ideally wrap to next line when interactive and not on last row #(some ansi art seems to expect this behaviour) #This presumably depends on the terminal's wrap mode @@ -3107,14 +3106,14 @@ tcl::namespace::eval overtype { #we may have both overflow_right and unapplied data #(can have overflow_right if we were in insert_mode and processed chars prior to this movement) #leave row as is - caller will need to determine how many rows the column-movement has consumed - incr cursor_column $num ;#give our caller the necessary info as columns from start of row + incr cursor_column $num ;#give our caller the necessary info as columns from start of row #incr idx_over - #should be gci following last one applied + #should be gci following last one applied priv::render_unapplied $overlay_grapheme_control_list $gci set instruction wrapmoveforward break } else { - set cursor_column $max + set cursor_column $max set idx [expr {$cursor_column -1}] } } @@ -3129,7 +3128,7 @@ tcl::namespace::eval overtype { #overtype mode set idxstart $idx set idxend [llength $outcols] - set moveend [expr {$idxend - $idxstart}] + set moveend [expr {$idxend - $idxstart}] if {$moveend < 0} {set moveend 0} ;#sanity? #puts "idxstart:$idxstart idxend:$idxend outcols[llength $outcols] undercols:[llength $undercols]" incr idx $moveend @@ -3151,7 +3150,7 @@ tcl::namespace::eval overtype { set gxstackinfo [list] } #pad outcols - set movemore [expr {$num - $moveend}] + set movemore [expr {$num - $moveend}] #assert movemore always at least 1 or we wouldn't be in this branch for {set m 1} {$m <= $movemore} {incr m} { incr idx @@ -3159,7 +3158,7 @@ tcl::namespace::eval overtype { priv::render_addchar $idx " " $stackinfo $gxstackinfo $insert_mode } } else { - #normal - insert + #normal - insert incr idx $num incr cursor_column $num if {$idx > [llength $outcols]} { @@ -3169,13 +3168,13 @@ tcl::namespace::eval overtype { } } } - } + } D { #Col move #puts stdout "<-back" #cursor back #left-arrow/move-back when ltr mode - lassign [split $param {;}] num modifierkey + lassign [split $param {;}] num modifierkey if {$modifierkey ne ""} { puts stderr "modifierkey:$modifierkey" } @@ -3189,7 +3188,7 @@ tcl::namespace::eval overtype { incr cursor_column -$num } else { if {!$autowrap_mode} { - set cursor_column 1 + set cursor_column 1 set idx 0 } else { set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] @@ -3239,7 +3238,7 @@ tcl::namespace::eval overtype { set cursor_row [expr {$cursor_row -$upmove}] if {$cursor_row < 1} { set cursor_row 1 - } + } set idx [expr {$cursor_column - 1}] set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] incr idx_over @@ -3269,9 +3268,8 @@ tcl::namespace::eval overtype { } #adjust to colstart - as column 1 is within overlay #??? REVIEW - set idx [expr {($targetcol -1) + $opt_colstart -1}] - - + set idx [expr {($targetcol -1) + $opt_colstart -1}] + set cursor_column $targetcol #puts stderr "renderline absolute col move ESC G (TEST)" } @@ -3280,7 +3278,7 @@ tcl::namespace::eval overtype { #CSI n;m f - HVP - Horizontal Vertical Position REVIEW - same as CUP with differences (what?) in some terminal modes # - 'counts as effector format function (like CR or LF) rather than an editor function (like CUD or CNL)' - # - REVIEW + # - REVIEW #see Annex A at: https://www.ecma-international.org/wp-content/uploads/ECMA-48_5th_edition_june_1991.pdf #test e.g ansicat face_2.ans @@ -3288,7 +3286,7 @@ tcl::namespace::eval overtype { lassign [split $param {;}] paramrow paramcol #missing defaults to 1 #CSI ;5H = CSI 1;5H -> row 1 col 5 - #CSI 17;H = CSI 17H = CSI 17;1H -> row 17 col 1 + #CSI 17;H = CSI 17H = CSI 17;1H -> row 17 col 1 if {$paramcol eq ""} {set paramcol 1} if {$paramrow eq ""} {set paramrow 1} @@ -3298,7 +3296,7 @@ tcl::namespace::eval overtype { } else { set max [llength $outcols] if {$overflow_idx == -1} { - incr max + incr max } if {$paramcol > $max} { set target_column $max @@ -3331,7 +3329,7 @@ tcl::namespace::eval overtype { } } J { - set modegroup [tcl::string::index $codenorm 4] ;#e.g ? + set modegroup [tcl::string::index $codenorm 4] ;#e.g ? switch -exact -- $modegroup { ? { #CSI ? Pn J - selective erase @@ -3339,7 +3337,7 @@ tcl::namespace::eval overtype { } default { puts stderr "overtype::renderline ED - ERASE IN DISPLAY (TESTING) [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" - if {$param eq ""} {set param 0} + if {$param eq ""} {set param 0} switch -exact -- $param { 0 { #clear from cursor to end of screen @@ -3375,12 +3373,12 @@ tcl::namespace::eval overtype { } K { #see DECECM regarding background colour - set modegroup [tcl::string::index $codenorm 4] ;#e.g ? + set modegroup [tcl::string::index $codenorm 4] ;#e.g ? switch -exact -- $modegroup { ? { puts stderr "overtype::renderline DECSEL - SELECTIVE ERASE IN LINE (UNIMPLEMENTED) [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" set param [string range $param 1 end] ;#chop qmark - if {$param eq ""} {set param 0} + if {$param eq ""} {set param 0} switch -exact -- $param { 0 { #clear from cursor to end of line - depending on DECSCA @@ -3400,7 +3398,7 @@ tcl::namespace::eval overtype { } default { puts stderr "overtype::renderline EL - ERASE IN LINE (TESTING) [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" - if {$param eq ""} {set param 0} + if {$param eq ""} {set param 0} switch -exact -- $param { 0 { #clear from cursor to end of line @@ -3431,7 +3429,7 @@ tcl::namespace::eval overtype { #CSI Pn T - SD Pan Up (empty lines introduced at top) #CSI Pn+T - kitty extension (lines at top come from scrollback buffer) #Pn new lines appear at top of the display, Pn old lines disappear at the bottom of the display - if {$param eq "" || $param eq "0"} {set param 1} + if {$param eq "" || $param eq "0"} {set param 1} if {[string index $param end] eq "+"} { puts stderr "overtype::renderline CSI Pn + T - kitty Pan Up - not implemented [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" } else { @@ -3442,7 +3440,7 @@ tcl::namespace::eval overtype { puts stderr "overtype::renderline X ECH ERASE CHARACTER - $param" #ECH - erase character if {$param eq "" || $param eq "0"} {set param 1}; #param=count of chars to erase - priv::render_erasechar $idx $param + priv::render_erasechar $idx $param #cursor position doesn't change. } q { @@ -3499,14 +3497,14 @@ tcl::namespace::eval overtype { if {$param ne ""} { #DECSLRM - should only be recognised if DECLRMM is set (vertical split screen mode) - lassign [split $param {;} margin_left margin_right + lassign [split $param {;}] margin_left margin_right puts stderr "overtype DECSLRM not yet supported - got [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" if {$margin_left eq ""} { set margin_left 1 } set columns_per_page 80 ;#todo - set to 'page width (DECSCPP set columns per page)' - could be 132 or?? if {$margin_right eq ""} { - set margin_right $columns_per_page + set margin_right $columns_per_page } puts stderr "DECSLRM margin left: $margin_left margin right: $margin_right" if {![string is integer -strict $margin_left] || $margin_left < 0} { @@ -3519,7 +3517,7 @@ tcl::namespace::eval overtype { if {$scrolling_region_size < 2 || $scrolling_region_size > $columns_per_page} { puts stderr "DECSLRM region size '$scrolling_regsion_size' must be between 1 and $columns_per_page" } - #todo + #todo } else { @@ -3535,7 +3533,7 @@ tcl::namespace::eval overtype { #any single shift 2 (SS2) or single shift 3(SSD) functions sent #$re_cursor_save - #cursor save could come after last column + #cursor save could come after last column if {$overflow_idx != -1 && $idx == $overflow_idx} { #bartman2.ans test file - fixes misalignment at bottom of dialog bubble #incr cursor_row @@ -3546,12 +3544,12 @@ tcl::namespace::eval overtype { set cursor_saved_position [list row $cursor_row column $cursor_column] } #there may be overlay stackable codes emitted that aren't in the understacks because they come between the last emmited character and the cursor_save control. - #we need the SGR and gx overlay codes prior to the cursor_save + #we need the SGR and gx overlay codes prior to the cursor_save #a real terminal would not be able to know the state of the underlay.. so we should probably ignore it. #set sgr_stack [lindex $understacks $idx] #set gx_stack [lindex $understacks_gx $idx] ;#not actually a stack - just a boolean state (for now?) - + set sgr_stack [list] set gx_stack [list] @@ -3559,12 +3557,12 @@ tcl::namespace::eval overtype { #The overlay_grapheme_control_list had leading resets from previous lines - so we go back to the beginning not just the first grapheme. foreach gc [lrange $overlay_grapheme_control_list 0 $gci-1] { - lassign $gc type code + lassign $gc type code #types g other sgr gx0 switch -- $type { gx0 { #code is actually a stand-in for the graphics on/off code - not the raw code - #It is either gx0_on or gx0_off + #It is either gx0_on or gx0_off set gx_stack [list $code] } sgr { @@ -3600,7 +3598,7 @@ tcl::namespace::eval overtype { #as there is apparently only one cursor storage element we don't need to throw back to the calling loop for a save. #don't incr index - or the save will cause cursor to move to the right - #carry on + #carry on } } u { @@ -3613,7 +3611,7 @@ tcl::namespace::eval overtype { #we only want to jump and render the unapplied at the new location. #lset overstacks $idx_over [list] - #set replay_codes_overlay "" + #set replay_codes_overlay "" #if {$cursor_saved_attributes ne ""} { # set replay_codes_overlay $cursor_saved_attributes ;#empty - or last save if it happend in this input chunk @@ -3622,8 +3620,8 @@ tcl::namespace::eval overtype { #set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] set replay_codes_overlay "" #} - - #like priv::render_unapplied - but without the overlay's ansi reset or gx stacks from before the restore code + + #like priv::render_unapplied - but without the overlay's ansi reset or gx stacks from before the restore code incr idx_over set unapplied "" @@ -3642,8 +3640,8 @@ tcl::namespace::eval overtype { #incr idx_over } set unapplied [join $unapplied_list ""] - #if the save occured within this line - that's ok - it's in the return value list and caller can prepend for the next loop. - set instruction restore_cursor + #if the save occured within this line - that's ok - it's in the return value list and caller can prepend for the next loop. + set instruction restore_cursor break } "{" { @@ -3662,10 +3660,10 @@ tcl::namespace::eval overtype { } } ~ { - set code_secondlast [tcl::string::index $codenorm end-1] ;#used for e.g CSI x '~ + set code_secondlast [tcl::string::index $codenorm end-1] ;#used for e.g CSI x '~ switch -exact -- $code_secondlast { ' { - #DECDC - editing sequence - Delete Column + #DECDC - editing sequence - Delete Column puts stderr "renderline warning - DECDC - unimplemented" } default { @@ -3677,7 +3675,7 @@ tcl::namespace::eval overtype { #e.g esc \[2~ insert esc \[2;2~ shift-insert #mod - subtract 1, and then use bitmask #shift = 1, (left)Alt = 2, control=4, meta=8 (meta seems to do nothing on many terminals on windows? Intercepted by windows?) - #puts stderr "vt key:$key mod:$mod code:[ansistring VIEW $code]" + #puts stderr "vt key:$key mod:$mod code:[ansistring VIEW $code]" if {$key eq "1"} { #home } elseif {$key eq "2"} { @@ -3744,7 +3742,7 @@ tcl::namespace::eval overtype { #set mode unset mode #we are matching only last char to get to this arm - but are there other sequences ending in h|l we need to handle? - #$re_mode if first after CSI is "?" + #$re_mode if first after CSI is "?" #some docs mention ESC=h|l - not seen on windows terminals.. review #e.g https://www2.math.upenn.edu/~kazdan/210/computer/ansi.html set modegroup [tcl::string::index $codenorm 4] ;#e.g ? = @@ -3774,15 +3772,15 @@ tcl::namespace::eval overtype { } 7 { - #DECAWM autowrap + #DECAWM autowrap if {$code_end eq "h"} { #set (enable) set autowrap_mode 1 if {$opt_width ne "\uFFEF"} { set overflow_idx $opt_width } else { - #review - this is also the cursor position when adding a char at end of line? - set overflow_idx [expr {[llength $undercols]}] ;#index at which we would be *in* overflow a row move may still override it + #review - this is also the cursor position when adding a char at end of line? + set overflow_idx [expr {[llength $undercols]}] ;#index at which we would be *in* overflow a row move may still override it } #review - can idx ever be beyond overflow_idx limit when we change e.g with a width setting and cursor movements? # presume not usually - but sanity check with warning for now. @@ -3832,7 +3830,7 @@ tcl::namespace::eval overtype { puts stderr "CRM MODE $code_end" #CRM - Show control character mode # 'No control functions are executed except LF,FF and VT which are represented in the CRM FONT before a CRLF(new line) is executed' - # + # #use ansistring VIEW -nul 1 -lf 2 -ff 2 -vt 2 #https://vt100.net/docs/vt510-rm/CRM.html #NOTE - vt100 CRM always does auto-wrap at right margin. @@ -3847,8 +3845,8 @@ tcl::namespace::eval overtype { if {$opt_width ne "\uFFEF"} { set overflow_idx $opt_width } else { - #review - this is also the cursor position when adding a char at end of line? - set overflow_idx [expr {[llength $undercols]}] ;#index at which we would be *in* overflow a row move may still override it + #review - this is also the cursor position when adding a char at end of line? + set overflow_idx [expr {[llength $undercols]}] ;#index at which we would be *in* overflow a row move may still override it } } else { set crm_mode 0 @@ -3884,10 +3882,10 @@ tcl::namespace::eval overtype { set page_width -1 ;#flag as unset if {$param eq ""} { set page_width 80 - } elseif {[string is integer -strict $param] && $param >=2 0} { + } elseif {[string is integer -strict $param] && $param >=2} { set page_width [expr {$param}] ;#we should allow leading zeros in the number - but lets normalize using expr } else { - puts stderr "overtype::renderline unacceptable DECSPP value '$param'" + puts stderr "overtype::renderline unacceptable DECSPP value '$param'" } if {$page_width > 2} { @@ -3905,19 +3903,19 @@ tcl::namespace::eval overtype { default { puts stderr "overtype::renderline CSI code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code] not implemented" } - } - } + } + } 7ESC { # #re_other_single {\x1b(D|M|E)$} - #also vt52 Y.. + #also vt52 Y.. #also PM \x1b^...(ST) switch -- [tcl::string::index $codenorm 4] { c { #RIS - reset terminal to initial state - where 'terminal' in this case is the renderspace - not the underlying terminal! puts stderr "renderline reset" priv::render_unapplied $overlay_grapheme_control_list $gci - set instruction reset + set instruction reset break } D { @@ -3925,11 +3923,11 @@ tcl::namespace::eval overtype { #index (IND) #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 + incr cursor_row priv::render_unapplied $overlay_grapheme_control_list $gci set instruction down #retain cursor_column - break + break } E { #\x85 @@ -3937,7 +3935,7 @@ tcl::namespace::eval overtype { #todo - possibly(?) same logic as handling above. i.e return instruction depends on where column_cursor is at the time we get NEL #leave implementation until logic for is set in stone... still under review #It's arguable NEL is a pure cursor movement as opposed to the semantic meaning of crlf or lf in a file. - # + # #Next Line (NEL) "Move the cursor to the left margin on the next line. If the cursor is at the bottom margin, scroll the page up" puts stderr "overtype::renderline ESC E unimplemented" @@ -3963,7 +3961,7 @@ tcl::namespace::eval overtype { priv::render_unapplied $overlay_grapheme_control_list $gci set instruction up ;#need instruction for scroll-down? #retain cursor_column - break + break } N { #\x8e - affects next character only @@ -3976,7 +3974,7 @@ tcl::namespace::eval overtype { P { #\x90 #DCS - shouldn't get here - handled in 7DCS branch - #similarly \] OSC (\x9d) and \\ (\x9c) ST + #similarly \] OSC (\x9d) and \\ (\x9c) ST } V { #\x96 @@ -4008,11 +4006,11 @@ tcl::namespace::eval overtype { } #We don't want to render it - but we need to make it available to the application #see the textblock library in punk, for the exception we make here for single backspace. - #It is unlikely to be encountered as a useful PM - so we hack to pass it through as a fix + #It is unlikely to be encountered as a useful PM - so we hack to pass it through as a fix #for spacing issues on old terminals which miscalculate the single-width 'Symbols for Legacy Computing' if {$pm_content eq "\b"} { #puts stderr "renderline PM sole backspace special handling for \U1FB00 - \U1FBFF" - #esc^\b\007 or esc^\besc\\ + #esc^\b\007 or esc^\besc\\ #HACKY pass-through - targeting terminals that both mis-space legacy symbols *and* don't support PMs #The result is repair of the extra space. If the terminal is a modern one and does support PM - the \b should be hidden anyway. #If the terminal has the space problem AND does support PMs - then this just won't fix it. @@ -4038,9 +4036,9 @@ tcl::namespace::eval overtype { } 7DCS - 8DCS { puts stderr "overtype::renderline DCS - DEVICE CONTROL STRING command UNIMPLEMENTED. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" - #ST (string terminator) \x9c or \x1b\\ + #ST (string terminator) \x9c or \x1b\\ if {[tcl::string::index $codenorm end] eq "\x9c"} { - set code_content [tcl::string::range $codenorm 4 end-1] ;#ST is 8-bit 0x9c + set code_content [tcl::string::range $codenorm 4 end-1] ;#ST is 8-bit 0x9c } else { set code_content [tcl::string::range $codenorm 4 end-2] ;#ST is \x1b\\ } @@ -4070,11 +4068,11 @@ tcl::namespace::eval overtype { 4 { #OSC 4 - set colour palette #can take multiple params - #e.g \x1b\]4\;1\;red\;2\;green\x1b\\ + #e.g \x1b\]4\;1\;red\;2\;green\x1b\\ set params [tcl::string::range $code_content 2 end] ;#strip 4 and first semicolon set cmap [dict create] foreach {cnum spec} [split $params {;}] { - if {$cnum >= 0 and $cnum <= 255} { + if {$cnum >= 0 && $cnum <= 255} { #todo - parse spec from names like 'red' to RGB #todo - accept rgb:ab/cd/ef as well as rgb:/a/b/c (as alias for aa/bb/cc) #also - what about rgb:abcd/defg/hijk and 12-bit abc/def/ghi ? @@ -4087,12 +4085,12 @@ tcl::namespace::eval overtype { puts stderr "overtype::renderline OSC 4 set colour palette unimplemented. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" - + } 10 - 11 - 12 - 13 - 14 - 15 - 16 - 17 { #OSC 10 through 17 - so called 'dynamic colours' #can take multiple params - each successive parameter changes the next colour in the list - #- e.g if code started at 11 - next param is for 12. 17 takes only one param because there are no more + #- e.g if code started at 11 - next param is for 12. 17 takes only one param because there are no more #10 change text foreground colour #11 change text background colour #12 change text cursor colour @@ -4102,7 +4100,7 @@ tcl::namespace::eval overtype { #16 change tektronix background colour #17 change highlight colour set params [tcl::string::range $code_content 2 end] - + puts stderr "overtype::renderline OSC $osc_code set dynamic colours unimplemented. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" @@ -4128,7 +4126,7 @@ tcl::namespace::eval overtype { break } 1337 { - #iterm2 graphics and file transfer + #iterm2 graphics and file transfer puts stderr "overtype::renderline OSC 1337 iterm2 graphics/file_transfer unimplemented. 1st 100 chars of code [ansistring VIEW -lf 1 -vt 1 -nul 1 [string range $code 0 99]]" } 5113 { @@ -4147,7 +4145,7 @@ tcl::namespace::eval overtype { } default { - #don't need to handle sgr or gx0 types + #don't need to handle sgr or gx0 types #we have our sgr gx0 codes already in stacks for each overlay grapheme } } @@ -4180,7 +4178,7 @@ tcl::namespace::eval overtype { #how does caller avoid an infinite loop if they have autowrap on and keep throwing graphemes to the next line? REVIEW set in_overflow 1 } - set trailing_nulls 0 + set trailing_nulls 0 foreach ch [lreverse $outcols] { if {$ch eq "\u0000"} { incr trailing_nulls @@ -4279,7 +4277,7 @@ tcl::namespace::eval overtype { if {$trailing_nulls && $i < $first_tail_null_posn} { append outstring " " ;#map inner nulls to space } else { - append outstring \u0000 + append outstring \u0000 } } } else { @@ -4296,13 +4294,13 @@ tcl::namespace::eval overtype { # # set outstring [tcl::string::trimright $outstring "\u0000"] # #} # set outstring [tcl::string::trimright $outstring "\u0000"] - # set outstring [tcl::string::map {\u0000 " "} $outstring] + # set outstring [tcl::string::map {\u0000 " "} $outstring] #} #REVIEW #set overflow_right [tcl::string::trimright $overflow_right "\u0000"] - #set overflow_right [tcl::string::map {\u0000 " "} $overflow_right] + #set overflow_right [tcl::string::map {\u0000 " "} $overflow_right] set replay_codes "" if {[llength $understacks] > 0} { @@ -4330,12 +4328,12 @@ tcl::namespace::eval overtype { #pdict $understacks if {[punk::ansi::ta::detect_sgr $outstring]} { - append outstring [punk::ansi::a] ;#without this - we would get for example, trailing backgrounds after rightmost column + append outstring [punk::ansi::a] ;#without this - we would get for example, trailing backgrounds after rightmost column #close off any open gx? - #probably should - and overflow_right reopen? + #probably should - and overflow_right reopen? } - + if {$opt_returnextra} { #replay_codes is the codestack at the boundary - used for ellipsis colouring to match elided text - review #replay_codes_underlay is the set of codes in effect at the very end of the original underlay @@ -4383,11 +4381,11 @@ tcl::namespace::eval overtype { set viewop VIEW switch -- $opt_returnextra { 2 { - #codes and character data + #codes and character data set viewop VIEWCODES ;#ansi colorisation of codes - green for SGR, blue/blue reverse for cursor_save/cursor_restore, cyan for movements, orange for others } 3 { - set viewop VIEWSTYLE ;#ansi colorise the characters within the output with preceding codes, stacking codes only within each dict value - may not be same SGR effect as the effect in-situ. + set viewop VIEWSTYLE ;#ansi colorise the characters within the output with preceding codes, stacking codes only within each dict value - may not be same SGR effect as the effect in-situ. } } tcl::dict::set result result [ansistring $viewop -lf 1 -vt 1 [tcl::dict::get $result result]] @@ -4397,7 +4395,7 @@ tcl::namespace::eval overtype { tcl::dict::set result replay_codes [ansistring $viewop -lf 1 -vt 1 [tcl::dict::get $result replay_codes]] tcl::dict::set result replay_codes_underlay [ansistring $viewop -lf 1 -vt 1 [tcl::dict::get $result replay_codes_underlay]] tcl::dict::set result replay_codes_overlay [ansistring $viewop -lf 1 -vt 1 [tcl::dict::get $result replay_codes_overlay]] - tcl::dict::set result cursor_saved_attributes [ansistring $viewop -lf 1 -vt 1 [tcl::dict::get $result cursor_saved_attributes]] + tcl::dict::set result cursor_saved_attributes [ansistring $viewop -lf 1 -vt 1 [tcl::dict::get $result cursor_saved_attributes]] return $result } } else { @@ -4409,7 +4407,7 @@ tcl::namespace::eval overtype { #*** !doctools #[list_end] [comment {--- end definitions namespace overtype ---}] -} +} tcl::namespace::eval overtype::piper { proc overcentre {args} { @@ -4457,7 +4455,7 @@ tcl::namespace::eval overtype::piper { tailcall overtype::renderline {*}$argsflags $under $over } } -interp alias "" piper_renderline "" overtype::piper::renderline +interp alias "" piper_renderline "" overtype::piper::renderline #intended primarily for single grapheme - but will work for multiple #WARNING: query CAN contain ansi or newlines - but if cache was not already set manually,the answer will be incorrect! @@ -4506,7 +4504,7 @@ proc overtype::blocksize {textblock} { set width [tcl::mathfunc::max {*}[lmap v [split $textblock \n] {::punk::char::ansifreestring_width $v}]] } else { set num_le 0 - set width [punk::char::ansifreestring_width $textblock] + set width [punk::char::ansifreestring_width $textblock] } #our concept of block-height is likely to be different to other line-counting mechanisms set height [expr {$num_le + 1}] ;# one line if no le - 2 if there is one trailing le even if no data follows le @@ -4524,7 +4522,7 @@ tcl::namespace::eval overtype::priv { variable cache_is_sgr if {[tcl::dict::exists $cache_is_sgr $code]} { return [tcl::dict::get $cache_is_sgr $code] - } + } set answer [punk::ansi::codetype::is_sgr $code] tcl::dict::set cache_is_sgr $code $answer return $answer @@ -4572,7 +4570,7 @@ tcl::namespace::eval overtype::priv { set unapplied [join $unapplied_list ""] } - #clearer - renders the specific gci forward as unapplied - prefixed with it's merged sgr stack + #clearer - renders the specific gci forward as unapplied - prefixed with it's merged sgr stack proc render_this_unapplied {overlay_grapheme_control_list gci} { upvar idx_over idx_over upvar unapplied unapplied @@ -4671,9 +4669,9 @@ tcl::namespace::eval overtype::priv { if {$existing eq "\0"} { lset o $i $c } else { - lset o $i $existing$c + lset o $i $existing$c } - } + } #is actually addgrapheme? proc render_addchar {i c sgrstack gx0stack {insert_mode 0}} { upvar outcols o @@ -4695,7 +4693,7 @@ tcl::namespace::eval overtype::priv { #note we can't just look for \x1b\[7m or \x1b\[27m # it may be a more complex sequence like \x1b\[0\;\;7\;31m etc - set existing_reverse_state 0 + set existing_reverse_state 0 set codeinfo [punk::ansi::codetype::sgr_merge $sgrstack -info 1] set codestate_reverse [dict get $codeinfo codestate reverse] switch -- $codestate_reverse { @@ -4718,13 +4716,13 @@ tcl::namespace::eval overtype::priv { set sgrstack [list [dict get $codeinfo mergeresult] $rflip] #set sgrstack [punk::ansi::codetype::sgr_merge [list [dict get $codeinfo mergeresult] $rflip]] } - + # -- --- --- - set nxt [llength $o] + set nxt [llength $o] if {!$insert_mode} { if {$i < $nxt} { - #These lists must always be in sync + #These lists must always be in sync lset o $i $c } else { lappend o $c @@ -4759,14 +4757,14 @@ tcl::namespace::eval overtype::priv { # -- --- --- --- --- --- --- --- --- --- --- tcl::namespace::eval overtype { - interp alias {} ::overtype::center {} ::overtype::centre + interp alias {} ::overtype::center {} ::overtype::centre } # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready +## Ready package provide overtype [tcl::namespace::eval overtype { variable version - set version 1.6.6 + set version 1.7.1 }] return diff --git a/src/bootsupport/modules/pattern-1.2.4.tm b/src/bootsupport/modules/pattern-1.2.4.tm deleted file mode 100644 index d6a9c932..00000000 --- a/src/bootsupport/modules/pattern-1.2.4.tm +++ /dev/null @@ -1,1285 +0,0 @@ -#PATTERN -# - A prototype-based Object system. -# -# Julian Noble 2003 -# License: Public domain -# - -# "I need pattern" - Lexx Series 1 Episode 3 - Eating Pattern. -# -# -# Pattern uses a mixture of class-based and prototype-based object instantiation. -# -# A pattern object has 'properties' and 'methods' -# The system makes a distinction between them with regards to the access syntax for write operations, -# and yet provides unity in access syntax for read operations. -# e.g >object . myProperty -# will return the value of the property 'myProperty' -# >ojbect . myMethod -# will return the result of the method 'myMethod' -# contrast this with the write operations: -# set [>object . myProperty .] blah -# >object . myMethod blah -# however, the property can also be read using: -# set [>object . myProperty .] -# Note the trailing . to give us a sort of 'reference' to the property. -# this is NOT equivalent to -# set [>object . myProperty] -# This last example is of course calling set against a standard variable whose name is whatever value is returned by reading the property -# i.e it is equivalent in this case to: set blah - -#All objects are represented by a command, the name of which contains a leading ">". -#Any commands in the interp which use this naming convention are assumed to be a pattern object. -#Use of non-pattern commands containing this leading character is not supported. (Behaviour is undefined) - -#All user-added properties & methods of the wrapped object are accessed -# using the separator character "." -#Metamethods supplied by the patterm system are accessed with the object command using the metamethod separator ".." -# e.g to instantiate a new object from an existing 'pattern' (the equivalent of a class or prototype) -# you would use the 'Create' metamethod on the pattern object like so: -# >MyFactoryClassOrPrototypeLikeThing .. Create >NameOfNewObject -# '>NameOfNewObject' is now available as a command, with certain inherited methods and properties -# of the object it was created from. ( - - -#The use of the access-syntax separator character "." allows objects to be kept -# 'clean' in the sense that the only methods &/or properties that can be called this way are ones -# the programmer(you!) put there. Existing metamethods such as 'Create' are accessed using a different syntax -# so you are free to implement your own 'Create' method on your object that doesn't conflict with -# the metamethod. - -#Chainability (or how to violate the Law of Demeter!) -#The . access-syntax gives TCL an OO syntax more closely in line with many OO systems in other -# languages such as Python & VB, and allows left to right keyboard-entry of a deeply nested object-reference -# structure, without the need to regress to enter matching brackets as is required when using -# standard TCL command syntax. -# ie instead of: -# [[[object nextObject] getItem 4] getItem [chooseItemNumber]] doSomething -# we can use: -# >object . nextObject . getItem 4 . getItem [chooseItemNumber] . doSomething -# -# This separates out the object-traversal syntax from the TCL command syntax. - -# . is the 'traversal operator' when it appears between items in a commandlist -# . is the 'reference operator' when it is the last item in a commandlist -# , is the 'index traversal operator' (or 'nest operator') - mathematically it marks where there is a matrix 'partition'. -# It marks breaks in the multidimensional structure that correspond to how the data is stored. -# e.g obj . arraydata x y , x1 y1 z1 -# represents an element of a 5-dimensional array structured as a plane of cubes -# e.g2 obj . arraydata x y z , x1 y1 -# represents an element of a 5-dimensional array structured as a cube of planes -# The underlying storage for e.g2 might consist of something such as a Tcl array indexed such as cube($x,$y,$z) where each value is a patternlib::>matrix object with indices x1 y1 -# .. is the 'meta-traversal operator' when it appears between items in a commandlist -# .. is the 'meta-info operator'(?) when it is the last item in a commandlist - - -#!todo - Duck Typing: http://en.wikipedia.org/wiki/Duck_typing -# implement iStacks & pStacks (interface stacks & pattern stacks) - -#see also: Using namsepace ensemble without a namespace: http://wiki.tcl.tk/16975 - - -#------------------------------------------------------------ -# System objects. -#------------------------------------------------------------ -#::p::-1 ::p::internals::>metaface -#::p::0 ::p::ifaces::>null -#::p::1 ::>pattern -#------------------------------------------------------------ - -#TODO - -#investigate use of [namespace path ... ] to resolve command lookup (use it to chain iStacks?) - - -#CHANGES -#2018-09 - v 1.2.2 -# varied refactoring -# Changed invocant datastructure curried into commands (the _ID_ structure) -# Changed MAP structure to dict -# Default Method no longer magic "item" - must be explicitly set with .. DefaultMethod (or .. PatternDefaultMethod for patterns) -# updated test suites -#2018-08 - v 1.2.1 -# split ::p::predatorX functions into separate files (pkgs) -# e.g patternpredator2-1.0.tm -# patternpredator1-1.0 - split out but not updated/tested - probably obsolete and very broken -# -#2017-08 - v 1.1.6 Fairly big overhaul -# New predator function using coroutines -# Added bang operator ! -# Fixed Constructor chaining -# Added a few tests to test::pattern -# -#2008-03 - preserve ::errorInfo during var writes - -#2007-11 -#Major overhaul + new functionality + new tests v 1.1 -# new dispatch system - 'predator'. -# (preparing for multiple interface stacks, multiple invocants etc) -# -# -#2006-05 -# Adjusted 'var' expansion to use the new tcl8.5 'namespace upvar $ns v1 n1 v2 n2 ... ' feature. -# -#2005-12 -# Adjusted 'var' expansion in method/constructor etc bodies to be done 'inline' where it appears rather than aggregated at top. -# -# Fixed so that PatternVariable default applied on Create. -# -# unified interface/object datastructures under ::p:::: instead of seperate ::p::IFACE:::: -# - heading towards multiple-interface objects -# -#2005-10-28 -# 1.0.8.1 passes 80/80 tests -# >object .. Destroy - improved cleanup of interfaces & namespaces. -# -#2005-10-26 -# fixes to refsync (still messy!) -# remove variable traces on REF vars during .. Destroy -# passes 76/76 -# -#2005-10-24 -# fix objectRef_TraceHandler so that reading a property via an object reference using array syntax will call a PropertyRead function if defined. -# 1.0.8.0 now passes 75/76 -# -#2005-10-19 -# Command alias introduced by @next@ is now placed in the interfaces namespace. (was unnamespaced before) -# changed IFACE array names for level0 methods to be m-1 instead of just m. (now consistent with higher level m-X names) -# 1.0.8.0 (passes 74/76) -# tests now in own package -# usage: -# package require test::pattern -# test::p::list -# test::p::run ?nameglob? ?-version ? -# -#2005-09?-12 -# -# fixed standalone 'var' statement in method bodies so that no implicit variable declarations added to proc. -# fixed @next@ so that destination method resolved at interface compile time instead of call time -# fixed @next@ so that on Create, .. PatternMethod x overlays existing method produced by a previous .. PatternMethod x. -# (before, the overlay only occured when '.. Method' was used to override.) -# -# -# miscellaneous tidy-ups -# -# 1.0.7.8 (passes 71/73) -# -#2005-09-10 -# fix 'unknown' system such that unspecified 'unknown' handler represented by lack of (unknown) variable instead of empty string value -# this is so that a mixin with an unspecified 'unknown' handler will not undo a lowerlevel 'unknown' specificier. -# -#2005-09-07 -# bugfix indexed write to list property -# bugfix Variable default value -# 1.0.7.7 (passes 70/72) -# fails: -# arrayproperty.test - array-entire-reference -# properties.test - property_getter_filter_via_ObjectRef -# -#2005-04-22 -# basic fix to PatternPropertyRead dispatch code - updated tests (indexed case still not fixed!) -# -# 1.0.7.4 -# -#2004-11-05 -# basic PropertyRead implementation (non-indexed - no tests!) -# -#2004-08-22 -# object creation speedups - (pattern::internals::obj simplified/indirected) -# -#2004-08-17 -# indexed property setter fixes + tests -# meta::Create fixes - state preservation on overlay (correct constructor called, property defaults respect existing values) -# -#2004-08-16 -# PropertyUnset & PatternPropertyUnset metaMethods (filter method called on property unset) -# -#2004-08-15 -# reference syncing: ensure writes to properties always trigger traces on property references (+ tests) -# - i.e method that updates o_myProp var in >myObj will cause traces on [>myObj . myProp .] to trigger -# - also trigger on curried traces to indexed properties i.e list and array elements. -# - This feature presumably adds some overhead to all property writes - !todo - investigate desirability of mechanism to disable on specific properties. -# -# fix (+ tests) for ref to multiple indices on object i.e [>myObj key1 key2 .] -# -#2004-08-05 -# add PropertyWrite & PatternPropertyWrite metaMethods - (filter method called on property write) -# -# fix + add tests to support method & property of same name. (method precedence) -# -#2004-08-04 -# disallow attempt to use method reference as if it were a property (raise error instead of silently setting useless var) -# -# 1.0.7.1 -# use objectref array access to read properties even when some props unset; + test -# unset property using array access on object reference; + test -# -# -#2004-07-21 -# object reference changes - array property values appear as list value when accessed using upvared array. -# bugfixes + tests - properties containing lists (multidimensional access) -# -#1.0.7 -# -#2004-07-20 -# fix default property value append problem -# -#2004-07-17 -# add initial implementation of 'Unknown' and 'PatternUnknown' meta-methods -# ( -# -#2004-06-18 -# better cleanup on '>obj .. Destroy' - recursively destroy objects under parents subnamespaces. -# -#2004-06-05 -# change argsafety operator to be anything with leading - -# if standalone '-' then the dash itself is not added as a parameter, but if a string follows '-' -# i.e tkoption style; e.g -myoption ; then in addition to acting as an argsafety operator for the following arg, -# the entire dash-prefixed operator is also passed in as an argument. -# e.g >object . doStuff -window . -# will call the doStuff method with the 2 parameters -window . -# >object . doStuff - . -# will call doStuff with single parameter . -# >object . doStuff - -window . -# will result in a reference to the doStuff method with the argument -window 'curried' in. -# -#2004-05-19 -#1.0.6 -# fix so custom constructor code called. -# update Destroy metamethod to unset $self -# -#1.0.4 - 2004-04-22 -# bug fixes regarding method specialisation - added test -# -#------------------------------------------------------------ - -package provide pattern [namespace eval pattern {variable version; set version 1.2.4}] - - -namespace eval pattern::util { - - # Generally better to use 'package require $minver-' - # - this only gives us a different error - proc package_require_min {pkg minver} { - if {[package vsatisfies [lindex [set available [lsort -increasing [package versions $pkg]]] end] $minver-]} { - package require $pkg - } else { - error "Package pattern requires package $pkg of at least version $minver. Available: $available" - } - } -} - -package require patterncmd 1.2.4- -package require metaface 1.2.4- ;#utility/system diagnostic commands (may be used by metaface lib etc) - - - -#package require cmdline -package require overtype - -#package require md5 ;#will be loaded if/when needed -#package require md4 -#package require uuid - - - - - -namespace eval pattern { - variable initialised 0 - - - if 0 { - if {![catch {package require twapi_base} ]} { - #twapi is a windows only package - #MUCH faster to load just twapi_base than full 'package require twapi' IFF using the modular twapi distribution with multiple separately loadable dlls. - # If available - windows seems to provide a fast uuid generator.. - #*IF* tcllibc is missing, then as at 2008-05 twapi::new_uuid is significantly faster than uuid::uuid generate ( e.g 19 usec vs 76thousand usec! on 2.4GHZ machine) - # (2018 update - 15-30usec vs ~200usec on core i9 @ ~2.6GHZ (time for a single call e.g time {pattern::new_uuid})) - interp alias {} ::pattern::new_uuid {} ::twapi::new_uuid -localok - } else { - #performance on freebsd seems not great, but adequate. (e.g 500usec on dualcore 1.6GHZ) - # (e.g 200usec 2018 corei9) - #(with or without tcllibc?) - #very first call is extremely slow though - 3.5seconds on 2018 corei9 - package require uuid - interp alias {} ::pattern::new_uuid {} ::uuid::uuid generate - } - #variable fastobj 0 ;#precalculated invocant ID in method body (instead of call time ) - removed for now - see pattern 1.2.1 (a premature optimisation which was hampering refactoring & advancement) - } - - -} - - - - - - -namespace eval p { - #this is also the interp alias namespace. (object commands created here , then renamed into place) - #the object aliases are named as incrementing integers.. !todo - consider uuids? - variable ID 0 - namespace eval internals {} - - - #!?? - #namespace export ?? - variable coroutine_instance 0 -} - -#------------------------------------------------------------------------------------- -#review - what are these for? -#note - this function is deliberately not namespaced -# - it begins with the letters 'proc' (as do the created aliases) - to aid in editor's auto indexing/mapping features -proc process_pattern_aliases {object args} { - set o [namespace tail $object] - interp alias {} process_patternmethod_$o {} [$object .. PatternMethod .] - interp alias {} process_method_$o {} [$object .. Method .] - interp alias {} process_constructor_$o {} [$object .. Constructor .] -} -#------------------------------------------------------------------------------------- - - - - -#!store all interface objects here? -namespace eval ::p::ifaces {} - - - -#K combinator - see http://wiki.tcl.tk/1923 -#proc ::p::K {x y} {set x} -#- not used - use inline K if desired i.e set x [lreplace $x[set x{}] $a $b blah] - - - - - - - - -proc ::p::internals::(VIOLATE) {_ID_ violation_script} { - #set out [::p::fixed_var_statements @IMPLICITDECLS@\n$violation_script] - set processed [dict create {*}[::p::predator::expand_var_statements $violation_script]] - - if {![dict get $processed explicitvars]} { - #no explicit var statements - we need the implicit ones - set self [set ::p::${_ID_}::(self)] - set IFID [lindex [set $self] 1 0 end] - #upvar ::p::${IFID}:: self_IFINFO - - - set varDecls {} - set vlist [array get ::p::${IFID}:: v,name,*] - set _k ""; set v "" - if {[llength $vlist]} { - append varDecls "upvar #0 " - foreach {_k v} $vlist { - append varDecls "::p::\${_ID_}::$v $v " - } - append varDecls "\n" - } - - #set violation_script [string map [::list @IMPLICITDECLS@ $varDecls] $out] - set violation_script $varDecls\n[dict get $processed body] - - #tidy up - unset processed varDecls self IFID _k v - } else { - set violation_script [dict get $processed body] - } - unset processed - - - - - #!todo - review (& document) exactly what context this script runs in and what vars/procs are/should be visible. - eval "unset violation_script;$violation_script" -} - - -proc ::p::internals::DestroyObjectsBelowNamespace {ns} { - #puts "\n##################\n#################### destroyObjectsBelowNamespace $ns\n" - - set nsparts [split [string trim [string map {:: :} $ns] :] :] - if { ! ( ([llength $nsparts] == 3) & ([lindex $nsparts 0] == "p") & ([lindex $nsparts end] eq "_ref") )} { - #ns not of form ::p::?::_ref - - foreach obj [info commands ${ns}::>*] { - #catch {::p::meta::Destroy $obj} - #puts ">>found object $obj below ns $ns - destroying $obj" - $obj .. Destroy - } - } - - #set traces [trace info variable ${ns}::-->PATTERN_ANCHOR] - #foreach tinfo $traces { - # trace remove variable ${ns}::-->PATTERN_ANCHOR {*}$tinfo - #} - #unset -nocomplain ${ns}::-->PATTERN_ANCHOR - - foreach sub [namespace children $ns] { - ::p::internals::DestroyObjectsBelowNamespace $sub - } -} - - - - -################################################# -################################################# -################################################# -################################################# -################################################# -################################################# -################################################# -################################################# -################################################# -################################################# - - - - - - - - - -proc ::p::get_new_object_id {} { - tailcall incr ::p::ID - #tailcall ::pattern::new_uuid -} - -#create a new minimal object - with no interfaces or patterns. - -#proc ::p::internals::new_object [list cmd {wrapped ""} [list OID [expr {-2}]]] {} -proc ::p::internals::new_object {cmd {wrapped ""} {OID "-2"}} { - - #puts "-->new_object cmd:$cmd wrapped:$wrapped OID:$OID" - - if {$OID eq "-2"} { - set OID [::p::get_new_object_id] - #set OID [incr ::p::ID] ;#!todo - use uuids? (too slow?) (use uuids as configurable option?, pre-allocate a list of uuids?) - #set OID [pattern::new_uuid] - } - #if $wrapped provided it is assumed to be an existing namespace. - #if {[string length $wrapped]} { - # #??? - #} - - #sanity check - alias must not exist for this OID - if {[llength [interp alias {} ::p::$OID]]} { - error "Object alias '::p::$OID' already exists - cannot create new object with this id" - } - - #system 'varspaces' - - - #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://wiki.tcl.tk/1030 'Dangers of creative writing') - #set o_open 1 - every object is initially also an open interface (?) - #NOTE! comments within namespace eval slow it down. - namespace eval ::p::$OID { - #namespace ensemble create - namespace eval _ref {} - namespace eval _meta {} - namespace eval _iface { - variable o_usedby; - variable o_open 1; - array set o_usedby [list]; - variable o_varspace "" ; - variable o_varspaces [list]; - variable o_methods [dict create]; - variable o_properties [dict create]; - variable o_variables; - variable o_propertyunset_handlers; - set o_propertyunset_handlers [dict create] - } - } - - #set alias ::p::$OID - - #objectid alis default_method object_command wrapped_namespace - set INVOCANTDATA [list $OID ::p::$OID "" $cmd $wrapped] - - #MAP is a dict - set MAP [list invocantdata $INVOCANTDATA interfaces {level0 {} level0_default "" level1 {} level1_default ""} patterndata {patterndefaultmethod ""}] - - - - #NOTE 'interp alias' will prepend :: if chosen srccmd already exists as an alias token - #we've already checked that ::p::$OID doesn't pre-exist - # - so we know the return value of the [interp alias {} $alias {} ...] will be $alias - #interp alias {} ::p::$OID {} ::p::internals::predator $MAP - - - # _ID_ structure - set invocants_dict [dict create this [list $INVOCANTDATA] ] - #puts stdout "New _ID_structure: $interfaces_dict" - set _ID_ [dict create i $invocants_dict context ""] - - - interp alias {} ::p::$OID {} ::p::internals::predator $_ID_ - #rename the command into place - thus the alias & the command name no longer match! - rename ::p::$OID $cmd - - set ::p::${OID}::_meta::map $MAP - - # called when no DefaultMethod has been set for an object, but it is called with indices e.g >x something - interp alias {} ::p::${OID}:: {} ::p::internals::no_default_method $_ID_ - - #set p2 [string map {> ?} $cmd] - #interp alias {} $p2 {} ::p::internals::alternative_predator $_ID_ - - - #trace add command $cmd delete "$cmd .. Destroy ;#" - #puts "@@@ trace add command $cmd rename [list $cmd .. Rename]" - - trace add command $cmd rename [list $cmd .. Rename] ;#will receive $oldname $newname "rename" - #trace add command $cmd rename [$cmd .. Rename .] ;#EXTREMELY slow. (but why?) - - #puts "@@@ trace added for $cmd -> '[trace info command $cmd]'" - - - #uplevel #0 "trace add command $cmd delete \"puts deleting$cmd ;#\"" - #trace add command $cmd delete "puts deleting$cmd ;#" - #puts stdout "trace add command $cmd delete \"puts deleting$cmd ;#\"" - - - #puts "--> new_object returning map $MAP" - return $MAP -} - - - - -#>x .. Create >y -# ".." is special case equivalent to "._." -# (whereas in theory it would be ".default.") -# "." is equivalent to ".default." is equivalent to ".default.default." (...) - -#>x ._. Create >y -#>x ._.default. Create >y ??? -# -# - -# create object using 'blah' as source interface-stack ? -#>x .blah. .. Create >y -#>x .blah,_. ._. Create .iStackDestination. >y - - - -# -# ">x .blah,_." is a reference(cast) to >x that contains only the iStacks in the order listed. i.e [list blah _] -# the 1st item, blah in this case becomes the 'default' iStack. -# -#>x .*. -# cast to object with all iStacks -# -#>x .*,!_. -# cast to object with all iStacks except _ -# -# --------------------- -#!todo - MultiMethod support via transient and persistent object conglomerations. Operators '&' & '@' -# - a persistent conglomeration will have an object id (OID) and thus associated namespace, whereas a transient one will not. -# -#eg1: >x & >y . some_multi_method arg arg -# this is a call to the MultiMethod 'some_multi_method' with 2 objects as the invocants. ('>x & >y' is a transient conglomeration of the two objects) -# No explicit 'invocation role' is specified in this call - so it gets the default role for multiple invocants: 'these' -# The invocant signature is thus {these 2} -# (the default invocation role for a standard call on a method with a single object is 'this' - with the associated signature {this 1}) -# Invocation roles can be specified in the call using the @ operator. -# e.g >x & >y @ points . some_multi_method arg arg -# The invocant signature for this is: {points 2} -# -#eg2: {*}[join $objects &] @ objects & >p @ plane . move $path -# This has the signature {objects n plane 1} where n depends on the length of the list $objects -# -# -# To get a persistent conglomeration we would need to get a 'reference' to the conglomeration. -# e.g set pointset [>x & >y .] -# We can now call multimethods on $pointset -# - - - - - - -#set ::p::internals::predator to a particular predatorversion (from a patternpredatorX package) -proc ::pattern::predatorversion {{ver ""}} { - variable active_predatorversion - set allowed_predatorversions {1 2} - set default_predatorversion [lindex $allowed_predatorversions end] ;#default to last in list of allowed_predatorversions - - if {![info exists active_predatorversion]} { - set first_time_set 1 - } else { - set first_time_set 0 - } - - if {$ver eq ""} { - #get version - if {$first_time_set} { - set active_predatorversions $default_predatorversion - } - return $active_predatorversion - } else { - #set version - if {$ver ni $allowed_predatorversions} { - error "Invalid attempt to set predatorversion - unknown value: $ver, try one of: $allowed_predatorversions" - } - - if {!$first_time_set} { - if {$active_predatorversion eq $ver} { - #puts stderr "Active predator version is already '$ver'" - #ok - nothing to do - return $active_predatorversion - } else { - package require patternpredator$ver 1.2.4- - if {![llength [info commands ::p::predator$ver]]} { - error "Unable to set predatorversion - command ::p::predator$ver not found" - } - rename ::p::internals::predator ::p::predator$active_predatorversion - } - } - package require patternpredator$ver 1.2.4- - if {![llength [info commands ::p::predator$ver]]} { - error "Unable to set predatorversion - command ::p::predator$ver not found" - } - - rename ::p::predator$ver ::p::internals::predator - set active_predatorversion $ver - - return $active_predatorversion - } -} -::pattern::predatorversion 2 - - - - - - - - - - - - -# >pattern has object ID 1 -# meta interface has object ID 0 -proc ::pattern::init args { - - if {[set ::pattern::initialised]} { - if {[llength $args]} { - #if callers want to avoid this error, they can do their own check of $::pattern::initialised - error "pattern package is already initialised. Unable to apply args: $args" - } else { - return 1 - } - } - - #this seems out of date. - # - where is PatternPropertyRead? - # - Object is obsolete - # - Coinjoin, Combine don't seem to exist - array set ::p::metaMethods { - Clone object - Conjoin object - Combine object - Create object - Destroy simple - Info simple - Object simple - PatternProperty simple - PatternPropertyWrite simple - PatternPropertyUnset simple - Property simple - PropertyWrite simple - PatternMethod simple - Method simple - PatternVariable simple - Variable simple - Digest simple - PatternUnknown simple - Unknown simple - } - array set ::p::metaProperties { - Properties object - Methods object - PatternProperties object - PatternMethods object - } - - - - - - #create metaface - IID = -1 - also OID = -1 - # all objects implement this special interface - accessed via the .. operator. - - - - - - set ::p::ID 4 ;#0,1,2,3 reserved for null interface,>pattern, >ifinfo & ::p::>interface - - - #OID = 0 - ::p::internals::new_object ::p::ifaces::>null "" 0 - - #? null object has itself as level0 & level1 interfaces? - #set ::p::ifaces::>null [list [list 0 ::p::ifaces::>null item] [list [list 0] [list 0]] [list {} {}]] - - #null interface should always have 'usedby' members. It should never be extended. - array set ::p::0::_iface::o_usedby [list i-1 ::p::internals::>metaface i0 ::p::ifaces::>null i1 ::>pattern] ;#'usedby' array - set ::p::0::_iface::o_open 0 - - set ::p::0::_iface::o_constructor [list] - set ::p::0::_iface::o_variables [list] - set ::p::0::_iface::o_properties [dict create] - set ::p::0::_iface::o_methods [dict create] - set ::p::0::_iface::o_varspace "" - set ::p::0::_iface::o_varspaces [list] - array set ::p::0::_iface::o_definition [list] - set ::p::0::_iface::o_propertyunset_handlers [dict create] - - - - - ############################### - # OID = 1 - # >pattern - ############################### - ::p::internals::new_object ::>pattern "" 1 - - #set ::>pattern [list [list 1 ::>pattern item] [list [list 0] [list 0]]] - - - array set ::p::1::_iface::o_usedby [list] ;#'usedby' array - - set _self ::pattern - - #set IFID [::p::internals::new_interface 1] ;#level 0 interface usedby object 1 - #set IFID_1 [::p::internals::new_interface 1] ;#level 1 interface usedby object 1 - - - - #1)this object references its interfaces - #lappend ID $IFID $IFID_1 - #lset SELFMAP 1 0 $IFID - #lset SELFMAP 2 0 $IFID_1 - - - #set body [string map [::list @self@ ::>pattern @_self@ ::pattern @self_ID@ 0 @itemCmd@ item] $::p::internals::OBJECTCOMMAND] - #proc ::>pattern args $body - - - - - ####################################################################################### - #OID = 2 - # >ifinfo interface for accessing interfaces. - # - ::p::internals::new_object ::p::ifaces::>2 "" 2 ;#>ifinfo object - set ::p::2::_iface::o_constructor [list] - set ::p::2::_iface::o_variables [list] - set ::p::2::_iface::o_properties [dict create] - set ::p::2::_iface::o_methods [dict create] - set ::p::2::_iface::o_varspace "" - set ::p::2::_iface::o_varspaces [list] - array set ::p::2::_iface::o_definition [list] - set ::p::2::_iface::o_open 1 ;#open for extending - - ::p::ifaces::>2 .. AddInterface 2 - - #Manually create a minimal >ifinfo implementation using the same general pattern we use for all method implementations - #(bootstrap because we can't yet use metaface methods on it) - - - - proc ::p::2::_iface::isOpen.1 {_ID_} { - return $::p::2::_iface::o_open - } - interp alias {} ::p::2::_iface::isOpen {} ::p::2::_iface::isOpen.1 - - proc ::p::2::_iface::isClosed.1 {_ID_} { - return [expr {!$::p::2::_iface::o_open}] - } - interp alias {} ::p::2::_iface::isClosed {} ::p::2::_iface::isClosed.1 - - proc ::p::2::_iface::open.1 {_ID_} { - set ::p::2::_iface::o_open 1 - } - interp alias {} ::p::2::_iface::open {} ::p::2::_iface::open.1 - - proc ::p::2::_iface::close.1 {_ID_} { - set ::p::2::_iface::o_open 0 - } - interp alias {} ::p::2::_iface::close {} ::p::2::_iface::close.1 - - - #proc ::p::2::_iface::(GET)properties.1 {_ID_} { - # set ::p::2::_iface::o_properties - #} - #interp alias {} ::p::2::_iface::(GET)properties {} ::p::2::_iface::(GET)properties.1 - - #interp alias {} ::p::2::properties {} ::p::2::_iface::(GET)properties - - - #proc ::p::2::_iface::(GET)methods.1 {_ID_} { - # set ::p::2::_iface::o_methods - #} - #interp alias {} ::p::2::_iface::(GET)methods {} ::p::2::_iface::(GET)methods.1 - #interp alias {} ::p::2::methods {} ::p::2::_iface::(GET)methods - - - - - - #link from object to interface (which in this case are one and the same) - - #interp alias {} ::p::2::isOpen {} ::p::2::_iface::isOpen [::p::ifaces::>2 --] - #interp alias {} ::p::2::isClosed {} ::p::2::_iface::isClosed [::p::ifaces::>2 --] - #interp alias {} ::p::2::open {} ::p::2::_iface::open [::p::ifaces::>2 --] - #interp alias {} ::p::2::close {} ::p::2::_iface::close [::p::ifaces::>2 --] - - interp alias {} ::p::2::isOpen {} ::p::2::_iface::isOpen - interp alias {} ::p::2::isClosed {} ::p::2::_iface::isClosed - interp alias {} ::p::2::open {} ::p::2::_iface::open - interp alias {} ::p::2::close {} ::p::2::_iface::close - - - #namespace eval ::p::2 "namespace export $method" - - ####################################################################################### - - - - - - - set ::pattern::initialised 1 - - - ::p::internals::new_object ::p::>interface "" 3 - #create a convenience object on which to manipulate the >ifinfo interface - #set IF [::>pattern .. Create ::p::>interface] - set IF ::p::>interface - - - #!todo - put >ifinfo on a separate pStack so that end-user can more freely treat interfaces as objects? - # (or is forcing end user to add their own pStack/iStack ok .. ?) - # - ::p::>interface .. AddPatternInterface 2 ;# - - ::p::>interface .. PatternVarspace _iface - - ::p::>interface .. PatternProperty methods - ::p::>interface .. PatternPropertyRead methods {} { - varspace _iface - var {o_methods alias} - return $alias - } - ::p::>interface .. PatternProperty properties - ::p::>interface .. PatternPropertyRead properties {} { - varspace _iface - var o_properties - return $o_properties - } - ::p::>interface .. PatternProperty variables - - ::p::>interface .. PatternProperty varspaces - - ::p::>interface .. PatternProperty definition - - ::p::>interface .. Constructor {{usedbylist {}}} { - #var this - #set this @this@ - #set ns [$this .. Namespace] - #puts "-> creating ns ${ns}::_iface" - #namespace eval ${ns}::_iface {} - - varspace _iface - var o_constructor o_variables o_properties o_methods o_definition o_usedby o_varspace o_varspaces - - set o_constructor [list] - set o_variables [list] - set o_properties [dict create] - set o_methods [dict create] - set o_varspaces [list] - array set o_definition [list] - - foreach usedby $usedbylist { - set o_usedby(i$usedby) 1 - } - - - } - ::p::>interface .. PatternMethod isOpen {} { - varspace _iface - var o_open - - return $o_open - } - ::p::>interface .. PatternMethod isClosed {} { - varspace _iface - var o_open - - return [expr {!$o_open}] - } - ::p::>interface .. PatternMethod open {} { - varspace _iface - var o_open - set o_open 1 - } - ::p::>interface .. PatternMethod close {} { - varspace _iface - var o_open - set o_open 0 - } - ::p::>interface .. PatternMethod refCount {} { - varspace _iface - var o_usedby - return [array size o_usedby] - } - - set ::p::2::_iface::o_open 1 - - - - - uplevel #0 {pattern::util::package_require_min patternlib 1.2.4} - #uplevel #0 {package require patternlib} - return 1 -} - - - -proc ::p::merge_interface {old new} { - #puts stderr " ** ** ** merge_interface $old $new" - set ns_old ::p::$old - set ns_new ::p::$new - - upvar #0 ::p::${new}:: IFACE - upvar #0 ::p::${old}:: IFACEX - - if {![catch {set c_arglist $IFACEX(c,args)}]} { - #constructor - #for now.. just add newer constructor regardless of any existing one - #set IFACE(c,args) $IFACEX(c,args) - - #if {![info exists IFACE(c,args)]} { - # #target interface didn't have a constructor - # - #} else { - # # - #} - } - - - set methods [::list] - foreach nm [array names IFACEX m-1,name,*] { - lappend methods [lindex [split $nm ,] end] ;#use the method key-name not the value! (may have been overridden) - } - - #puts " *** merge interface $old -> $new ****merging-in methods: $methods " - - foreach method $methods { - if {![info exists IFACE(m-1,name,$method)]} { - #target interface doesn't yet have this method - - set THISNAME $method - - if {![string length [info command ${ns_new}::$method]]} { - - if {![set ::p::${old}::_iface::o_open]} { - #interp alias {} ${ns_new}::$method {} ${ns_old}::$method - #namespace eval $ns_new "namespace export [namespace tail $method]" - } else { - #wait to compile - } - - } else { - error "merge interface - command collision " - } - #set i 2 ??? - set i 1 - - } else { - #!todo - handle how? - #error "command $cmd already exists in interface $new" - - - set i [incr IFACE(m-1,chain,$method)] - - set THISNAME ___system___override_${method}_$i - - #move metadata using subindices for delegated methods - set IFACE(m-$i,name,$method) $IFACE(m-1,name,$method) - set IFACE(m-$i,iface,$method) $IFACE(m-1,iface,$method) - set IFACE(mp-$i,$method) $IFACE(mp-1,$method) - - set IFACE(m-$i,body,$method) $IFACE(m-1,body,$method) - set IFACE(m-$i,args,$method) $IFACE(m-1,args,$method) - - - #set next [::p::next_script $IFID0 $method] - if {![string length [info command ${ns_new}::$THISNAME]]} { - if {![set ::p::${old}::_iface::o_open]} { - interp alias {} ${ns_new}::$THISNAME {} ${ns_old}::$method - namespace eval $ns_new "namespace export $method" - } else { - #wait for compile - } - } else { - error "merge_interface - command collision " - } - - } - - array set IFACE [::list \ - m-1,chain,$method $i \ - m-1,body,$method $IFACEX(m-1,body,$method) \ - m-1,args,$method $IFACEX(m-1,args,$method) \ - m-1,name,$method $THISNAME \ - m-1,iface,$method $old \ - ] - - } - - - - - - #array set ${ns_new}:: [array get ${ns_old}::] - - - #!todo - review - #copy everything else across.. - - foreach {nm v} [array get IFACEX] { - #puts "-.- $nm" - if {([string first "m-1," $nm] != 0) && ($nm ne "usedby")} { - set IFACE($nm) $v - } - } - - #!todo -write a test - set ::p::${new}::_iface::o_open 1 - - #!todo - is this done also when iface compiled? - #namespace eval ::p::$new {namespace ensemble create} - - - #puts stderr "copy_interface $old $new" - - #assume that the (usedby) data is now obsolete - #???why? - #set ${ns_new}::(usedby) [::list] - - #leave ::(usedby) reference in place - - return -} - - - - -#detect attempt to treat a reference to a method as a property -proc ::p::internals::commandrefMisuse_TraceHandler {OID field args} { -#puts "commandrefMisuse_TraceHandler fired OID:$OID field:$field args:$args" - lassign [lrange $args end-2 end] vtraced vidx op - #NOTE! cannot rely on vtraced as it may have been upvared - - switch -- $op { - write { - error "$field is not a property" "property ref write failure for property $field (OID: $OID refvariable: [lindex $args 0])" - } - unset { - #!todo - monitor stat of Tcl bug# 1911919 - when/(if?) fixed - reinstate 'unset' trace - #trace add variable $traced {read write unset} [concat ::p::internals::commandrefMisuse_TraceHandler $OID $field $args] - - #!todo - don't use vtraced! - trace add variable $vtraced {read write unset array} [concat ::p::internals::commandrefMisuse_TraceHandler $OID $field $args] - - #pointless raising an error as "Any errors in unset traces are ignored" - #error "cannot unset. $field is a method not a property" - } - read { - error "$field is not a property (args $args)" "property ref read failure for property $field (OID: $OID refvariable: [lindex $args 0])" - } - array { - error "$field is not a property (args $args)" "property ref use as array failure for property $field (OID: $OID refvariable: [lindex $args 0])" - #error "unhandled operation in commandrefMisuse_TraceHandler - got op:$op expected read,write,unset. OID:$OID field:$field args:$args" - } - } - - return -} - - - - -#!todo - review calling-points for make_dispatcher.. probably being called unnecessarily at some points. -# -# The 'dispatcher' is an object instance's underlying object command. -# - -#proc ::p::make_dispatcher {obj ID IFID} { -# proc [string map {::> ::} $obj] {{methprop INFO} args} [string map [::list @IID@ $IFID @oid@ $ID] { -# ::p::@IID@ $methprop @oid@ {*}$args -# }] -# return -#} - - - - -################################################################################################################################################ -################################################################################################################################################ -################################################################################################################################################ - -#aliased from ::p::${OID}:: -# called when no DefaultMethod has been set for an object, but it is called with indices e.g >x something -proc ::p::internals::no_default_method {_ID_ args} { - puts stderr "p::internals::no_default_method _ID_:'$_ID_' args:'$args'" - lassign [lindex [dict get $_ID_ i this] 0] OID alias default_method object_command wrapped - tailcall error "No default method on object $object_command. (To get or set, use: $object_command .. DefaultMethod ?methodname? or use PatternDefaultMethod)" -} - -#force 1 will extend an interface even if shared. (??? why is this necessary here?) -#if IID empty string - create the interface. -proc ::p::internals::expand_interface {IID {force 0}} { - #puts stdout ">>> expand_interface $IID [info level -1]<<<" - if {![string length $IID]} { - #return [::p::internals::new_interface] ;#new interface is by default open for extending (o_open = 1) - set iid [expr {$::p::ID + 1}] - ::p::>interface .. Create ::p::ifaces::>$iid - return $iid - } else { - if {[set ::p::${IID}::_iface::o_open]} { - #interface open for extending - shared or not! - return $IID - } - - if {[array size ::p::${IID}::_iface::o_usedby] > 1} { - #upvar #0 ::p::${IID}::_iface::o_usedby prev_usedby - - #oops.. shared interface. Copy before specialising it. - set prev_IID $IID - - #set IID [::p::internals::new_interface] - set IID [expr {$::p::ID + 1}] - ::p::>interface .. Create ::p::ifaces::>$IID - - ::p::internals::linkcopy_interface $prev_IID $IID - #assert: prev_usedby contains at least one other element. - } - - #whether copied or not - mark as open for extending. - set ::p::${IID}::_iface::o_open 1 - return $IID - } -} - -#params: old - old (shared) interface ID -# new - new interface ID -proc ::p::internals::linkcopy_interface {old new} { - #puts stderr " ** ** ** linkcopy_interface $old $new" - set ns_old ::p::${old}::_iface - set ns_new ::p::${new}::_iface - - - - foreach nsmethod [info commands ${ns_old}::*.1] { - #puts ">>> adding $nsmethod to iface $new" - set tail [namespace tail $nsmethod] - set method [string range $tail 0 end-2] ;#strip .1 - - if {![llength [info commands ${ns_new}::$method]]} { - - set oldhead [interp alias {} ${ns_old}::$method] ;#the 'head' of the cmdchain that it actually points to ie $method.$x where $x >=1 - - #link from new interface namespace to existing one. - #(we assume that since ${ns_new}::$method didn't exist, that all the $method.$x chain slots are empty too...) - #!todo? verify? - #- actual link is chainslot to chainslot - interp alias {} ${ns_new}::$method.1 {} $oldhead - - #!todo - review. Shouldn't we be linking entire chain, not just creating a single .1 pointer to the old head? - - - #chainhead pointer within new interface - interp alias {} ${ns_new}::$method {} ${ns_new}::$method.1 - - namespace eval $ns_new "namespace export $method" - - #if {[string range $method 0 4] ni {(GET) (SET) (UNSE (CONS }} { - # lappend ${ns_new}::o_methods $method - #} - } else { - if {$method eq "(VIOLATE)"} { - #ignore for now - #!todo - continue - } - - #!todo - handle how? - #error "command $cmd already exists in interface $new" - - #warning - existing chainslot will be completely shadowed by linked method. - # - existing one becomes unreachable. #!todo review!? - - - error "linkcopy_interface $old -> $new - chainslot shadowing not implemented (method $method already exists on target interface $new)" - - } - } - - - #foreach propinf [set ${ns_old}::o_properties] { - # lassign $propinf prop _default - # #interp alias {} ${ns_new}::(GET)$prop {} ::p::predator::getprop $prop - # #interp alias {} ${ns_new}::(SET)$prop {} ::p::predator::setprop $prop - # lappend ${ns_new}::o_properties $propinf - #} - - - set ${ns_new}::o_variables [set ${ns_old}::o_variables] - set ${ns_new}::o_properties [set ${ns_old}::o_properties] - set ${ns_new}::o_methods [set ${ns_old}::o_methods] - set ${ns_new}::o_constructor [set ${ns_old}::o_constructor] - - - set ::p::${old}::_iface::o_usedby(i$new) linkcopy - - - #obsolete.? - array set ::p::${new}:: [array get ::p::${old}:: ] - - - - #!todo - is this done also when iface compiled? - #namespace eval ::p::${new}::_iface {namespace ensemble create} - - - #puts stderr "copy_interface $old $new" - - #assume that the (usedby) data is now obsolete - #???why? - #set ${ns_new}::(usedby) [::list] - - #leave ::(usedby) reference in place for caller to change as appropriate - 'copy' - - return -} -################################################################################################################################################ -################################################################################################################################################ -################################################################################################################################################ - -pattern::init - -return $::pattern::version diff --git a/src/bootsupport/modules/patterncmd-1.2.4.tm b/src/bootsupport/modules/patterncmd-1.2.4.tm deleted file mode 100644 index ca061a7c..00000000 --- a/src/bootsupport/modules/patterncmd-1.2.4.tm +++ /dev/null @@ -1,645 +0,0 @@ -package provide patterncmd [namespace eval patterncmd { - variable version - - set version 1.2.4 -}] - - -namespace eval pattern { - variable idCounter 1 ;#used by pattern::uniqueKey - - namespace eval cmd { - namespace eval util { - package require overtype - variable colwidths_lib [dict create] - variable colwidths_lib_default 15 - - dict set colwidths_lib "library" [list ch " " num 21 head "|" tail ""] - dict set colwidths_lib "version" [list ch " " num 7 head "|" tail ""] - dict set colwidths_lib "type" [list ch " " num 9 head "|" tail ""] - dict set colwidths_lib "note" [list ch " " num 31 head "|" tail "|"] - - proc colhead {type args} { - upvar #0 ::pattern::cmd::util::colwidths_$type colwidths - set line "" - foreach colname [dict keys $colwidths] { - append line "[col $type $colname [string totitle $colname] {*}$args]" - } - return $line - } - proc colbreak {type} { - upvar #0 ::pattern::cmd::util::colwidths_$type colwidths - set line "" - foreach colname [dict keys $colwidths] { - append line "[col $type $colname {} -backchar - -headoverridechar + -tailoverridechar +]" - } - return $line - } - proc col {type col val args} { - # args -head bool -tail bool ? - #---------------------------------------------------------------------------- - set known_opts [list -backchar -headchar -tailchar -headoverridechar -tailoverridechar -justify] - dict set default -backchar "" - dict set default -headchar "" - dict set default -tailchar "" - dict set default -headoverridechar "" - dict set default -tailoverridechar "" - dict set default -justify "left" - if {([llength $args] % 2) != 0} { - error "(pattern::cmd::util::col) ERROR: uneven options supplied - must be of form '-option value' " - } - foreach {k v} $args { - if {$k ni $known_opts} { - error "((pattern::cmd::util::col) ERROR: option '$k' not in known options: '$known_opts'" - } - } - set opts [dict merge $default $args] - set backchar [dict get $opts -backchar] - set headchar [dict get $opts -headchar] - set tailchar [dict get $opts -tailchar] - set headoverridechar [dict get $opts -headoverridechar] - set tailoverridechar [dict get $opts -tailoverridechar] - set justify [dict get $opts -justify] - #---------------------------------------------------------------------------- - - - - upvar #0 ::pattern::cmd::util::colwidths_$type colwidths - #calculate headwidths - set headwidth 0 - set tailwidth 0 - foreach {key def} $colwidths { - set thisheadlen [string length [dict get $def head]] - if {$thisheadlen > $headwidth} { - set headwidth $thisheadlen - } - set thistaillen [string length [dict get $def tail]] - if {$thistaillen > $tailwidth} { - set tailwidth $thistaillen - } - } - - - set spec [dict get $colwidths $col] - if {[string length $backchar]} { - set ch $backchar - } else { - set ch [dict get $spec ch] - } - set num [dict get $spec num] - set headchar [dict get $spec head] - set tailchar [dict get $spec tail] - - if {[string length $headchar]} { - set headchar $headchar - } - if {[string length $tailchar]} { - set tailchar $tailchar - } - #overrides only apply if the head/tail has a length - if {[string length $headchar]} { - if {[string length $headoverridechar]} { - set headchar $headoverridechar - } - } - if {[string length $tailchar]} { - if {[string length $tailoverridechar]} { - set tailchar $tailoverridechar - } - } - set head [string repeat $headchar $headwidth] - set tail [string repeat $tailchar $tailwidth] - - set base [string repeat $ch [expr {$headwidth + $num + $tailwidth}]] - if {$justify eq "left"} { - set left_done [overtype::left $base "$head$val"] - return [overtype::right $left_done "$tail"] - } elseif {$justify in {centre center}} { - set mid_done [overtype::centre $base $val] - set left_mid_done [overtype::left $mid_done $head] - return [overtype::right $left_mid_done $tail] - } else { - set right_done [overtype::right $base "$val$tail"] - return [overtype::left $right_done $head] - } - - } - - } - } - -} - -#package require pattern - -proc ::pattern::libs {} { - set libs [list \ - pattern {-type core -note "alternative:pattern2"}\ - pattern2 {-type core -note "alternative:pattern"}\ - patterncmd {-type core}\ - metaface {-type core}\ - patternpredator2 {-type core}\ - patterndispatcher {-type core}\ - patternlib {-type core}\ - patterncipher {-type optional -note optional}\ - ] - - - - package require overtype - set result "" - - append result "[cmd::util::colbreak lib]\n" - append result "[cmd::util::colhead lib -justify centre]\n" - append result "[cmd::util::colbreak lib]\n" - foreach libname [dict keys $libs] { - set libinfo [dict get $libs $libname] - - append result [cmd::util::col lib library $libname] - if {[catch [list package present $libname] ver]} { - append result [cmd::util::col lib version "N/A"] - } else { - append result [cmd::util::col lib version $ver] - } - append result [cmd::util::col lib type [dict get $libinfo -type]] - - if {[dict exists $libinfo -note]} { - set note [dict get $libinfo -note] - } else { - set note "" - } - append result [cmd::util::col lib note $note] - append result "\n" - } - append result "[cmd::util::colbreak lib]\n" - return $result -} - -proc ::pattern::record {recname fields} { - if {[uplevel 1 [list namespace which $recname]] ne ""} { - error "(pattern::record) Can't create command '$recname': A command of that name already exists" - } - - set index -1 - set accessor [list ::apply { - {index rec args} - { - if {[llength $args] == 0} { - return [lindex $rec $index] - } - if {[llength $args] == 1} { - return [lreplace $rec $index $index [lindex $args 0]] - } - error "Invalid number of arguments." - } - - }] - - set map {} - foreach field $fields { - dict set map $field [linsert $accessor end [incr index]] - } - uplevel 1 [list namespace ensemble create -command $recname -map $map -parameters rec] -} -proc ::pattern::record2 {recname fields} { - if {[uplevel 1 [list namespace which $recname]] ne ""} { - error "(pattern::record) Can't create command '$recname': A command of that name already exists" - } - - set index -1 - set accessor [list ::apply] - - set template { - {rec args} - { - if {[llength $args] == 0} { - return [lindex $rec %idx%] - } - if {[llength $args] == 1} { - return [lreplace $rec %idx% %idx% [lindex $args 0]] - } - error "Invalid number of arguments." - } - } - - set map {} - foreach field $fields { - set body [string map [list %idx% [incr index]] $template] - dict set map $field [list ::apply $body] - } - uplevel 1 [list namespace ensemble create -command $recname -map $map -parameters rec] -} - -proc ::argstest {args} { - package require cmdline - -} - -proc ::pattern::objects {} { - set result [::list] - - foreach ns [namespace children ::pp] { - #lappend result [::list [namespace tail $ns] [set ${ns}::(self)]] - set ch [namespace tail $ns] - if {[string range $ch 0 2] eq "Obj"} { - set OID [string range $ch 3 end] ;#OID need not be digits (!?) - lappend result [::list $OID [list OID $OID object_command [set pp::${ch}::v_object_command] usedby [array names ${ns}::_iface::o_usedby]]] - } - } - - - - - return $result -} - - - -proc ::pattern::name {num} { - #!todo - fix - #set ::p::${num}::(self) - - lassign [interp alias {} ::p::$num] _predator info - if {![string length $_predator$info]} { - error "No object found for num:$num (no interp alias for ::p::$num)" - } - set invocants [dict get $info i] - set invocants_with_role_this [dict get $invocants this] - set invocant_this [lindex $invocants_with_role_this 0] - - - #lassign $invocant_this id info - #set map [dict get $info map] - #set fields [lindex $map 0] - lassign $invocant_this _id _ns _defaultmethod name _etc - return $name -} - - -proc ::pattern::with {cmd script} { - foreach c [info commands ::p::-1::*] { - interp alias {} [namespace tail $c] {} $c $cmd - } - interp alias {} . {} $cmd . - interp alias {} .. {} $cmd .. - - return [uplevel 1 $script] -} - - - - - -#system diagnostics etc - -proc ::pattern::varspace_list {IID} { - namespace upvar ::p::${IID}::_iface o_varspace o_varspace o_variables o_variables - - set varspaces [list] - dict for {vname vdef} $o_variables { - set vs [dict get $vdef varspace] - if {$vs ni $varspaces} { - lappend varspaces $vs - } - } - if {$o_varspace ni $varspaces} { - lappend varspaces $o_varspace - } - return $varspaces -} - -proc ::pattern::check_interfaces {} { - foreach ns [namespace children ::p] { - set IID [namespace tail $ns] - if {[string is digit $IID]} { - foreach ref [array names ${ns}::_iface::o_usedby] { - set OID [string range $ref 1 end] - if {![namespace exists ::p::${OID}::_iface]} { - puts -nonewline stdout "\r\nPROBLEM!!!!!!!!! nonexistant/invalid object $OID referenced by Interface $IID\r\n" - } else { - puts -nonewline stdout . - } - - - #if {![info exists ::p::${OID}::(self)]} { - # puts "PROBLEM!!!!!!!!! nonexistant object $OID referenced by Interface $IID" - #} - } - } - } - puts -nonewline stdout "\r\n" -} - - -#from: http://wiki.tcl.tk/8766 (Introspection on aliases) -#usedby: metaface-1.1.6+ -#required because aliases can be renamed. -#A renamed alias will still return it's target with 'interp alias {} oldname' -# - so given newname - we require which_alias to return the same info. - proc ::pattern::which_alias {cmd} { - uplevel 1 [list ::trace add execution $cmd enterstep ::error] - catch {uplevel 1 $cmd} res - uplevel 1 [list ::trace remove execution $cmd enterstep ::error] - #puts stdout "which_alias $cmd returning '$res'" - return $res - } -# [info args] like proc following an alias recursivly until it reaches -# the proc it originates from or cannot determine it. -# accounts for default parameters set by interp alias -# - - - -proc ::pattern::aliasargs {cmd} { - set orig $cmd - - set defaultargs [list] - - # loop until error or return occurs - while {1} { - # is it a proc already? - if {[string equal [info procs $cmd] $cmd]} { - set result [info args $cmd] - # strip off the interp set default args - return [lrange $result [llength $defaultargs] end] - } - # is it a built in or extension command we can get no args for? - if {![string equal [info commands $cmd] $cmd]} { - error "\"$orig\" isn't a procedure" - } - - # catch bogus cmd names - if {[lsearch [interp aliases {}] $cmd]==-1} { - if {[catch {::pattern::which_alias $cmd} alias]} { - error "\"$orig\" isn't a procedure or alias or command" - } - #set cmd [lindex $alias 0] - if {[llength $alias]>1} { - set cmd [lindex $alias 0] - set defaultargs [concat [lrange $alias 1 end] $defaultargs] - } else { - set cmd $alias - } - } else { - - if {[llength [set cmdargs [interp alias {} $cmd]]]>0} { - # check if it is aliased in from another interpreter - if {[catch {interp target {} $cmd} msg]} { - error "Cannot resolve \"$orig\", alias leads to another interpreter." - } - if {$msg != {} } { - error "Not recursing into slave interpreter \"$msg\".\ - \"$orig\" could not be resolved." - } - # check if defaults are set for the alias - if {[llength $cmdargs]>1} { - set cmd [lindex $cmdargs 0] - set defaultargs [concat [lrange $cmdargs 1 end] $defaultargs] - } else { - set cmd $cmdargs - } - } - } - } - } -proc ::pattern::aliasbody {cmd} { - set orig $cmd - - set defaultargs [list] - - # loop until error or return occurs - while {1} { - # is it a proc already? - if {[string equal [info procs $cmd] $cmd]} { - set result [info body $cmd] - # strip off the interp set default args - return $result - #return [lrange $result [llength $defaultargs] end] - } - # is it a built in or extension command we can get no args for? - if {![string equal [info commands $cmd] $cmd]} { - error "\"$orig\" isn't a procedure" - } - - # catch bogus cmd names - if {[lsearch [interp aliases {}] $cmd]==-1} { - if {[catch {::pattern::which_alias $cmd} alias]} { - error "\"$orig\" isn't a procedure or alias or command" - } - #set cmd [lindex $alias 0] - if {[llength $alias]>1} { - set cmd [lindex $alias 0] - set defaultargs [concat [lrange $alias 1 end] $defaultargs] - } else { - set cmd $alias - } - } else { - - if {[llength [set cmdargs [interp alias {} $cmd]]]>0} { - # check if it is aliased in from another interpreter - if {[catch {interp target {} $cmd} msg]} { - error "Cannot resolve \"$orig\", alias leads to another interpreter." - } - if {$msg != {} } { - error "Not recursing into slave interpreter \"$msg\".\ - \"$orig\" could not be resolved." - } - # check if defaults are set for the alias - if {[llength $cmdargs]>1} { - set cmd [lindex $cmdargs 0] - set defaultargs [concat [lrange $cmdargs 1 end] $defaultargs] - } else { - set cmd $cmdargs - } - } - } - } - } - - - - - -proc ::pattern::uniqueKey2 {} { - #!todo - something else?? - return [clock seconds]-[incr ::pattern::idCounter] -} - -#used by patternlib package -proc ::pattern::uniqueKey {} { - return [incr ::pattern::idCounter] - #uuid with tcllibc is about 30us compared with 2us - # for large datasets, e.g about 100K inserts this would be pretty noticable! - #!todo - uuid pool with background thread to repopulate when idle? - #return [uuid::uuid generate] -} - - - -#------------------------------------------------------------------------------------------------------------------------- - -proc ::pattern::test1 {} { - set msg "OK" - - puts stderr "next line should say:'--- saystuff:$msg" - ::>pattern .. Create ::>thing - - ::>thing .. PatternMethod saystuff args { - puts stderr "--- saystuff: $args" - } - ::>thing .. Create ::>jjj - - ::>jjj . saystuff $msg - ::>jjj .. Destroy - ::>thing .. Destroy -} - -proc ::pattern::test2 {} { - set msg "OK" - - puts stderr "next line should say:'--- property 'stuff' value:$msg" - ::>pattern .. Create ::>thing - - ::>thing .. PatternProperty stuff $msg - - ::>thing .. Create ::>jjj - - puts stderr "--- property 'stuff' value:[::>jjj . stuff]" - ::>jjj .. Destroy - ::>thing .. Destroy -} - -proc ::pattern::test3 {} { - set msg "OK" - - puts stderr "next line should say:'--- property 'stuff' value:$msg" - ::>pattern .. Create ::>thing - - ::>thing .. Property stuff $msg - - puts stderr "--- property 'stuff' value:[::>thing . stuff]" - ::>thing .. Destroy -} - -#--------------------------------- -#unknown/obsolete - - - - - - - - -#proc ::p::internals::showargs {args {ch stdout}} {puts $ch $args} -if {0} { - proc ::p::internals::new_interface {{usedbylist {}}} { - set OID [incr ::p::ID] - ::p::internals::new_object ::p::ifaces::>$OID "" $OID - puts "obsolete >> new_interface created object $OID" - foreach usedby $usedbylist { - set ::p::${OID}::_iface::o_usedby(i$usedby) 1 - } - set ::p::${OID}::_iface::o_varspace "" ;#default varspace is the object's namespace. (varspace is absolute if it has leading :: , otherwise it's a relative namespace below the object's namespace) - #NOTE - o_varspace is only the default varspace for when new methods/properties are added. - # it is possible to create some methods/props with one varspace value, then create more methods/props with a different varspace value. - - set ::p::${OID}::_iface::o_constructor [list] - set ::p::${OID}::_iface::o_variables [list] - set ::p::${OID}::_iface::o_properties [dict create] - set ::p::${OID}::_iface::o_methods [dict create] - array set ::p::${OID}::_iface::o_definition [list] - set ::p::${OID}::_iface::o_open 1 ;#open for extending - return $OID - } - - - #temporary way to get OID - assumes single 'this' invocant - #!todo - make generic. - proc ::pattern::get_oid {_ID_} { - #puts stderr "#* get_oid: [lindex [dict get $_ID_ i this] 0 0]" - return [lindex [dict get $_ID_ i this] 0 0] - - #set invocants [dict get $_ID_ i] - #set invocant_roles [dict keys $invocants] - #set role_members [dict get $invocants this] - ##set this_invocant [lindex $role_members 0] ;#for the role 'this' we assume only one invocant in the list. - #set this_invocant [lindex [dict get $_ID_ i this] 0] ; - #lassign $this_invocant OID this_info - # - #return $OID - } - - #compile the uncompiled level1 interface - #assert: no more than one uncompiled interface present at level1 - proc ::p::meta::PatternCompile {self} { - ???? - - upvar #0 $self SELFMAP - set ID [lindex $SELFMAP 0 0] - - set patterns [lindex $SELFMAP 1 1] ;#list of level1 interfaces - - set iid -1 - foreach i $patterns { - if {[set ::p::${i}::_iface::o_open]} { - set iid $i ;#found it - break - } - } - - if {$iid > -1} { - #!todo - - ::p::compile_interface $iid - set ::p::${iid}::_iface::o_open 0 - } else { - #no uncompiled interface present at level 1. Do nothing. - return - } - } - - - proc ::p::meta::Def {self} { - error ::p::meta::Def - - upvar #0 $self SELFMAP - set self_ID [lindex $SELFMAP 0 0] - set IFID [lindex $SELFMAP 1 0 end] - - set maxc1 0 - set maxc2 0 - - set arrName ::p::${IFID}:: - - upvar #0 $arrName state - - array set methods {} - - foreach nm [array names state] { - if {[regexp {^m-1,name,(.+)} $nm _match mname]} { - set methods($mname) [set state($nm)] - - if {[string length $mname] > $maxc1} { - set maxc1 [string length $mname] - } - if {[string length [set state($nm)]] > $maxc2} { - set maxc2 [string length [set state($nm)]] - } - } - } - set bg1 [string repeat " " [expr {$maxc1 + 2}]] - set bg2 [string repeat " " [expr {$maxc2 + 2}]] - - - set r {} - foreach nm [lsort -dictionary [array names methods]] { - set arglist $state(m-1,args,$nm) - append r "[overtype::left $bg1 $nm] : [overtype::left $bg2 $methods($nm)] [::list $arglist]\n" - } - return $r - } - - - -} \ No newline at end of file diff --git a/src/bootsupport/modules/patternlib-1.2.6.tm b/src/bootsupport/modules/patternlib-1.2.6.tm deleted file mode 100644 index bd4b3e59..00000000 --- a/src/bootsupport/modules/patternlib-1.2.6.tm +++ /dev/null @@ -1,2590 +0,0 @@ -#JMN 2004 -#public domain - - -package provide patternlib [namespace eval patternlib { - - variable version - set version 1.2.6 -}] - - - -#Change History -#------------------------------------------------------------------------------- -#2022-05 -# added . search and . itemKeys methods to >collection to enable lookups by value -#2021-09 -# Add >keyvalprotector - an object to overload various collection methods such as 'remove' to stop deletion of specific items. -# -#2006-05 -# deprecate 'del' in favour of 'remove' - 'del' still there but delegated to 'remove'. todo - emit deprecation warnings. -# -#2005-04 -# remove 'name' method - incorporate indexed retrieval into 'names' method -# !todo? - adjust key/keys methods for consistency? -# -#2004-10 -# initial key aliases support -# fix negative index support on some methods e.g remove -#2004-08 -# separated >collection predicate methods out onto separate 'mixin' object >predicatedCollection -# added $posn $result variables to predicate methods, changed varnames from $k $v to $key $value -# -#2004-06-05 -# added 'sort' method to sort on values. -# fixed 'keySort' method to accept multiple sort options -# added predicate methods 'all' 'allKeys' 'collectAll' -#2004-06-01 -# '>collection . names' method now accepts optional 'glob' parameter to filter result -#2004-05-19 -#fix '>collection . clear' method so consecutive calls don't raise an error -#------------------------------------------------------------------------------- - -namespace eval ::patternlib::util { - proc package_require_min {pkg minver} { - if {[package vsatisfies [lindex [set available [lsort -increasing [package versions $pkg]]] end] $minver-]} { - package require $pkg - } else { - error "Package pattern requires package $pkg of at least version $minver. Available: $available" - } - } - - #bloom filter experiment https://wiki.tcl-lang.org/page/A+Simple+Bloom+Filter - # k-hashes - # m-bits - # n-elements - # optimal value of k: (m/n)ln(2) - #proc bloom_optimalNumHashes {capacity_n bitsize_m} { - # expr { round((double($bitsize_m) / $capacity_n) * log(2))} - #} - #proc bloom_optimalNumBits {capacity fpp} { - # expr {entier(-$capacity * log($fpp) / (log(2) * log(2)))} - #} - -} -::patternlib::util::package_require_min pattern 1.2.4 -#package require pattern -::pattern::init ;# initialises (if not already) - - -namespace eval ::patternlib {namespace export {[a-z]*} - namespace export {[>]*} - - variable keyCounter 0 ;#form part of unique keys for collections when items added without any key specified - proc uniqueKey {} { - return [incr ::patternlib::keyCounter] - } - -#!todo - multidimensional collection -# - o_list as nested list -# - o_array with compound keys(?) how will we unambiguously delimit dimensions in a concatenated key? -# - perhaps a key is always a list length n where n is the number of dimensions? -# - therefore we'll need an extra level of nesting for the current base case n=1 -# -# - how about a nested dict for each key-structure (o_list & o_array) ? - -#COLLECTION -# -#!todo? - consider putting the actual array & list vars in the objects namespace, and using the instancevars to hold their names -# - consider array-style access using traced var named same as collection. -# would this defeat the purpose ? if it was faster, would users always use array syntax in preference.. in which case they may as well just use arrays..? -#!todo - add boolean property to force unique values as well as keys - - -#::pattern::create >collection - - - - -::>pattern .. Create >collection -set COL >collection -#process_pattern_aliases [namespace origin >collection] -#process_pattern_aliases ::patternlib::>collection -$COL .. Property version 1.0 -$COL .. PatternDefaultMethod item - -set PV [$COL .. PatternVariable .] - -$PV o_data -#$PV o_array -#$PV o_list -$PV o_alias -$PV this - -#for invert method -$PV o_dupes 0 - - -$COL .. PatternProperty bgEnum - - -#PV o_ns - -$PV m_i_filteredCollection - -#set ID [lindex [set >collection] 0 0] ;#context ID -#set IID [lindex [set >collection] 1 0] ;#level 1 base-interface ID - -$COL .. Constructor {args} { - var o_data m_i_filteredCollection o_count o_bgEnum - - var this - set this @this@ - - set m_i_filteredCollection 0 - if {![llength $args]} { - set o_data [dict create] - #array set o_array [list] - #set o_list [list] - set o_count 0 - } elseif {[llength $args] == 1} { - set o_data [dict create] - set pairs [lindex $args 0] - if {[llength $pairs] % 2} { - error "patternllib::>collection - if an argument given to constructor, it must have an even number of elements. Bad args: $args" - } - set keys_seen [list] - foreach key [dict keys $pairs] { - if {[string is integer -strict $key] } { - error ">collection key must be non-integer. Bad key: $key. No items added." - } - if {$key in $keys_seen} { - error "key '$key' already exists in this collection. No items added." - } - lappend keys_seen $key - } - unset keys_seen - #rely on dict ordering guarantees (post 8.5? preserves order?) - set o_data [dict merge $o_data[set o_data {}] $pairs] - set o_count [dict size $o_data] - } else { - error "patternlib::>collection constructor did not understand arguments supplied. Try a dict as a single argument." - } - array set o_alias [list] - - array set o_bgEnum [list] - @next@ -} -#comment block snipped from collection Constructor - #--------------------------------------------- - #set o_selfID [lindex [set $o_this] 0] ;#object id always available in methods as $_ID_ anyway - # - #### OBSOLETE - left as example of an approach - #make count property traceable (e.g so property ref can be bound to Tk widgets) - #!todo - manually update o_count in relevant methods faster?? - # should avoid trace calls for addList methods, shuffle etc - # - #set handler ::p::${_ID_}::___count_TraceHandler - #proc $handler {_ID_ vname vidx op} { - # #foreach {vname vidx op} [lrange $args end-2 end] {break} - # #! we shouldn't trust this vname - it may be that we are being accessed via upvar so it is a different name - # - # #this is only a 'write' handler - # set ::p::[lindex ${_ID_} 0 0]::o_count [llength [set ::p::[lindex ${_ID_} 0 0]::o_list]] - # return - #} - #trace add variable o_list {write} [list $handler $_ID_] - #### - # - # - #puts "--->collection constructor id: $_ID_" - - - - -set PM [$COL .. PatternMethod .] - - -#!review - why do we need the count method as well as the property? -#if needed - document why. -# read traces on count property can be bypassed by method call... shouldn't we avoid that? -#2018 - in theory write traces on the . count property are very useful from an application-writer's perpective. -# -$COL .. PatternMethod count {} { - #we don't require any instance vars to be upvar'ed - argless [var] stops them automatically being added. - #we directly refer to the ::O:: var if only accessing a few times rather than upvar'ing. - var o_data - dict size $o_data -} - -$COL .. PatternProperty count -$COL .. PatternPropertyWrite count {_val} { - var - error "count property is read-only" -} - -$COL .. PatternPropertyUnset count {} { - var -} ;#cannot raise error's in unset trace handlers - simply fail to unset silently - -$COL .. PatternMethod isEmpty {} { - #var o_list - #return [expr {[llength $o_list] == 0}] - var o_data - expr {[dict size $o_data] == 0} -} - -$COL .. PatternProperty inverted 0 - - - -###### -# item -###### -#defaults to fifo when no idx supplied (same as 'pair' method). !review? is lifo more logical/intuitive/useful? -# i.e [>obj . item] returns the 1st element in the list -#[>obj . item -1] returns the last element (equiv to "end" keyword used by Tcl list commands) -#[>obj . item -2] returns 2nd last element (equiv to "end-1") - - -$COL .. PatternMethod item {{idx 0}} { - #with pattern::0::$OID access.. was measured faster than item2 : approx 110us vs 140us for 26element collection accessed via string (time {>col $key} 10000) - # (still at least 20 times slower than a plain array... at <5us) - var o_data o_alias - - #!todo - review 'string is digit' vs 'string is integer' ?? - if {[string is integer -strict $idx]} { - if {$idx < 0} { - set idx "end-[expr {abs($idx + 1)}]" - } - set keys [dict keys $o_data] - if {[catch {dict get $o_data [lindex $keys $idx]} result]} { - var this - error "no such index : '$idx' in collection: $this" - } else { - return $result - } - } else { - if {[catch {dict get $o_data $idx} result]} { - if {[catch {set o_alias($idx)} nextIdx ]} { - var this - error "no such index: '$idx' in collection: $this" - } else { - #try again - #return $o_array($nextIdx) - #tailcall? - #item $_ID_ $nextIdx - #puts stdout "\n\n\n !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! about to call tailcall item $_ID_ $nextIdx \n\n\n" - tailcall item $_ID_ $nextIdx - } - } else { - return $result - } - } -} - - - -if {0} { -#leave this here for comparison. -$COL .. PatternMethod item2 {{idx 0}} { - var o_array o_list o_alias this - - if {[string is integer -strict $idx]} { - if {$idx < 0} { - set idx "end-[expr {abs($idx + 1)}]" - } - - if {[catch {set o_array([lindex $o_list $idx])} result]} { - error "no such index : '$idx' in collection: $this" - } else { - return $result - } - } else { - if {[catch {set o_array($idx)} result]} { - - if {[catch {set o_alias($idx)} nextIdx ]} { - error "no such index: '$idx' in collection: $this" - } else { - #try again - #return $o_array($nextIdx) - item $_ID_ $nextIdx - } - } else { - return $result - } - } - -} -} - -#simple no-frills access for speed.. (timed at 43us vs 63us for item (depending on dispatch method!)) -$COL .. PatternMethod itemNamed {idx} { - var o_data - dict get $o_data $idx -} -$COL .. PatternMethod in {idx} { - var o_data - dict get $o_data $idx -} - -$COL .. PatternMethod itemAt {idx} { - var o_data - dict get $o_data [lindex [dict keys $o_data] $idx] -} - -$COL .. PatternMethod replace {idx val} { - var o_data o_alias this - - if {[string is integer -strict $idx]} { - if {$idx < 0} { - set idx "end-[expr {abs($idx + 1)}]" - } - - if {[catch {dict set o_data [lindex [dict keys $o_data] $idx] $val}]} { - error "no such index: '$idx' in collection: $this" - } else { - return $val - } - } else { - if {[catch {dict set o_data $idx $val}]} { - if {[catch {set o_alias($idx)} nextIdx ]} { - error "no such index: '$idx' in collection: $this" - } else { - #try again - tailcall replace $_ID_ $nextIdx $val - } - - } else { - return $val - } - } -} - -#if the supplied index is an alias, return the underlying key; else return the index supplied. -$COL .. PatternMethod realKey {idx} { - var o_alias - - if {[catch {set o_alias($idx)} key]} { - return $idx - } else { - return $key - } -} - -#note alias feature is possibly ill-considered. -#if we delete an item - should we delete corresponding alias? If not - we then would need to allow adding under an alias only if the corresponding key is missing. -$COL .. PatternMethod alias {newAlias existingKeyOrAlias} { - var o_alias - - #set existingKey [realKey $_ID_ $existingKeyOrAlias] - #alias to the supplied KeyOrAlias - not the underlying key - - if {[string is integer -strict $newAlias]} { - error "collection key alias cannot be integer" - } - - if {[string length $existingKeyOrAlias]} { - set o_alias($newAlias) $existingKeyOrAlias - } else { - unset o_alias($newAlias) - } -} -$COL .. PatternMethod aliases {{key ""}} { - var o_alias - - if {[string length $key]} { - set result [list] - #lsearch -stride? - foreach {n v} [array get o_alias] { - if {$v eq $key} { - lappend result $n $v - } - } - - return $result - } else { - return [array get o_alias] - } -} - -#'pop' & 'unshift' methods !todo - optimize so lsearch not called when numerical idx/posn already supplied - -#default to removing item from the end, otherwise from supplied index (position or key) -#!todo - accept alias indices -#!todo - review.. should any corresponding alias be destroyed when the corresponding item is popped (or removed in any way?) -#!todo - review.. for performance.. shouldn't pop NOT accept an index? -#if we need to pop from other than the end.. this could be a separate function. Do other langs use pop with an index?? -$COL .. PatternMethod pop {{idx ""}} { - var o_data o_count - - if {$idx eq ""} { - set key [lindex [dict keys $o_data] end] - } else { - if {[string is integer -strict $idx]} { - set key [lindex [dict keys $o_data] $idx] - } else { - set key $idx - } - } - set posn [lsearch -exact [dict keys $o_data] $key] - - if {($posn >= 0) && ($posn < [dict size $o_data])} { - set result [dict get $o_data $key] - dict unset o_data $key - set o_count [dict size $o_data] - return $result - } else { - error "no such index: '$idx'" - } -} -$COL .. PatternMethod poppair {} { - var o_data o_count - set key [lindex [dict keys $o_data] end] - set val [dict get $o_data $key] - dict unset o_data $key - set o_count [dict size $o_data] - return [list $key $val] -} - - - -#!todo - add 'push' method... (basically specialized versions of 'add') -#push - add at end (effectively an alias for add) -#shift - add at start ???bad name? this is completely at odds with for example the common Perl shift function, which returns and removes the first element of an array. -#add - add at end - -#ordered -$COL .. PatternMethod items {} { - var o_data - - dict values $o_data -} - - - - -#### -#pair -#### -#fifo-style accesss when no idx supplied (likewise with 'add' method) -$COL .. PatternMethod pair {{idx 0}} { - var o_data - - if {[string is integer -strict $idx]} { - set key [lindex [dict keys $o_data] $idx] - } else { - set key $idx - } - - if {[catch {dict get $o_data $key} val]} { - error "no such index: '$idx'" - } else { - return [list $key $val] - } -} -$COL .. PatternMethod pairs {} { - var o_data - set o_data -} - -$COL .. PatternMethod get {} { - var o_data - set o_data -} -#todo - fix >pattern so that methods don't collide with builtins -#may require change to use oo - or copy 'my' mechanism to call own methods -$COL .. PatternMethod Info {} { - var o_data - return [dict info $o_data] -} -#2006-05-21.. args to add really should be in key, value order? -# - this the natural order in array-like lists -# - however.. key should be optional. - -$COL .. PatternMethod add {val args} { - #(using args instead of {key ""} enables use of empty string as a key ) - - var o_data o_alias o_count this - - if {![llength $args]} { - set key "_[::patternlib::uniqueKey]_" - } else { - #!todo - could we handle multiple val,key pairs without impacting performance of the common case? - if {[llength $args] > 1} { - error "add method expected 'val' and optional 'key' - got: $val $args" - - } - - set key [lindex $args 0] - if {[string is integer -strict $key]} { - error ">collection key must be non-numeric. Other structures such as >hashMap allow user specified integer keys" - } - } - - if {[dict exists $o_data $key]} { - #error "key $key already exists in collection [set ::p::[lindex ${_ID_} 0 0]::this]" - error "key '$key' already exists in collection $this" - } - if {[info exists o_alias($key)]} { - if {[dict exists $o_data $o_alias($key)]} { - #only disallow adding via the alias if there is an existing o_data element for the key pointed to by the alias - error "key '$key' already exists as an alias for $o_alias($key) in collection $this" - } - } - - dict set o_data $key $val - - - set posn $o_count - incr o_count - - return $posn -} - - -#should the 'stack' methods such as shift,push,pop,peek actually be on a separate interface? -#what then of methods like 'count' which apply equally well to collections and stacks? - -#Alias for 'add' - is there a way to alias this to add implementation with zero overhead?? -$COL .. PatternMethod push {val args} { - #(using args instead of {key ""} enables use of empty string as a key ) - - var o_data o_alias o_count this - - if {![llength $args]} { - set key "_[::patternlib::uniqueKey]_" - } else { - #!todo - could we handle multiple val,key pairs without impacting performance of the common case? - if {[llength $args] > 1} { - error "add method expected 'val' and optional 'key' - got: $val $args" - - } - - set key [lindex $args 0] - if {[string is integer -strict $key]} { - error ">collection key must be non-numeric. Other structures such as >hashMap allow user specified integer keys" - } - } - - if {[dict exists $o_data $key]} { - #error "key $key already exists in collection [set ::p::[lindex ${_ID_} 0 0]::this]" - error "key '$key' already exists in collection $this" - } - if {[info exists o_alias($key)]} { - if {[dict exists $o_data $o_alias($key)]} { - #only disallow adding via the alias if there is an existing o_data element for the key pointed to by the alias - error "key '$key' already exists as an alias for $o_alias($key) in collection $this" - } - } - - dict set o_data $key $val - - - set posn $o_count - incr o_count - - return $posn -} - - -#shift/unshift - roughly analogous to those found in Perl & PHP -#unshift adds 1 or more values to the beginning of the collection. -$COL .. PatternMethod unshift {values {keys ""}} { - var o_data o_count - - if {![llength $keys]} { - for {set i 0} {$i < [llength $values]} {incr i} { - lappend keys "_[::patternlib::uniqueKey]_" - } - } else { - #check keys before we insert any of them. - foreach newkey $keys { - if {[string is integer -strict $newkey]} { - error "cannot accept key '$newkey', >collection keys must be non-numeric. Other structures such as >hashMap allow user specified integer keys" - } - } - } - if {[llength $values] != [llength $keys]} { - error "unshift requires same number of keys as values. (or no keys for auto-generated keys) Received [llength $values] values, [llength $keys] keys" - } - - #separate loop through keys because we want to fail the whole operation if any are invalid. - - set existing_keys [dict keys $o_data] - foreach newkey $keys { - if {$newkey in $exisint_keys} { - #puts stderr "==============> key $key already exists in this collection" - error "key '$newkey' already exists in this collection" - } - } - - - #ok - looks like entire set can be inserted. - set newpairs [list] - foreach val $values key $keys { - lappend newpairs $key $val - } - set o_data [concat $newpairs $o_data[set o_data {}]] - set o_count [dict size $o_data] - - return [expr {$o_count - 1}] -} - -#default to removing item from the beginning, otherwise from supplied index (position or key) -#!todo - accept alias indices -$COL .. PatternMethod shift {{idx ""}} { - var o_data o_count - - if {$idx eq ""} { - set key [lindex [dict keys $o_data] 0] - } else { - if {[string is integer -strict $idx]} { - set key [lindex [dict keys $o_data] $idx] - } else { - set key $idx - } - } - set posn [lsearch -exact [dict keys $o_data] $key] - - if {($posn >= 0) && (($posn/2) < [dict size $o_data])} { - set result [dict get $o_data $key] - dict unset o_data $key - set o_count [dict size $o_data] - return $result - } else { - error "no such index: '$idx'" - } -} - - -$COL .. PatternMethod peek {} { - var o_data - - #set o_array([lindex $o_list end]) - - #dict get $o_data [lindex [dict keys $o_data] end] - lindex $o_data end -} - -$COL .. PatternMethod peekKey {} { - var o_data - #lindex $o_list end - lindex $o_data end-1 -} - - -$COL .. PatternMethod insert {val args} { - var o_data o_count - - set idx 0 - set key "" - - if {[llength $args] <= 2} { - #standard arg (ordered) style: - #>obj . insert $value $position $key - - lassign $args idx key - } else { - #allow for literate programming style: - #e.g - # >obj . insert $value at $listPosition as $key - - if {[catch {array set iargs $args}]} { - error "insert did not understand argument list. -usage: ->obj . insert \$val \$position \$key ->obj . insert \$val at \$position as \$key" - } - if {[info exists iargs(at)]} { - set idx $iargs(at) - } - if {[info exists iargs(as)]} { - set key $iargs(as) - } - } - - if {![string length $key]} { - set key "_[::patternlib::uniqueKey]_" - } - - if {[string is integer -strict $key]} { - error ">collection key must be non-numeric. Other structures such as >hashMap allow user specified integer keys" - } - - - if {[dict exists $o_data $key]} { - #puts stderr "==============> key $key already exists in this collection" - error "key '$key' already exists in this collection" - } - - if {$idx eq "end"} { - #lappend o_list $key - #standard dict set will add it to the end anyway - dict set o_data $key $val - - } else { - #set o_list [linsert $o_list $idx $key] - - #treat dict as list - set o_data [linsert $o_data[set o_data {}] [expr {$idx*2}] $key $val] - } - - - #set o_array($key) $val - - - set o_count [dict size $o_data] - - return [expr {$o_count - 1}] -} - -#!todo - deprecate and give it a better name! addDict addPairs ? -$COL .. PatternMethod addArray {list} { - var - puts stderr "patternlib::>collection WARNING: addArray deprecated - call addPairs with same argument instead" - tailcall addPairs $_ID_ $list -} -$COL .. PatternMethod addPairs {list} { - var o_data o_alias o_count - if {[llength $list] % 2} { - error "must supply an even number of elements" - } - - set aliaslist [array names o_alias] - #set keylist [dict keys $o_data] - foreach newkey [dict keys $list] { - if {[string is integer -strict $newkey] } { - error ">collection key must be non-integer. Bad key: $newkey. No items added." - } - - #if {$newkey in $keylist} {} - #for small to medium collections - testing for newkey in $keylist is probably faster, - # but we optimise here for potentially large existing collections, where presumably a dict exists lookup will be more efficient. - if {[dict exists $o_data $newkey]} { - error "key '$newkey' already exists in this collection. No items added." - } - #The assumption is that there are in general relatively few aliases - so a list test is appropriate - if {$newkey in $aliaslist} { - if {[dict exists $o_data $o_alias($newkey)]} { - error "key '$newkey' already exists as an alias for $o_alias($newkey) in collection. No items added " - } - } - #! check if $list contains dups? - #- slows method down - for little benefit? - } - #!todo - test? (but we need a loop to test for integer keys.. so what's the point?) - #set intersection [struct::set intersect [dict keys $list] [dict keys $o_data]] - #if {[llength $intersection]} { - # error "keys '$intersection' already present in this collection. No items added." - #} - - - #rely on dict ordering guarantees (post 8.5? preserves order?) - set o_data [dict merge $o_data[set o_data {}] $list] - - set o_count [dict size $o_data] - - return [expr {$o_count - 1}] -} -$COL .. PatternMethod addList {list} { - var o_data o_count - - foreach val $list { - dict set o_data "_[::patternlib::uniqueKey]_" $val - #!todo - test. Presumably lappend faster because we don't need to check existing keys.. - #..but.. is there shimmering involved in treating o_data as a list? - #lappend o_data _[::patternlib::uniqueKey]_ $val - - #tested 2008-06 tcl8.6a0 lappend was slower as the gain is lost (and more!) during subsequent [dict size $o_data] - } - set o_count [dict size $o_data] - - return [expr {$o_count - 1}] -} - -#'del' is not a very good name... as we're not really 'deleting' anything. -# 'remove' seems better, and appears to be more consistent with other languages' collection implementations. -#!todo - handle 'endRange' parameter for removing ranges of items. -$COL .. PatternMethod del {idx {endRange ""}} { - var - #!todo - emit a deprecation warning for 'del' - tailcall remove $_ID_ $idx $endRange -} - -$COL .. PatternMethod remove {idx {endRange ""}} { - var o_data o_count o_alias this - - if {[string length $endRange]} { - 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} { - if {[catch {set o_alias($key)} nextKey]} { - error "no such index: '$idx' in collection: $this" - } else { - #try with next key in alias chain... - #return [remove $_ID_ $nextKey] - tailcall remove $_ID_ $nextKey - } - } - } - - dict unset o_data $key - - set o_count [dict size $o_data] - return -} - -#ordered -$COL .. PatternMethod names {{globOrIdx {}}} { - var o_data - - if {[llength $globOrIdx]} { - if {[string is integer -strict $globOrIdx]} { - #Idx - set idx $globOrIdx - - if {$idx < 0} { - set idx "end-[expr {abs($idx + 1)}]" - } - - - - if {[catch {lindex [dict keys $o_data] $idx} result]} { - error "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] - } -} - -#ordered -$COL .. PatternMethod keys {} { - #like 'names' but without globbing - var o_data - dict keys $o_data -} - -#Unfortunately the string 'name' is highly collidable when mixing in a collection over existing objects -# - !todo - review. Is it worth adjusting the collection methodnames to avoid a few common collision cases? -# - some sort of resolution order/interface-selection is clearly required anyway -# so perhaps it's generally best not to bother being 'polite' here, and implement a robust understandable resolution mechanism. -# In the mean time however... we'll at least avoid 'name'! -# -#$PM name {{posn 0}} { -# var o_array o_list -# -# if {$posn < 0} { -# set posn "end-[expr {abs($posn + 1)}]" -# } -# -# if {[catch {lindex $o_list $posn} result]} { -# error "no such index : '$posn'" -# } else { -# return $result -# } -#} - -$COL .. PatternMethod key {{posn 0}} { - var o_data - - if {$posn < 0} { - set posn "end-[expr {abs($posn + 1)}]" - } - - if {[catch {lindex [dict keys $o_data] $posn} result]} { - error "no such index : '$posn'" - } else { - return $result - } -} - - -#!todo - consider use of 'end-x' syntax for 'to', and implications re consistency with other commands. -$COL .. PatternMethod setPosn {idx to} { - var o_data - - if {![string is integer -strict $to]} { - error "destination position must be numeric, consider reKey method if you are trying to change the string key under which this value is stored" - } - - if {[string is integer -strict $idx]} { - set idx [expr {$idx % [dict size $o_data]}] - - set key [lindex [dict keys $o_data] $idx] - set posn $idx - } else { - set key $idx - set posn [lsearch -exact [dict keys $o_data] $key] - } - - set to [expr {$to % [dict size $o_data]}] - - - set val [dict get $o_data $key] - dict unset o_data $key - - #treat dict as list - set o_data [linsert $o_data[set o_data {}] [expr {$posn*2}] $key $val] - - #set o_list [lreplace $o_list $posn $posn] - #set o_list [linsert $o_list $to $key] - - return $to -} -#!todo - improve efficiency of calls to other functions on this object.. 'inline'?? -#presumably the collection object functionality will be long-term stable because it's purpose is to be a core datastructure; therefore it should be reasonable to favour efficiency over maintainability. -$COL .. PatternMethod incrPosn {idx {by 1}} { - var o_data - if {[string is integer -strict $idx]} { - set idx [expr {$idx % [dict size $o_data]}] - set key [lindex [dict keys $o_data] $idx] - set posn $idx - } else { - set key $idx - set posn [lsearch -exact [dict keys $o_data] $key] - } - - set newPosn [expr {($posn + $by) % [dict size $o_data]}] - - setPosn $_ID_ $posn $newPosn - return $newPosn -} -$COL .. PatternMethod decrPosn {idx {by 1}} { - var - return [incrPosn $_ID_ $idx [expr {- $by}]] -} -$COL .. PatternMethod move {idx to} { - var - return [setPosn $_ID_ $idx $to] -} -$COL .. PatternMethod posn {key} { - var o_data - return [lsearch -exact [dict keys $o_data] $key] -} - -#!todo? - disallow numeric values for newKey so as to be consistent with add -#!note! - item can be reKeyed out from under an alias such that the alias chain no longer points to anything -# - this is ok. -$COL .. PatternMethod reKey {idx newKey} { - var o_data o_alias - - - if {[dict exists $o_data $newKey]} { - #puts stderr "==============> reKey collision, key $newKey already exists in this collection" - error "reKey collision, key '$newKey' already exists in this collection" - } - if {[info exists o_alias($newKey)]} { - if {[dict exists $o_data $o_alias($newKey)]} { - error "reKey collision, key '$newKey' already present as an alias in this collection" - } else { - set newKey $o_alias($newKey) - } - } - - - - 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} { - if {[catch {set o_alias($key)} nextKey]} { - error "no such index: '$idx'" - } else { - #try with next key in alias chain... - #return [reKey $_ID_ $nextKey $newKey] - tailcall reKey $_ID_ $nextKey $newKey - } - } - } - - #set o_list [lreplace $o_list $posn $posn $newKey] - ##atomic? (traces on array?) - #set o_array($newKey) $o_array($key) - #unset o_array($key) - - dict set o_data $newKey [dict get $o_data $key] - dict unset o_data $key - - return -} -$COL .. PatternMethod hasKey {key} { - var o_data - dict exists $o_data $key -} -$COL .. PatternMethod hasAlias {key} { - var o_alias - info exists o_alias($key) -} - -#either key or alias -$COL .. PatternMethod hasIndex {key} { - var o_data o_alias - if {[dict exists $o_data $key]} { - return 1 - } else { - return [info exists o_alias($key)] - } -} - - -#Shuffle methods from http://mini.net/tcl/941 -$COL .. PatternMethod shuffleFast {} { - #shuffle6 - fast, but some orders more likely than others. - - var o_data - - set keys [dict keys $o_data] - - set n [llength $keys] - for { set i 1 } { $i < $n } { incr i } { - set j [expr { int( rand() * $n ) }] - set temp [lindex $keys $i] - lset keys $i [lindex $keys $j] - lset keys $j $temp - } - - #rebuild dict in new order - #!todo - can we do the above 'in place'? - set newdata [dict create] - foreach k $keys { - dict set newdata $k [dict get $o_data $k] - } - set o_data $newdata - - return -} -$COL .. PatternMethod shuffle {} { - #shuffle5a - - var o_data - - set n 1 - set keys [list] ;#sorted list of keys - foreach k [dict keys $o_data] { - #set index [expr {int(rand()*$n)}] - - #set slist [linsert [::pattern::K $keys [set keys {}]] $index $k] - - #faster alternative.. 'inline K' [lindex [list a b] 0] ~ [K a b] - set keys [linsert [lindex [list $keys [set keys {}]] 0] [expr {int(rand()*$n)}] $k] - incr n - } - - #rebuild dict in new order - #!todo - can we do the above 'in place'? - set newdata [dict create] - foreach k $keys { - dict set newdata $k [dict get $o_data $k] - } - set o_data $newdata - - return -} - - -#search is a somewhat specialised form of 'itemKeys' -$COL .. PatternMethod search {value args} { - var o_data - #only search on values as it's possible for keys to match - especially with options such as -glob - 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 - } -} - -#inverse lookup -$COL .. PatternMethod itemKeys {value} { - var o_data - #only search on values as it's possible for keys to match - 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 -} - -#invert: -#change collection to be indexed by its values with the old keys as new values. -# - keys of duplicate values become a list keyed on the value. -#e.g the array equivalent is: -# arr(a) 1 -# arr(b) 2 -# arr(c) 2 -#becomes -# inv(1) a -# inv(2) {b c} -#where the order of duplicate-value keys is not defined. -# -#As the total number of keys may change on inversion - order is not preserved if there are ANY duplicates. -# - - -#!todo - try just [lreverse $o_data] ?? - - -$COL .. PatternMethod invert {{splitvalues ""}} { - - var o_data o_count o_dupes o_inverted - - - if {$splitvalues eq ""} { - #not overridden - use o_dupes from last call to determine if values are actually keylists. - if {$o_dupes > 0} { - set splitvalues 1 - } else { - set splitvalues 0 - } - } - - - #set data [array get o_array] - set data $o_data - - if {$o_count > 500} { - #an arbitrary optimisation for 'larger' collections. - #- should theoretically keep the data size and save some reallocations. - #!todo - test & review - # - foreach nm [dict keys $o_data] { - dict unset o_data $nm - } - } else { - set o_data [dict create] - } - - if {!$splitvalues} { - dict for {k v} $data { - dict set o_data $v $k - } - } else { - dict for {k v} $data { - #we're splitting values because each value is a list of keys - #therefore sub should be unique - no need for lappend in this branch. - foreach sub $v { - #if {[info exists o_array($sub)]} { - # puts stderr "---here! v:$v sub:$sub k:$k" - # lappend o_array($sub) $k - #} else { - dict set o_data $sub $k - #} - } - } - } - - - if {[dict size $o_data] != $o_count} { - #must have been some dupes - - set o_dupes [expr {$o_count - [dict size $o_data]}] - #update count to match inverted collection - set o_count [dict size $o_data] - } else { - set o_dupes 0 - } - - set o_inverted [expr {!$o_inverted}] - - #'dupes' is the size difference - so 3 equal values in the original collection corresponds to '2 dupes' - return $o_dupes -} - - - - - - -#NOTE: values are treated as lists and split into separate keys for inversion only if requested! -# To treat values as keylists - set splitvalues 1 -# To treat each value atomically - set splitvalues 0 -# i.e only set splitvalues 1 if you know the values represent duplicate keys from a previous call to invert! -# -# -#Initially call invert with splitvalues = 0 -#To keep calling invert and get back where you started.. -# The rule is... if the previous call to invert returned > 0... pass 1 on the next call. -# -$COL .. PatternMethod invert_manual {{splitvalues 0}} { - #NOTE - the list nesting here is *tricky* - It probably isn't broken. - - var o_list o_array o_count - - set data [array get o_array] - - if {$o_count > 500} { - #an arbitrary optimisation for 'large' collections. - #- should theoretically keep the array size and save some reallocations. - #!todo - test & review - # - foreach nm [array names o_array] { - unset o_array($nm) - } - } else { - array unset o_array - } - - if {!$splitvalues} { - foreach {k v} $data { - lappend o_array($v) $k - } - } else { - foreach {k v} $data { - #we're splitting values because each value is a list of keys - #therefore sub should be unique - no need for lappend in this branch. - foreach sub $v { - #if {[info exists o_array($sub)]} { - # puts stderr "---here! v:$v sub:$sub k:$k" - # lappend o_array($sub) $k - #} else { - set o_array($sub) $k - #} - } - } - } - - - if {[array size o_array] != $o_count} { - #must have been some dupes - set o_list [array names o_array] - - - set dupes [expr {$o_count - [array size o_array]}] - #update count to match inverted collection - set o_count [array size o_array] - } else { - #review - are these machinations worthwhile for order preservation? what speed penalty do we pay? - array set prev $data - set i -1 - if {$splitvalues} { - #values are lists of length one. Take lindex 0 so list values aren't overnested. - foreach oldkey $o_list { - lset o_list [incr i] [lindex $prev($oldkey) 0] - } - } else { - foreach oldkey $o_list { - lset o_list [incr i] $prev($oldkey) - } - } - - set dupes 0 - } - - - #'dupes' is the size difference - so 3 equal values in the original collection corresponds to '2 dupes' - return $dupes -} - - - -#Note that collections cannot be inverted without loss of information if they have duplicates AND compound keys -# (keys that are lists) -$COL .. PatternMethod invert_lossy {{splitvalues 1}} { - var o_list o_array o_count - - set data [array get o_array] - - if {$o_count > 500} { - #an arbitrary optimisation for 'large' collections. - #- should theoretically keep the array size and save some reallocations. - #!todo - test & review - # - foreach nm [array names o_array] { - unset o_array($nm) - } - } else { - array unset o_array - } - - if {!$splitvalues} { - foreach {k v} $data { - #note! we must check for existence and use 'set' for first case. - #using 'lappend' only will result in deeper nestings on each invert! - #If you don't understand this - don't change it! - if {[info exists o_array($v)]} { - lappend o_array($v) $k - } else { - set o_array($v) $k - } - } - } else { - foreach {k v} $data { - #length test necessary to avoid incorrect 'un-nesting' - #if {[llength $v] > 1} { - foreach sub $v { - if {[info exists o_array($sub)]} { - lappend o_array($sub) $k - } else { - set o_array($sub) $k - } - } - #} else { - # if {[info exists o_array($v)]} { - # lappend o_array($v) $k - # } else { - # set o_array($v) $k - # } - #} - } - } - - - if {[array size o_array] != $o_count} { - #must have been some dupes - set o_list [array names o_array] - - - set dupes [expr {$o_count - [array size o_array]}] - #update count to match inverted collection - set o_count [array size o_array] - } else { - #review - are these machinations worthwhile for order preservation? what speed penalty do we pay? - array set prev $data - set i -1 - foreach oldkey $o_list { - lset o_list [incr i] $prev($oldkey) - } - set dupes 0 - } - - - #'dupes' is the size difference - so 3 equal values in the original collection corresponds to '2 dupes' - return $dupes -} - -$COL .. PatternMethod reverse {} { - var o_data - - 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 -} - -$COL .. PatternMethod keySort {{options -ascii}} { - var o_data - - set keys [lsort {*}$options [dict keys $o_data]] - - set dictnew [dict create] - foreach k $keys { - dict set dictnew $k [dict get $o_data $k] - } - set o_data $dictnew - - return -} - -#!todo - allow simple options in combination with options such as -command and -object. Redo args handling completely for more complex sorting. -$COL .. PatternMethod sort {args} { - var o_data - - #defaults - set options [dict create -index 1] ;#values always in subelement 1 of name-value pair list for sorting. - - set options_simple [list] - - - for {set i 0} {$i < [llength $args]} {incr i} { - set a [lindex $args $i] - switch -- $a { - -indices - - -ascii - - -dictionary - - -integer - - -real - - -increasing - - -decreasing { - #dict set options $a 1 - lappend options_simple $a - } - -unique { - #not a valid option - #this would stuff up the data... - #!todo? - remove dups from collection if this option used? - alias the keys? - } - -object { - #!todo - treat value as object and allow sorting by sub-values .eg >col1 . sort -object ". sub . property" -increasing - #may be slow - but handy. Consider -indexed property to store/cache these values on first run - } - -command { - dict set options $a [lindex $args [incr i]] - } - -index { - #allow sorting on subindices of the value. - dict set options -index [concat [dict get $options -index] [lindex $args [incr i]] ] - } - default { - #unrecognised option - print usage? - } - } - } - - - - if {[set posn [lsearch -exact $options_simple "-indices"]] >= 0} { - - var o_array - - set slist [list] - foreach k [dict keys $o_data] { - lappend slist [list $k [dict get $o_data $k]] - } - return [lsort {*}$options_simple {*}$options $slist] - - - - #set options_simple [lreplace $options_simple $posn $posn] ;# - #set slist [list] - #foreach {n v} [array get ::p::[lindex ${_ID_} 0 0]::o_array] { - # lappend slist [list $n $v] - #} - #set slist [lsort {*}$options_simple {*}$options $slist] - #foreach i $slist { - # #determine the position in the collections list - # lappend result {*}[lsearch -exact $o_list [lindex $i 0]] - #} - #return $result - } else { - set slist [list] - dict for {k v} $o_data { - lappend slist [list $k $v] - } - #set slist [lsort {*}$options_simple {*}$options $slist] - set slist [lsort {*}$options_simple {*}$options $slist[set slist {}]] ;#K combinator for efficiency - - - #set o_list [lsearch -all -inline -subindices -index 0 $slist *] - - set o_data [dict create] - foreach pair $slist { - dict set o_data [lindex $pair 0] [lindex $pair 1] - } - - - - return - } - -} - - -$COL .. PatternMethod clear {} { - var o_data o_count - - set o_data [dict create] - set o_count 0 - #aliases? - return -} - -#see http://wiki.tcl.tk/15271 - A generic collection traversal interface -# -#!todo - options: -progresscommand -errorcommand (-granularity ?) (-self ? (to convert to an iterator?)) -#!todo? - lazy retrieval of items so that all changes to the collection are available to a running asynch enumeration? -# - should this be an option? which mechanism should be the default? -# - currently only the keylist is treated in 'snapshot' fashion -# so values could be changed and the state could be invalidated by other code during an enumeration -# -$COL .. PatternMethod enumerate {args} { - #---------- - lassign [lrange $args end-1 end] cmd seed - set optionlist [list] - foreach a [lrange $args 0 end-2] { - lappend optionlist $a - } - set opt(-direction) left - set opt(-completioncommand) "" - array set opt $optionlist - #---------- - var o_data - - if {[string tolower [string index $opt(-direction) 0]] eq "r"} { - #'right' 'RIGHT' 'r' etc. - set list [lreverse [dict keys $o_data]] - } else { - #normal left-right order - set list [dict keys $o_data] - } - - if {![string length $opt(-completioncommand)]} { - #standard synchronous processing - foreach k $list { - set seed [uplevel #0 [list {*}$cmd $seed [dict get $o_data $k]]] - } - return $seed - } else { - #ASYNCHRONOUS enumeration - var this o_bgEnum - #!todo - make id unique - #!todo - facility to abort running enumeration. - set enumID enum[array size o_bgEnum] - - set seedvar [$this . bgEnum $enumID .] - set $seedvar $seed - - after 0 [list $this . _doBackgroundEnum $enumID $list $cmd $seedvar $opt(-completioncommand)] - return $enumID - } -} - -#!todo - make private? - put on a separate interface? -$COL .. PatternMethod _doBackgroundEnum {enumID slice cmd seedvar completioncommand} { - var this o_data - - - #Note that we don't post to the eventqueue using 'foreach s $slice' - # we only schedule another event after each item is processed - # - otherwise we would be spamming the eventqueue with items. - - #!todo? - accept a -granularity option to allow handling of n list-items per event? - - if {[llength $slice]} { - set slice [lassign $slice head] - - set script [string map [list %cmd% $cmd %seedvar% $seedvar %val% [dict get $o_data $head]] { - %cmd% [set %seedvar%] %val% - }] - - #post to eventqueue and re-enter _doBackgroundEnum - # - after idle [list after 0 [subst {set $seedvar \[uplevel #0 [list $script] \]; $this . _doBackgroundEnum $enumID [list $slice] [list $cmd] $seedvar [list $completioncommand]}]] - - } else { - #done. - - set script [string map [list %cmd% $completioncommand %seedvar% $seedvar] { - lindex [list [%cmd% [set %seedvar%]] [unset %seedvar%]] 0 - }] - - after idle [list after 0 [list uplevel #0 $script]] - } - - return -} - -$COL .. PatternMethod enumeratorstate {} { - var o_bgEnum - parray o_bgEnum -} - -#proc ::bgerror {args} { -# puts stderr "=bgerror===>$args" -#} - - -#map could be done in terms of the generic 'enumerate' method.. but it's slower. -# -#$PM map2 {proc} { -# var -# enumerate $_ID_ [list ::map-helper $proc] [list] -#} -#proc ::map-helper {proc accum item} { -# lappend accum [uplevel #0 [list {*}$proc $item]] -#} - -$COL .. PatternMethod map {cmd} { - var o_data - set seed [list] - dict for {k v} $o_data { - lappend seed [uplevel #0 [list {*}$cmd $v]] - } - - return $seed -} -$COL .. PatternMethod objectmap {cmd} { - var o_data - set seed [list] - dict for {k v} $o_data { - lappend seed [uplevel #0 [list $v {*}$cmd]] - } - - return $seed -} - - -#End core collection functionality. -#collection 'mixin' interfaces - ->pattern .. Create >keyvalprotector ->keyvalprotector .. PatternVariable o_protectedkeys ->keyvalprotector .. PatternVariable o_protectedvals - -#!todo - write test regarding errors in Constructors for mixins like this -# - an error (e.g from bad args) can cause errors with vars after it's re-run with correct args ->keyvalprotector .. Constructor {args} { - var this o_protectedkeys o_protectedvals - set this @this@ - #---------------------------------------------------------------------------- - set known_opts [list -keys -vals ] - dict set default -keys [list] - dict set default -vals [list] - if {([llength $args] % 2) != 0} { - error "(>keyvalprotector .. Constructor) ERROR: uneven options supplied - must be of form '-option value' " - } - foreach {k v} $args { - if {$k ni $known_opts} { - error "(>keyvalprotector .. Constructor) ERROR: option '$k' not in known options: '$known_opts'" - } - } - set opts [dict merge $default $args] - set o_protectedkeys [dict get $opts -keys] - set o_protectedvals [dict get $opts -vals] - #---------------------------------------------------------------------------- - set protections [concat $o_protectedkeys $o_protectedvals] - if {![llength $protections]} { - error "(>keyvalprotector .. Constructor) ERROR: must supply at least one argument to -vals or -keys" - } - -} ->keyvalprotector .. PatternMethod clear {} { - error "(>keyvalprotector . clear) ERROR: This collection is protected by a >keyvalprotector mixin. Cannot clear" -} ->keyvalprotector .. PatternMethod pop {{idx ""}} { - var o_data o_count o_protectedkeys o_protectedvals - - if {$idx eq ""} { - set key [lindex [dict keys $o_data] end] - } else { - if {[string is integer -strict $idx]} { - set key [lindex [dict keys $o_data] $idx] - } else { - set key $idx - } - } - - if {$key in $o_protectedkeys} { - error "(>keyvalprotector . pop) ERROR: Cannot pop object with index '$idx', key '$key' from collection." - } - set posn [lsearch -exact [dict keys $o_data] $key] - if {($posn >= 0) && ($posn < [dict size $o_data])} { - set result [dict get $o_data $key] - if {$result in $o_protectedvals} { - error "(>keyvalprotector . pop) ERROR: Cannot pop object '$result' with index '$idx', key '$key' from collection." - } - dict unset o_data $key - set o_count [dict size $o_data] - return $result - } else { - error "no such index: '$idx'" - } - -} ->keyvalprotector .. PatternMethod remove {idx {endRange ""}} { - var this o_data o_count o_alias o_protectedkeys o_protectedvals - - if {[string length $endRange]} { - 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] - if {$key in $o_protectedkeys} { - error "(>keyvalprotector . remove) ERROR: cannot remove item with index '$idx' key '$key' from collection" - } - set posn $idx - } else { - set key $idx - set posn [lsearch -exact [dict keys $o_data] $key] - if {$posn < 0} { - if {[catch {set o_alias($key)} nextKey]} { - error "no such index: '$idx' in collection: $this" - } else { - if {$key in $o_protectedkeys} { - error "(>keyvalprotector . remove) ERROR: cannot remove item with index '$idx' from collection" - } - #try with next key in alias chain... - #return [remove $_ID_ $nextKey] - tailcall remove $_ID_ $nextKey - } - } - } - - dict unset o_data $key - - set o_count [dict size $o_data] - return -} - -#1) -#predicate methods (order preserving) -#usage: -# >collection .. Create >c1 -# >predicatedCollection .. Create >c1 ;#overlay predicate methods on existing collection - -#e.g >col1 . all {$val > 14} -#e.g >col1 . filterToCollection {$val > 19} . count -#e.g >col1 . filter {[string match "x*" $key]} -#!todo - fix. currying fails.. - -::>pattern .. Create >predicatedCollection -#process_pattern_aliases ::patternlib::>predicatedCollection - -set PM [>predicatedCollection .. PatternMethod .] - ->predicatedCollection .. PatternMethod filter {predicate} { - var this o_list o_array - set result [list] - - #!note (jmn 2004) how could we do smart filtering based on $posn? - #i.e it would make sense to lrange $o_list based on $posn... - #but what about complicated expressions where $posn is a set of ranges and/or combined with tests on $key & $val ?? - #Seems better to provide an alternative efficient means of generating subcolllections/ranges to perform predicate operations upon. - #given this, is $posn even useful? - - set posn 0 - foreach key $o_list { - set val $o_array($key) - if $predicate { - lappend result $val - } - incr posn - } - set result -} ->predicatedCollection .. PatternMethod filterToKeys {predicate} { - var this o_list o_array - set result [list] - - set posn 0 - foreach key $o_list { - set val $o_array($key) - if $predicate { - lappend result $key - } - incr posn - } - set result -} ->predicatedCollection .. PatternMethod filterToCollection {predicate {destCollection {}}} { - #!todo - collection not in subordinate namespace? -> if subordinate, should imply modification of sub's contents will be reflected in parent? - #!todo - implement as 'view' on current collection object.. extra o_list variables? - #!todo - review/document 'expected' key collision behaviour - source keys used as dest keys.. -autokey option required? - var this o_list o_array m_i_filteredCollection - - incr m_i_filteredCollection - if {![string length $destCollection]} { - #!todo? - implement 'one-shot' object (similar to RaTcl) - set result [::patternlib::>collection .. Create [$this .. Namespace]::>filteredCollection-$m_i_filteredCollection] - } else { - set result $destCollection - } - - #### - #externally manipulate new collection - #set ADD [$c . add .] - #foreach key $o_list { - # set val $o_array($key) - # if $predicate { - # $ADD $val $key - # } - #} - ### - - #internal manipulation faster - #set cID [lindex [set $result] 0] - set cID [lindex [$result --] 0] - - #use list to get keys so as to preserve order - set posn 0 - upvar #0 ::p::${cID}::o_array cARRAY ::p::${cID}::o_list cLIST - foreach key $o_list { - set val $o_array($key) - if $predicate { - if {[info exists cARRAY($key)]} { - error "key '$key' already exists in this collection" - } - lappend cLIST $key - set cARRAY($key) $val - } - incr posn - } - - return $result -} - -#NOTE! unbraced expr/if statements. We want to evaluate the predicate. ->predicatedCollection .. PatternMethod any {predicate} { - var this o_list o_array - set posn 0 - foreach key $o_list { - set val $o_array($key) - if $predicate { - return 1 - } - incr posn - } - return 0 -} ->predicatedCollection .. PatternMethod all {predicate} { - var this o_list o_array - set posn 0 - foreach key $o_list { - set val $o_array($key) - if !($predicate) { - return 0 - } - incr posn - } - return 1 -} ->predicatedCollection .. PatternMethod dropWhile {predicate} { - var this o_list o_array - set result [list] - set _idx 0 - set posn 0 - foreach key $o_list { - set val $o_array($key) - if $predicate { - incr _idx - } else { - break - } - incr posn - } - set remaining [lrange $o_list $_idx end] - foreach key $remaining { - set val $o_array($key) - lappend result $val - } - return $result -} ->predicatedCollection .. PatternMethod takeWhile {predicate} { - var this o_list o_array - set result [list] - set posn 0 - foreach key $o_list { - set val $o_array($key) - if $predicate { - lappend result $val - } else { - break - } - incr posn - } - set result -} - - - -#end >collection mixins -###################################### - - - - -#----------------------------------------------------------- -#!TODO - methods for converting an arrayHandle to & from a hashMap efficiently? -# Why do we need both? apart from the size variable, what is the use of hashMap? -#----------------------------------------------------------- -#::pattern::create >hashMap -::>pattern .. Create >hashMap - ->hashMap .. PatternVariable o_size ->hashMap .. PatternVariable o_array - ->hashMap .. Constructor {args} { - var o_array o_size - array set o_array [list] - set o_size 0 -} ->hashMap .. PatternDefaultMethod "item" ->hashMap .. PatternMethod item {key} { - var o_array - set o_array($key) -} ->hashMap .. PatternMethod items {} { - var o_array - - set result [list] - foreach nm [array names o_array] { - lappend result $o_array($nm) - } - return $result -} ->hashMap .. PatternMethod pairs {} { - var o_array - - array get o_array -} ->hashMap .. PatternMethod add {val key} { - var o_array o_size - - set o_array($key) $val - incr o_size - return $key -} - ->hashMap .. PatternMethod del {key} { - var - puts stderr "warning: 'del' method of >hashMap deprecated. Use 'remove' instead." - remove $_ID_ $key -} ->hashMap .. PatternMethod remove {key} { - var o_array o_size - unset o_array($key) - incr o_size -1 - return $key -} ->hashMap .. PatternMethod count {} { - var o_size - #array size o_array - return $o_size -} ->hashMap .. PatternMethod count2 {} { - var o_array - #array size o_array ;#slow, at least for TCLv8.4.4 - #even array statistics is faster than array size ! - #e.g return [lindex [array statistics o_array] 0] - #but.. apparently there are circumstances where array statistics doesn't report the correct size. - return [array size o_array] -} ->hashMap .. PatternMethod names {} { - var o_array - array names o_array -} ->hashMap .. PatternMethod keys {} { - #synonym for names - var o_array - array names o_array -} ->hashMap .. PatternMethod hasKey {key} { - var o_array - return [info exists o_array($key)] -} ->hashMap .. PatternMethod clear {} { - var o_array o_size - unset o_array - set o_size 0 - return -} -#>hashMap .. Ready 1 - - - - - - - - - - - - - - - -#explicitly create metadata. Not required for user-defined patterns. -# this is only done here because this object is used for the metadata of all objects -# so the object must have all it's methods/props before its own metadata structure can be built. -#uplevel 1 "::pattern::object ::pattern::>_nullMeta createMetadata >collection" -#uplevel 1 "::patternlib::>collection .. CreateMetadata ::patternlib::>collection" - - - - -if 0 { - - -#----------------------------------------------------------- -#::pattern::create >arrayHandle { -# variable o_arrayName -# variable this -#} -::>pattern .. Create >arrayHandle - ->arrayHandle .. PatternVariable o_arrayName ->arrayHandle .. PatternVariable this - ->arrayHandle .. Constructor {args} { - var o_arrayName this - set this @this@ - - - set o_arrayName [$this .. Namespace]::array - - upvar #0 $o_arrayName $this - #? how to automatically update this after a namespace import? - - array set $o_arrayName [list] - -} ->arrayHandle .. PatternMethod array {} { - var o_arrayName - return $o_arrayName -} - -#------------------------------------------------------- -#---- some experiments ->arrayHandle .. PatternMethod up {varname} { - var o_arrayName - - #is it dodgy to hard-code the calling depth? - #will it be different for different object systems? - #Will it even be consistent for the same object. - # Is this method necessary anyway? - - # - users can always instead do: - # upvar #0 [>instance . array] var - - uplevel 3 [list upvar 0 $o_arrayName $varname] - - return -} ->arrayHandle .. PatternMethod global {varname} { - var o_arrayName - # upvar #0 [>instance . array] var - - if {![string match ::* $varname]} { - set varname ::$varname - } - - upvar #0 $o_arrayName $varname - - return -} ->arrayHandle .. PatternMethod depth {} { - var o_arrayName - # - for {set i 0} {$i < [info level]} { - puts "${i}: [uplevel $i [list namespace current] , [info level $i]]" - } - -} - # -------------------------------------------- - - ->arrayHandle .. PatternMethod item {key} { - var o_arrayName - set ${o_arrayName}($key) -} ->arrayHandle .. PatternMethod items {} { - var o_arrayName - - set result [list] - foreach nm [array names $o_arrayName] { - lappend result [set ${o_arrayName}($nm)] - } - return $result -} ->arrayHandle .. PatternMethod pairs {} { - var o_arrayName - - array get $o_arrayName -} ->arrayHandle .. PatternMethod add {val key} { - var o_arrayName - - set ${o_arrayName}($key) $val - return $key -} ->arrayHandle .. PatternMethod del {key} { - puts stderr "Warning: 'del' method of >arrayHandle deprecated. Use 'remove' instead." - remove $_ID_ $key -} ->arrayHandle .. PatternMethod remove {key} { - var o_arrayName - unset ${o_arrayName}($key) - return $key -} ->arrayHandle .. PatternMethod size {} { - var o_arrayName - return [array size $o_arrayName] -} ->arrayHandle .. PatternMethod count {} { - #alias for size - var o_arrayName - return [array size $o_arrayName] -} ->arrayHandle .. PatternMethod statistics {} { - var o_arrayName - return [array statistics $o_arrayName] -} ->arrayHandle .. PatternMethod names {} { - var o_arrayName - array names $o_arrayName -} ->arrayHandle .. PatternMethod keys {} { - #synonym for names - var o_arrayName - array names $o_arrayName -} ->arrayHandle .. PatternMethod hasKey {key} { - var o_arrayName - - return [info exists ${o_arrayName}($key)] -} ->arrayHandle .. PatternMethod clear {} { - var o_arrayName - unset $o_arrayName - array set $o_arrayName [list] - - return -} -#>arrayHandle .. Ready 1 - - - - -::>pattern .. Create >matrix - ->matrix .. PatternVariable o_array ->matrix .. PatternVariable o_size - ->matrix .. Constructor {args} { - var o_array o_size - - array set o_array [list] - set o_size 0 -} - - -#process_pattern_aliases ::patternlib::>matrix - -set PM [>matrix .. PatternMethod .] - ->matrix .. PatternMethod item {args} { - var o_array - - if {![llength $args]} { - error "indices required" - } else { - - } - if [info exists o_array($args)] { - return $o_array($args) - } else { - error "no such index: '$args'" - } -} ->matrix .. PatternMethod items {} { - var o_array - - set result [list] - foreach nm [array names o_array] { - lappend result $o_array($nm) - } - return $result -} ->matrix .. PatternMethod pairs {} { - var o_array - - array get o_array -} ->matrix .. PatternMethod slice {args} { - var o_array - - if {"*" ni $args} { - lappend args * - } - - array get o_array $args -} ->matrix .. PatternMethod add {val args} { - var o_array o_size - - if {![llength $args]} { - error "indices required" - } - - set o_array($args) $val - incr o_size - - #return [array size o_array] - return $o_size -} ->matrix .. PatternMethod names {} { - var o_array - array names o_array -} ->matrix .. PatternMethod keys {} { - #synonym for names - var o_array - array names o_array -} ->matrix .. PatternMethod hasKey {args} { - var o_array - - return [info exists o_array($args)] -} ->matrix .. PatternMethod clear {} { - var o_array o_size - unset o_array - set o_size 0 - return -} ->matrix .. PatternMethod count {} { - var o_size - return $o_size -} ->matrix .. PatternMethod count2 {} { - var o_array - #see comments for >hashMap count2 - return [array size o_array] -} -#>matrix .. Ready 1 - -#-------------------------------------------------------- -#tree data structure (based *loosely* on API at http://www.msen.com/%7Eclif/treeNobj.html - discussed in Clif Flynts book Tcl programming) -#!todo - compare API to http://tcllib.sourceforge.net/doc/tree.html -#!todo - create an >itree (inheritance tree) where node data is readable/writable on children unless overridden. -::>pattern .. Create >tree - -set _NODE [::>pattern .. Create [>tree .. Namespace]::>node] -set _TREE_NODE $_NODE -#process_pattern_aliases $_TREE_NODE - -$_NODE .. PatternVariable o_treens ;#tree namespace -$_NODE .. PatternVariable o_idref -$_NODE .. PatternVariable o_nodePrototype - -#$_NODE .. PatternProperty data -$_NODE .. PatternProperty info - -$_NODE .. PatternProperty tree -$_NODE .. PatternProperty parent -$_NODE .. PatternProperty children -$_NODE .. PatternMethod addNode {} { - set nd_id [incr $o_idref] - set nd [$o_nodePrototype .. Create ${o_treens}::>n-$nd_id -tree $o_tree -parent @this@] - @this@ . add $nd n-$nd_id - - return n-$nd_id -} -#flat list of all nodes below this -#!todo - something else? ad-hoc collections? -#!todo - non-recursive version? tail-call opt? -$_NODE .. PatternMethod nodes {} { - set result [list] - - #use(abuse?) our knowledge of >collection internals - foreach n $o_list { - #eval lappend result $n [$o_array($n) . nodes] - #!todo - test - lappend result $n {*}[$o_array($n) . nodes] - } - return $result -} -#count of number of descendants -#!todo - non-recursive version? tail-call opt? -$_NODE .. PatternMethod size {} { - set result 0 - #use(abuse?) our knowledge of >collection internals - foreach n $o_list { - incr result [expr {1 + [$o_array($n) . size]}] - } - return $result -} -$_NODE .. PatternMethod isLeaf {} { - #!todo - way to stop unused vars being uplevelled? - var o_tree - - #tailcall isEmpty $_ID_ ;#fails. because isEmpty is from >collection interface - so different ns? - tailcall [@this@ . isEmpty .] -} -$_NODE .. Constructor {args} { - array set A $args - - set o_tree $A(-tree) - set o_parent $A(-parent) - - #array set o_data [list] - array set o_info [list] - - set o_nodePrototype [::patternlib::>tree .. Namespace]::>node - set o_idref [$o_tree . nodeID .] - set o_treens [$o_tree .. Namespace] - #set o_children [::patternlib::>collection .. Create [@this@ .. Namespace]::>children] - - #overlay children collection directly on the node - set o_children [::patternlib::>collection .. Create @this@] - - return -} - ->tree .. PatternProperty test blah ->tree .. PatternProperty nodeID 0 ;#public only so node can access.. need 'friend' concept? ->tree .. PatternVariable o_ns ->tree .. Constructor {args} { - set o_ns [@this@ .. Namespace] - - #>tree is itself also a node (root node) - #overlay new 'root' node onto existing tree, pass tree to constructor - [::patternlib::>tree .. Namespace]::>node .. Create @this@ -tree @this@ -parent "" -} - - - - -unset _NODE - - - - -#-------------------------------------------------------- -#a basic binary search tree experiment -# - todo - 'scheme' property to change behaviour? e.g balanced tree -::>pattern .. Create >bst -#process_pattern_aliases ::patternlib::>bst ->bst .. PatternVariable o_NS ;#namespace ->bst .. PatternVariable o_this ;#namespace ->bst .. PatternVariable o_nodeID - ->bst .. PatternProperty root "" ->bst .. Constructor {args} { - set o_this @this@ - set o_NS [$o_this .. Namespace] - namespace eval ${o_NS}::nodes {} - puts stdout ">bst constructor" - set o_nodeID 0 -} ->bst .. PatternMethod insert {key args} { - set newnode [::patternlib::>bstnode .. Create ${o_NS}::nodes::>n-[incr o_nodeID]] - set [$newnode . key .] $key - if {[llength $args]} { - set [$newnode . value .] $args - } - if {![string length $o_root]} { - set o_root $newnode - set [$newnode . parent .] $o_this - } else { - set ipoint {} ;#insertion point - set tpoint $o_root ;#test point - set side {} - while {[string length $tpoint]} { - set ipoint $tpoint - if {[$newnode . key] < [$tpoint . key]} { - set tpoint [$tpoint . left] - set side left - } else { - set tpoint [$tpoint . right] - set side right - } - } - set [$newnode . parent .] $ipoint - set [$ipoint . $side .] $newnode - } - return $newnode -} ->bst .. PatternMethod item {key} { - if {![string length $o_root]} { - error "item $key not found" - } else { - set tpoint $o_root - while {[string length $tpoint]} { - if {[$tpoint . key] eq $key} { - return $tpoint - } else { - if {$key < [$tpoint . key]} { - set tpoint [$tpoint . left] - } else { - set tpoint [$tpoint . right] - } - } - } - error "item $key not found" - } -} ->bst .. PatternMethod inorder-walk {} { - if {[string length $o_root]} { - $o_root . inorder-walk - } - puts {} -} ->bst .. PatternMethod view {} { - array set result [list] - - if {[string length $o_root]} { - array set result [$o_root . view 0 [list]] - } - - foreach depth [lsort [array names result]] { - puts "$depth: $result($depth)" - } - -} -::>pattern .. Create >bstnode -#process_pattern_aliases ::patternlib::>bstnode ->bstnode .. PatternProperty parent ->bstnode .. PatternProperty left "" ->bstnode .. PatternProperty right "" ->bstnode .. PatternProperty key ->bstnode .. PatternProperty value - ->bstnode .. PatternMethod inorder-walk {} { - if {[string length $o_left]} { - $o_left . inorder-walk - } - - puts -nonewline "$o_key " - - if {[string length $o_right]} { - $o_right . inorder-walk - } - - return -} ->bstnode .. PatternMethod view {depth state} { - #!todo - show more useful representation of structure - set lower [incr depth] - - if {[string length $o_left]} { - set state [$o_left . view $lower $state] - } - - if {[string length $o_right]} { - set state [$o_right . view $lower $state] - } - - - array set s $state - lappend s($depth) $o_key - - return [array get s] -} - - -#-------------------------------------------------------- -#::pattern::create ::pattern::>metaObject -#::pattern::>metaObject PatternProperty methods -#::pattern::>metaObject PatternProperty properties -#::pattern::>metaObject PatternProperty PatternMethods -#::pattern::>metaObject PatternProperty patternProperties -#::pattern::>metaObject Constructor args { -# set this @this@ -# -# set [$this . methods .] [::>collection create [$this namespace]::methods] -# set [$this . properties .] [::>collection create [$this namespace]::properties] -# set [$this . PatternMethods .] [::>collection create [$this namespace]::PatternMethods] -# set [$this . patternProperties .] [::>collection create [$this namespace]::patternProperties] -# -#} - - - - #tidy up - unset PV - unset PM - - - -#-------------------------------------------------------- -::>pattern .. Create >enum -#process_pattern_aliases ::patternlib::>enum ->enum .. PatternMethod item {{idx 0}} { - var o_array o_list - - if {[string is integer -strict $idx]} { - if {$idx < 0} { - set idx "end-[expr {abs($idx + 1)}]" - } - if {[catch {set o_array([lindex $o_list $idx])} result]} { - error "no such index : '$idx'" - } else { - return $result - } - } else { - if {[catch {set o_array($idx)} result]} { - error "no such index: '$idx'" - } else { - return $result - } - } -} - - - -#proc makeenum {type identifiers} { -# #!!todo - make generated procs import into whatever current system context? -# -# upvar #0 wbpbenum_${type}_number a1 wbpbenum_number_${type} a2 -# -# #obliterate any previous enum for this type -# catch {unset a1} -# catch {unset a2} -# -# set n 0 -# foreach id $identifiers { -# set a1($id) $n -# set a2($n) $id -# incr n -# } -# proc ::${type}_to_number key [string map [list @type@ $type] { -# upvar #0 wbpbenum_@type@_number ary -# if {[catch {set ary($key)} num]} { -# return -code error "unknown @type@ '$key'" -# } -# return $num -# }] -# -# proc ::number_to_${type} {number} [string map [list @type@ $type] { -# upvar #0 wbpbenum_number_@type@ ary -# if {[catch {set ary($number)} @type@]} { -# return -code error "no @type@ for '$number'" -# } -# return $@type@ -# }] -# -# #eval "namespace eval ::sysnexus {namespace export number_to_${type}; namespace export ${type}_to_number}" -# #eval "namespace eval :: {namespace import -force sysnexus::number_to_${type} sysnexus::${type}_to_number}" -#} -# -#-------------------------------------------------------- -::>pattern .. Create >nest ->nest .. PatternVariable THIS ->nest .. PatternProperty data -autoclone ->nest .. Constructor {args} { - var o_data - var THIS - set THIS @this@ - array set o_data [list] -} ->nest .. PatternMethod item {args} { - set THIS @this@ - return [$THIS . data [join $args ,]] -} - -# -# e.g -# set [>nest a , b . data c .] blah -# >nest a , b , c -# -# set [>nest w x , y . data z .] etc -# >nest w x , y , z -#-------------------------------------------------------- - -} - -} - - -#package require patternlibtemp diff --git a/src/bootsupport/modules/patternpredator2-1.2.4.tm b/src/bootsupport/modules/patternpredator2-1.2.4.tm deleted file mode 100644 index 680ea88f..00000000 --- a/src/bootsupport/modules/patternpredator2-1.2.4.tm +++ /dev/null @@ -1,754 +0,0 @@ -package provide patternpredator2 1.2.4 - -proc ::p::internals::jaws {OID _ID_ args} { - #puts stderr ">>>(patternpredator2 lib)jaws called with _ID_:$_ID_ args: $args" - #set OID [lindex [dict get $_ID_ i this] 0 0] ;#get_oid - - yield - set w 1 - - set stack [list] - set wordcount [llength $args] - set terminals [list . .. , # @ !] ;#tokens which require the current stack to be evaluated first - set unsupported 0 - set operator "" - set operator_prev "" ;#used only by argprotect to revert to previous operator - - - if {$OID ne "null"} { - #!DO NOT use upvar here for MAP! (calling set on a MAP in another iteration/call will overwrite a map for another object!) - #upvar #0 ::p::${OID}::_meta::map MAP - set MAP [set ::p::${OID}::_meta::map] - } else { - # error "jaws - OID = 'null' ???" - set MAP [list invocantdata [lindex [dict get $_ID_ i this] 0] ] ;#MAP taken from _ID_ will be missing 'interfaces' key - } - set invocantdata [dict get $MAP invocantdata] - lassign $invocantdata OID alias default_method object_command wrapped - - set finished_args 0 ;#whether we've completely processed all args in the while loop and therefor don't need to peform the final word processing code - - #don't use 'foreach word $args' - we sometimes need to backtrack a little by manipulating $w - while {$w < $wordcount} { - set word [lindex $args [expr {$w -1}]] - #puts stdout "w:$w word:$word stack:$stack" - - if {$operator eq "argprotect"} { - set operator $operator_prev - lappend stack $word - incr w - } else { - if {[llength $stack]} { - if {$word in $terminals} { - set reduction [list 0 $_ID_ {*}$stack ] - #puts stderr ">>>jaws yielding value: $reduction triggered by word $word in position:$w" - - - set _ID_ [yield $reduction] - set stack [list] - #set OID [::pattern::get_oid $_ID_] - set OID [lindex [dict get $_ID_ i this] 0 0] ;#get_oid - - if {$OID ne "null"} { - set MAP [set ::p::${OID}::_meta::map] ;#Do not use upvar here! - } else { - set MAP [list invocantdata [lindex [dict get $_ID_ i this] 0] interfaces [list level0 {} level1 {}]] - #puts stderr "WARNING REVIEW: jaws-branch - leave empty??????" - } - - #review - 2018. switched to _ID_ instead of MAP - lassign [lindex [dict get $_ID_ i this] 0] OID alias default_method object_command - #lassign [dict get $MAP invocantdata] OID alias default_method object_command - - - #puts stdout "---->>> yielded _ID_: $_ID_ OID:$OID alias:$alias default_method:$default_method object_command:$object_command" - set operator $word - #don't incr w - #incr w - } else { - if {$operator eq "argprotect"} { - set operator $operator_prev - set operator_prev "" - lappend stack $word - } else { - #only look for leading argprotect chacter (-) if we're not already in argprotect mode - if {$word eq "--"} { - set operator_prev $operator - set operator "argprotect" - #Don't add the plain argprotector to the stack - } elseif {[string match "-*" $word]} { - #argSafety operator (tokens that appear to be Tcl 'options' automatically 'protect' the subsequent argument) - set operator_prev $operator - set operator "argprotect" - lappend stack $word - } else { - lappend stack $word - } - } - - - incr w - } - } else { - #no stack - switch -- $word {.} { - - if {$OID ne "null"} { - #we know next word is a property or method of a pattern object - incr w - set nextword [lindex $args [expr {$w - 1}]] - set command ::p::${OID}::$nextword - set stack [list $command] ;#2018 j - set operator . - if {$w eq $wordcount} { - set finished_args 1 - } - } else { - # don't incr w - #set nextword [lindex $args [expr {$w - 1}]] - set command $object_command ;#taken from the MAP - set stack [list "_exec_" $command] - set operator . - } - - - } {..} { - incr w - set nextword [lindex $args [expr {$w -1}]] - set command ::p::-1::$nextword - #lappend stack $command ;#lappend a small number of items to an empty list is slower than just setting the list. - set stack [list $command] ;#faster, and intent is clearer than lappend. - set operator .. - if {$w eq $wordcount} { - set finished_args 1 - } - } {,} { - #puts stdout "Stackless comma!" - - - if {$OID ne "null"} { - set command ::p::${OID}::$default_method - } else { - set command [list $default_method $object_command] - #object_command in this instance presumably be a list and $default_method a list operation - #e.g "lindex {A B C}" - } - #lappend stack $command - set stack [list $command] - set operator , - } {--} { - set operator_prev $operator - set operator argprotect - #no stack - - } {!} { - set command $object_command - set stack [list "_exec_" $object_command] - #puts stdout "!!!! !!!! $stack" - set operator ! - } default { - if {$operator eq ""} { - if {$OID ne "null"} { - set command ::p::${OID}::$default_method - } else { - set command [list $default_method $object_command] - } - set stack [list $command] - set operator , - lappend stack $word - } else { - #no stack - so we don't expect to be in argprotect mode already. - if {[string match "-*" $word]} { - #argSafety operator (tokens that appear to be Tcl 'options' automatically 'protect' the subsequent argument) - set operator_prev $operator - set operator "argprotect" - lappend stack $word - } else { - lappend stack $word - } - - } - } - incr w - } - - } - } ;#end while - - #process final word outside of loop - #assert $w == $wordcount - #trailing operators or last argument - if {!$finished_args} { - set word [lindex $args [expr {$w -1}]] - if {$operator eq "argprotect"} { - set operator $operator_prev - set operator_prev "" - - lappend stack $word - incr w - } else { - - - switch -- $word {.} { - if {![llength $stack]} { - #set stack [list "_result_" [::p::internals::ref_to_object $_ID_]] - yieldto return [::p::internals::ref_to_object $_ID_] - error "assert: never gets here" - - } else { - #puts stdout "==== $stack" - #assert - whenever _ID_ changed in this proc - we have updated the $OID variable - yieldto return [::p::internals::ref_to_stack $OID $_ID_ $stack] - error "assert: never gets here" - } - set operator . - - } {..} { - #trailing .. after chained call e.g >x . item 0 .. - #puts stdout "$$$$$$$$$$$$ [list 0 $_ID_ {*}$stack] $$$$" - #set reduction [list 0 $_ID_ {*}$stack] - yieldto return [yield [list 0 $_ID_ {*}$stack]] - } {#} { - set unsupported 1 - } {,} { - set unsupported 1 - } {&} { - set unsupported 1 - } {@} { - set unsupported 1 - } {--} { - - #set reduction [list 0 $_ID_ {*}$stack[set stack [list]]] - #puts stdout " -> -> -> about to call yield $reduction <- <- <-" - set _ID_ [yield [list 0 $_ID_ {*}$stack[set stack [list]]] ] - #set OID [::pattern::get_oid $_ID_] - set OID [lindex [dict get $_ID_ i this] 0 0] ;#get_oid - - if {$OID ne "null"} { - set MAP [set ::p::${OID}::_meta::map] ;#DO not use upvar here! - } else { - set MAP [list invocantdata [lindex [dict get $_ID_ i this] 0] interfaces {level0 {} level1 {}} ] - } - yieldto return $MAP - } {!} { - #error "untested branch" - set _ID_ [yield [list 0 $_ID_ {*}$stack[set stack [list]]]] - #set OID [::pattern::get_oid $_ID_] - set OID [lindex [dict get $_ID_ i this] 0 0] ;#get_oid - - if {$OID ne "null"} { - set MAP [set ::p::${OID}::_meta::map] ;#DO not use upvar here! - } else { - set MAP [list invocantdata [lindex [dict get $_ID_ i this] 0] ] - } - lassign [dict get $MAP invocantdata] OID alias default_command object_command - set command $object_command - set stack [list "_exec_" $command] - set operator ! - } default { - if {$operator eq ""} { - #error "untested branch" - lassign [dict get $MAP invocantdata] OID alias default_command object_command - #set command ::p::${OID}::item - set command ::p::${OID}::$default_command - lappend stack $command - set operator , - - } - #do not look for argprotect items here (e.g -option) as the final word can't be an argprotector anyway. - lappend stack $word - } - if {$unsupported} { - set unsupported 0 - error "trailing '$word' not supported" - - } - - #if {$operator eq ","} { - # incr wordcount 2 - # set stack [linsert $stack end-1 . item] - #} - incr w - } - } - - - #final = 1 - #puts stderr ">>>jaws final return value: [list 1 $_ID_ {*}$stack]" - - return [list 1 $_ID_ {*}$stack] -} - - - -#trailing. directly after object -proc ::p::internals::ref_to_object {_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 object_command - set refname ::p::${OID}::_ref::__OBJECT - - array set $refname [list] ;#important to initialise the variable as an array here - or initial read attempts on elements will not fire traces - - set traceCmd [list ::p::predator::object_read_trace $OID $_ID_] - if {[list {read} $traceCmd] ni [trace info variable $refname]} { - #puts stdout "adding read trace on variable '$refname' - traceCmd:'$traceCmd'" - trace add variable $refname {read} $traceCmd - } - set traceCmd [list ::p::predator::object_array_trace $OID $_ID_] - if {[list {array} $traceCmd] ni [trace info variable $refname]} { - trace add variable $refname {array} $traceCmd - } - - set traceCmd [list ::p::predator::object_write_trace $OID $_ID_] - if {[list {write} $traceCmd] ni [trace info variable $refname]} { - trace add variable $refname {write} $traceCmd - } - - set traceCmd [list ::p::predator::object_unset_trace $OID $_ID_] - if {[list {unset} $traceCmd] ni [trace info variable $refname]} { - trace add variable $refname {unset} $traceCmd - } - return $refname -} - - -proc ::p::internals::create_or_update_reference {OID _ID_ refname command} { - #if {[lindex $fullstack 0] eq "_exec_"} { - # #strip it. This instruction isn't relevant for a reference. - # set commandstack [lrange $fullstack 1 end] - #} else { - # set commandstack $fullstack - #} - #set argstack [lassign $commandstack command] - #set field [string map {> __OBJECT_} [namespace tail $command]] - - - - set reftail [namespace tail $refname] - set argstack [lassign [split $reftail +] field] - set field [string map {> __OBJECT_} [namespace tail $command]] - - #puts stderr "refname:'$refname' command: $command field:$field" - - - if {$OID ne "null"} { - upvar #0 ::p::${OID}::_meta::map MAP - } else { - #set map [dict get [lindex [dict get $_ID_ i this] 0 1] map] - set MAP [list invocantdata [lindex [dict get $_ID_ i this] 0] interfaces {level0 {} level1 {}}] - } - lassign [dict get $MAP invocantdata] OID alias default_method object_command - - - - if {$OID ne "null"} { - interp alias {} $refname {} $command $_ID_ {*}$argstack - } else { - interp alias {} $refname {} $command {*}$argstack - } - - - #set iflist [lindex $map 1 0] - set iflist [dict get $MAP interfaces level0] - #set iflist [dict get $MAP interfaces level0] - set field_is_property_like 0 - foreach IFID [lreverse $iflist] { - #tcl (braced) expr has lazy evaluation for &&, || & ?: operators - so this should be reasonably efficient. - if {[llength [info commands ::p::${IFID}::_iface::(GET)$field]] || [llength [info commands ::p::${IFID}::_iface::(SET)$field]]} { - set field_is_property_like 1 - #There is a setter or getter (but not necessarily an entry in the o_properties dict) - break - } - } - - - - - #whether field is a property or a method - remove any commandrefMisuse_TraceHandler - foreach tinfo [trace info variable $refname] { - #puts "-->removing traces on $refname: $tinfo" - if {[lindex $tinfo 1 0] eq "::p::internals::commandrefMisuse_TraceHandler"} { - trace remove variable $refname {*}$tinfo - } - } - - if {$field_is_property_like} { - #property reference - - - set this_invocantdata [lindex [dict get $_ID_ i this] 0] - lassign $this_invocantdata OID _alias _defaultmethod object_command - #get fully qualified varspace - - # - set propdict [$object_command .. GetPropertyInfo $field] - if {[dict exist $propdict $field]} { - set field_is_a_property 1 - set propinfo [dict get $propdict $field] - set varspace [dict get $propinfo varspace] - if {$varspace eq ""} { - set full_varspace ::p::${OID} - } else { - if {[::string match "::*" $varspace]} { - set full_varspace $varspace - } else { - set full_varspace ::p::${OID}::$varspace - } - } - } else { - set field_is_a_property 0 - #no propertyinfo - this field was probably established as a PropertyRead and/or PropertyWrite without a Property - #this is ok - and we still set the trace infrastructure below (app may convert it to a normal Property later) - set full_varspace ::p::${OID} - } - - - - - - #We only trace on entire property.. not array elements (if references existed to both the array and an element both traces would be fired -(entire array trace first)) - set Hndlr [::list ::p::predator::propvar_write_TraceHandler $OID $field] - if { [::list {write} $Hndlr] ni [trace info variable ${full_varspace}::o_${field}]} { - trace add variable ${full_varspace}::o_${field} {write} $Hndlr - } - set Hndlr [::list ::p::predator::propvar_unset_TraceHandler $OID $field] - if { [::list {unset} $Hndlr] ni [trace info variable ${full_varspace}::o_${field}]} { - trace add variable ${full_varspace}::o_${field} {unset} $Hndlr - } - - - #supply all data in easy-access form so that propref_trace_read is not doing any extra work. - set get_cmd ::p::${OID}::(GET)$field - set traceCmd [list ::p::predator::propref_trace_read $get_cmd $_ID_ $refname $field $argstack] - - if {[list {read} $traceCmd] ni [trace info variable $refname]} { - set fieldvarname ${full_varspace}::o_${field} - - - #synch the refvar with the real var if it exists - #catch {set $refname [$refname]} - if {[array exists $fieldvarname]} { - if {![llength $argstack]} { - #unindexed reference - array set $refname [array get $fieldvarname] - #upvar $fieldvarname $refname - } else { - set s0 [lindex $argstack 0] - #refs to nonexistant array members common? (catch vs 'info exists') - if {[info exists ${fieldvarname}($s0)]} { - set $refname [set ${fieldvarname}($s0)] - } - } - } else { - #refs to uninitialised props actually should be *very* common. - #If we use 'catch', it means retrieving refs to non-initialised props is slower. Fired catches can be relatively expensive. - #Because it's common to get a ref to uninitialised props (e.g for initial setting of their value) - we will use 'info exists' instead of catch. - - #set errorInfo_prev $::errorInfo ;#preserve errorInfo across catches! - - #puts stdout " ---->>!!! ref to uninitialised prop $field $argstack !!!<------" - - - if {![llength $argstack]} { - #catch {set $refname [set ::p::${OID}::o_$field]} - if {[info exists $fieldvarname]} { - set $refname [set $fieldvarname] - #upvar $fieldvarname $refname - } - } else { - if {[llength $argstack] == 1} { - #catch {set $refname [lindex [set ::p::${OID}::o_$field] [lindex $argstack 0]]} - if {[info exists $fieldvarname]} { - set $refname [lindex [set $fieldvarname] [lindex $argstack 0]] - } - - } else { - #catch {set $refname [lindex [set ::p::${OID}::o_$field] $argstack]} - if {[info exists $fieldvarname]} { - set $refname [lindex [set $fieldvarname] $argstack] - } - } - } - - #! what if someone has put a trace on ::errorInfo?? - #set ::errorInfo $errorInfo_prev - } - trace add variable $refname {read} $traceCmd - - set traceCmd [list ::p::predator::propref_trace_write $_ID_ $OID $full_varspace $refname] - trace add variable $refname {write} $traceCmd - - set traceCmd [list ::p::predator::propref_trace_unset $_ID_ $OID $refname] - trace add variable $refname {unset} $traceCmd - - - set traceCmd [list ::p::predator::propref_trace_array $_ID_ $OID $refname] - # puts "**************** installing array variable trace on ref:$refname - cmd:$traceCmd" - trace add variable $refname {array} $traceCmd - } - - } else { - #puts "$refname ====> adding refMisuse_traceHandler $alias $field" - #matching variable in order to detect attempted use as property and throw error - - #2018 - #Note that we are adding a trace on a variable (the refname) which does not exist. - #this is fine - except that the trace won't fire for attempt to write it as an array using syntax such as set $ref(someindex) - #we could set the ref to an empty array - but then we have to also undo this if a property with matching name is added - ##array set $refname {} ;#empty array - # - the empty array would mean a slightly better error message when misusing a command ref as an array - #but this seems like a code complication for little benefit - #review - - trace add variable $refname {read write unset array} [list ::p::internals::commandrefMisuse_TraceHandler $OID $field] - } -} - - - -#trailing. after command/property -proc ::p::internals::ref_to_stack {OID _ID_ fullstack} { - if {[lindex $fullstack 0] eq "_exec_"} { - #strip it. This instruction isn't relevant for a reference. - set commandstack [lrange $fullstack 1 end] - } else { - set commandstack $fullstack - } - set argstack [lassign $commandstack command] - set field [string map {> __OBJECT_} [namespace tail $command]] - - - #!todo? - # - make every object's OID unpredictable and sparse (UUID) and modify 'namespace child' etc to prevent iteration/inspection of ::p namespace. - # - this would only make sense for an environment where any meta methods taking a code body (e.g .. Method .. PatternMethod etc) are restricted. - - - #references created under ::p::${OID}::_ref are effectively inside a 'varspace' within the object itself. - # - this would in theory allow a set of interface functions on the object which have direct access to the reference variables. - - - set refname ::p::${OID}::_ref::[join [concat $field $argstack] +] - - if {[llength [info commands $refname]]} { - #todo - review - what if the field changed to/from a property/method? - #probably should fix that where such a change is made and leave this short circuit here to give reasonable performance for existing refs - return $refname - } - ::p::internals::create_or_update_reference $OID $_ID_ $refname $command - return $refname -} - - -namespace eval pp { - variable operators [list .. . -- - & @ # , !] - variable operators_notin_args "" - foreach op $operators { - append operators_notin_args "({$op} ni \$args) && " - } - set operators_notin_args [string trimright $operators_notin_args " &"] ;#trim trailing spaces and ampersands - #set operators_notin_args {({.} ni $args) && ({,} ni $args) && ({..} ni $args)} -} -interp alias {} strmap {} string map ;#stop code editor from mono-colouring our big string mapped code blocks! - - - - - -# 2017 ::p::predator2 is the development version - intended for eventual use as the main dispatch mechanism. -#each map is a 2 element list of lists. -# form: {$commandinfo $interfaceinfo} -# commandinfo is of the form: {ID Namespace defaultmethod commandname _?} - -#2018 -#each map is a dict. -#form: {invocantdata {ID Namespace defaultmethod commandname _?} interfaces {level0 {} level1 {}}} - - -#OID = Object ID (integer for now - could in future be a uuid) -proc ::p::predator2 {_ID_ args} { - #puts stderr "predator2: _ID_:'$_ID_' args:'$args'" - #set invocants [dict get $_ID_ i] - #set invocant_roles [dict keys $invocants] - - #For now - we are 'this'-centric (single dispatch). todo - adapt for multiple roles, multimethods etc. - #set this_role_members [dict get $invocants this] - #set this_invocant [lindex [dict get $_ID_ i this] 0] ;#for the role 'this' we assume only one invocant in the list. - #lassign $this_invocant this_OID this_info_dict - - set this_OID [lindex [dict get $_ID_ i this] 0 0] ;#get_oid - - - set cheat 1 ;# - #------- - #Optimise the next most common use case. A single . followed by args which contain no other operators (non-chained call) - #(it should be functionally equivalent to remove this shortcut block) - if {$cheat} { - if { ([lindex $args 0] eq {.}) && ([llength $args] > 1) && ([llength [lsearch -all -inline $args .]] == 1) && ({,} ni $args) && ({..} ni $args) && ({--} ni $args) && ({!} ni $args)} { - - set remaining_args [lassign $args dot method_or_prop] - - #how will we do multiple apis? (separate interface stacks) apply? apply [list [list _ID_ {*}$arglist] ::p::${stackid?}::$method_or_prop ::p::${this_OID}] ??? - set command ::p::${this_OID}::$method_or_prop - #REVIEW! - #e.g what if the method is named "say hello" ?? (hint - it will break because we will look for 'say') - #if {[llength $command] > 1} { - # error "methods with spaces not included in test suites - todo fix!" - #} - #Dont use {*}$command - (so we can support methods with spaces) - #if {![llength [info commands $command]]} {} - if {[namespace which $command] eq ""} { - if {[namespace which ::p::${this_OID}::(UNKNOWN)] ne ""} { - #lset command 0 ::p::${this_OID}::(UNKNOWN) ;#seems wrong - command could have spaces - set command ::p::${this_OID}::(UNKNOWN) - #tailcall {*}$command $_ID_ $cmdname {*}[lrange $args 2 end] ;#delegate to UNKNOWN, along with original commandname as 1st arg. - tailcall $command $_ID_ $method_or_prop {*}[lrange $args 2 end] ;#delegate to UNKNOWN, along with original commandname as 1st arg. - } else { - return -code error -errorinfo "(::p::predator2) error running command:'$command' argstack:'[lrange $args 2 end]'\n - command not found and no 'unknown' handler" "method '$method_or_prop' not found" - } - } else { - #tailcall {*}$command $_ID_ {*}$remaining_args - tailcall $command $_ID_ {*}$remaining_args - } - } - } - #------------ - - - if {([llength $args] == 1) && ([lindex $args 0] eq "..")} { - return $_ID_ - } - - - #puts stderr "pattern::predator (test version) called with: _ID_:$_ID_ args:$args" - - - - #puts stderr "this_info_dict: $this_info_dict" - - - - - if {![llength $args]} { - #should return some sort of public info.. i.e probably not the ID which is an implementation detail - #return cmd - return [lindex [dict get [set ::p::${this_OID}::_meta::map] invocantdata] 0] ;#Object ID - - #return a dict keyed on object command name - (suitable as use for a .. Create 'target') - #lassign [dict get [set ::p::${this_OID}::_meta::map] invocantdata] this_OID alias default_method object_command wrapped - #return [list $object_command [list -id $this_OID ]] - } elseif {[llength $args] == 1} { - #short-circuit the single index case for speed. - if {[lindex $args 0] ni {.. . -- - & @ # , !}} { - #lassign [dict get [set ::p::${this_OID}::_meta::map] invocantdata] this_OID alias default_method - lassign [lindex [dict get $_ID_ i this] 0] this_OID alias default_method - - tailcall ::p::${this_OID}::$default_method $_ID_ [lindex $args 0] - } elseif {[lindex $args 0] eq {--}} { - - #!todo - we could hide the invocant by only allowing this call from certain uplevel procs.. - # - combined with using UUIDs for $OID, and a secured/removed metaface on the object - # - (and also hiding of [interp aliases] command so they can't iterate and examine all aliases) - # - this could effectively hide the object's namespaces,vars etc from the caller (?) - return [set ::p::${this_OID}::_meta::map] - } - } - - - - #upvar ::p::coroutine_instance c ;#coroutine names must be unique per call to predator (not just per object - or we could get a clash during some cyclic calls) - #incr c - #set reduce ::p::reducer${this_OID}_$c - set reduce ::p::reducer${this_OID}_[incr ::p::coroutine_instance] - #puts stderr "..................creating reducer $reduce with args $this_OID _ID_ $args" - coroutine $reduce ::p::internals::jaws $this_OID $_ID_ {*}$args - - - set current_ID_ $_ID_ - - set final 0 - set result "" - while {$final == 0} { - #the argument given here to $reduce will be returned by 'yield' within the coroutine context (jaws) - set reduction_args [lassign [$reduce $current_ID_[set current_ID_ [list]] ] final current_ID_ command] - #puts stderr "..> final:$final current_ID_:'$current_ID_' command:'$command' reduction_args:'$reduction_args'" - #if {[string match *Destroy $command]} { - # puts stdout " calling Destroy reduction_args:'$reduction_args'" - #} - if {$final == 1} { - - if {[llength $command] == 1} { - if {$command eq "_exec_"} { - tailcall {*}$reduction_args - } - if {[llength [info commands $command]]} { - tailcall {*}$command $current_ID_ {*}$reduction_args - } - set cmdname [namespace tail $command] - set this_OID [lindex [dict get $current_ID_ i this] 0 0] - if {[llength [info commands ::p::${this_OID}::(UNKNOWN)]]} { - lset command 0 ::p::${this_OID}::(UNKNOWN) - tailcall {*}$command $current_ID_ $cmdname {*}$reduction_args ;#delegate to UNKNOWN, along with original commandname as 1st arg. - } else { - return -code error -errorinfo "1)error running command:'$command' argstack:'$reduction_args'\n - command not found and no 'unknown' handler" "method '$cmdname' not found" - } - - } else { - #e.g lindex {a b c} - tailcall {*}$command {*}$reduction_args - } - - - } else { - if {[lindex $command 0] eq "_exec_"} { - set result [uplevel 1 [list {*}[lrange $command 1 end] {*}$reduction_args]] - - set current_ID_ [list i [list this [list [list "null" {} {lindex} $result {} ] ] ] context {} ] - } else { - if {[llength $command] == 1} { - if {![llength [info commands $command]]} { - set cmdname [namespace tail $command] - set this_OID [lindex [dict get $current_ID_ i this] 0 0] - if {[llength [info commands ::p::${this_OID}::(UNKNOWN)]]} { - - lset command 0 ::p::${this_OID}::(UNKNOWN) - set result [uplevel 1 [list {*}$command $current_ID_ $cmdname {*}$reduction_args]] ;#delegate to UNKNOWN, along with original commandname as 1st arg. - } else { - return -code error -errorinfo "2)error running command:'$command' argstack:'$reduction_args'\n - command not found and no 'unknown' handler" "method '$cmdname' not found" - } - } else { - #set result [uplevel 1 [list {*}$command $current_ID_ {*}$reduction_args ]] - set result [uplevel 1 [list {*}$command $current_ID_ {*}$reduction_args ]] - - } - } else { - set result [uplevel 1 [list {*}$command {*}$reduction_args]] - } - - if {[llength [info commands $result]]} { - if {([llength $result] == 1) && ([string first ">" [namespace tail $result]] == 0)} { - #looks like a pattern command - set current_ID_ [$result .. INVOCANTDATA] - - - #todo - determine if plain .. INVOCANTDATA is sufficient instead of .. UPDATEDINVOCANTDATA - #if {![catch {$result .. INVOCANTDATA} result_invocantdata]} { - # set current_ID_ $result_invocantdata - #} else { - # return -code error -errorinfo "3)error running command:'$command' argstack:'$reduction_args'\n - Failed to access result:'$result' as a pattern object." "Failed to access result:'$result' as a pattern object" - #} - } else { - #non-pattern command - set current_ID_ [list i [list this [list [list "null" {} {lindex} $result {} ] ] ] context {}] - } - } else { - set current_ID_ [list i [list this [list [list "null" {} {lindex} $result {} ] ] ] context {}] - #!todo - allow further operations on non-command values. e.g dicts, lists & strings (treat strings as lists) - - } - } - - } - } - error "Assert: Shouldn't get here (end of ::p::predator2)" - #return $result -} diff --git a/src/bootsupport/modules/punk/args-0.2.1.tm b/src/bootsupport/modules/punk/args-0.2.1.tm index 6a2a3376..c20e3b51 100644 --- a/src/bootsupport/modules/punk/args-0.2.1.tm +++ b/src/bootsupport/modules/punk/args-0.2.1.tm @@ -4950,7 +4950,7 @@ tcl::namespace::eval punk::args { set argd [punk::args::parse $args withid ::myns::myfunc] lassign [dict values $argd] leaders opts values received solos if {[dict exists $received] -configfile} { - puts "have option for existing file [dict get $opts -configfile]" + puts "have option for existing file [dict get $opts -configfile]" } } }]} @@ -6515,7 +6515,7 @@ tcl::namespace::eval punk::args { set range [lindex $ranges $clausecolumn] #todo - small-value double comparisons with error-margin? review lassign $range low high - if {$low$high ne ""} { + if {"$low$high" ne ""} { if {$low eq ""} { #lowside unspecified - check only high if {$e_check > $high} { diff --git a/src/bootsupport/modules/punk/lib-0.1.2.tm b/src/bootsupport/modules/punk/lib-0.1.2.tm deleted file mode 100644 index b6b784f5..00000000 --- a/src/bootsupport/modules/punk/lib-0.1.2.tm +++ /dev/null @@ -1,4533 +0,0 @@ -# -*- tcl -*- -# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'pmix make' or bin/punkmake to update from -buildversion.txt -# module template: punkshell/src/decktemplates/vendor/punk/modules/template_module-0.0.2.tm -# -# 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) 2024 -# -# @@ Meta Begin -# Application punk::lib 0.1.2 -# Meta platform tcl -# Meta license BSD -# @@ Meta End - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# doctools header -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -#*** !doctools -#[manpage_begin punkshell_module_punk::lib 0 0.1.2] -#[copyright "2024"] -#[titledesc {punk general utility functions}] [comment {-- Name section and table of contents description --}] -#[moddesc {punk library}] [comment {-- Description at end of page heading --}] -#[require punk::lib] -#[keywords module utility lib] -#[description] -#[para]This is a set of utility functions that are commonly used across punk modules or are just considered to be general-purpose functions. -#[para]The base set includes string and math functions but has no specific theme - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - -#*** !doctools -#[section Overview] -#[para] overview of punk::lib -#[subsection Concepts] -#[para]The punk::lib modules should have no strong dependencies other than Tcl -#[para]Dependendencies that only affect display or additional functionality may be included - but should fail gracefully if not present, and only when a function is called that uses one of these soft dependencies. -#[para]This requirement for no strong dependencies, means that many utility functions that might otherwise seem worthy of inclusion here are not present. - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Requirements -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - -#*** !doctools -#[subsection dependencies] -#[para] packages used by punk::lib -#[list_begin itemized] - -package require Tcl 8.6- -package require punk::args -#*** !doctools -#[item] [package {Tcl 8.6-}] -#[item] [package {punk::args}] - -# #package require frobz -# #*** !doctools -# #[item] [package {frobz}] - -#*** !doctools -#[list_end] - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - -#*** !doctools -#[section API] - - -tcl::namespace::eval punk::lib::ensemble { - #wiki.tcl-lang.org/page/ensemble+extend - # extend an ensemble-like routine with the routines in some namespace - proc extend {routine extension} { - if {![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 {![string match ::* $extension]} { - set extension [uplevel 1 [ - list [tcl::namespace::which namespace] current]]::$extension - } - - if {![tcl::namespace::exists $extension]} { - error [list {no such namespace} $extension] - } - - set extension [tcl::namespace::eval $extension [ - list [tcl::namespace::which namespace] current]] - - tcl::namespace::eval $extension [ - list [tcl::namespace::which namespace] export *] - - while 1 { - set renamed ${routinens}::${routinetail}_[clock clicks] ;#clock clicks unlikely to collide when not directly consecutive such as: list [clock clicks] [clock clicks] - if {[tcl::namespace::which $renamed] eq {}} break - } - - rename $routine $renamed - - tcl::namespace::eval $extension [ - list namespace ensemble create -command $routine -unknown [ - list apply {{renamed ensemble routine args} { - list $renamed $routine - }} $renamed - ] - ] - - return $routine - } -} - -# some (?) tcl bug check procs needed to exist before main punk::lib namespaces are evaluated -tcl::namespace::eval punk::lib::check { - proc has_tclbug_script_var {} { - - set script {set j [list spud] ; list} - append script \n - uplevel #0 $script - set rep1 [tcl::unsupported::representation $::j] - set script "" - set rep2 [tcl::unsupported::representation $::j] - - set nostring1 [string match "*no string" $rep1] - set nostring2 [string match "*no string" $rep2] - - #we assume it should have no string rep in either case - #Review: check Tcl versions for behaviour/consistency - if {!$nostring2} { - return true - } else { - return false - } - } - proc has_tclbug_lsearch_strideallinline {} { - #bug only occurs with single -index value combined with -stride -all -inline -subindices - #https://core.tcl-lang.org/tcl/tktview/5a1aaa201d - if {[catch {lsearch -stride 3 -all -inline -index 1 -subindices {a1 a2 a3} *} result]} { - #we aren't looking for an error result - error most likely indicates tcl too old to support -stride - return 0 - } - return [expr {$result ne "a2"}] - } - - proc has_tclbug_list_quoting_emptyjoin {} { - #https://core.tcl-lang.org/tcl/tktview/e38dce74e2 - set v1 [list {*}[lindex #foo] {*}[]] ;#can return "#foo" instead of "{#foo}" under some beta 9 releases - set v2 [list #foo] ;#normal tcl list quoting for 1st element that looks like a comment -> "{#foo}" - return [expr {![string equal $v1 $v2]}] ;#if they're not equal - we have the bug. - } - - proc has_tclbug_safeinterp_compile {{show 0}} { - #ensemble calls within safe interp not compiled - namespace eval [namespace current]::testcompile { - proc ensembletest {} {string index a 0} - } - - set has_bug 0 - - set bytecode_outer [tcl::unsupported::disassemble proc [namespace current]::testcompile::ensembletest] - if {$show} { - puts outer: - puts $bytecode_outer - } - if {![interp issafe]} { - #test of safe subinterp only needed if we aren't already in a safe interp - if {![catch { - interp create x -safe - } errMsg]} { - x eval {proc ensembletest {} {string index a 0}} - set bytecode_safe [x eval {tcl::unsupported::disassemble proc ::ensembletest}] - if {$show} { - puts safe: - puts $bytecode_safe - } - interp delete x - #mainly we expect the safe interp might contain invokeStk - indicating not byte compiled (or we would see strindex instead) - #It's possible the interp we're running in is also not compiling ensembles. - #we could then get a result of 2 - which still indicates a problem - if {[string last "invokeStk" $bytecode_safe] >= 1} { - incr has_bug - } - } else { - #our failure to create a safe interp here doesn't necessarily mean the Tcl version doesn't have the problem - but we could end up returning zero if somehow safe interp can't be created from unsafe interp? - #unlikely - but we should warn - puts stderr "Unable to create a safe sub-interp to test - result only indicates status of current interpreter" - } - } - - namespace delete [namespace current]::testcompile - - if {[string last "invokeStk" $bytecode_outer] >= 1} { - incr has_bug - } - return $has_bug - } -} - -tcl::namespace::eval punk::lib::compat { - #*** !doctools - #[subsection {Namespace punk::lib::compat}] - #[para] compatibility functions for features that may not be available in earlier Tcl versions - #[para] These are generally 'forward compatibility' functions ie allowing earlier versions to use later features/idioms by using a Tcl-only version of a missing builtin. - #[para] Such Tcl-only versions will inevitably be less performant - perhaps significantly so. - - #*** !doctools - #[list_begin definitions] - - - - - if {"::lremove" ne [info commands ::lremove]} { - #puts stderr "Warning - no built-in lremove" - interp alias {} lremove {} ::punk::lib::compat::lremove - } - proc lremove {list args} { - #*** !doctools - #[call [fun lremove] [arg list] [opt {index ...}]] - #[para] Forwards compatible lremove for versions 8.6 or less to support equivalent 8.7 lremove - - set data [lmap v $list {list data $v}] - foreach doomed_index $args { - if {[llength $doomed_index] != 1} {error "bad index \"$doomed_index\": must be integer?\[+-]integer? or end?\[+-]integer?"} - lset data $doomed_index x ;#x won't collide as all our data has been mapped to 2 elements per value - } - set keep [lsearch -all -inline -not -exact $data x] - return [lsearch -all -inline -index 1 -subindices $keep *] - } - #not significantly different in performance over test of 100 elements - getting somewhere near 10% for 1k integers - proc lremove2 {list args} { - set data [lmap v $list {list data $v}] - foreach doomed_index $args { - if {[llength $doomed_index] != 1} {error "bad index \"$doomed_index\": must be integer?\[+-]integer? or end?\[+-]integer?"} - lset data $doomed_index x ;#x won't collide as all our data has been mapped to 2 elements per value - } - set keep [lsearch -all -inline -not -exact $data x] - return [lmap v $keep {lindex $v 1}] - } - #outside of lmap - don't know of any particularly nice ways to flatten to subindex 1 of each element.. - #flattening then lsearch with -stride and * would be nice - but it's not avail in 8.6 - - if {![info exists ::auto_index(readFile)]} { - if {[info commands ::readFile] eq ""} { - proc ::readFile {filename {mode text}} { - #readFile not seen in auto_index or as command: installed by punk::lib - # Parse the arguments - set MODES {binary text} - set ERR [list -level 1 -errorcode [list TCL LOOKUP MODE $mode]] - set mode [tcl::prefix match -message "mode" -error $ERR $MODES $mode] - - # Read the file - set f [open $filename [dict get {text r binary rb} $mode]] - try { - return [read $f] - } finally { - close $f - } - } - } - } - if {![info exists ::auto_index(writeFile)]} { - if {[info commands ::writeFile] eq ""} { - proc ::writeFile {args} { - #writeFile not seen in auto_index or as command: installed by punk::lib - # Parse the arguments - switch [llength $args] { - 2 { - lassign $args filename data - set mode text - } - 3 { - lassign $args filename mode data - set MODES {binary text} - set ERR [list -level 1 -errorcode [list TCL LOOKUP MODE $mode]] - set mode [tcl::prefix match -message "mode" -error $ERR $MODES $mode] - } - default { - set COMMAND [lindex [info level 0] 0] - return -code error -errorcode {TCL WRONGARGS} "wrong # args: should be \"$COMMAND filename ?mode? data\"" - } - } - - # Write the File - set f [open $filename [dict get {text w binary wb} $mode]] - try { - puts -nonewline $f $data - } finally { - close $f - } - } - } - } - - if {"::lpop" ne [info commands ::lpop]} { - #puts stderr "Warning - no built-in lpop" - interp alias {} lpop {} ::punk::lib::compat::lpop - punk::args::set_alias ::punk::lib::compat::lpop ::lpop ;#point to the definition of ::lpop defined in punk::args::tclcore - } - proc lpop {lvar args} { - #*** !doctools - #[call [fun lpop] [arg listvar] [opt {index}]] - #[para] Forwards compatible lpop for versions 8.6 or less to support equivalent 8.7 lpop - upvar $lvar l - if {![llength $args]} { - set args [list end] - } - set v [lindex $l {*}$args] - set newlist $l - - set path [list] - set subl $l - for {set i 0} {$i < [llength $args]} {incr i} { - set idx [lindex $args $i] - if {![llength [lrange $subl $idx $idx]]} { - error "tcl_lpop index \"$idx\" out of range" - } - lappend path [lindex $args $i] - set subl [lindex $l {*}$path] - } - - set sublist_path [lrange $args 0 end-1] - set tailidx [lindex $args end] - if {![llength $sublist_path]} { - #set newlist [lremove $newlist $tailidx] - set newlist [lreplace $newlist $tailidx $tailidx] - } else { - set sublist [lindex $newlist {*}$sublist_path] - #set sublist [lremove $sublist $tailidx] - set sublist [lreplace $sublist $tailidx $tailidx] - lset newlist {*}$sublist_path $sublist - } - #puts "[set l] -> $newlist" - set l $newlist - return $v - } - if {"::ledit" ni [info commands ::ledit]} { - interp alias {} ledit {} ::punk::lib::compat::ledit - punk::args::set_alias ::punk::lib::compat::ledit ::ledit - } - proc ledit {lvar first last args} { - upvar $lvar l - #use lindex_resolve to support for example: ledit lst end+1 end+1 h i - set fidx [punk::lib::lindex_resolve [llength $l] $first] - switch -exact -- $fidx { - -3 { - #index below lower bound - set pre [list] - set fidx -1 - } - -2 { - #first index position is greater than index of last element in the list - set pre [lrange $l 0 end] - set fidx [llength $l] - } - default { - set pre [lrange $l 0 $first-1] - } - } - set lidx [punk::lib::lindex_resolve [llength $l] $last] - switch -exact -- $lidx { - -3 { - #index below lower bound - set post [lrange $l 0 end] - } - -2 { - #index above upper bound - set post [list] - } - default { - if {$lidx < $fidx} { - #from ledit man page: - #If last is less than first, then any specified elements will be inserted into the list before the element specified by first with no elements being deleted. - set post [lrange $l $fidx end] - } else { - set post [lrange $l $last+1 end] - } - } - } - set l [list {*}$pre {*}$args {*}$post] - } - - - #slight isolation - varnames don't leak - but calling context vars can be affected - proc lmaptcl2 {varnames list script} { - set result [list] - set values [list] - foreach v $varnames { - lappend values "\$$v" - } - set linkvars [uplevel 1 [list info vars]] - set nscaller [uplevel 1 [list namespace current]] - - set apply_script "" - foreach vname $linkvars { - append apply_script [string map [list %vname% $vname]\ - {upvar 2 %vname% %vname%}\ - ] \n - } - append apply_script $script \n - - #puts "--> $apply_script" - foreach $varnames $list { - lappend result [apply\ - [list\ - $varnames\ - $apply_script\ - $nscaller\ - ] {*}[subst $values]\ - ] - } - return $result - } - - if {"::lmap" ne [info commands ::lmap]} { - #puts stderr "Warning - no built-in lpop" - interp alias {} lmap {} ::punk::lib::compat::lmaptcl - } - #lmap came in Tcl 8.6 - so probably not much need for a tcl forward compatibility version - but here it is anyway - proc lmaptcl {varnames list script} { - set result [list] - set varlist [list] - foreach varname $varnames { - upvar 1 $varname var_$varname ;#ensure no collisions with vars in this proc - lappend varlist var_$varname - } - foreach $varlist $list { - lappend result [uplevel 1 $script] - } - return $result - } - - #tcl8.7/9 compatibility for 8.6 - if {[info commands ::tcl::string::insert] eq ""} { - #https://wiki.tcl-lang.org/page/string+insert - # Pure Tcl implementation of [string insert] command. - proc ::tcl::string::insert {string index insertString} { - # Convert end-relative and TIP 176 indexes to simple integers. - if {[regexp -expanded { - ^(end(?![\t\n\v\f\r ]) # "end" is never followed by whitespace - |[\t\n\v\f\r ]*[+-]?\d+) # m, with optional leading whitespace - (?:([+-]) # op, omitted when index is "end" - ([+-]?\d+))? # n, omitted when index is "end" - [\t\n\v\f\r ]*$ # optional whitespace (unless "end") - } $index _ m op n]} { - # Convert first index to an integer. - switch $m { - end {set index [string length $string]} - default {scan $m %d index} - } - - # Add or subtract second index, if provided. - switch $op { - + {set index [expr {$index + $n}]} - - {set index [expr {$index - $n}]} - } - } elseif {![string is integer -strict $index]} { - # Reject invalid indexes. - return -code error "bad index \"$index\": must be\ - integer?\[+-\]integer? or end?\[+-\]integer?" - } - - # Concatenate the pre-insert, insertion, and post-insert strings. - string cat [string range $string 0 [expr {$index - 1}]] $insertString\ - [string range $string $index end] - } - - # Bind [string insert] to [::tcl::string::insert]. - tcl::namespace::ensemble configure string -map [tcl::dict::replace\ - [tcl::namespace::ensemble configure string -map]\ - insert ::tcl::string::insert] - } - #*** !doctools - #[list_end] [comment {--- end definitions namespace punk::lib::compat ---}] -} - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# Base namespace -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -namespace eval punk::lib { - variable PUNKARGS - tcl::namespace::export * - variable has_struct_list - set has_struct_list [expr {![catch {package require struct::list}]}] - variable has_struct_set - set has_struct_set [expr {![catch {package require struct::set}]}] - variable has_punk_ansi - set has_punk_ansi [expr {![catch {package require punk::ansi}]}] - set has_twapi 0 - if {"windows" eq $::tcl_platform(platform)} { - set has_twapi [expr {![catch {package require twapi}]}] - } - - - - # == == == == == == == == == == == == == == == == == == == == == == == == == == == == == == == - # Maintenance - This is the primary source for tm_version... functions - # - certain packages script require these but without package dependency - # - 1 punk boot script - # - 2 packagetrace module - # - These should be updated to sync with this - # == == == == == == == == == == == == == == == == == == == == == == == == == == == == == == == - proc tm_version_isvalid {versionpart} { - #Needs to be suitable for use with Tcl's 'package vcompare' - if {![catch [list package vcompare $versionpart $versionpart]]} { - return 1 - } else { - return 0 - } - } - proc tm_version_major {version} { - if {![tm_version_isvalid $version]} { - error "Invalid version '$version' is not a proper Tcl module version number" - } - set firstpart [lindex [split $version .] 0] - #check for a/b in first segment - if {[string is integer -strict $firstpart]} { - return $firstpart - } - if {[string first a $firstpart] > 0} { - return [lindex [split $firstpart a] 0] - } - if {[string first b $firstpart] > 0} { - return [lindex [split $firstpart b] 0] - } - error "tm_version_major unable to determine major version from version number '$version'" - } - proc tm_version_canonical {ver} { - #accepts a single valid version only - not a bounded or unbounded spec - if {![tm_version_isvalid $ver]} { - error "tm_version_canonical version '$ver' is not valid for a package version" - } - set parts [split $ver .] - set newparts [list] - foreach o $parts { - set trimmed [string trimleft $o 0] - set firstnonzero [string index $trimmed 0] - switch -exact -- $firstnonzero { - "" { - lappend newparts 0 - } - a - b { - #e.g 000bnnnn -> bnnnnn - set tailtrimmed [string trimleft [string range $trimmed 1 end] 0] - if {$tailtrimmed eq ""} { - set tailtrimmed 0 - } - lappend newparts 0$firstnonzero$tailtrimmed - } - default { - #digit - if {[string is integer -strict $trimmed]} { - #e.g 0100 -> 100 - lappend newparts $trimmed - } else { - #e.g 0100b003 -> 100b003 (still need to process tail) - if {[set apos [string first a $trimmed]] > 0} { - set lhs [string range $trimmed 0 $apos-1] ;#assert lhs non-empty and only digits or wouldn't be in this branch - set rhs [string range $trimmed $apos+1 end] ;#assert rhs non-empty and only digits - set rhs [string trimleft $rhs 0] - if {$rhs eq ""} { - set rhs 0 - } - lappend newparts ${lhs}a${rhs} - } elseif {[set bpos [string first b $trimmed]] > 0} { - set lhs [string range $trimmed 0 $bpos-1] ;#assert lhs non-empty and only digits or wouldn't be in this branch - set rhs [string range $trimmed $bpos+1 end] ;#assert rhs non-empty and only digits - set rhs [string trimleft $rhs 0] - if {$rhs eq ""} { - set rhs 0 - } - lappend newparts ${lhs}b${rhs} - } else { - #assert - shouldn't get here trimmed val should have been empty, an int or contained an a or b - error "tm_version_canonical error - trimfail - unexpected" - } - } - } - } - } - return [join $newparts .] - } - proc tm_version_required_canonical {versionspec} { - #also trim leading zero from any dottedpart? - #Tcl *allows* leading zeros in any of the dotted parts - but they are not significant. - #e.g 1.01 is equivalent to 1.1 and 01.001 - #also 1b3 == 1b0003 - - if {[string trim $versionspec] eq ""} {return ""} ;#unspecified = any version - set errmsg "tm_version_required_canonical - invalid version specification" - if {[string first - $versionspec] < 0} { - #no dash - #looks like a minbounded version (ie a single version with no dash) convert to min-max form - set from $versionspec - if {![tm_version_isvalid $from]} { - error "$errmsg '$versionpec'" - } - if {![catch {tm_version_major $from} majorv]} { - set from [tm_version_canonical $from] - return "${from}-[expr {$majorv +1}]" - } else { - error "$errmsg '$versionspec'" - } - } else { - # min- or min-max - #validation and canonicalisation (strip leading zeroes from each segment, including either side of a or b) - set parts [split $versionspec -] ;#we expect only 2 parts - lassign $parts from to - if {![tm_version_isvalid $from]} { - error "$errmsg '$versionspec'" - } - set from [tm_version_canonical $from] - if {[llength $parts] == 2} { - if {$to ne ""} { - if {![tm_version_isvalid $to]} { - error "$errmsg '$versionspec'" - } - set to [tm_version_canonical $to] - return $from-$to - } else { - return $from- - } - } else { - error "$errmsg '$versionspec'" - } - error "tm_version_required_canonical should have already returned a canonicalised versionspec - or produced an error with reason before this point" - } - } - # end tm_version... functions - # == == == == == == == == == == == == == == == == == == == == == == == == == == == == == == == - - - - # -- --- - #https://stackoverflow.com/questions/17631269/whats-the-best-way-to-join-two-lists - #DKF's 2013 recommendation of using list {*}$first {*}$second seems not to apply in 2024 - #8.6,8.7,9.0 - 'lappend first {*}$second' is many times faster - especially as list grows - # Review and retest as new versions come out. - # -- --- - proc list_multi_append1 {lvar1 lvar2} { - #clear winner in 2024 - upvar $lvar1 l1 $lvar2 l2 - lappend l1 {*}$l2 - return $l1 - } - proc list_multi_append2 {lvar1 lvar2} { - upvar $lvar1 l1 $lvar2 l2 - set l1 [list {*}$l1 {*}$l2] - } - proc list_multi_append3 {lvar1 lvar2} { - upvar $lvar1 l1 $lvar2 l2 - set l1 [lindex [list [list {*}$l1 {*}$l2] [unset l1]] 0] - } - #testing e.g - #set l1_reset {a b c} - #set l2 {a b c d e f g} - #set l1 $l1_reset - #time {list_multi_append1 l1 l2} 1000 - #set l1 $l1_reset - #time {list_multi_append2 l1 l2} 1000 - # -- --- - - - proc lswap {lvar a z} { - upvar $lvar l - set len [llength $l] - if {[lindex_resolve_basic $len $a] < 0 || [lindex_resolve_basic $len $z] < 0} { - #lindex_resolve_basic returns only -1 if out of range - #if we didn't do this check - we could raise an error on second lset below - leaving list corrupted because only one lset occurred - #(e.g using: lswap mylist end-2 end on a two element list) - - #on the unhapy path we can take time to check the nature of the out-of-boundness to give a nicer report - #use full 'lindex_resolve' which can report which side via -3 and -2 special results being lower and upper bound breaches respectively (-1 never returned) - set a_index [lindex_resolve $len $a] - set a_msg "" - switch -- $a_index { - -2 { - set a_msg "1st supplied index $a is above the upper bound for the list ([llength $l])" - } - -3 { - set a_msg "1st supplied index $a is below the lower bound for the list (0)" - } - } - set z_index [lindex_resolve $len $z] - set z_msg "" - switch -- $z_index { - -2 { - set z_msg "2nd supplied index $z is above the upper bound for the list ([llength $l])" - } - -3 { - set z_msg "2nd supplied index $z is below the lower bound for the list (0)" - } - } - set errmsg "lswap cannot swap indices $a and $z" - if {$a_msg ne ""} { - append errmsg \n $a_msg - } - if {$z_msg ne ""} { - append errmsg \n $z_msg - } - error $errmsg - } - set item2 [lindex $l $z] - lset l $z [lindex $l $a] - lset l $a $item2 - return $l - } - #proc lswap2 {lvar a z} { - # upvar $lvar l - # #if index a strictly less <= z we can do in one-liner for fun - but it's replacing whole list - so much slower - # set l [concat [lrange $l 0 $a-1] [lindex $l $z] [lrange $l $a+1 $z-1] [lindex $l $a] [lrange $l $z+1 end]] - #} - - proc lswap2 {lvar a z} { - upvar $lvar l - #if index a strictly less <= z we can do in one-liner for fun - but it's replacing whole list - so much slower - set l [list {*}[lrange $l 0 $a-1] [lindex $l $z] {*}[lrange $l $a+1 $z-1] [lindex $l $a] {*}[lrange $l $z+1 end]] - } - - #an experimental test of swapping vars without intermediate variables - #It's an interesting idea - but probably of little to no practical use - # - the swap_intvars3 version using intermediate var is faster in Tcl - # - This is probably unsurprising - as it's simpler code. - # Even if we tried this technique in c - the compiler would probably do a better job with the intermediate variable than with the math tricks. - #proc swap_intvars {swapv1 swapv2} { - # upvar $swapv1 _x $swapv2 _y - # set _x [expr {[expr {$_x + $_y}] - [set _y $_x]}] - #} - #proc swap_intvars2 {swapv1 swapv2} { - # upvar $swapv1 _x $swapv2 _y - # set _x [expr {$_x ^ $_y}] - # set _y [expr {$_x ^ $_y}] - # set _x [expr {$_x ^ $_y}] - #} - #proc swap_intvars3 {swapv1 swapv2} { - # #using intermediate variable - # upvar $swapv1 _x $swapv2 _y - # set z $_x - # set _x $_y - # set _y $z - #} - - #*** !doctools - #[subsection {Namespace punk::lib}] - #[para] Core API functions for punk::lib - #[list_begin definitions] - - if {[info commands lseq] ne ""} { - #tcl 8.7+ lseq significantly faster, especially for larger ranges - #The internal rep can be an 'arithseries' with no string representation - #support minimal set from to - proc range {from to} { - lseq $from $to - } - } else { - #lseq accepts basic expressions e.g 4-2 for both arguments - #e.g we can do lseq 0 [llength $list]-1 - #if range is to be consistent with the lseq version above - it should support that, even though we don't support most lseq functionality in either wrapper. - proc range {from to} { - set to [offset_expr $to] - set from [offset_expr $from] - if {$to > $from} { - set count [expr {($to -$from) + 1}] - if {$from == 0} { - return [lsearch -all [lrepeat $count 0] *] - } else { - incr from -1 - return [lmap v [lrepeat $count 0] {incr from}] - } - #slower methods. - #2) - #set i -1 - #set L [lrepeat $count 0] - #lmap v $L {lset L [incr i] [incr from];lindex {}} - #return $L - #3) - #set L {} - #for {set i 0} {$i < $count} {incr i} { - # lappend L [incr from] - #} - #return $L - } elseif {$from > $to} { - set count [expr {$from - $to} + 1] - #1) - if {$to == 0} { - return [lreverse [lsearch -all [lrepeat $count 0] *]] - } else { - incr from - return [lmap v [lrepeat $count 0] {incr from -1}] - } - - #2) - #set i -1 - #set L [lrepeat $count 0] - #lmap v $L {lset L [incr i] [incr from -1];lindex {}} - #return $L - #3) - #set L {} - #for {set i 0} {$i < $count} {incr i} { - # lappend L [incr from -1] - #} - #return $L - } else { - return [list $from] - } - } - } - - proc lzip {args} { - switch -- [llength $args] { - 0 {return {}} - 1 {return [lindex $args 0]} - 2 {return [lzip2lists {*}$args]} - 3 {return [lzip3lists {*}$args]} - 4 {return [lzip4lists {*}$args]} - 5 {return [lzip5lists {*}$args]} - 6 {return [lzip6lists {*}$args]} - 7 {return [lzip7lists {*}$args]} - 8 {return [lzip8lists {*}$args]} - 9 {return [lzip9lists {*}$args]} - 10 {return [lzip10lists {*}$args]} - 11 - 12 - 13 - 14 - 15 - 16 - 17 - 18 - 19 - 20 - 21 - 22 - 23 - 24 - 25 - 26 - 27 - 28 - 29 - 30 - 31 - 32 { - set n [llength $args] - if {[info commands ::punk::lib::lzip${n}lists] eq ""} { - puts "calling ::punk::lib::Build_lzipn $n" - ::punk::lib::Build_lzipn $n - } - return [lzip${n}lists {*}$args] - } - default { - if {[llength $args] < 4000} { - set n [llength $args] - if {[info commands ::punk::lib::lzip${n}lists] eq ""} { - puts "calling ::punk::lib::Build_lzipn $n" - ::punk::lib::Build_lzipn $n - } - return [lzip${n}lists {*}$args] - } else { - return [lzipn {*}$args] - } - } - } - } - - proc Build_lzipn {n} { - set arglist [list] - #use punk::lib::range which defers to lseq if available - set vars [lmap i [punk::lib::range 0 $n] {string cat v$i}] ;#v0 v1 v2.. (v0 ignored) - set body "\nlmap " - for {set i 1} {$i <= $n} {incr i} { - lappend arglist l$i - append body "[lindex $vars $i] \$l$i " - } - append body "\{list " - for {set i 1} {$i <= $n} {incr i} { - append body "\$[lindex $vars $i] " - } - append body "\}" \n - puts "proc punk::lib::lzip${n}lists {$arglist} \{" - puts "$body" - puts "\}" - proc ::punk::lib::lzip${n}lists $arglist $body - } - - #fastest is to know the number of lists to be zipped - proc lzip2lists {l1 l2} { - lmap a $l1 b $l2 {list $a $b} - } - proc lzip3lists {l1 l2 l3} { - lmap a $l1 b $l2 c $l3 {list $a $b $c} - } - proc lzip4lists {l1 l2 l3 l4} { - lmap a $l1 b $l2 c $l3 d $l4 {list $a $b $c $d} - } - proc lzip5lists {l1 l2 l3 l4 l5} { - lmap a $l1 b $l2 c $l3 d $l4 e $l5 {list $a $b $c $d $e} - } - proc lzip6lists {l1 l2 l3 l4 l5 l6} { - lmap a $l1 b $l2 c $l3 d $l4 e $l5 f $l6 {list $a $b $c $d $e $f} - } - proc lzip7lists {l1 l2 l3 l4 l5 l6 l7} { - lmap a $l1 b $l2 c $l3 d $l4 e $l5 f $l6 g $l7 {list $a $b $c $d $e $f $g} - } - proc lzip8lists {l1 l2 l3 l4 l5 l6 l7 l8} { - lmap a $l1 b $l2 c $l3 d $l4 e $l5 f $l6 g $l7 h $l8 {list $a $b $c $d $e $f $g $h} - } - proc lzip9lists {l1 l2 l3 l4 l5 l6 l7 l8 l9} { - lmap a $l1 b $l2 c $l3 d $l4 e $l5 f $l6 g $l7 h $l8 i $l9 {list $a $b $c $d $e $f $g $h $i} - } - proc lzip10lists {l1 l2 l3 l4 l5 l6 l7 l8 l9 l10} { - lmap a $l1 b $l2 c $l3 d $l4 e $l5 f $l6 g $l7 h $l8 i $l9 j $l10 {list $a $b $c $d $e $f $g $h $i $j} - } - - #neat algorithm - but while lmap seems better than foreach - it seems the script is evaluated a little slowly - # review - - proc lzipn_alt args { - #stackoverflow - courtesy glenn jackman (modified) - foreach l $args { - lappend vars [incr n] - lappend lmap_args $n $l - } - lmap {*}$lmap_args {lmap v $vars {set $v}} - } - - #2024 - outperforms lmap version - presumably because list sizes reduced as it goes(?) - proc lzipn_tcl8 {args} { - #wiki - courtesy JAL - set list_l $args - set zip_l [] - while {1} { - set cur [lmap a_l $list_l { lindex $a_l 0 }] - set list_l [lmap a_l $list_l { lrange $a_l 1 end }] - - if {[join $cur {}] eq {}} { - break - } - lappend zip_l $cur - } - return $zip_l - } - proc lzipn_tcl9a {args} { - #compared to wiki version - #comparable for lists len <3 or number of args < 3 - #approx 2x faster for large lists or more lists - #needs -stride single index bug fix to use empty string instead of NULL - if {![llength $args]} {return {}} - set lens [lmap l $args {llength $l}] - set numcolumns [::tcl::mathfunc::max {*}$lens] - set flatlist [lrepeat [expr {$numcolumns * [llength $args]}] {}] - set outlist [lrepeat $numcolumns {}] - set s 0 - foreach len $lens list $args { - #ledit flatlist $s $e {*}$l {*}[lrepeat [expr {($numcolumns -([llength $l] % $numcolumns)) % $numcolumns}] NULL] - ledit flatlist $s [expr {$s + $len - 1}] {*}$list - incr s $numcolumns - } - #needs single index lstride bugfix - for {set c 0} {$c < $numcolumns} {incr c} { - ledit outlist $c $c [lsearch -stride $numcolumns -index $c -inline -all -subindices $flatlist *] - } - return $outlist - } - proc lzipn_tcl9b {args} { - if {![llength $args]} {return {}} - set lens [lmap l $args {llength $l}] - set numcolumns [::tcl::mathfunc::max {*}$lens] - set flatlist [list] - foreach len $lens list $args { - lappend flatlist {*}$list {*}[lrepeat [expr {($numcolumns - ($len % $numcolumns)) % $numcolumns}] ""] - } - lmap c [lseq 0 $numcolumns-1] {lsearch -stride $numcolumns -index $c -inline -all -subindices $flatlist *} - } - proc lzipn_tcl9c {args} { - #SLOW - if {![llength $args]} {return {}} - set lens [lmap l $args {llength $l}] - set numcolumns [::tcl::mathfunc::max {*}$lens] - set flatlist [list] - foreach len $lens list $args { - lappend flatlist {*}$list {*}[lrepeat [expr {($numcolumns - ($len % $numcolumns)) % $numcolumns}] ""] - } - set zip_l {} - set cols_remaining $numcolumns - for {set c 0} {$c < $numcolumns} {incr c} { - if {$cols_remaining == 1} { - return [list {*}$zip_l $flatlist] - } - lappend zip_l [lsearch -stride $cols_remaining -index 0 -inline -all -subindices $flatlist *] - set flen [llength $flatlist] - set flatlist [lremove $flatlist {*}[lseq 0 to $flen-1 by $cols_remaining]] - incr cols_remaining -1 - } - return $zip_l - } - #keep both lzipn_tclX functions available for side-by-side testing in Tcl versions where it's possible - if {![package vsatisfies [package present Tcl] 9.0-] || [punk::lib::check::has_tclbug_lsearch_strideallinline ]} { - #-stride either not available - or has bug preventing use of main algorithm below - proc lzipn {args} [info body ::punk::lib::lzipn_tcl8] - } else { - proc lzipn {args} [info body ::punk::lib::lzipn_tcl9a] - } - - - namespace import ::punk::args::lib::tstr - - - - proc invoke command { - #*** !doctools - #[call [fun invoke] [arg command]] - #[para]Invoke an external command (using tcl open command) capturing stdout,stderr and the exitcode - #[example { - # set script { - # puts stdout {hello on stdout} - # puts stderr {hello on stderr} - # exit 42 - # } - # invoke [list tclsh <<$script] - #}] - - #see https://wiki.tcl-lang.org/page/open - lassign [chan pipe] chanout chanin - lappend command 2>@$chanin - set fh [open |$command] - set stdout [read $fh] - close $chanin - set stderr [read $chanout] - close $chanout - if {[catch {close $fh} cres e]} { - dict with e {} - lassign [set -errorcode] sysmsg pid exit - if {$sysmsg eq {NONE}} { - #output to stderr caused [close] to fail. Do nothing - } elseif {$sysmsg eq {CHILDSTATUS}} { - return [list $stdout $stderr $exit] - } else { - return -options $e $stderr - } - } - return [list $stdout $stderr 0] - } - - proc pdict {args} { - package require punk::args - variable has_punk_ansi - if {!$has_punk_ansi} { - set sep " = " - } else { - #set sep " [a+ Web-seagreen]=[a] " - set sep " [punk::ansi::a+ Green]=[punk::ansi::a] " - } - set argspec [string map [list %sep% $sep] { - @id -id ::punk::lib::pdict - @cmd -name pdict -help\ - "Print dict keys,values to channel - The pdict function operates on variable names - passing the value to the showdict function which operates on values - (see also showdict)" - - @opts -any 1 - - #default separator to provide similarity to tcl's parray function - -separator -default "%sep%" - -roottype -default "dict" - -substructure -default {} - -channel -default stdout -help\ - "existing channel - or 'none' to return as string" - - @values -min 1 -max -1 - - dictvar -type string -help "name of variable. Can be a dict, list or array" - - patterns -type string -default "*" -multiple 1 -help {Multiple patterns can be specified as separate arguments. - Each pattern consists of 1 or more segments separated by the hierarchy separator (forward slash) - The system uses similar patterns to the punk pipeline pattern-matching system. - The default assumed type is dict - but an array will automatically be extracted into key value pairs so will also work. - Segments are classified into list,dict and string operations. - Leading % indicates a string operation - e.g %# gives string length - A segment with a single @ is a list operation e.g @0 gives first list element, @1-3 gives the lrange from 1 to 3 - A segment containing 2 @ symbols is a dict operation. e.g @@k1 retrieves the value for dict key 'k1' - The operation type indicator is not always necessary if lower segments in the hierarchy are of the same type as the previous one. - e.g1 pdict env */%# - the pattern starts with default type dict, so * retrieves all keys & values, - the next hierarchy switches to a string operation to get the length of each value. - e.g2 pdict env W* S* - Here we supply 2 patterns, each in default dict mode - to display keys and values where the keys match the glob patterns - e.g3 pdict punk_testd */* - This displays 2 levels of the dict hierarchy. - Note that if the sublevel can't actually be interpreted as a dictionary (odd number of elements or not a list at all) - - then the normal = separator will be replaced with a coloured (or underlined if colour off) 'mismatch' indicator. - e.g4 set list {{k1 v1 k2 v2} {k1 vv1 k2 vv2}}; pdict list @0-end/@@k2 @*/@@k1 - Here we supply 2 separate pattern hierarchies, where @0-end and @* are list operations and are equivalent - The second level segment in each pattern switches to a dict operation to retrieve the value by key. - When a list operation such as @* is used - integer list indexes are displayed on the left side of the = for that hierarchy level. - } - }] - #puts stderr "$argspec" - set argd [punk::args::parse $args withdef $argspec] - - set opts [dict get $argd opts] - set dvar [dict get $argd values dictvar] - set patterns [dict get $argd values patterns] - set isarray [uplevel 1 [list array exists $dvar]] - if {$isarray} { - set dvalue [uplevel 1 [list array get $dvar]] - if {![dict exists $opts -keytemplates]} { - set arrdisplay [string map [list %dvar% $dvar] {${[if {[lindex $key 1] eq "query"} {val "%dvar% [lindex $key 0]"} {val "%dvar%($key)"}]}}] - dict set opts -keytemplates [list $arrdisplay] - } - dict set opts -keysorttype dictionary - } else { - set dvalue [uplevel 1 [list set $dvar]] - } - showdict {*}$opts $dvalue {*}$patterns - } - - #TODO - much. - #showdict needs to be able to show different branches which share a root path - #e.g show key a1/b* in its entirety along with a1/c* - (or even exact duplicates) - # - specify ansi colour per pattern so different branches can be highlighted? - # - ideally we want to be able to use all the dict & list patterns from the punk pipeline system eg @head @tail # (count) etc - # - The current version is incomplete but passably usable. - # - Copy proc and attempt rework so we can get back to this as a baseline for functionality - proc showdict {args} { ;# analogous to parray (except that it takes the dict as a value) - #set sep " [a+ Web-seagreen]=[a] " - variable has_punk_ansi - if {!$has_punk_ansi} { - set RST "" - set sep " = " - #set sep_mismatch " mismatch " - set sep \u2260 ;# equivalent [punk::ansi::convert_g0 [punk::ansi::g0 |]] (not equal symbol) - } else { - set RST [punk::ansi::a] - set sep " [punk::ansi::a+ Green]=$RST " ;#stick to basic default colours for wider terminal support - #set sep_mismatch " [punk::ansi::a+ Brightred undercurly underline undt-white]mismatch$RST " - set sep_mismatch " [punk::ansi::a+ Brightred undercurly underline undt-white]\u2260$RST " - } - package require punk::pipe - #package require punk ;#we need pipeline pattern matching features - package require textblock - - set argd [punk::args::parse $args withdef [string map [list %sep% $sep %sep_mismatch% $sep_mismatch] { - @id -id ::punk::lib::showdict - @cmd -name punk::lib::showdict -help "display dictionary keys and values" - #todo - table tableobject - -return -default "tailtohead" -choices {tailtohead sidebyside} - -channel -default none - -trimright -default 1 -type boolean -help\ - "Trim whitespace off rhs of each line. - This can help prevent a single long line that wraps in terminal from making - every line wrap due to long rhs padding." - -separator -default {%sep%} -help\ - "Separator column between keys and values" - -separator_mismatch -default {%sep_mismatch%} -help\ - "Separator to use when patterns mismatch" - -roottype -default "dict" -help\ - "list,dict,string" - -ansibase_keys -default "" -help\ - "ansi list for each level in -substructure. e.g \[list \[a+ red\] \[a+ web-green\]\]" - -substructure -default {} - -ansibase_values -default "" - -keytemplates -default {\$\{$key\}} -type list -help\ - "list of templates for keys at each level" - -keysorttype -default "none" -choices {none dictionary ascii integer real} - -keysortdirection -default increasing -choices {increasing decreasing} - -debug -default 0 -type boolean -help\ - "When enabled, produces some rudimentary debug output on stderr" - -- -type none -optional 1 - @values -min 1 -max -1 - dictvalue -type list -help\ - "dict or list value" - patterns -default "*" -type string -multiple 1 -help\ - "key or key glob pattern" - }]] - - #for punk::lib - we want to reduce pkg dependencies. - # - so we won't even use the tcllib debug pkg here - set opt_debug [dict get $argd opts -debug] - if {$opt_debug} { - if {[info body debug::showdict] eq ""} { - proc ::punk::lib::debug::showdict {args} { - catch {puts stderr "punk::lib::showdict-> [string cat {*}$args]"} - } - } - } else { - if {[info body debug::showdict] ne ""} { - proc ::punk::lib::debug::showdict {args} {} - } - } - - set opt_sep [dict get $argd opts -separator] - set opt_mismatch_sep [dict get $argd opts -separator_mismatch] - set opt_keysorttype [dict get $argd opts -keysorttype] - set opt_keysortdirection [dict get $argd opts -keysortdirection] - set opt_trimright [dict get $argd opts -trimright] - set opt_keytemplates [dict get $argd opts -keytemplates] - debug::showdict "keytemplates ---> $opt_keytemplates <---" - set opt_ansibase_keys [dict get $argd opts -ansibase_keys] - set opt_ansibase_values [dict get $argd opts -ansibase_values] - set opt_return [dict get $argd opts -return] - set opt_roottype [dict get $argd opts -roottype] - set opt_structure [dict get $argd opts -substructure] - - set dval [dict get $argd values dictvalue] - set patterns [dict get $argd values patterns] - - set result "" - - #pattern hierarchy - # */@1/@0,%#,%str @0/@1 - patterns each one is a pattern or pattern_nest - # * @1 @0,%#,%str - segments - # a b 1 0 %# %str - keys - - set pattern_key_index [list] ;#list of pattern_nests, same length as number of keys generated - set pattern_next_substructure [dict create] - set pattern_this_structure [dict create] - - # -- --- --- --- - #REVIEW - #as much as possible we should pass the indices along as a query to the pipeline pattern matching system so we're not duplicating the work and introducing inconsistencies. - #The main difference here is that sometimes we are treating the result as key-val pairs with the key being the query, other times the key is part of the query, or from the result itself (list/dict indices/keys). - #todo - determine if there is a more consistent rule-based way to do this rather than adhoc - #e.g pdict something * - #we want the keys from the result as individual lines on lhs - #e.g pdict something @@ - #we want on lhs result on rhs - # = v0 - #e.g pdict something @0-2,@4 - #we currently return: - #0 = v0 - #1 = v1 - #2 = v2 - #4 = v4 - #This means we've effectively auto-expanded the first list - elements 0-2. (or equivalently stated: we've flattened the 3 element and 1 element lists into one list of 4 elements) - #ie pdict is doing 'magic' compared to the normal pattern matching syntax, to make useage more convenient. - #this is a tradeoff that could create surprises and make things messy and/or inconsistent. - #todo - see if we can find a balance that gives consistency and logicality to the results whilst allowing still simplified matching syntax that is somewhat intuitive. - #It may be a matter of documenting what type of indexes are used directly as keys, and which return sets of further keys - #The solution for more consistency/predictability may involve being able to bracket some parts of the segment so for example we can apply an @join or %join within a segment - #that involves more complex pattern syntax & parsing (to be added to the main pipeline pattern syntax) - # -- --- --- --- - - set filtered_keys [list] - if {$opt_roottype in {dict list string}} { - #puts "getting keys for roottype:$opt_roottype" - if {[llength $dval]} { - set re_numdashnum {^([-+]{0,1}\d+)-([-+]{0,1}\d+)$} - set re_idxdashidx {^([-+]{0,1}\d+|end[-+]{1}\d+|end)-([-+]{0,1}\d+|end[-+]{1}\d+|end)$} - foreach pattern_nest $patterns { - set keyset [list] - set keyset_structure [list] - - set segments [split $pattern_nest /] - set levelpatterns [lindex $segments 0] ;#possibly comma separated patterns - #we need to use _split_patterns to separate (e.g to protect commas that appear within quotes) - set patterninfo [punk::pipe::lib::_split_patterns $levelpatterns] - #puts stderr "showdict-->_split_patterns: $patterninfo" - foreach v_idx $patterninfo { - lassign $v_idx v idx - #we don't support vars on lhs of index in this context - (because we support simplified glob patterns such as x* and literal dict keys such as kv which would otherwise be interpreted as vars with no index) - set p $v$idx ;#_split_patterns has split too far in this context - the entire pattern is the index pattern - if {[string index $p 0] eq "!"} { - set get_not 1 - set p [string range $p 1 end] - } else { - set get_not 0 - } - switch -exact -- $p { - * - "" { - if {$opt_roottype eq "list"} { - set keys [punk::lib::range 0 [llength $dval]-1] ;#compat wrapper around subset of lseq functionality - lappend keyset {*}$keys - lappend keyset_structure {*}[lrepeat [llength $keys] list] - dict set pattern_this_structure $p list - } elseif {$opt_roottype eq "dict"} { - set keys [dict keys $dval] - lappend keyset {*}$keys - lappend keyset_structure {*}[lrepeat [llength $keys] dict] - dict set pattern_this_structure $p dict - } else { - lappend keyset %string - lappend keyset_structure string - dict set pattern_this_structure $p string - } - } - %# { - dict set pattern_this_structure $p string - lappend keyset %# - lappend keyset_structure string - } - # { - #todo get_not !# is test for listiness (see punk) - dict set pattern_this_structure $p list - lappend keyset # - lappend keyset_structure list - } - ## { - dict set pattern_this_structure $p dict - lappend keyset [list ## query] - lappend keyset_structure dict - } - @* { - #puts "showdict ---->@*<----" - dict set pattern_this_structure $p list - set keys [punk::lib::range 0 [llength $dval]-1] - lappend keyset {*}$keys - lappend keyset_structure {*}[lrepeat [llength $keys] list] - } - @@ { - #get first k v from dict - dict set pattern_this_structure $p dict - lappend keyset [list @@ query] - lappend keyset_structure dict - } - @*k@* - @*K@* { - #returns keys only - lappend keyset [list $p query] - lappend keyset_structure dict - dict set pattern_this_structure $p dict - } - @*.@* { - set keys [dict keys $dval] - lappend keyset {*}$keys - lappend keyset_structure {*}[lrepeat [llength $keys] dict] - dict set pattern_this_structure $p dict - } - default { - #puts stderr "===p:$p" - #the basic scheme also doesn't allow commas in dict keys access via the convenience @@key - which isn't great, especially for arrays where it is common practice! - #we've already sacrificed whitespace in keys - so extra limitations should be reduced if it's to be passably useful - #@@"key,etc" should allow any non-whitespace key - switch -glob -- $p { - {@k\*@*} - {@K\*@*} { - #value glob return keys - #set search [string range $p 4 end] - #dict for {k v} $dval { - # if {[string match $search $v]} { - # lappend keyset $k - # } - #} - if {$get_not} { - lappend keyset [list !$p query] - } else { - lappend keyset [list $p query] - } - lappend keyset_structure dict - dict set pattern_this_structure $p dict - } - @@* { - #exact match key - review - should raise error to match punk pipe behaviour? - set k [string range $p 2 end] - if {$get_not} { - if {[dict exists $dval $k]} { - set keys [dict keys [dict remove $dval $k]] - lappend keyset {*}$keys - lappend keyset_structure {*}[lrepeat [llength $keys] dict] - } else { - lappend keyset {*}[dict keys $dval] - lappend keyset_structure {*}[lrepeat [dict size $dval] dict] - } - } else { - if {[dict exists $dval $k]} { - lappend keyset $k - lappend keyset_structure dict - } - } - dict set pattern_this_structure $p dict - } - @k@* - @K@* { - #TODO get_not - set k [string range $p 3 end] - if {[dict exists $dval $k]} { - lappend keyset $k - lappend keyset_structure dict - } - dict set pattern_this_structure $p dict - } - {@\*@*} { - #return list of values - #set k [string range $p 3 end] - #lappend keyset {*}[dict keys $dval $k] - if {$get_not} { - lappend keyset [list !$p query] - } else { - lappend keyset [list $p query] - } - lappend keyset_structure dict - dict set pattern_this_structure $p dict - } - {@\*.@*} { - #TODO get_not - set k [string range $p 4 end] - set keys [dict keys $dval $k] - lappend keyset {*}$keys - lappend keyset_structure {*}[lrepeat [llength $keys] dict] - dict set pattern_this_structure $p dict - } - {@v\*@*} - {@V\*@*} { - #value-glob return value - #error "dict value-glob value-return only not supported here - bad pattern '$p' in '$pattern_nest'" - if {$get_not} { - lappend keyset [list !$p query] - } else { - lappend keyset [list $p query] - } - lappend keyset_structure dict - dict set pattern_this_structure $p dict - } - {@\*v@*} - {@\*V@*} { - #key-glob return value - lappend keyset [list $p query] - lappend keyset_structure dict - dict set pattern_this_structure $p dict - } - {@\*@*} - {@\*v@*} - {@\*V@} { - #key glob return val - lappend keyset [list $p query] - lappend keyset_structure dict - dict set pattern_this_structure $p dict - } - @??@* { - #exact key match - no error - lappend keyset [list $p query] - lappend keyset_structure dict - dict set pattern_this_structure $p dict - } - default { - set this_type $opt_roottype - if {[string match @* $p]} { - #list mode - trim optional list specifier @ - set p [string range $p 1 end] - dict set pattern_this_structure $p list - set this_type list - } elseif {[string match %* $p]} { - dict set pattern_this_structure $p string - lappend keyset $p - lappend keyset_structure string - set this_type string - } - if {$this_type eq "list"} { - dict set pattern_this_structure $p list - if {[string is integer -strict $p]} { - if {$get_not} { - set keys [punk::lib::range 0 [llength $dval]-1] - set keys [lremove $keys $p] - lappend keyset {*}$keys - lappend keyset_structure {*}[lrepeat [llength $keys] list] - } else { - lappend keyset $p - lappend keyset_structure list - } - } elseif {[string match "?*-?*" $p]} { - #could be either - don't change type - #list indices with tcl8.7 underscores? be careful. Before 8.7 we could have used regexp \d on integers - #now we should map _ to "" first - set p [string map {_ {}} $p] - #lassign [textutil::split::splitx $p {\.\.}] a b - if {![regexp $re_idxdashidx $p _match a b]} { - error "unrecognised pattern $p" - } - set lower_resolve [punk::lib::lindex_resolve [llength $dval] $a] ;#-2 for too low, -1 for too high - #keep lower_resolve as separate var to lower for further checks based on which side out-of-bounds - if {${lower_resolve} == -2} { - ##x - #lower bound is above upper list range - #match with decreasing indices is still possible - set lower [expr {[llength $dval]-1}] ;#set to max - } elseif {$lower_resolve == -3} { - ##x - set lower 0 - } else { - set lower $lower_resolve - } - set upper [punk::lib::lindex_resolve [llength $dval] $b] - if {$upper == -3} { - ##x - #upper bound is below list range - - if {$lower_resolve >=-2} { - ##x - set upper 0 - } else { - continue - } - } elseif {$upper == -2} { - #use max - set upper [expr {[llength $dval]-1}] - #assert - upper >=0 because we have ruled out empty lists - } - #note lower can legitimately be higher than upper - lib::range, like lseq can produce sequence in reverse order - set keys [punk::lib::range $lower $upper] - if {$get_not} { - set fullrange [punk::lib::range 0 [llength $dval]-1] - set keys [lremove $fullrange {*}$keys] - if {$lower > $upper} { - set keys [lreverse $keys] - } - } - lappend keyset {*}$keys - lappend keyset_structure {*}[lrepeat [llength $keys] list] - } else { - if {$get_not} { - lappend keyset [list !@$p query] - } else { - lappend keyset [list @$p query] - } - lappend keyset_structure list - } - } elseif {$this_type eq "string"} { - dict set pattern_this_structure $p string - } elseif {$this_type eq "dict"} { - #default equivalent to @\*@* - dict set pattern_this_structure $p dict - #puts "dict: appending keys from index '$p' keys: [dict keys $dval $p]" - set keys [dict keys $dval $p] - if {$get_not} { - set keys [dict keys [dict remove $dval {*}$keys]] - } - lappend keyset {*}$keys - lappend keyset_structure {*}[lrepeat [llength $keys] dict] - } else { - puts stderr "list: unrecognised pattern $p" - } - } - } - } - } - } - - # -- --- --- --- - #check next pattern-segment for substructure type to use - # -- --- --- --- - set substructure "" - set pnext [lindex $segments 1] - set patterninfo [punk::pipe::lib::_split_patterns $levelpatterns] - if {[llength $patterninfo] == 0} { - # // ? -review - what does this mean? for xpath this would mean at any level - set substructure [lindex $pattern_this_structure end] - } elseif {[llength $patterninfo] == 1} { - #ignore the NOT operator for purposes of query-type detection - if {[string index $pnext 0] eq "!"} { - set pnext [string range $pnext 1 end] - } - # single type in segment e.g /@@something/ - switch -exact $pnext { - "" { - set substructure string - } - @*k@* - @*K@* - @*.@* - ## { - set substructure dict - } - # { - set substructure list - } - ## { - set substructure dict - } - %# { - set substructure string - } - * { - #set substructure $opt_roottype - #set substructure [dict get $pattern_this_structure $pattern_nest] - set substructure [lindex $pattern_this_structure end] - } - default { - switch -glob -- $pnext { - @??@* - @?@* - @@* { - #all 4 or 3 len prefixes bounded by @ are dict - set substructure dict - } - default { - if {[string match @* $pnext]} { - set substructure list - } elseif {[string match %* $pnext]} { - set substructure string - } else { - #set substructure $opt_roottype - #set substructure [dict get $pattern_this_structure $pattern_nest] - set substructure [lindex $pattern_this_structure end] - } - } - } - } - } - } else { - #e.g /@0,%str,.../ - #doesn't matter what the individual types are - we have a list result - set substructure list - } - #puts "--pattern_nest: $pattern_nest substructure: $substructure" - dict set pattern_next_substructure $pattern_nest $substructure - # -- --- --- --- - - if {$opt_keysorttype ne "none"} { - set int_keyset 1 - foreach k $keyset { - if {![string is integer -strict $k]} { - set int_keyset 0 - break - } - } - if {$int_keyset} { - set sortindices [lsort -indices -integer $keyset] - #set keyset [lsort -integer $keyset] - } else { - #set keyset [lsort -$opt_keysorttype $keyset] - set sortindices [lsort -indices -$opt_keysorttype $keyset] - } - set keyset [lmap i $sortindices {lindex $keyset $i}] - set keyset_structure [lmap i $sortindices {lindex $keyset_structure $i}] - } - - foreach k $keyset { - lappend pattern_key_index $pattern_nest - } - - lappend filtered_keys {*}$keyset - lappend all_keyset_structure {*}$keyset_structure - - #puts stderr "--->pattern_nest:$pattern_nest keyset:$keyset" - } - } - #puts stderr "[dict get $pattern_this_structure $pattern_nest] keys: $filtered_keys" - } else { - puts stdout "unrecognised roottype: $opt_roottype" - return $dval - } - - if {[llength $filtered_keys]} { - #both keys and values could have newline characters. - #simple use of 'format' won't cut it for more complex dict keys/values - #use block::width or our columns won't align in some cases - switch -- $opt_return { - "tailtohead" { - #last line of key is side by side (possibly with separator) with first line of value - #This is more intelligible when terminal wrapping occurs - and is closer to what happens with parray multiline keys and values - #we still pad the key to max width so that the separator appears in the same column - which in the case of wide keys could cause that to wrap for all entries - - set kt [lindex $opt_keytemplates 0] - if {$kt eq ""} { - set kt {${$key}} - } - #set display_keys [lmap k $filtered_keys {tcl::string::map [list %k% $k] $kt}] - set display_keys [lmap key $filtered_keys {tstr -ret string -allowcommands $kt}] - set maxl [::tcl::mathfunc::max {*}[lmap v $display_keys {textblock::width $v}]] - - set kidx 0 - set last_hidekey 0 - foreach keydisplay $display_keys key $filtered_keys { - set thisval "?" - set hidekey 0 - set pattern_nest [lindex $pattern_key_index $kidx] - set pattern_nest_list [split $pattern_nest /] - #set this_type [dict get $pattern_this_structure $pattern_nest] - #set this_type [dict get $pattern_this_structure $key] - set this_type [lindex $all_keyset_structure $kidx] - #puts stderr "---> kidx:$kidx key:$key - pattern_nest:$pattern_nest this_type:$this_type" - - set is_match 1 ;#whether to display the normal separator or bad-match separator - switch -- $this_type { - dict { - #todo? - slower lsearch if -dupes 1 flag set so we can display duplicate 'keys' if var not a proper dict but rather a dict-shaped list that we want to display as a dict - # - default highlight dupes (ansi underline?) - if {[lindex $key 1] eq "query"} { - set qry [lindex $key 0] - % thisval.= $qry= $dval - } else { - set thisval [tcl::dict::get $dval $key] - } - - #set substructure [lrange $opt_structure 1 end] - - set nextpatterns [list] - #which pattern nest applies to this branch - set nextsub [dict get $pattern_next_substructure $pattern_nest] - if {[llength $pattern_nest_list]} { - set nest [lrange $pattern_nest_list 1 end] - lappend nextpatterns {*}[join $nest /] - } - set nextopts [dict get $argd opts] - - - set subansibasekeys [lrange $opt_ansibase_keys 1 end] - set nextkeytemplates [lrange $opt_keytemplates 1 end] - #dict set nextopts -substructure $nextsub - dict set nextopts -keytemplates $nextkeytemplates - dict set nextopts -ansibase_keys $subansibasekeys - dict set nextopts -roottype $nextsub - dict set nextopts -channel none - #puts stderr "showdict {*}$nextopts $thisval [lindex $args end]" - - if {[llength $nextpatterns]} { - if {[catch { - set thisval [showdict {*}$nextopts -- $thisval {*}$nextpatterns] - } errMsg]} { - #puts stderr ">>> nextpatterns:'$nextpatterns' nextopts:'$nextopts'" - set is_match 0 - } - } - } - list { - if {[string is integer -strict $key]} { - set thisval [lindex $dval $key] - } else { - if {[lindex $key 1] eq "query"} { - set qry [lindex $key 0] - } else { - set qry $key - } - % thisval.= $qry= $dval - } - - set nextpatterns [list] - #which pattern nest applies to this branch - set nextsub [dict get $pattern_next_substructure $pattern_nest] - if {[llength $pattern_nest_list]} { - set nest [lrange $pattern_nest_list 1 end] - lappend nextpatterns {*}[join $nest /] - } - set nextopts [dict get $argd opts] - - dict set nextopts -roottype $nextsub - dict set nextopts -channel none - - #if {![llength $nextpatterns]} { - # set nextpatterns * - #} - if {[llength $nextpatterns]} { - if {[catch { - set thisval [showdict {*}$nextopts -- $thisval {*}$nextpatterns] - } errMsg]} { - set is_match 0 - } - } - } - string { - set hidekey 1 - if {$key eq "%string"} { - set hidekey 1 - set thisval $dval - } elseif {$key eq "%ansiview"} { - set thisval [ansistring VIEW -lf 1 $dval] - } elseif {$key eq "%ansiviewstyle"} { - set thisval [ansistring VIEWSTYLE -lf 1 $dval] - } elseif {[string match *lpad-* $key]} { - set hidekey 1 - lassign [split $key -] _ extra - set width [expr {[textblock::width $dval] + $extra}] - set thisval [textblock::pad $dval -which left -width $width] - } elseif {[string match *lpadstr-* $key]} { - set hidekey 1 - lassign [split $key -] _ extra - set width [expr {[textblock::width $dval] + [tcl::string::length $extra]}] - set thisval [textblock::pad $dval -which left -width $width -padchar $extra] - } elseif {[string match *rpad-* $key]} { - set hidekey 1 - lassign [split $key -] _ extra - set width [expr {[textblock::width $dval] + $extra}] - set thisval [textblock::pad $dval -which right -width $width] - } elseif {[string match *rpadstr-* $key]} { - set hidekey 1 - lassign [split $key -] _ extra - set width [expr {[textblock::width $dval] + [tcl::string::length $extra]}] - set thisval [textblock::pad $dval -which right -width $width -padchar $extra] - } else { - if {[lindex $key 1] eq "query"} { - set qry [lindex $key 0] - } else { - set qry $key - } - set thisval $dval - if {[string index $key 0] ne "%"} { - set key %$key - } - % thisval.= $key= $thisval - } - - set nextpatterns [list] - #which pattern nest applies to this branch - set nextsub [dict get $pattern_next_substructure $pattern_nest] - if {[llength $pattern_nest_list]} { - set nest [lrange $pattern_nest_list 1 end] - lappend nextpatterns {*}[join $nest /] - } - #set nextopts [dict get $argd opts] - dict set nextopts -roottype $nextsub - dict set nextopts -channel none - - if {[llength $nextpatterns]} { - set thisval [showdict {*}$nextopts -- $thisval {*}$nextpatterns] - } - - } - } - if {$this_type eq "string" && $hidekey} { - lassign [textblock::size $thisval] _vw vwidth _vh vheight - #set blanks_above [string repeat \n [expr {$kheight -1}]] - set vblock $opt_ansibase_values$thisval$RST - #append result [textblock::join_basic -- $vblock] - #review - we wouldn't need this space if we had a literal %sp %sp-x ?? - append result " $vblock" - } else { - set ansibase_key [lindex $opt_ansibase_keys 0] - - lassign [textblock::size $keydisplay] _kw kwidth _kh kheight - lassign [textblock::size $thisval] _vw vwidth _vh vheight - - set totalheight [expr {$kheight + $vheight -1}] - set blanks_above [string repeat \n [expr {$kheight -1}]] - set blanks_below [string repeat \n [expr {$vheight -1}]] - - if {$is_match} { - set use_sep $opt_sep - } else { - set use_sep $opt_mismatch_sep - } - - - set sepwidth [textblock::width $use_sep] - set kblock [textblock::pad $ansibase_key$keydisplay$RST$blanks_below -width $maxl] - set sblock [textblock::pad $blanks_above$use_sep$blanks_below -width $sepwidth] - set vblock $blanks_above$opt_ansibase_values$thisval$RST - #only vblock is ragged - we can do a basic join because we don't care about rhs whitespace - if {$last_hidekey} { - append result \n - } - #append result [textblock::join_basic -- $kblock $sblock $vblock] \n - append result [textblock::join_basic_raw $kblock $sblock $vblock] \n - } - set last_hidekey $hidekey - incr kidx - } - } - "sidebyside" { - # TODO - fix - #This is nice for multiline keys and values of reasonable length, will produce unintuitive results when line-wrapping occurs. - #use ansibase_key etc to make the output more comprehensible in that situation. - #This is why it is not the default. (review - terminal width detection and wrapping?) - set maxl [::tcl::mathfunc::max {*}[lmap v $filtered_keys {textblock::width $v}]] - foreach key $filtered_keys { - set kt [lindex $opt_keytemplates 0] - if {$kt eq ""} { - set kt "%k%" - } - set keydisplay $opt_ansibase_keys[string map [list %k% $key] $kt]$RST - #append result [format "%-*s = %s" $maxl $key [dict get $dval $key]] \n - #differing height blocks (ie ragged) so we need a full textblock::join rather than join_basic - append result [textblock::join -- [textblock::pad $keydisplay -width $maxl] $opt_sep "$opt_ansibase_values[dict get $dval $key]$RST"] \n - } - } - } - } - if {$opt_trimright} { - set result [::join [lines_as_list -line trimright $result] \n] - } - if {[string last \n $result] == [string length $result]-1} { - set result [string range $result 0 end-1] - } - #stdout/stderr can exist but not be in 'chan names' (e.g when transforms in place) - set chan [dict get $argd opts -channel] - switch -- $chan { - stderr - stdout { - puts $chan $result - } - none { - return $result - } - default { - #review - check member of chan names? - #just try outputting to the supplied channel for now - puts $chan $result - } - } - } - - proc is_list_all_in_list {small large} { - if {[llength $small] > [llength $large]} {return 0} - foreach x $large { - ::set ($x) {} - } - foreach x $small { - if {![info exists ($x)]} { - return 0 - } - } - return 1 - } - #v2 generally seems slower - proc is_list_all_in_list2 {small large} { - set small_in_large [lsort [struct::set intersect [lsort -unique $small] $large ]] - return [struct::list equal [lsort $small] $small_in_large] - } - if {!$has_struct_list || !$has_struct_set} { - set body { - package require struct::list - package require struct::set - } - append body [info body is_list_all_in_list2] - proc is_list_all_in_list2 {small large} $body - } - - proc is_list_all_ni_list {A B} { - foreach x $B { - ::set ($x) {} - } - foreach x $A { - if {[info exists ($x)]} { - return 0 - } - } - return 1 - } - proc is_list_all_ni_list2 {a b} { - set i [struct::set intersect $a $b] - return [expr {[llength $i] == 0}] - } - if {!$has_struct_set} { - set body { - package require struct::list - } - append body [info body is_list_all_ni_list2] - proc is_list_all_ni_list2 {a b} $body - } - - #somewhat like struct::set difference - but order preserving, and doesn't treat as a 'set' so preserves dupes in fromlist - #struct::set difference may happen to preserve ordering when items are integers, but order can't be relied on, - # especially as struct::set has 2 differing implementations (tcl vs critcl) which return results with different ordering to each other and different deduping behaviour in some cases (e.g empty 2nd arg) - proc ldiff {fromlist removeitems} { - if {[llength $removeitems] == 0} {return $fromlist} - set result {} - foreach item $fromlist { - if {$item ni $removeitems} { - lappend result $item - } - } - return $result - } - #with ledit (also avail in 8.6 using punk::lib::compat::ledit - proc ldiff2 {fromlist removeitems} { - if {[llength $removeitems] == 0} {return $fromlist} - foreach item $removeitems { - set posns [lsearch -all -exact $fromlist $item] - foreach p $posns {ledit fromlist $p $p} - } - return $fromlist - } - proc ldiff3 {fromlist removeitems} { - set doomed [list] - foreach item $removeitems { - lappend doomed {*}[lsearch -all -exact $fromlist $item] - } - lremove $fromlist {*}$doomed - } - - #fix for tcl impl of struct::set::diff which doesn't dedupe - proc struct_set_diff_unique {A B} { - package require struct::set ;#require even if tcl impl - so the dependency isn't missed accidentally due to Loaded state of programmers machine. - if {[struct::set::Loaded] eq "tcl"} { - return [punk::lib::setdiff $A $B] - } else { - #use (presumably critcl) implementation for speed - return [struct::set difference $A $B] - } - } - - - #non-dupe preserving - for consistency in dedupe behaviour we don't shortcircuit empty B - #consistent dedupe and order-maintenance of remaining items in A differentiate this from struct::set difference (dedupes with critcl, doesn't with tcl implementation 2024) - #also struct::set difference with critcl is faster - proc setdiff {A B} { - if {[llength $A] == 0} {return {}} - set d [dict create] - foreach x $A {dict set d $x {}} - foreach x $B {dict unset d $x} - return [dict keys $d] - } - #bulk dict remove is slower than a foreach with dict unset - #proc setdiff2 {fromlist removeitems} { - # #if {[llength $fromlist] == 0} {return {}} - # set d [dict create] - # foreach x $fromlist { - # dict set d $x {} - # } - # return [dict keys [dict remove $d {*}$removeitems]] - #} - #array is about 15% faster than dict - but unordered. (which is ok for sets - but we have struct::set for that) - proc setdiff_unordered {A B} { - if {[llength $A] == 0} {return {}} - array set tmp {} - foreach x $A {::set tmp($x) .} - foreach x $B {catch {unset tmp($x)}} - return [array names tmp] - } - - #default/fallback implementation - proc lunique_unordered {list} { - lunique $list - } - if {$has_struct_set} { - if {[struct::set equal [struct::set union {a a} {}] {a}]} { - proc lunique_unordered {list} { - struct::set union $list {} - } - } else { - puts stderr "WARNING: struct::set union no longer dedupes!" - #we could also test a sequence of: struct::set add - } - } - - - #order-preserving - proc lunique {list} { - set new {} - foreach item $list { - if {$item ni $new} { - lappend new $item - } - } - return $new - } - proc lunique2 {list} { - set doomed [list] - #expr 'in' probably faster than using a dict - for lists approx < 20,000 items. (wiki wisdom - url?) - for {set i 0} {$i < [llength $list]} {} { - set item [lindex $list $i] - lappend doomed {*}[lrange [lsearch -all -exact -start $i $list $item] 1 end] - while {[incr i] in $doomed} {} - } - lremove $list {*}$doomed - } - #The closure-like behaviour is *very* slow especially when called from a context such as the global namespace with lots of vars and large arrays such as ::env - proc lmapflat_closure {varnames list script} { - set result [list] - set values [list] - foreach v $varnames { - lappend values "\$$v" - } - # -- --- --- - #capture - use uplevel 1 or namespace eval depending on context - set capture [uplevel 1 { - apply { varnames { - set capturevars [tcl::dict::create] - set capturearrs [tcl::dict::create] - foreach fullv $varnames { - set v [tcl::namespace::tail $fullv] - upvar 1 $v var - if {[info exists var]} { - if {(![array exists var])} { - tcl::dict::set capturevars $v $var - } else { - tcl::dict::set capturearrs capturedarray_$v [array get var] - } - } else { - #A variable can show in the results for 'info vars' but still not 'exist'. e.g a 'variable x' declaration in the namespace where the variable has never been set - } - } - return [tcl::dict::create vars $capturevars arrs $capturearrs] - } } [info vars] - } ] - # -- --- --- - set cvars [tcl::dict::get $capture vars] - set carrs [tcl::dict::get $capture arrs] - set apply_script "" - foreach arrayalias [tcl::dict::keys $carrs] { - set realname [string range $arrayalias [string first _ $arrayalias]+1 end] - append apply_script [string map [list %realname% $realname %arrayalias% $arrayalias] { - array set %realname% [set %arrayalias%][unset %arrayalias%] - }] - } - - append apply_script [string map [list %script% $script] { - #foreach arrayalias [info vars capturedarray_*] { - # set realname [string range $arrayalias [string first _ $arrayalias]+1 end] - # array set $realname [set $arrayalias][unset arrayalias] - #} - #return [eval %script%] - %script% - }] - #puts "--> $apply_script" - foreach $varnames $list { - lappend result {*}[apply\ - [list\ - [concat $varnames [tcl::dict::keys $cvars] [tcl::dict::keys $carrs] ]\ - $apply_script\ - ] {*}[subst $values] {*}[tcl::dict::values $cvars] {*}[tcl::dict::values $carrs] ] - } - return $result - } - #link version - can write to vars in calling context - but keeps varnames themselves isolated - #performance much better than capture version - but still a big price to pay for the isolation - proc lmapflat_link {varnames list script} { - set result [list] - set values [list] - foreach v $varnames { - lappend values "\$$v" - } - set linkvars [uplevel 1 [list info vars]] - set nscaller [uplevel 1 [list namespace current]] - - set apply_script "" - foreach vname $linkvars { - append apply_script [string map [list %vname% $vname]\ - {upvar 2 %vname% %vname%}\ - ] \n - } - append apply_script $script \n - - #puts "--> $apply_script" - foreach $varnames $list { - lappend result {*}[apply\ - [list\ - $varnames\ - $apply_script\ - $nscaller\ - ] {*}[subst $values]\ - ] - } - return $result - } - - #proc lmapflat {varnames list script} { - # concat {*}[uplevel 1 [list lmap $varnames $list $script]] - #} - #lmap can accept multiple var list pairs - proc lmapflat {args} { - concat {*}[uplevel 1 [list lmap {*}$args]] - } - proc lmapflat2 {args} { - concat {*}[uplevel 1 lmap {*}$args] - } - - #proc dict_getdef {dictValue args} { - # if {[llength $args] < 1} { - # error {wrong # args: should be "dict_getdef dictValue ?key ...? key default"} - # } - # set keys [lrange $args -1 end-1] - # if {[tcl::dict::exists $dictValue {*}$keys]} { - # return [tcl::dict::get $dictValue {*}$keys] - # } else { - # return [lindex $args end] - # } - #} - if {[info commands ::tcl::dict::getdef] eq ""} { - proc dict_getdef {dictValue args} { - set keys [lrange $args 0 end-1] - if {[tcl::dict::exists $dictValue {*}$keys]} { - return [tcl::dict::get $dictValue {*}$keys] - } else { - return [lindex $args end] - } - } - } else { - #we pay a minor perf penalty for the wrap - interp alias "" ::punk::lib::dict_getdef "" ::tcl::dict::getdef - } - - - #proc sample1 {p1 n args} { - # #*** !doctools - # #[call [fun sample1] [arg p1] [arg n] [opt {option value...}]] - # #[para]Description of sample1 - # #[para] Arguments: - # # [list_begin arguments] - # # [arg_def tring p1] A description of string argument p1. - # # [arg_def integer n] A description of integer argument n. - # # [list_end] - # return "ok" - #} - - #supports *safe* ultra basic offset expressions as used by lindex etc, but without the 'end' features - #safe in that we don't evaluate the expression as a string. - proc offset_expr {expression} { - set expression [tcl::string::map {_ {}} $expression] - if {[tcl::string::is integer -strict $expression]} { - return [expr {$expression}] - } - if {[regexp {(.*)([+-])(.*)} $expression _match a op b] && [tcl::string::is integer -strict $a] && [tcl::string::is integer -strict $b]} { - if {$op eq "-"} { - return [expr {$a - $b}] - } else { - return [expr {$a + $b}] - } - } else { - error "bad expression '$expression': must be integer?\[+-\]integer?" - } - } - - punk::args::define { - @id -id ::punk::lib::is_indexset - @cmd -name punk::lib::is_indexset\ - -summary\ - "Validate string is a comma-delimited 'indexset'."\ - -help\ - "Validate that a string is an 'indexset' - - An indexset consists of a comma delimited list of indexes or index-ranges. - The indexes are 0-based. - Ranges must be specified with .. as the separator. - Common whitespace elements space,tab,newlines are ignored. - Each index (or endpoint of an index-range) can be of the forms accepted by Tcl list or string commands, - e.g end-2 or 2+2. - - see indexset_resolve" - @values -min 2 -max 2 - indexset -type string - } - proc is_indexset {indexset} { - #collapse internal whitespace (for basic whitespace set we allow) - set indexset [string map [list " " "" \t "" \r\n "" \n ""] $indexset] - if {![regexp {^[\-\+_end,\.0-9]*$} $indexset]} { - return 0 - } - set ranges [split $indexset ,] - foreach r $ranges { - set validateindices [list] - set rposn [string first .. $r] - if {$rposn >= 0} { - lappend validateindices {*}[string range $r 0 $rposn-1] {*}[string range $r $rposn+2 end] - } else { - #'range' is just an index - set validateindices [list $r] - } - foreach v $validateindices { - if {$v eq "" || $v eq "end"} {continue} - if {[string is integer -strict $v]} {continue} - if {[catch {lindex {} $v}]} { - return 0 - } - } - } - return 1 - } - #review - compare to IMAP4 methods of specifying ranges? - punk::args::define { - @id -id ::punk::lib::indexset_resolve - @cmd -name punk::lib::indexset_resolve\ - -summary\ - "Resolve an indexset to a list of integers based on supplied list or string length."\ - -help\ - "Resolve an 'indexset' to a list of actual indices within the range of the provided numitems value. - e.g in a basic case: for a list of 10 items, 'indexset_resolve 10 end' will return the index 9 - - An indexset consists of a comma delimited list of indexes or index-ranges. - The indexes are 0-based. - Ranges must be specified with .. as the separator. - Whitespace is ignored. - Each index (or endpoint of an index-range) can be of the forms accepted by Tcl list or string commands, - e.g end-2 or 2+2. - - end means the last item. - end-1 means the second last item. - 0.. is the same as 0..end. - indexset examples: - 1,3.. - output the index 1 (2nd item) followed by all from index 3 to the end. - 'indexset_resolve 4 1,3..' -> 1 3 - 'indexset_resolve 10 1,3..' -> 1 3 4 5 6 7 8 9 - 0-2,end - output the first 3 indices, and the last index. - end-1..0 - output the indexes in reverse order from 2nd last item to first item." - @values -min 2 -max 2 - numitems -type integer - indexset -type indexset -help "comma delimited specification for indices to return" - } - proc indexset_resolve {numitems indexset} { - if {![string is integer -strict $numitems] || ![is_indexset $indexset]} { - #use parser on unhappy path only - set errmsg [punk::args::usage -scheme error ::punk::lib::indexset_resolve] - uplevel 1 [list return -code error -errorcode {TCL WRONGARGS PUNK} $errmsg] - } - set indexset [string map [list " " "" \t "" \r\n "" \n ""] $indexset] ;#collapse basic whitespace - set index_list [list] ;#list of actual indexes within the range - set iparts [split $indexset ,] - set index_list [list] - foreach ipart $iparts { - set ipart [string trim $ipart] - set rposn [string first .. $ipart] - if {$rposn>=0} { - #range - lassign [punk::lib::string_splitbefore_indices $ipart $rposn $rposn+2] rawa _ rawb - set rawa [string trim $rawa] - set rawb [string trim $rawb] - if {$rawa eq ""} {set rawa 0} - set a [punk::lib::lindex_resolve $numitems $rawa] - if {$a == -3} { - #undershot - leave negative - } elseif {$a == -2 && $rawa ne "-2"} { - #overshot - set a [expr {$numitems}] ;#put it outside the range on the upper side - } - - if {$rawb eq ""} { - if {$a > $numitems-1} { - set rawb $a ;#make sure .. doesn't return last item - should return nothing - } else { - set rawb end - } - } - set b [punk::lib::lindex_resolve $numitems $rawb] - if {$b == -3} { - #undershot - leave negative - } elseif {$b == -2 && $rawb ne "-2"} { - set b [expr {$numitems}] ;#overshot - put it outside the range on the upper side - } - - #e.g make sure .. doesn't return last item - should return nothing as both are above the range. - if {$a >= 0 && $a <= $numitems-1 && $b >=0 && $b <= $numitems-1} { - lappend index_list {*}[punk::lib::range $a $b] ;#required for tcl8.6, on tcl9 this will call lseq internally. - } else { - if {$a >= 0 && $a <= $numitems-1} { - #only a is in the range - if {$b < 0} { - set b 0 - } else { - set b [expr {$numitems-1}] - } - lappend index_list {*}[punk::lib::range $a $b] ;#required for tcl8.6, on tcl9 this will call lseq internally. - } elseif {$b >=0 && $b <= $numitems-1} { - #only b is in the range - if {$a < 0} { - set a 0 - } else { - set a [expr {$numitems-1}] - } - lappend index_list {*}[punk::lib::range $a $b] ;#required for tcl8.6, on tcl9 this will call lseq internally. - } else { - #both outside the range - if {$a < 0 && $b > 0} { - #spans the range in forward order - set a 0 - set b [expr {$numitems-1}] - lappend index_list {*}[punk::lib::range $a $b] ;#required for tcl8.6, on tcl9 this will call lseq internally. - } elseif {$a > 0 && $b < 0} { - #spans the range in reverse order - set a [expr {$numitems-1}] - set b 0 - lappend index_list {*}[punk::lib::range $a $b] ;#required for tcl8.6, on tcl9 this will call lseq internally. - } - #both outside of range on same side - } - } - } else { - set idx [punk::lib::lindex_resolve_basic $numitems $ipart] - if {$idx >= 0} { - lappend index_list $idx - } - } - } - return $index_list - } - # showdict uses lindex_resolve results -2 & -3 to determine whether index is out of bounds on upper vs lower side - #REVIEW: This shouldn't really need the list itself - just the length would suffice - punk::args::define { - @id -id ::punk::lib::lindex_resolve - @cmd -name punk::lib::lindex_resolve\ - -summary\ - "Resolve an indexexpression to an integer based on supplied list or string length."\ - -help\ - "Resolve an index which may be of the forms accepted by Tcl list or string commands such as end-2 or 2+2 - to the actual integer index for the supplied list/string length, or to a negative value below -1 indicating - whether the index was below or above the range of possible indices for the length supplied. - - Users may define procs which accept a list/string index and wish to accept the forms understood by Tcl. - This means the proc may be called with something like $x+2 end-$y etc - Sometimes the actual integer index is desired. - - We want to resolve the index used, without passing arbitrary expressions into the 'expr' function - - which could have security risks. - lindex_resolve will parse the index expression and return: - a) -3 if the supplied index expression is below the lower bound for the supplied list. (< 0) - b) -2 if the supplied index expression is above the upper bound for the supplied list. (> end) - lindex_resolve never returns -1 - as the similar function lindex_resolve_basic uses this to denote - out of range at either end of the list/string. - Otherwise it will return an integer corresponding to the position in the data. - This is in stark contrast to Tcl list/string function indices which will return empty strings for out of - bounds indices, or in the case of lrange, return results anyway. - Like Tcl list commands - it will produce an error if the form of the index is not acceptable. - For empty lists/string (datalength 0), end and end+x indices are considered to be out of bounds on the upper side - - thus returning -2 - - Note that for an index such as $x+1 - we never see the '$x' as it is substituted in the calling command. - We will get something like 10+1 - which can be resolved safely with expr - " - @values -min 2 -max 2 - datalength -type integer - index -type indexexpression - } - proc lindex_resolve {len index} { - #*** !doctools - #[call [fun lindex_resolve] [arg len] [arg index]] - #[para]Resolve an index which may be of the forms accepted by Tcl list commands such as end-2 or 2+2 to the actual integer index for the supplied list/string length - #[para]Users may define procs which accept a list/string index and wish to accept the forms understood by Tcl. - #[para]This means the proc may be called with something like $x+2 end-$y etc - #[para]Sometimes the actual integer index is desired. - #[para]We want to resolve the index used, without passing arbitrary expressions into the 'expr' function - which could have security risks. - #[para]lindex_resolve will parse the index expression and return: - #[para] a) -3 if the supplied index expression is below the lower bound for the supplied list. (< 0) - #[para] b) -2 if the supplied index expression is above the upper bound for the supplied list. (> end) - #[para] We don't return -1 - as the similar function lindex_resolve_basic uses this to denote out of range at either end of the list/string - #[para]Otherwise it will return an integer corresponding to the position in the list. - #[para]This is in stark contrast to Tcl list function indices which will return empty strings for out of bounds indices, or in the case of lrange, return results anyway. - #[para]Like Tcl list commands - it will produce an error if the form of the index is not acceptable - #[para]For empty lists, end and end+x indices are considered to be out of bounds on the upper side - thus returning -2 - - #Note that for an index such as $x+1 - we never see the '$x' as it is substituted in the calling command. We will get something like 10+1 - which can be resolved safely with expr - #if {![llength $list]} { - # #review - # return ??? - #} - if {![string is integer -strict $len]} { - #<0 ? - error "lindex_resolve len must be an integer" - } - set index [tcl::string::map {_ {}} $index] ;#basic forward compatibility with integers such as 1_000 for 8.6 - #todo - be stricter about malformations such as 1000_ - if {[string is integer -strict $index]} { - #can match +i -i - if {$index < 0} { - return -3 - } elseif {$index >= $len} { - return -2 - } else { - #integer may still have + sign - normalize with expr - return [expr {$index}] - } - } else { - if {[string match end* $index]} { - if {$index ne "end"} { - set op [string index $index 3] - set offset [string range $index 4 end] - if {$op ni {+ -} || ![string is integer -strict $offset]} {error "bad index '$index': must be integer?\[+-\]integer? or end?\[+-\]integer?"} - if {$op eq "+" && $offset != 0} { - return -2 - } - } else { - #index is 'end' - set index [expr {$len-1}] - if {$index < 0} { - #special case - 'end' with empty list - treat end like a positive number out of bounds - return -2 - } else { - return $index - } - } - if {$offset == 0} { - set index [expr {$len-1}] - if {$index < 0} { - return -2 ;#special case as above - } else { - return $index - } - } else { - #by now, if op = + then offset = 0 so we only need to handle the minus case - set index [expr {($len-1) - $offset}] - } - if {$index < 0} { - return -3 - } else { - return $index - } - } else { - #plain +- already handled above. - #we are trying to avoid evaluating unbraced expr of potentially insecure origin - if {[regexp {(.*)([+-])(.*)} $index _match a op b]} { - if {[string is integer -strict $a] && [string is integer -strict $b]} { - if {$op eq "-"} { - set index [expr {$a - $b}] - } else { - set index [expr {$a + $b}] - } - } else { - error "bad index '$index': must be integer?\[+-\]integer? or end?\[+-\]integer?" - } - } else { - error "bad index '$index': must be integer?\[+-\]integer? or end?\[+-\]integer?" - } - if {$index < 0} { - return -3 - } elseif {$index >= $len} { - return -2 - } - return $index - } - } - } - proc lindex_resolve_basic {len index} { - #*** !doctools - #[call [fun lindex_resolve_basic] [arg len] [arg index]] - #[para] Accepts index of the forms accepted by Tcl's list commands. (e.g compound indices such as 3+1 end-2) - #[para] returns -1 for out of range at either end, or a valid integer index - #[para] Unlike lindex_resolve; lindex_resolve_basic can't determine if an out of range index was out of range at the lower or upper bound - #[para] This is only likely to be faster than average over lindex_resolve for small lists and for Tcl which has the builtin lseq command - #[para] The performance advantage is more likely to be present when using compound indexes such as $x+1 or end-1 - #[para] For pure integer indices the performance should be equivalent - - if {![string is integer -strict $len]} { - error "lindex_resolve_basic len must be an integer" - } - - set index [tcl::string::map {_ {}} $index] ;#forward compatibility with integers such as 1_000 - if {[string is integer -strict $index]} { - #can match +i -i - #avoid even the lseq overhead when the index is simple - if {$index < 0 || ($index >= $len)} { - #even though in this case we could return -2 or -3 like lindex_resolve; for consistency we don't, as it's not always determinable for compound indices using the lseq method. - return -1 - } else { - #integer may still have + sign - normalize with expr - return [expr {$index}] - } - } - if {$len > 0} { - #For large len - this is a wasteful allocation if no true lseq available in Tcl version. - #lseq produces an 'arithseries' object which we can index into without allocating an entire list (REVIEW) - set testlist [punk::lib::range 0 [expr {$len-1}]] ;# uses lseq if available, has fallback. - } else { - set testlist [list] - #we want to call 'lindex' even in this case - to get the appropriate error message - } - set idx [lindex $testlist $index] - if {$idx eq ""} { - #we have no way to determine if out of bounds is at lower vs upper end - return -1 - } else { - return $idx - } - } - proc lindex_get {list index} { - set resultlist [lrange $list $index $index] - if {![llength $resultlist]} { - return -1 - } else { - #we still don't know the actual integer index for an index such as end-x or int-int without parsing and evaluating ourself. - #we can return the value - but only in a way that won't collide with our -1 out-of-range indicator - return [tcl::dict::create value [lindex $resultlist 0]] - } - } - - proc string_splitbefore {str index} { - if {![string is integer -strict $index]} { - set index [punk::lib::lindex_resolve [string length $str] $index] - switch -- $index { - -2 { - return [list $str ""] - } - -3 { - return [list "" $str] - } - } - } - return [list [string range $str 0 $index-1] [string range $str $index end]] - #scan %s stops at whitespace - not useful here. - #scan $s %${p}s%s - } - proc string_splitbefore_indices {str args} { - set parts [list $str] - set sizes [list [string length $str]] - set s 0 - foreach index $args { - if {![string is integer -strict $index]} { - set index [punk::lib::lindex_resolve [string length $str] $index] - switch -- $index { - -2 { - if {[lindex $sizes end] != 0} { - ledit parts end end [lindex $parts end] {} - ledit sizes end end [lindex $sizes end] 0 - } - continue - } - -3 { - if {[lindex $sizes 0] != 0} { - ledit parts 0 0 {} [lindex $parts 0] - ledit sizes 0 0 0 [lindex $sizes 0] - } - continue - } - } - } - if {$index <= 0} { - if {[lindex $sizes 0] != 0} { - ledit parts 0 0 {} [lindex $parts 0] - ledit sizes 0 0 0 [lindex $sizes 0] - } - continue - } - if {$index >= [string length $str]} { - if {[lindex $sizes end] != 0} { - ledit parts end end [lindex $parts end] {} - ledit sizes end end [lindex $sizes end] 0 - } - continue - } - set i -1 - set a 0 - foreach sz $sizes { - incr i - if {$a + $sz > $index} { - set p [lindex $parts $i] - #puts "a:$a index:$index" - if {$a == $index} { - break - } - ledit parts $i $i [string range $p 0 [expr {$index -$a -1}]] [string range $p $index-$a end] - ledit sizes $i $i [expr {$index - $a}] [expr {($a + $sz)-$index}] - break - } - incr a $sz - } - #puts "->parts:$parts" - #puts "->sizes:$sizes" - } - return $parts - } - - proc K {x y} {return $x} - #*** !doctools - #[call [fun K] [arg x] [arg y]] - #[para]The K-combinator function - returns the first argument, x and discards y - #[para]see [uri https://wiki.tcl-lang.org/page/K] - #[para]It is used in cases where command-substitution at the calling-point performs some desired effect. - - - proc is_utf8_multibyteprefix {bytes} { - #*** !doctools - #[call [fun is_utf8_multibyteprefix] [arg str]] - #[para] Returns a boolean if str is potentially a prefix for a multibyte utf-8 character - #[para] ie - tests if it is possible that appending more data will result in a utf-8 codepoint - #[para] Will return false for an already complete utf-8 codepoint - #[para] It is assumed the incomplete sequence is at the beginning of the bytes argument - #[para] Suitable input for this might be from the unreturned tail portion of get_utf8_leading $testbytes - #[para] e.g using: set head [lb]get_utf8_leading $testbytes[rb] ; set tail [lb]string range $testbytes [lb]string length $head[rb] end[rb] - regexp {(?x) - ^ - (?: - [\xC0-\xDF] | #possible prefix for two-byte codepoint - [\xE0-\xEF] [\x80-\xBF]{0,1} | #possible prefix for three-byte codepoint - [\xF0-\xF4] [\x80-\xBF]{0,2} #possible prefix for - ) - $ - } $bytes - } - - proc is_utf8_first {str} { - regexp {(?x) # Expanded regexp syntax, so I can put in comments :-) - ^ - (?: - [\x00-\x7F] | # Single-byte chars (ASCII range) - [\xC0-\xDF] [\x80-\xBF] | # Two-byte chars (\u0080-\u07FF) - [\xE0-\xEF] [\x80-\xBF]{2} | # Three-byte chars (\u0800-\uFFFF) - [\xF0-\xF4] [\x80-\xBF]{3} # Four-byte chars (U+10000-U+10FFFF, not supported by Tcl 8.5) - ) - } $str - } - proc is_utf8_single {1234bytes} { - #*** !doctools - #[call [fun is_utf8_single] [arg 1234bytes]] - #[para] Tests input of 1,2,3 or 4 bytes and responds with a boolean indicating if it is a valid utf-8 character (codepoint) - regexp {(?x) # Expanded regexp syntax, so I can put in comments :-) - ^ - (?: - [\x00-\x7F] | # Single-byte chars (ASCII range) - [\xC0-\xDF] [\x80-\xBF] | # Two-byte chars (\u0080-\u07FF) - [\xE0-\xEF] [\x80-\xBF]{2} | # Three-byte chars (\u0800-\uFFFF) - [\xF0-\xF4] [\x80-\xBF]{3} # Four-byte chars (U+10000-U+10FFFF, not supported by Tcl 8.5) - ) - $ - } $1234bytes - } - proc get_utf8_leading {rawbytes} { - #*** !doctools - #[call [fun get_utf8_leading] [arg rawbytes]] - #[para] return the leading portion of rawbytes that is a valid utf8 sequence. - #[para] This will stop at the point at which the bytes can't be interpreted as a complete utf-8 codepoint - #[para] e.g It will not return the first byte or 2 of a 3-byte utf-8 character if the last byte is missing, and will return only the valid utf-8 string from before the first byte of the incomplete character. - #[para] It will also only return the prefix before any bytes that cannot be part of a utf-8 sequence at all. - #[para] Note that while this will return valid utf8 - it has no knowledge of grapheme clusters or diacritics - #[para] This means if it is being used to process bytes split at some arbitrary point - the trailing data that isn't returned could be part of a grapheme cluster that belongs with the last character of the leading string already returned - #[para] The utf-8 BOM \xEF\xBB\xBF is a valid UTF8 3-byte sequence and so can also be returned as part of the leading utf8 bytes - if {[regexp {(?x) # Expanded regexp syntax, so I can put in comments :-) - \A ( - [\x00-\x7F] | # Single-byte chars (ASCII range) - [\xC0-\xDF] [\x80-\xBF] | # Two-byte chars (\u0080-\u07FF) - [\xE0-\xEF] [\x80-\xBF]{2} | # Three-byte chars (\u0800-\uFFFF) - [\xF0-\xF4] [\x80-\xBF]{3} # Four-byte chars (U+10000-U+10FFFF, not supported by Tcl 8.5) - ) + - } $rawbytes completeChars]} { - return $completeChars - } - return "" - } - proc hex2dec {args} { - #*** !doctools - #[call [fun hex2dec] [opt {option value...}] [arg list_largeHex]] - #[para]Convert a list of (possibly large) unprefixed hex strings to their decimal values - #[para]hex2dec accepts and ignores internal underscores in the same manner as Tcl 8.7+ numbers e.g hex2dec FF_FF returns 65535 - #[para]Leading and trailing underscores are ignored as a matter of implementation convenience - but this shouldn't be relied upon. - #[para]Leading or trailing whitespace in each list member is allowed e.g hex2dec " F" returns 15 - #[para]Internal whitespace e.g "F F" is not permitted - but a completely empty element "" is allowed and will return 0 - - set list_largeHex [lindex $args end] - set argopts [lrange $args 0 end-1] - if {[llength $argopts]%2 !=0} { - error "[namespace current]::hex2dec arguments prior to list_largeHex must be option/value pairs - received '$argopts'" - } - set opts [tcl::dict::create\ - -validate 1\ - -empty_as_hex "INVALID set -empty_as_hex to a hex string e.g FF if empty values should be replaced"\ - ] - set known_opts [tcl::dict::keys $opts] - foreach {k v} $argopts { - tcl::dict::set opts [tcl::prefix match -message "options for hex2dec. Unexpected option" $known_opts $k] $v - } - # -- --- --- --- - set opt_validate [tcl::dict::get $opts -validate] - set opt_empty [tcl::dict::get $opts -empty_as_hex] - # -- --- --- --- - - set list_largeHex [lmap h $list_largeHex[unset list_largeHex] {string map {_ ""} [string trim $h]}] - if {$opt_validate} { - #Note appended F so that we accept list of empty strings as per the documentation - if {![string is xdigit -strict [join $list_largeHex ""]F ]} { - error "[namespace current]::hex2dec error: non-hex digits encountered after stripping underscores and leading/trailing whitespace for each element\n $list_largeHex" - } - } - if {![string is xdigit -strict [string map {_ ""} $opt_empty]]} { - #mapping empty string to a value destroys any advantage of -scanonly - #todo - document that -scanonly has 2 restrictions - each element must be valid hex and less than 7 chars long - #set list_largeHex [lmap v $list_largeHex[set list_largeHex {}] {expr {$v eq ""} ? {0} : {[set v]}}] - if {[lsearch $list_largeHex ""] >=0} { - error "[namespace current]::hex2dec error: empty values in list cannot be mapped to non-hex $opt_empty" - } - } else { - set opt_empty [string trim [string map {_ ""} $opt_empty]] - if {[set first_empty [lsearch $list_largeHex ""]] >= 0} { - #set list_largeHex [lmap v $list_largeHex[set list_largeHex {}] {expr {$v eq ""} ? {$opt_empty} : {$v}}] - set nonempty_head [lrange $list_largeHex 0 $first_empty-1] - set list_largeHex [concat $nonempty_head [lmap v [lrange $list_largeHex $first_empty end] {expr {$v eq ""} ? {$opt_empty} : {$v}}]] - } - } - return [scan $list_largeHex [string repeat %llx [llength $list_largeHex]]] - } - - proc dec2hex {args} { - #*** !doctools - #[call [fun dex2hex] [opt {option value...}] [arg list_decimals]] - #[para]Convert a list of decimal integers to a list of hex values - #[para] -width can be used to make each hex value at least int characters wide, with leading zeroes. - #[para] -case upper|lower determines the case of the hex letters in the output - set list_decimals [lindex $args end] - set argopts [lrange $args 0 end-1] - if {[llength $argopts]%2 !=0} { - error "[namespace current]::dec2hex arguments prior to list_decimals must be option/value pairs - received '$argopts'" - } - set defaults [tcl::dict::create\ - -width 1\ - -case upper\ - -empty_as_decimal "INVALID set -empty_as_decimal to a number if empty values should be replaced"\ - ] - set known_opts [tcl::dict::keys $defaults] - set fullopts [tcl::dict::create] - foreach {k v} $argopts { - tcl::dict::set fullopts [tcl::prefix match -message "options for [tcl::namespace::current]::dec2hex. Unexpected option" $known_opts $k] $v - } - set opts [tcl::dict::merge $defaults $fullopts] - # -- --- --- --- - set opt_width [tcl::dict::get $opts -width] - set opt_case [tcl::dict::get $opts -case] - set opt_empty [tcl::dict::get $opts -empty_as_decimal] - # -- --- --- --- - - - set resultlist [list] - switch -- [string tolower $opt_case] { - upper { - set spec X - } - lower { - set spec x - } - default { - error "[namespace current]::dec2hex unknown value '$opt_case' for -case expected upper|lower" - } - } - set fmt "%${opt_width}.${opt_width}ll${spec}" - - set list_decimals [lmap d $list_decimals[unset list_decimals] {string map {_ ""} [string trim $d]}] - if {![string is digit -strict [string map {_ ""} $opt_empty]]} { - if {[lsearch $list_decimals ""] >=0} { - error "[namespace current]::dec2hex error: empty values in list cannot be mapped to non-decimal $opt_empty" - } - } else { - set opt_empty [string map {_ ""} $opt_empty] - if {[set first_empty [lsearch $list_decimals ""]] >= 0} { - set nonempty_head [lrange $list_decimals 0 $first_empty-1] - set list_decimals [concat $nonempty_head [lmap v [lrange $list_decimals $first_empty end] {expr {$v eq ""} ? {$opt_empty} : {$v}}]] - } - } - return [format [lrepeat [llength $list_decimals] $fmt] {*}$list_decimals] - } - - proc log2 x "expr {log(\$x)/[expr log(2)]}" - #*** !doctools - #[call [fun log2] [arg x]] - #[para]log base2 of x - #[para]This uses a 'live' proc body - the divisor for the change of base is computed once at definition time - #[para](courtesy of RS [uri https://wiki.tcl-lang.org/page/Additional+math+functions]) - - proc logbase {b x} { - #*** !doctools - #[call [fun logbase] [arg b] [arg x]] - #[para]log base b of x - #[para]This function uses expr's natural log and the change of base division. - #[para]This means for example that we can get results like: logbase 10 1000 = 2.9999999999999996 - #[para]Use expr's log10() function or tcl::mathfunc::log10 for base 10 - expr {log($x)/log($b)} - } - proc factors {x} { - #*** !doctools - #[call [fun factors] [arg x]] - #[para]Return a sorted list of the positive factors of x where x > 0 - #[para]For x = 0 we return only 0 and 1 as technically any number divides zero and there are an infinite number of factors. (including zero itself in this context)* - #[para]This is a simple brute-force implementation that iterates all numbers below the square root of x to check the factors - #[para]Because the implementation is so simple - the performance is very reasonable for numbers below at least a few 10's of millions - #[para]See tcllib math::numtheory::factors for a more complex implementation - which seems to be slower for 'small' numbers - #[para]Comparisons were done with some numbers below 17 digits long - #[para]For seriously big numbers - this simple algorithm would no doubt be outperformed by more complex algorithms. - #[para]The numtheory library stores some data about primes etc with each call - so may become faster when being used on more numbers - #but has the disadvantage of being slower for 'small' numbers and using more memory. - #[para]If the largest factor below x is needed - the greatestOddFactorBelow and GreatestFactorBelow functions are a faster way to get there than computing the whole list, even for small values of x - #[para]* Taking x=0; Notion of x being divisible by integer y being: There exists an integer p such that x = py - #[para] In other mathematical contexts zero may be considered not to divide anything. - set factors [list 1] - set j 2 - set max [expr {sqrt($x)}] - while {$j <= $max} { - if {($x % $j) == 0} { - lappend factors $j [expr {$x / $j}] - } - incr j - } - lappend factors $x - return [lsort -unique -integer $factors] - } - proc oddFactors {x} { - #*** !doctools - #[call [fun oddFactors] [arg x]] - #[para]Return a list of odd integer factors of x, sorted in ascending order - set j 2 - set max [expr {sqrt($x)}] - set factors [list 1] - while {$j <= $max} { - if {$x % $j == 0} { - set other [expr {$x / $j}] - if {$other % 2} { - if {$other ni $factors} { - lappend factors $other - } - } - if {$j % 2} { - if {$j ni $factors} { - lappend factors $j - } - } - } - incr j - } - return [lsort -integer -increasing $factors] - } - proc greatestFactorBelow {x} { - #*** !doctools - #[call [fun greatestFactorBelow] [arg x]] - #[para]Return the largest factor of x excluding itself - #[para]factor functions can be useful for console layout calculations - #[para]See Tcllib math::numtheory for more extensive implementations - if {$x % 2 == 0 || $x == 0} { - return [expr {$x / 2}] - } - set j 3 - set max [expr {sqrt($x)}] - while {$j <= $max} { - if {$x % $j == 0} { - return [expr {$x / $j}] - } - incr j 2 - } - return 1 - } - proc greatestOddFactorBelow {x} { - #*** !doctools - #[call [fun greatestOddFactorBelow] [arg x]] - #[para]Return the largest odd integer factor of x excluding x itself - if {$x %2 == 0} { - return [greatestOddFactor $x] - } - set j 3 - #dumb brute force - time taken to compute is wildly variable on big numbers - #todo - use a (memoized?) generator of primes to reduce the search space - #tcllib math::numtheory has suitable functions - but do we want that dependency here? Testing shows brute-force often faster for small numbers. - set god 1 - set max [expr {sqrt($x)}] - while { $j <= $max} { - if {$x % $j == 0} { - set other [expr {$x / $j}] - if {$other % 2 == 0} { - set god $j - } else { - set god [expr {$x / $j}] - #lowest j - so other side must be highest - break - } - } - incr j 2 - } - return $god - } - proc greatestOddFactor {x} { - #*** !doctools - #[call [fun greatestOddFactor] [arg x]] - #[para]Return the largest odd integer factor of x - #[para]For an odd value of x - this will always return x - if {$x % 2 != 0 || $x == 0} { - return $x - } - set r [expr {$x / 2}] - while {$r % 2 == 0} { - set r [expr {$r / 2}] - } - return $r - } - proc gcd {n m} { - #*** !doctools - #[call [fun gcd] [arg n] [arg m]] - #[para]Return the greatest common divisor of m and n - #[para]Straight from Lars Hellström's math::numtheory library in Tcllib - #[para]Graphical use: - #[para]An a by b rectangle can be covered with square tiles of side-length c, - #[para]only if c is a common divisor of a and b - - # - # Apply Euclid's good old algorithm - # - if { $n > $m } { - set t $n - set n $m - set m $t - } - - while { $n > 0 } { - set r [expr {$m % $n}] - set m $n - set n $r - } - - return $m - } - proc lcm {n m} { - #*** !doctools - #[call [fun gcd] [arg n] [arg m]] - #[para]Return the lowest common multiple of m and n - #[para]Straight from Lars Hellström's math::numtheory library in Tcllib - #[para] - set gcd [gcd $n $m] - return [expr {$n*$m/$gcd}] - } - proc commonDivisors {x y} { - #*** !doctools - #[call [fun commonDivisors] [arg x] [arg y]] - #[para]Return a list of all the common factors of x and y - #[para](equivalent to factors of their gcd) - return [factors [gcd $x $y]] - } - - #experimental only - there are better/faster ways - proc sieve n { - set primes [list] - if {$n < 2} {return $primes} - set nums [tcl::dict::create] - for {set i 2} {$i <= $n} {incr i} { - tcl::dict::set nums $i "" - } - set next 2 - set limit [expr {sqrt($n)}] - while {$next <= $limit} { - for {set i $next} {$i <= $n} {incr i $next} {tcl::dict::unset nums $i} - lappend primes $next - tcl::dict::for {next -} $nums break - } - return [concat $primes [tcl::dict::keys $nums]] - } - proc sieve2 n { - set primes [list] - if {$n < 2} {return $primes} - set nums [tcl::dict::create] - for {set i 2} {$i <= $n} {incr i} { - tcl::dict::set nums $i "" - } - set next 2 - set limit [expr {sqrt($n)}] - while {$next <= $limit} { - for {set i $next} {$i <= $n} {incr i $next} {tcl::dict::unset nums $i} - lappend primes $next - #dict for {next -} $nums break - set next [lindex $nums 0] - } - return [concat $primes [tcl::dict::keys $nums]] - } - - proc hasglobs {str} { - #*** !doctools - #[call [fun hasglobs] [arg str]] - #[para]Return a boolean indicating whether str contains any of the glob characters: * ? [lb] [rb] - #[para]hasglobs uses append to preserve Tcls internal representation for str - so it should help avoid shimmering in the few cases where this may matter. - regexp {[*?\[\]]} [append obj2 $str {}] ;# int-rep preserving - } - - proc trimzero {number} { - #*** !doctools - #[call [fun trimzero] [arg number]] - #[para]Return number with left-hand-side zeros trimmed off - unless all zero - #[para]If number is all zero - a single 0 is returned - set trimmed [string trimleft $number 0] - if {[string length $trimmed] == 0} { - set trimmed 0 - } - return $trimmed - } - proc substring_count {str substring} { - #*** !doctools - #[call [fun substring_count] [arg str] [arg substring]] - #[para]Search str and return number of occurrences of substring - - #faster than lsearch on split for str of a few K - if {$substring eq ""} {return 0} - set occurrences [expr {[string length $str]-[string length [string map [list $substring {}] $str]]}] - return [expr {$occurrences / [string length $substring]}] - } - - proc dict_merge_ordered {defaults main} { - #*** !doctools - #[call [fun dict_merge_ordered] [arg defaults] [arg main]] - #[para]The standard dict merge accepts multiple dicts with values from dicts to the right (2nd argument) taking precedence. - #[para]When merging with a dict of default values - this means that any default key/vals that weren't in the main dict appear in the output before the main data. - #[para]This function merges the two dicts whilst maintaining the key order of main followed by defaults. - - #1st merge (inner merge) with wrong values taking precedence - but right key-order - then (outer merge) restore values - return [tcl::dict::merge [tcl::dict::merge $main $defaults] $main] - } - - proc askuser {question} { - #*** !doctools - #[call [fun askuser] [arg question]] - #[para]A basic utility to read an answer from stdin - #[para]The prompt is written to the terminal and then it waits for a user to type something - #[para]stdin is temporarily configured to blocking and then put back in its original state in case it wasn't already so. - #[para]If the terminal is using punk::console and is in raw mode - the terminal will temporarily be put in line mode. - #[para](Generic terminal raw vs linemode detection not yet present) - #[para]The user must hit enter to submit the response - #[para]The return value is the string if any that was typed prior to hitting enter. - #[para]The question argument can be manually colourised using the various punk::ansi funcitons - #[example_begin] - # set answer [lb]punk::lib::askuser "[lb]a+ green bold[rb]Do you want to proceed? (Y|N)[lb]a[rb]"[rb] - # if {[lb]string match y* [lb]string tolower $answer[rb][rb]} { - # puts "Proceeding" - # } else { - # puts "Cancelled by user" - # } - #[example_end] - puts stdout $question - flush stdout - set stdin_state [chan configure stdin] - if {[catch { - package require punk::console - set console_raw [tsv::get console is_raw] - } err_console]} { - #assume normal line mode - set console_raw 0 - } - try { - chan configure stdin -blocking 1 - if {$console_raw} { - punk::console::disableRaw - set answer [gets stdin] - punk::console::enableRaw - } else { - set answer [gets stdin] - } - } finally { - chan configure stdin -blocking [tcl::dict::get $stdin_state -blocking] - } - return $answer - } - - #like textutil::adjust::indent - but doesn't strip trailing lines, and doesn't implement skip parameter. - proc indent {text {prefix " "}} { - set result [list] - foreach line [split $text \n] { - if {[string trim $line] eq ""} { - lappend result "" - } else { - lappend result $prefix[string trimright $line] - } - } - return [join $result \n] - } - #dedent? - proc undent {text} { - if {$text eq ""} { - return "" - } - set lines [split $text \n] - set nonblank [list] - foreach ln $lines { - if {[string trim $ln] eq ""} { - continue - } - lappend nonblank $ln - } - set lcp [longestCommonPrefix $nonblank] - if {$lcp eq ""} { - return $text - } - regexp {^([\t ]*)} $lcp _m lcp - if {$lcp eq ""} { - return $text - } - set len [string length $lcp] - set result [list] - foreach ln $lines { - if {[string trim $ln] eq ""} { - lappend result "" - } else { - lappend result [string range $ln $len end] - } - } - return [join $result \n] - } - #A version of textutil::string::longestCommonPrefixList - proc longestCommonPrefix {items} { - if {[llength $items] <= 1} { - return [lindex $items 0] - } - set items [lsort $items[unset items]] - set min [lindex $items 0] - set max [lindex $items end] - #if first and last of sorted list share a prefix - then all do (first and last of sorted list are the most different in the list) - #(sort order nothing to do with length - e.g min may be longer than max) - if {[string length $min] > [string length $max]} { - set temp $min - set min $max - set max $temp - } - set n [string length $min] - set prefix "" - set i -1 - while {[incr i] < $n && ([set c [string index $min $i]] eq [string index $max $i])} { - append prefix $c - } - return $prefix - } - - #e.g linesort -decreasing $data - proc linesort {args} { - #*** !doctools - #[call [fun linesort] [opt {sortoption ?val?...}] [arg textblock]] - #[para]Sort lines in textblock - #[para]Returns another textblock with lines sorted - #[para]options are flags as accepted by lsort ie -ascii -command -decreasing -dictionary -index -indices -integer -nocase -real -stride -unique - if {[llength $args] < 1} { - error "linesort missing lines argument" - } - set lines [lindex $args end] - set opts [lrange $args 0 end-1] - #.= list $lines |@0,sortopts/1> linelist |> .=data>1,sortopts>1* lsort |> list_as_lines <| {*}$opts - list_as_lines [lsort {*}$opts [linelist $lines]] - } - - proc list_as_lines {args} { - #*** !doctools - #[call [fun list_as_lines] [opt {-joinchar char}] [arg linelist]] - #[para]This simply joins the elements of the list with -joinchar - #[para]It is mainly intended for use in pipelines where the primary argument comes at the end - but it can also be used as a general replacement for join $lines - #[para]The sister function lines_as_list takes a block of text and splits it into lines - but with more options related to trimming the block and/or each line. - if {[set eop [lsearch $args --]] == [llength $args]-2} { - #end-of-opts not really necessary - except for consistency with lines_as_list - set args [concat [lrange $args 0 $eop-1] [lrange $args $eop+1 end]] - } - if {[llength $args] == 3 && [lindex $args 0] eq "-joinchar"} { - set joinchar [lindex $args 1] - set lines [lindex $args 2] - } elseif {[llength $args] == 1} { - set joinchar "\n" - set lines [lindex $args 0] - } else { - error "list_as_lines usage: list_as_lines ?-joinchar ? " - } - return [join $lines $joinchar] - } - proc list_as_lines2 {args} { - #eat or own dogfood version - shows the implementation is simpler - but unfortunately not suitable for a simple function like this which should be as fast as possible? - lassign [tcl::dict::values [punk::args::parse $args withdef { - -joinchar -default \n - @values -min 1 -max 1 - }]] leaders opts values - - return [join [tcl::dict::get $values 0] [tcl::dict::get $opts -joinchar]] - } - - proc lines_as_list {args} { - #*** !doctools - #[call [fun lines_as_list] [opt {option value ...}] [arg text]] - #[para]Returns a list of possibly trimmed lines depeding on options - #[para]The concept of lines is raw lines from splitting on newline after crlf is mapped to lf - #[para]- not console lines which may be entirely different due to control characters such as vertical tabs or ANSI movements - - #The underlying function linelist has the validation code which gives nicer usage errors. - #we can't use a dict merge here without either duplicating the underlying validation somewhat, or risking a default message from dict merge error - #..because we don't know what to say if there are odd numbers of args - #we can guess that it's ok to insert our default if no -block found in $args - but as a general principle this mightn't always work - #e.g if -block is also a valid value for the textblock itself. Which in this case it is - although unlikely, and our -block {} default is irrelevant in that case anyway - - if {[lsearch $args "--"] == [llength $args]-2} { - set opts [lrange $args 0 end-2] - } else { - set opts [lrange $args 0 end-1] - } - #set opts [tcl::dict::merge {-block {}} $opts] - set bposn [lsearch $opts -block] - if {$bposn < 0} { - lappend opts -block {} - } - set text [lindex $args end] - #tailcall linelist {*}$opts $text - return [linelist {*}$opts $text] - } - #this demonstrates the ease of using an args processor - but as lines_as_list is heavily used in terminal output - we can't afford the extra microseconds - proc lines_as_list2 {args} { - #pass -anyopts 1 so we can let the next function decide what arguments are valid - but still pass our defaults - #-anyopts 1 avoids having to know what to say if odd numbers of options passed etc - #we don't have to decide what is an opt vs a value - #even if the caller provides the argument -block without a value the next function's validation will report a reasonable error because there is now nothing in $values (consumed by -block) - lassign [tcl::dict::values [punk::args::parse $args withdef { - @opts -any 1 - -block -default {} - }]] leaderdict opts valuedict - tailcall linelist {*}$opts {*}[tcl::dict::values $valuedict] - } - - # important for pipeline & match_assign - # -line trimline|trimleft|trimright -block trimhead|trimtail|triminner|trimall|trimhead1|trimtail1|collateempty -commandprefix {string length} ? - # -block trimming only trims completely empty lines. use -line trimming to remove whitespace e.g -line trimright will clear empty lines without affecting leading whitespace on other lines that aren't pure whitespace - set linelist_body { - set usage "linelist ?-ansiresets auto|? ?-ansireplays 0|1? ?-line trimline|trimleft|trimright? ?-block trimhead|trimtail|triminner|trimall|trimhead1|trimtail1|collateempty? -commandprefix text" - if {[llength $args] == 0} { - error "linelist missing textchunk argument usage:$usage" - } - set text [lindex $args end] - set text [string map {\r\n \n} $text] ;#review - option? - - set arglist [lrange $args 0 end-1] - set opts [tcl::dict::create\ - -block {trimhead1 trimtail1}\ - -line {}\ - -commandprefix ""\ - -ansiresets auto\ - -ansireplays 0\ - ] - foreach {o v} $arglist { - switch -- $o { - -block - -line - -commandprefix - -ansiresets - -ansireplays { - tcl::dict::set opts $o $v - } - default { - error "linelist: Unrecognized option '$o' usage:$usage" - } - } - } - # -- --- --- --- --- --- - set opt_block [tcl::dict::get $opts -block] - if {[llength $opt_block]} { - foreach bo $opt_block { - switch -- $bo { - trimhead - trimtail - triminner - trimall - trimhead1 - trimtail1 - collateempty {} - default { - set known_blockopts [list trimhead trimtail triminner trimall trimhead1 trimtail1 collateempty] - error "linelist: unknown -block option value: $bo known values: $known_blockopts" - } - } - } - #normalize certain combos - if {"trimhead" in $opt_block && [set posn [lsearch $opt_block trimhead1]] >=0} { - set opt_block [lreplace $opt_block $posn $posn] - } - if {"trimtail" in $opt_block && [set posn [lsearch $opt_block trimtail1]] >=0} { - set opt_block [lreplace $opt_block $posn $posn] - } - if {"trimall" in $opt_block} { - #no other block options make sense in combination with this - set opt_block [list "trimall"] - } - - #TODO - if {"triminner" in $opt_block } { - error "linelist -block triminner not implemented - sorry" - } - - } - - - # -- --- --- --- --- --- - set opt_line [tcl::dict::get $opts -line] - set tl_left 0 - set tl_right 0 - set tl_both 0 - foreach lo $opt_line { - switch -- $lo { - trimline { - set tl_both 1 - } - trimleft { - set tl_left 1 - } - trimright { - set tl_right 1 - } - default { - set known_lineopts [list trimline trimleft trimright] - error "linelist: unknown -line option value: $lo known values: $known_lineopts" - } - } - } - #normalize trimleft trimright combo - if {$tl_left && $tl_right} { - set opt_line [list "trimline"] - set tl_both 1 - } - # -- --- --- --- --- --- - set opt_commandprefix [tcl::dict::get $opts -commandprefix] - # -- --- --- --- --- --- - set opt_ansiresets [tcl::dict::get $opts -ansiresets] - # -- --- --- --- --- --- - set opt_ansireplays [tcl::dict::get $opts -ansireplays] - if {$opt_ansireplays} { - if {$opt_ansiresets eq "auto"} { - set opt_ansiresets 1 - } - } else { - if {$opt_ansiresets eq "auto"} { - set opt_ansiresets 0 - } - } - # -- --- --- --- --- --- - set linelist [list] - set nlsplit [split $text \n] - if {![llength $opt_line]} { - set linelist $nlsplit - #lappend linelist {*}$nlsplit - } else { - #already normalized trimleft+trimright to trimline - if {$tl_both} { - foreach ln $nlsplit { - lappend linelist [string trim $ln] - } - } elseif {$tl_left} { - foreach ln $nlsplit { - lappend linelist [string trimleft $ln] - } - } elseif {$tl_right} { - foreach ln $nlsplit { - lappend linelist [string trimright $ln] - } - } - } - - if {"collateempty" in $opt_block} { - set inputlist $linelist[set linelist [list]] - set last "-" - foreach input $inputlist { - if {$input ne ""} { - lappend linelist $input - set last "-" - } else { - if {$last ne ""} { - lappend linelist "" - } - set last "" - } - } - } - - if {"trimall" in $opt_block} { - set linelist [lsearch -all -inline -not -exact $linelist[set linelist {}] ""] - } else { - set start 0 - if {"trimhead" in $opt_block} { - set idx 0 - set lastempty -1 - foreach ln $linelist { - if {[lindex $linelist $idx] ne ""} { - break - } else { - set lastempty $idx - } - incr idx - } - if {$lastempty >=0} { - set start [expr {$lastempty +1}] - } - } - set linelist [lrange $linelist $start end] - - if {"trimtail" in $opt_block} { - set revlinelist [lreverse $linelist][set linelist {}] - set i 0 - foreach ln $revlinelist { - if {$ln ne ""} { - set linelist [lreverse [lrange $revlinelist $i end]] - break - } - incr i - } - } - - # --- --- - set start 0 - set end "end" - if {"trimhead1" in $opt_block} { - if {[lindex $linelist 0] eq ""} { - set start 1 - } - } - if {"trimtail1" in $opt_block} { - if {[lindex $linelist end] eq ""} { - set end "end-1" - } - } - set linelist [lrange $linelist $start $end] - } - - #review - we need to make sure ansiresets don't accumulate/grow on any line - #Each resulting line should have a reset of some type at start and a pure-reset at end to stop - #see if we can find an ST sequence that most terminals will not display for marking sections? - if {$opt_ansireplays} { - ;#package require punk::ansi - if {$opt_ansiresets} { - set RST "\x1b\[0m" - } else { - set RST "" - } - set replaycodes $RST ;#todo - default? - set transformed [list] - #shortcircuit common case of no ansi - #NOTE: running ta::detect on a list (or dict) as a whole can be problematic if items in the list have backslash escapes due to Tcl list quoting and escaping behaviour. - #This commonly happens if there is an unbalanced brace (which is a normal occurrence and needs to be handled) - #ta::detect on a list of ansi-containing string may appear to work for some simple inputs but is not reliable - #detect_in_list/detectcode_in_list will check at first level. (not intended for detecting ansi in deeper structures) - - #we use detectcode_in_list instead of detect_in_list - #detectcode_in_list will detect unclosed (or unopened) paired sequences such as PM (privacy message) - # - but the main reason is it is slightly faster. - if {![punk::ansi::ta::detectcode_in_list $linelist]} { - if {$opt_ansiresets} { - foreach ln $linelist { - lappend transformed $RST$ln$RST - } - set linelist $transformed - } - } else { - - #INLINE punk::ansi::codetype::is_sgr_reset - #regexp {\x1b\[0*m$} $code - set re_is_sgr_reset {\x1b\[0*m$} - #INLINE punk::ansi::codetype::is_sgr - #regexp {\033\[[0-9;:]*m$} $code - set re_is_sgr {\x1b\[[0-9;:]*m$} - - foreach ln $linelist { - #set is_replay_pure_reset [regexp {\x1b\[0*m$} $replaycodes] ;#only looks at tail code - but if tail is pure reset - any prefix is ignorable - - #set ansisplits [punk::ansi::ta::split_codes_single $ln] ;#REVIEW - this split accounts for a large portion of the time taken to run this function. - #get_codes_single lists only the codes. no plaintext or empty elements - set ansisplits [punk::ansi::ta::get_codes_single $ln] ;#REVIEW - this split accounts for a large portion of the time taken to run this function. - if {[llength $ansisplits] == 0} { - #plaintext only - no ansi codes in line - lappend transformed [string cat $replaycodes $ln $RST] - #leave replaycodes as is for next line - set nextreplay $replaycodes - } else { - set tail $RST - set lastcode [lindex $ansisplits end] ;#may or may not be SGR - set lastcodeoffset [expr {[string length $lastcode]-1}] - if {[punk::ansi::codetype::is_sgr_reset $lastcode]} { - if {[string range $ln end-$lastcodeoffset end] eq $lastcode} { - #last plaintext is empty. So the line is already suffixed with a reset - set tail "" - set nextreplay $RST - } else { - #trailing text has been reset within line - but no tail reset present - #we normalize by putting a tail reset on anyway - set tail $RST - set nextreplay $RST - } - } elseif {[string range $ln end-$lastcodeoffset end] eq $lastcode && [punk::ansi::codetype::has_sgr_leadingreset $lastcode]} { - #code is at tail (no trailing plaintext) - #No tail reset - and no need to examine whole line to determine stack that is in effect - set tail $RST - set nextreplay $lastcode - } else { - #last codeset doesn't reset from earlier codes or isn't SGR - so we have to look at whole line to determine codes in effect - #last codeset doesn't end in a pure-reset - #whether code was at very end or not - add a reset tail - set tail $RST - #determine effective replay for line - set codestack [list start] - foreach code $ansisplits { - if {[punk::ansi::codetype::is_sgr_reset $code]} { - set codestack [list] ;#different from 'start' marked - this means we've had a reset - } elseif {[punk::ansi::codetype::has_sgr_leadingreset $code]} { - set codestack [list $code] - } else { - if {[punk::ansi::codetype::is_sgr $code]} { - #todo - proper test of each code - so we only take latest background/foreground etc. - #requires handling codes with varying numbers of parameters. - #basic simplification - remove straight dupes. - set dup_posns [lsearch -all -exact $codestack $code] ;#!must use -exact as codes have square brackets which are interpreted as glob chars. - set codestack [lremove $codestack {*}$dup_posns] - lappend codestack $code - } ;#else gx0 or other code - we don't want to stack it with SGR codes - } - } - if {$codestack eq [list start]} { - #No SGRs - may have been other codes - set line_has_sgr 0 - } else { - #list is either empty or begins with start - empty means it had SGR reset - so it still invalidates current state of replaycodes - set line_has_sgr 1 - if {[lindex $codestack 0] eq "start"} { - set codestack [lrange $codestack 1 end] - } - } - - #set newreplay [join $codestack ""] - set newreplay [punk::ansi::codetype::sgr_merge_list {*}$codestack] - - if {$line_has_sgr && $newreplay ne $replaycodes} { - #adjust if it doesn't already does a reset at start - if {[punk::ansi::codetype::has_sgr_leadingreset $newreplay]} { - set nextreplay $newreplay - } else { - set nextreplay $RST$newreplay - } - } else { - set nextreplay $replaycodes - } - } - if {[punk::ansi::codetype::has_sgr_leadingreset $ln]} { - #no point attaching any replay - lappend transformed [string cat $ln $tail] - } else { - lappend transformed [string cat $replaycodes $ln $tail] - } - } - set replaycodes $nextreplay - } - set linelist $transformed - } - } - - if {[llength $opt_commandprefix]} { - set transformed [list] - foreach ln $linelist { - lappend transformed [{*}$opt_commandprefix $ln] - } - set linelist $transformed - } - - return $linelist - } - if {$has_punk_ansi} { - #optimise linelist as much as possible - set linelist_body [string map { ""} $linelist_body] - } else { - #punk ansi not avail at time of package load. - #by putting in calls to punk::ansi the user will get appropriate error messages - set linelist_body [string map { "package require punk::ansi"} $linelist_body] - } - - set linelist_body_original { - set usage "linelist ?-ansiresets auto|? ?-ansireplays 0|1? ?-line trimline|trimleft|trimright? ?-block trimhead|trimtail|triminner|trimall|trimhead1|trimtail1|collateempty? -commandprefix text" - if {[llength $args] == 0} { - error "linelist missing textchunk argument usage:$usage" - } - set text [lindex $args end] - set text [string map {\r\n \n} $text] ;#review - option? - - set arglist [lrange $args 0 end-1] - set opts [tcl::dict::create\ - -block {trimhead1 trimtail1}\ - -line {}\ - -commandprefix ""\ - -ansiresets auto\ - -ansireplays 0\ - ] - foreach {o v} $arglist { - switch -- $o { - -block - -line - -commandprefix - -ansiresets - -ansireplays { - tcl::dict::set opts $o $v - } - default { - error "linelist: Unrecognized option '$o' usage:$usage" - } - } - } - # -- --- --- --- --- --- - set opt_block [tcl::dict::get $opts -block] - if {[llength $opt_block]} { - foreach bo $opt_block { - switch -- $bo { - trimhead - trimtail - triminner - trimall - trimhead1 - trimtail1 - collateempty {} - default { - set known_blockopts [list trimhead trimtail triminner trimall trimhead1 trimtail1 collateempty] - error "linelist: unknown -block option value: $bo known values: $known_blockopts" - } - } - } - #normalize certain combos - if {"trimhead" in $opt_block && [set posn [lsearch $opt_block trimhead1]] >=0} { - set opt_block [lreplace $opt_block $posn $posn] - } - if {"trimtail" in $opt_block && [set posn [lsearch $opt_block trimtail1]] >=0} { - set opt_block [lreplace $opt_block $posn $posn] - } - if {"trimall" in $opt_block} { - #no other block options make sense in combination with this - set opt_block [list "trimall"] - } - - #TODO - if {"triminner" in $opt_block } { - error "linelist -block triminner not implemented - sorry" - } - - } - - - # -- --- --- --- --- --- - set opt_line [tcl::dict::get $opts -line] - set tl_left 0 - set tl_right 0 - set tl_both 0 - foreach lo $opt_line { - switch -- $lo { - trimline { - set tl_both 1 - } - trimleft { - set tl_left 1 - } - trimright { - set tl_right 1 - } - default { - set known_lineopts [list trimline trimleft trimright] - error "linelist: unknown -line option value: $lo known values: $known_lineopts" - } - } - } - #normalize trimleft trimright combo - if {$tl_left && $tl_right} { - set opt_line [list "trimline"] - set tl_both 1 - } - # -- --- --- --- --- --- - set opt_commandprefix [tcl::dict::get $opts -commandprefix] - # -- --- --- --- --- --- - set opt_ansiresets [tcl::dict::get $opts -ansiresets] - # -- --- --- --- --- --- - set opt_ansireplays [tcl::dict::get $opts -ansireplays] - if {$opt_ansireplays} { - if {$opt_ansiresets eq "auto"} { - set opt_ansiresets 1 - } - } else { - if {$opt_ansiresets eq "auto"} { - set opt_ansiresets 0 - } - } - # -- --- --- --- --- --- - set linelist [list] - set nlsplit [split $text \n] - if {![llength $opt_line]} { - set linelist $nlsplit - #lappend linelist {*}$nlsplit - } else { - #already normalized trimleft+trimright to trimline - if {$tl_both} { - foreach ln $nlsplit { - lappend linelist [string trim $ln] - } - } elseif {$tl_left} { - foreach ln $nlsplit { - lappend linelist [string trimleft $ln] - } - } elseif {$tl_right} { - foreach ln $nlsplit { - lappend linelist [string trimright $ln] - } - } - } - - if {"collateempty" in $opt_block} { - set inputlist $linelist[set linelist [list]] - set last "-" - foreach input $inputlist { - if {$input ne ""} { - lappend linelist $input - set last "-" - } else { - if {$last ne ""} { - lappend linelist "" - } - set last "" - } - } - } - - if {"trimall" in $opt_block} { - set linelist [lsearch -all -inline -not -exact $linelist[set linelist {}] ""] - } else { - set start 0 - if {"trimhead" in $opt_block} { - set idx 0 - set lastempty -1 - foreach ln $linelist { - if {[lindex $linelist $idx] ne ""} { - break - } else { - set lastempty $idx - } - incr idx - } - if {$lastempty >=0} { - set start [expr {$lastempty +1}] - } - } - set linelist [lrange $linelist $start end] - - if {"trimtail" in $opt_block} { - set revlinelist [lreverse $linelist][set linelist {}] - set i 0 - foreach ln $revlinelist { - if {$ln ne ""} { - set linelist [lreverse [lrange $revlinelist $i end]] - break - } - incr i - } - } - - # --- --- - set start 0 - set end "end" - if {"trimhead1" in $opt_block} { - if {[lindex $linelist 0] eq ""} { - set start 1 - } - } - if {"trimtail1" in $opt_block} { - if {[lindex $linelist end] eq ""} { - set end "end-1" - } - } - set linelist [lrange $linelist $start $end] - } - - #review - we need to make sure ansiresets don't accumulate/grow on any line - #Each resulting line should have a reset of some type at start and a pure-reset at end to stop - #see if we can find an ST sequence that most terminals will not display for marking sections? - if {$opt_ansireplays} { - #package require punk::ansi - - if {$opt_ansiresets} { - set RST "\x1b\[0m" - } else { - set RST "" - } - set replaycodes $RST ;#todo - default? - set transformed [list] - #shortcircuit common case of no ansi - #NOTE: running ta::detect on a list (or dict) as a whole can be problematic if items in the list have backslash escapes due to Tcl list quoting and escaping behaviour. - #This commonly happens if there is an unbalanced brace (which is a normal occurrence and needs to be handled) - #ta::detect on a list of ansi-containing string may appear to work for some simple inputs but is not reliable - #detect_in_list will check at first level. (not intended for detecting ansi in deeper structures) - if {![punk::ansi::ta::detect_in_list $linelist]} { - if {$opt_ansiresets} { - foreach ln $linelist { - lappend transformed $RST$ln$RST - } - set linelist $transformed - } - } else { - - #INLINE punk::ansi::codetype::is_sgr_reset - #regexp {\x1b\[0*m$} $code - set re_is_sgr_reset {\x1b\[0*m$} - #INLINE punk::ansi::codetype::is_sgr - #regexp {\033\[[0-9;:]*m$} $code - set re_is_sgr {\x1b\[[0-9;:]*m$} - - foreach ln $linelist { - #set is_replay_pure_reset [regexp {\x1b\[0*m$} $replaycodes] ;#only looks at tail code - but if tail is pure reset - any prefix is ignorable - - set ansisplits [punk::ansi::ta::split_codes_single $ln] ;#REVIEW - this split accounts for a large portion of the time taken to run this function. - if {[llength $ansisplits]<= 1} { - #plaintext only - no ansi codes in line - lappend transformed [string cat $replaycodes $ln $RST] - #leave replaycodes as is for next line - set nextreplay $replaycodes - } else { - set tail $RST - set lastcode [lindex $ansisplits end-1] ;#may or may not be SGR - if {[punk::ansi::codetype::is_sgr_reset $lastcode]} { - if {[lindex $ansisplits end] eq ""} { - #last plaintext is empty. So the line is already suffixed with a reset - set tail "" - set nextreplay $RST - } else { - #trailing text has been reset within line - but no tail reset present - #we normalize by putting a tail reset on anyway - set tail $RST - set nextreplay $RST - } - } elseif {[lindex $ansisplits end] ne "" && [punk::ansi::codetype::has_sgr_leadingreset $lastcode]} { - #No tail reset - and no need to examine whole line to determine stack that is in effect - set tail $RST - set nextreplay $lastcode - } else { - #last codeset doesn't reset from earlier codes or isn't SGR - so we have to look at whole line to determine codes in effect - #last codeset doesn't end in a pure-reset - #whether code was at very end or not - add a reset tail - set tail $RST - #determine effective replay for line - set codestack [list start] - foreach {pt code} $ansisplits { - if {[punk::ansi::codetype::is_sgr_reset $code]} { - set codestack [list] ;#different from 'start' marked - this means we've had a reset - } elseif {[punk::ansi::codetype::has_sgr_leadingreset $code]} { - set codestack [list $code] - } else { - if {[punk::ansi::codetype::is_sgr $code]} { - #todo - proper test of each code - so we only take latest background/foreground etc. - #requires handling codes with varying numbers of parameters. - #basic simplification - remove straight dupes. - set dup_posns [lsearch -all -exact $codestack $code] ;#!must use -exact as codes have square brackets which are interpreted as glob chars. - set codestack [lremove $codestack {*}$dup_posns] - lappend codestack $code - } ;#else gx0 or other code - we don't want to stack it with SGR codes - } - } - if {$codestack eq [list start]} { - #No SGRs - may have been other codes - set line_has_sgr 0 - } else { - #list is either empty or begins with start - empty means it had SGR reset - so it still invalidates current state of replaycodes - set line_has_sgr 1 - if {[lindex $codestack 0] eq "start"} { - set codestack [lrange $codestack 1 end] - } - } - - #set newreplay [join $codestack ""] - set newreplay [punk::ansi::codetype::sgr_merge_list {*}$codestack] - - if {$line_has_sgr && $newreplay ne $replaycodes} { - #adjust if it doesn't already does a reset at start - if {[punk::ansi::codetype::has_sgr_leadingreset $newreplay]} { - set nextreplay $newreplay - } else { - set nextreplay $RST$newreplay - } - } else { - set nextreplay $replaycodes - } - } - if {[punk::ansi::codetype::has_sgr_leadingreset $ln]} { - #no point attaching any replay - lappend transformed [string cat $ln $tail] - } else { - lappend transformed [string cat $replaycodes $ln $tail] - } - } - set replaycodes $nextreplay - } - set linelist $transformed - } - } - - if {[llength $opt_commandprefix]} { - set transformed [list] - foreach ln $linelist { - lappend transformed [{*}$opt_commandprefix $ln] - } - set linelist $transformed - } - - return $linelist - } - if {$has_punk_ansi} { - #optimise linelist as much as possible - set linelist_body [string map { ""} $linelist_body] - } else { - #punk ansi not avail at time of package load. - #by putting in calls to punk::ansi the user will get appropriate error messages - set linelist_body [string map { "package require punk::ansi"} $linelist_body] - } - proc linelist {args} $linelist_body - - - interp alias {} errortime {} punk::lib::errortime - proc errortime {script groupsize {iters 2}} { - #by use MAK from https://wiki.tcl-lang.org/page/How+to+Measure+Performance - set i 0 - set times {} - if {$iters < 2} {set iters 2} - - for {set i 0} {$i < $iters} {incr i} { - set result [uplevel [list time $script $groupsize]] - lappend times [lindex $result 0] - } - - set average 0.0 - set s2 0.0 - - foreach time $times { - set average [expr {$average + double($time)/$iters}] - } - - foreach time $times { - set s2 [expr {$s2 + (($time-$average)*($time-$average) / ($iters-1))}] - } - - set sigma [expr {int(sqrt($s2))}] - set average [expr {int($average)}] - - return "$average +/- $sigma microseconds per iteration" - } - - #test function to use with show_jump_tables - #todo - check if switch compilation to jump tables differs by Tcl version - proc switch_char_test {c} { - set dec [scan $c %c] - foreach t [list 1 2 3] { - switch -- $c { - x { - return [list $dec x $t] - } - y { - return [list $dec y $t] - } - z { - return [list $dec z $t] - } - } - } - - #tcl 8.6/8.7 (at least) - #curlies must be unescaped and unbraced to work as literals in switch and enable it to compile to jumpTable - switch -- $c { - a { - return [list $dec a] - } - {"} { - return [list $dec dquote] - } - {[} {return [list $dec lb]} - {]} {return [list $dec rb]} - "{" { - return [list $dec lbrace] - } - "}" { - return [list $dec rbrace] - } - default { - return [list $dec $c] - } - } - - - - } - - #we are interested in seeing jumpTable line and following lines up until next line starting with "Command" or bracketed number e.g (164) - proc show_jump_tables {args} { - #avoiding use of 'info cmdtype' as unavaliable in safe interps as at 2024-06. - if {[llength $args] == 1} { - set data [tcl::unsupported::disassemble proc [lindex $args 0]] - } elseif {[llength $args] == 2} { - #review - this looks for direct methods on the supplied object/class, and then tries to disassemble method on the supplied class or class of supplied object if it isn't a class itself. - #not sure if this handles more complex hierarchies or mixins etc. - lassign $args obj method - if {![info object isa object $obj]} { - error "show_jump_tables unable to examine '$args'. $obj is not an oo object" - } - #classes are objects too and can have direct methods - if {$method in [info object methods $obj]} { - set data [tcl::unsupported::disassemble objmethod $obj $method] - } else { - if {![info object isa class $obj]} { - set obj [info object class $obj] - } - set data [tcl::unsupported::disassemble method $obj $method] - } - } else { - error "show_jump_tables expected a procname or a class/object and method" - } - set result "" - set in_jt 0 - foreach ln [split $data \n] { - set tln [string trim $ln] - if {!$in_jt} { - if {[string match *jumpTable* $ln]} { - append result $ln \n - set in_jt 1 - } - } else { - if {[string match Command* $tln] || [string match "(*) *" $tln]} { - set in_jt 0 - } else { - append result $ln \n - } - } - } - return $result - } - - proc temperature_f_to_c {deg_fahrenheit} { - return [expr {($deg_fahrenheit -32) * (5/9.0)}] - } - proc temperature_c_to_f {deg_celsius} { - return [expr {($deg_celsius * (9/5.0)) + 32}] - } - - proc interp_sync_package_paths {interp} { - if {![interp exists $interp]} { - error "interp_sync_package_paths error. interp '$interp' not found. Create it first with \[interp create $interp\]" - } - interp eval $interp [list set ::auto_path $::auto_path] - interp eval $interp {tcl::tm::remove {*}[tcl::tm::list]} - interp eval $interp [list tcl::tm::add {*}[lreverse [tcl::tm::list]]] - } - - proc objclone {obj} { - append obj2 $obj {} - } - proc set_clone {varname obj} { - #used by repl's codeinterp. Maintains internal rep, easier to call e.g interp eval code [list punk::set_clone varnmame $val] - append obj2 $obj {} - uplevel 1 [list set $varname $obj2] - } - - - - proc format_number {numbers_or_commaformattednumbers {delim ""} {groupsize ""}} { - variable has_twapi - if {$has_twapi} { - if {$delim eq "" && $groupsize eq ""} { - set localeid [twapi::get_system_default_lcid] - } - } - #when using twapi we currently only get the localeid - not the specific defaults - #when not using twapi, or on non-windows platforms - we don't currently have a mechanism to look up user preferences for this - set default_delim "," - set default_groupsize 3 - - set results [list] - set nums [objclone $numbers_or_commaformattednumbers] ;#stops single num from getting internal rep of list - foreach inputnum $nums { - set number [objclone $inputnum] - #also handle tcl 8.7+ underscores in numbers - set number [string map [list _ "" , ""] $number] - #normalize e.g 2e4 -> 20000.0 - set number [expr {$number}] - - if {$has_twapi} { - if {$delim eq "" && $groupsize eq ""} { - lappend results [twapi::format_number $number $localeid -idigits -1] - continue - } else { - #setting just one of delim or groupsize means we don't get the user's localeid based default for the non-set one - #todo - document it? Find a way to lookup localeid based defaults whenever either is unspecified? - if {$delim eq ""} {set delim $default_delim} - if {$groupsize eq ""} {set groupsize $default_groupsize} - lappend results [twapi::format_number $number 0 -idigits -1 -sthousand $delim -sgrouping $groupsize] - continue - } - } - #todo - get configured user defaults - if {$delim eq ""} { - set delim $default_delim - } - if {$groupsize eq ""} { - set groupsize $default_groupsize - } - - lappend results [delimit_number $number $delim $groupsize] - } - - if {[llength $results] == 1} { - #keep intrep as string rather than list - return [lindex $results 0] - } - return $results - } - - - #from wiki https://wiki.tcl-lang.org/page/Delimiting+Numberse - # Given a number represented as a string, insert delimiters to break it up for - # readability. Normally, the delimiter will be a comma which will be inserted every - # three digits. However, the delimiter and groupsize are optional arguments, - # permitting use in other locales. - # - # The string is assumed to consist of digits, possibly preceded by spaces, - # and possibly containing a decimal point, i.e.: [:space:]*[:digit:]*\.[:digit:]* - - proc delimit_number {unformattednumber {delim ","} {GroupSize 3}} { - set number [objclone $unformattednumber] - set number [string map {_ ""} $number] - #normalize using expr - e.g 2e4 -> 20000.0 - set number [expr {$number}] - # First, extract right hand part of number, up to and including decimal point - set point [string last "." $number]; - if {$point >= 0} { - set PostDecimal [string range $number $point+1 end]; - set PostDecimalP 1; - } else { - set point [expr {[string length $number] + 1}] - set PostDecimal ""; - set PostDecimalP 0; - } - - # Now extract any leading spaces. review - regex for whitespace instead of just ascii space? - set ind 0; - while {[string equal [string index $number $ind] \u0020]} { - incr ind; - } - set FirstNonSpace $ind; - set LastSpace [expr {$FirstNonSpace - 1}]; - set LeadingSpaces [string range $number 0 $LastSpace]; - - # Now extract the non-fractional part of the number, omitting leading spaces. - set MainNumber [string range $number $FirstNonSpace $point-1]; - - # Insert commas into the non-fractional part. - set Length [string length $MainNumber]; - set Phase [expr {$Length % $GroupSize}] - set PhaseMinusOne [expr {$Phase -1}]; - set DelimitedMain ""; - - #First we deal with the extra stuff. - if {$Phase > 0} { - append DelimitedMain [string range $MainNumber 0 $PhaseMinusOne]; - } - set FirstInGroup $Phase; - set LastInGroup [expr {$FirstInGroup + $GroupSize -1}]; - while {$LastInGroup < $Length} { - if {$FirstInGroup > 0} { - append DelimitedMain $delim; - } - append DelimitedMain [string range $MainNumber $FirstInGroup $LastInGroup]; - incr FirstInGroup $GroupSize - incr LastInGroup $GroupSize - } - - # Reassemble the number. - if {$PostDecimalP} { - return [format "%s%s.%s" $LeadingSpaces $DelimitedMain $PostDecimal]; - } else { - return [format "%s%s" $LeadingSpaces $DelimitedMain]; - } - } - - - - #*** !doctools - #[list_end] [comment {--- end definitions namespace punk::lib ---}] -} -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - -tcl::namespace::eval punk::lib::flatgrid { - namespace export filler_count rows cols col row block - - #WARNING - requires lseq and 'lsearch -stride' - #WARNING - lsearch -stride oddity with empty strings https://core.tcl-lang.org/tcl/tktview/edebb6a4 - #todo - 8.6 fallback? - - proc filler_count {listlen numcolumns} { - #if {$numcolumns <= 0} {error "filler_count requires 1 or more numcolumns"} ;#or allow divide by zero error - #if {$listlen == 0} {return $numcolumns} ;#an option - but returning zero might make more sense - expr {($numcolumns - ($listlen % $numcolumns)) % $numcolumns} - } - proc rows {list numcolumns {blank NULL}} { - set numblanks [filler_count [llength $list] $numcolumns] - set padded_list [list {*}$list {*}[lrepeat $numblanks $blank]] - set splits [lseq 0 to [llength $padded_list] by $numcolumns] - set rows [list] - set i 1 - foreach s [lrange $splits 0 end-1] { - lappend rows [lrange $padded_list $s [lindex $splits $i]-1] - incr i - } - return $rows - } - proc cols {list numcolumns {blank NULL}} { - set cols [list] - foreach colindex [lseq 0 $numcolumns-1] { - lappend cols [lsearch -stride $numcolumns -index [list $colindex 0] -subindices -all -inline [list {*}$list {*}[lrepeat [filler_count [llength $list] $numcolumns] $blank]] *] - } - return $cols - } - proc cols2 {list numcolumns {blank NULL}} { - set cols [list] - foreach colindex [lseq 0 $numcolumns-1] { - lappend cols [col2 $list $numcolumns $colindex $blank] - } - return $cols - } - proc col {list numcolumns colindex {blank NULL}} { - lsearch -stride $numcolumns -index [list $colindex 0] -subindices -all -inline [list {*}$list {*}[lrepeat [filler_count [llength $list] $numcolumns] $blank]] * - } - proc col2 {list numcolumns colindex {blank NULL}} { - set numblanks [filler_count [llength $list] $numcolumns] - set padded_list [list {*}$list {*}[lrepeat $numblanks $blank]] - set splits [lseq 0 to [llength $padded_list] by $numcolumns] - set col [list] - foreach s [lrange $splits 0 end-1] { - lappend col [lindex $padded_list $s+$colindex] - } - return $col - } - proc col3 {list numcolumns colindex {blank NULL}} { - set padded_list [list {*}$list {*}[lrepeat [filler_count [llength $list] $numcolumns] $blank]] - lmap s [lrange [lseq 0 to [llength $padded_list] by $numcolumns] 0 end-1] {lindex $padded_list $s+$colindex} - } - proc col4 {list numcolumns colindex {blank NULL}} { - #slow - set vars [lrepeat $numcolumns _] - lset vars $colindex v - if {$blank eq ""} { - return [lmap $vars $list {set v}] - } - set padded_list [list {*}$list {*}[lrepeat [filler_count [llength $list] $numcolumns] $blank]] - lmap $vars [list {*}$list {*}[lrepeat [filler_count [llength $list] $numcolumns] $blank]] {set v} - } - - proc block {list numcolumns {blank NULL}} { - set colblocks [list] - foreach c [cols $list $numcolumns $blank] { - lappend colblocks [join $c \n] " " - } - textblock::join -- {*}$colblocks - } - proc block2 {list numcolumns {blank NULL}} { - set colblocks [list] - foreach c [cols2 $list $numcolumns $blank] { - lappend colblocks [join $c \n] " " - } - textblock::join -- {*}$colblocks - } -} - -tcl::namespace::eval punk::lib::test { - - - -} - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -#todo - way to generate 'internal' docs separately? -#*** !doctools -#[section Internal] -tcl::namespace::eval punk::lib::system { - #*** !doctools - #[subsection {Namespace punk::lib::system}] - #[para] Internal functions that are not part of the API - #[list_begin definitions] - - - proc mostFactorsBelow {n} { - ##*** !doctools - #[call [fun mostFactorsBelow] [arg n]] - #[para]Find the number below $n which has the greatest number of factors - #[para]This will get slow quickly as n increases (100K = 1s+ 2024) - set most 0 - set mostcount 0 - for {set i 1} {$i < $n} {incr i} { - set fc [llength [punk::lib::factors $i]] - if {$fc > $mostcount} { - set most $i - set mostcount $fc - } - } - return [list number $most numfactors $mostcount] - } - proc factorCountBelow_punk {n} { - ##*** !doctools - #[call [fun factorCountBelow] [arg n]] - #[para]For numbers 1 to n - keep a tally of the total count of factors - #[para]This is not useful other than a quick and dirty check that different algorithms return *probably* the same result - #[para]and as a rudimentary performance comparison - #[para]gets slow quickly! - set tally 0 - for {set i 1} {$i <= $n} {incr i} { - incr tally [llength [punk::lib::factors $i]] - } - return $tally - } - proc factorCountBelow_numtheory {n} { - ##*** !doctools - #[call [fun factorCountBelow] [arg n]] - #[para]For numbers 1 to n - keep a tally of the total count of factors - #[para]This is not useful other than a quick and dirty check that different algorithms return *probably* the same result - #[para]and as a rudimentary performance comparison - #[para]gets slow quickly! (significantly slower than factorCountBelow_punk) - package require math::numtheory - set tally 0 - for {set i 1} {$i <= $n} {incr i} { - incr tally [llength [math::numtheory::factors $i]] - } - return $tally - } - - proc factors2 {x} { - ##*** !doctools - #[call [fun factors2] [arg x]] - #[para]Return a sorted list of factors of x - #[para]A similar brute-force mechanism to factors - but keeps result ordering as we go. - set smallfactors [list 1] - set j 2 - set max [expr {sqrt($x)}] - while {$j < $max} { - if {($x % $j) == 0} { - lappend smallfactors $j - lappend largefactors [expr {$x / $j}] - } - incr j - } - #handle sqrt outside loop so we don't have to sort/dedup or check list membership in main loop - if {($x % $j) == 0} { - if {$j == ($x / $j)} { - lappend smallfactors $j - } - } - return [concat $smallfactors [lreverse $largefactors] $x] - } - - - - # incomplete - report which is the innermost bracket/quote etc awaiting completion for a Tcl command - #important - used by punk::repl - proc incomplete {partial} { - #we can apparently get away without concatenating current innerpartial to previous in list - REVIEW. - if {[info complete $partial]} { - return [list] - } - set clist [split $partial ""] - #puts stderr "-->$clist<--" - set waiting [list ""] - set innerpartials [list ""] - set escaped 0 - set i 0 - foreach c $clist { - if {$c eq "\\"} { - set escaped [expr {!$escaped}] - incr i - continue - } ;# set escaped 0 at end - set p [lindex $innerpartials end] - if {$escaped == 0} { - #NOTE - curly braces as switch arm keys must be unescaped and balanced. (escapes stop byte-compilation to jumpTable for switch statements for tcl8.6/8.7 at least) - switch -- $c { - {"} { - if {![info complete ${p}]} { - lappend waiting {"} - lappend innerpartials "" - } else { - if {[lindex $waiting end] eq {"}} { - #this quote is endquote - set waiting [lrange $waiting 0 end-1] - set innerpartials [lrange $innerpartials 0 end-1] - } else { - if {![info complete ${p}$c]} { - lappend waiting {"} - lappend innerpartials "" - } else { - set p ${p}${c} - lset innerpartials end $p - } - } - } - } - {[} { - if {![info complete ${p}$c]} { - lappend waiting "\]" - lappend innerpartials "" - } else { - set p ${p}${c} - lset innerpartials end $p - } - } - "{" { - if {![info complete ${p}$c]} { - lappend waiting "\}" - lappend innerpartials "" - } else { - set p ${p}${c} - lset innerpartials end $p - } - } - "}" - - default { - set waitingfor [lindex $waiting end] - if {$c eq "$waitingfor"} { - set waiting [lrange $waiting 0 end-1] - set innerpartials [lrange $innerpartials 0 end-1] - } else { - set p ${p}${c} - lset innerpartials end $p - } - } - } - } else { - set p ${p}${c} - lset innerpartials end $p - } - set escaped 0 - incr i - } - set incomplete [list] - foreach w $waiting { - #to be treated as literals - curly braces must be unescaped here - and balanced - hence the left-curly empty arm. - switch -- $w { - {"} { - lappend incomplete $w - } - {]} { - lappend incomplete "\[" - } - "{" {} - "}" { - lappend incomplete "\{" - } - } - } - set debug 0 - if {$debug} { - foreach w $waiting p $innerpartials { - puts stderr "->awaiting:'$w' partial: $p" - } - } - return $incomplete - } - #This only works for very simple cases will get confused with for example: - # {set x "a["""} - proc incomplete_naive {partial} { - if {[info complete $partial]} { - return [list] - } - set clist [split $partial ""] - set waiting [list] - set escaped 0 - foreach c $clist { - if {$c eq "\\"} { - set escaped [expr {!$escaped}] - continue - } - if {!$escaped} { - if {$c eq {"}} { - if {[lindex $waiting end] eq {"}} { - set waiting [lrange $waiting 0 end-1] - } else { - lappend waiting {"} - } - } elseif {$c eq "\["} { - lappend waiting "\]" - } elseif {$c eq "\{"} { - lappend waiting "\}" - } else { - set waitingfor [lindex $waiting end] - if {$c eq "$waitingfor"} { - set waiting [lrange $waiting 0 end-1] - } - } - } - } - set incomplete [list] - foreach w $waiting { - if {$w eq {"}} { - lappend incomplete $w - } elseif {$w eq "\]"} { - lappend incomplete "\[" - } elseif {$w eq "\}"} { - lappend incomplete "\{" - } - } - return $incomplete - } - - #get info about punk nestindex key ie type: list,dict,undetermined - # pdict devel - proc nestindex_info {args} { - set argd [punk::args::parse $args withdef { - -parent -default "" - nestindex - }] - set opt_parent [dict get $argd opts -parent] - if {$opt_parent eq ""} { - set parent_type undetermined - } else { - set parent_type [nestindex_info -parent "" $opt_parent] ;#make sure we explicitly set parent of parent to empty so we don't just recurse forever doing nothing - } - - #??? - - } - #*** !doctools - #[list_end] [comment {--- end definitions namespace punk::lib::system ---}] -} - -tcl::namespace::eval punk::lib::debug { - proc showdict {args} {} -} - -namespace eval ::punk::args::register { - #use fully qualified so 8.6 doesn't find existing var in global namespace - lappend ::punk::args::register::NAMESPACES ::punk::lib -} -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready -package provide punk::lib [tcl::namespace::eval punk::lib { - variable pkg punk::lib - variable version - set version 0.1.2 -}] -return - -#*** !doctools -#[manpage_end] - diff --git a/src/bootsupport/modules/punk/mix/templates-0.1.3.tm b/src/bootsupport/modules/punk/mix/templates-0.1.3.tm new file mode 100644 index 0000000000000000000000000000000000000000..e679d01307bca6d437e4c564d9e02e4bee17a1a0 GIT binary patch literal 70519 zcmce;1z1#F*Eddzl1eut-Ju}e(%sz*-7|Dbhk&9;BMkx)0@5G?5&{y^(%oH3d}mPa zc=W#C=X<~Z^`Gk+2F}@g?bYkI7iSMD=r1oSFKZ`|g|!_RS}EVwRQjjb1fjuAV(LFn+1fA4@L^=2(ou{ zb%280tzblfOHKd<)W56;~WMXD(VhLt(1G_-19UVXxj&?BitRWzP1Bi(|_~#W92#6JGe=W>^ENBUK z0K1sLh`K_o9W40(7Gb3M`0T7r`S|QjY{5nV4@Tdwf><0aEFfSg)YAzJGI24p0@wrz z0QX^95&{W8?XQ3Nn@H9cAa6Z06R4RL$opEE4vsGNCU(|dV33}*gM}jqV&-D)1U2wA z@CAAQZ6-`HU>6rag_J**zt#rS)%5#iR*;5+i7B8-K(XdvKyUWe4qzDnuD~@X6Q~s{ zh~CK&0-E$aKXzf7E*05f=d14LoG|BgeL zeAGYggTT%pN=lHA59qGmwX9$dYX}qq`g#AiBK|*%NeTKJ&oFv_mjZSLuo_G?=GHEt z@2mm8Ilw&R58i$u0-FN%0RKAWJAwbSBaE7(1u((P6$&$pfq}tqNdjCLnK+mm0Z#ja z6&FWG=ru3j2}4b+?fzuzS0Z*MfK4qOKza}-J8S6m$Ug|O82oU6Ya&15;gwVE^7j2z+rLf|`(IBJ z0_pu_@qc0xwj#`6uvA1X`isP{+prgGh$x6!>|Y0nfv5p8za8>>QGYJ%{rlS%jxJym zApSi7&OqLi(`LkKf7& z8~S@eet-3cAN*Elzwr&KUvd@9_aQ(o2eOnS$Q=waGjRaC7*;6&W?dYeT&#fvZRhz5 zvoKBCnVCSqM&A>!5d>^$4|V_&jvg$*IamUj(azERk2w1?UVxbXhv@uH4~S79iNbOy zG3_kW5)SoZk~|8_1W4wgW@`>Pz^ zld-{Hg8M(#00C}l0OF@|g#gtI@B*+4P>NvIHV47T|5kjM3QU1uv;FPeU)}fDD}PfU z_21<9$Jm0I%)-^q?gtzJ>Df2}_(RXk(E+IYpuZEjPS=2M!6+Mm`1oKF!sddm3xJ~q zP`Ix#4G4fNfaK;dB=hr<%Xh5xTiLGN1{O0$z>+`k5!-i#UvuNl==*m@4A_8Cz<97Z z3t$Qunu1lrpM~U?HGDx}JHQbC?6ZGW0F2TP8Gj)JGtqCE{l8-e^%ug|mb=b}W{&pu zK!t^XuA>wN&j18^Evx|uKuDC7|Kz?@CN7q)unYp=Rv3^pvx508;BSr~Qy?t?a0!TZ z*zIdT{1e#n@hMy9ksmX^XU%J3zb9hu=s*XB`4x!nFZhfOK;&Qt5EOugu%!7XM-Tu( zLL32*^pkfG;9PcK69^P!34^}&FeCzenuG03JRu+efxBBfm^->dKu&fhP#^~akQ;!n z4vr2i*EPxn5P{+MoT*#EP&+UYsJyQB0DkfWN)$lkyY|`G00Y2y`;K6NiUV8+BE$r+ zC)C~1#r7KS{)z+t=4{t`0cwLe0DVEWV1Qx0UmfJ1(<&t!+jm!D1Kj(2pizPxtYHBS z{PmsqKRMR58<+z{&Ke2^i7Lzd@T|W$=pRA;L)9R6SONg{2QE-oU_S)g4LLXhrgJjC z)(OjxQu*DWwhoT&z<%U!z6*0vM^`8a>f(8=IOy-S1LN#Ea(--4erp}rAlQrQ7k&MK zQ$c@d=ilNONOrJY9M~Qv4+N;qu(hE-Om6~mcX0%4Z0QPyKtS{+E>LR=V7~_flA;N$ zp27kX*s=hY|BLSeJ_B(DgM@$YR^QnM7Yq`|5XG34TXPJG>}AHTonGX zj{LzbU^5V~l?C9B^}lihGu+*uo6BEW`@;RyOeyua^he~R0)AjjU0h)hYJwb)3NL=L@XvR?+w`v<{;L^brTdqX4b#IP^&9AR{Eu$- zHx+y*2>NN=YjeP|{r__DABG1kcWt!qH3cYrdVl%T;NO+^w`Ak$@SUUI@bj+`@}qz9 zXQRXdC{WjK@)PO6`a%H4f+_D>>9B$Y{0{4(Q2zzf{4=k=H>L0Ivj7#4i@vM+Z*U6) zaWw_@B*0eO5eR(~J9k()g_S}W*Z{Z#T5Eswn}9tMuFbqhje>TVf z^aJzW?^6LQ0z%pUR!^=@c3_~@2I2s4IDl<{s^aPbz>NQ;)qgFX{|XzaEKKa|OaZ(L zi!fL<03z@wsQN9pRElD(AT0oIT*DYM0O$kd6sDVNSYQvdYG4-tMM6Lyf$K>;uL9&a${VB!Yk;_H6l_g3wHH2!{Ork|fb`ULg> z8$c9O%2)tU>wAm$JITLxc1>IW_xyuA%MZ0*#}Ldc@yVOt+Npe?}q&%p=d_CGjP2k2Zkj)Cqn2tZ2!tbmywSnWr^09!8@ zhybXY{Ok|IVE3PG<-aDSO?CnV1p@L%n;8ITKUw{E2EQjEYCx60^=g<5{~9N- z0kGHgKGPhe_cKO*ZXteh0s7Tp|8YSWz5l}F|G%j;u*LplTH{A9r?vnx@qdQczcLJ? z^Z!Fehb{B_tp3k;en0*n((5l$|95KsMK^z6)Ytb%hvh#z(?9;hVDKM_5BC3^KVk&% zX&?dr+4LkpXXRkM z&-NdG1I0C0Ytm)%!EN7BExXq}JOokQORsG56;qDyVkNCr`hD~exLq4(90VsGkf#xQ z)o2MH7e~rhr53|ReRFeZa~v(7)0;Q@3CWpo(jZ-~y>XFU-{HVlWp2;@KGx2%Itx^i zJc@<*sV`s5xpM@pmAdgid*m$?e&$v$WD=s)dRBT+D_~A3%wtn1hMcFdCHu9uPWS4b z-h&C;QGM^#&i4w5@+Pe>`;kp*D+~$r#oxTORXv=XX^#4=MDeLJ?6t`~KFg>yrs5LY zP&*2z;$roFIeX}sYEdh#uI~*T9(TVD!~~*BA17q@tfFKs{ZaikgEV!e+BcQvrrD!j z)^Wu4kfHFZnrBmzY)Y$}s8^IXvtHS3;%P88tJ>xzGp)Ef9cevmV6m-k zZB*}2((cR*(P6#|7@e3u8!Ze>lQqS`W5pNoD-UptzeBp}dQ9t02OqEY=EjCx99qlj zs5jgKvd0PTg-O&c@=vqMElk6SaEV`B(Zk{Hrjti4+x2^*w=u>Cyc8IiWEe0y&mG`O zunX!yu-p*DU0^cl+ke@0F}x@YRif35-`pctsn@h1P5LAmL_1nIBAcaKm&MUASaVUl z)&2C7twG4a0bSiL;czt$yq9t`F5#4W4O)!BVLwF^0}pqaaG9ndk%k63`F3MwE9fXn zcHdO{c}Ll6FHS3lTc^B%s;j#C*_QkneQU(BA_#YUFFl5Ypz=46`CEAKT&lO)GeR4p zu+K*t)l3)BOG~+`(>Ti-g$^zHH@h75%~av#3DchFdRZn1)Hl3p@9)dkraljiUL){A z7l`Om5?5VkdSDO@@+vrf*W5TZl_sn(huD2g_BFJSm6PQeI9Nob=q>im=NUJwA0NFR zH&d~fA7%2f!ABjSH;`V!jpvSgSEIjQ+{$669uD6p9t3hUd$ce1#jnGfV2~n?XdpCR z#g`;nxEvP?RY zMwIlLH?G=N?Y+K|+_eEev&T6MJi|1e+gPUrT`?G>yNddaT1379f!fMzo=ox7ElgI< z3}o_;$$W-dDs&_`%g~V}v2*?PD78tF;F;fu*3p8*9kzXhsO7O*q88l)$*pPh*rrt3 zg9!bVG2-^L8|-{~4!iG;7}(hem5oRph9EwQ!r_oTK8u7j24;reb#si}5HfFHyXtxE zNqNvr?KlBBG>Ry`7<^5#XK%c$?T?L}JIfk9(S|_kSv5LlcHqd(7pqcgR#S|4-_8Vt z&mnR$-`Gr8uxe@d87tU4{< zeumj#!c*HgwUoZQZfdVAXfz#d!Yg5Y!kHTV@`0K4<)-qYmJ4%sivY<0zbD~U-}c;- zWfTO~_Y^p_480boNv^&StIl|GPy4iZFNjFBN&0$NXJ-8C)CifF9X;GN&%yzS^$Yr^ zU3dKX9+7#Ey8HAMnDYA+9ah<#M=kO z*bm^P0=)mnV!#Hp2Z3Ickqg)Y!Upv6ZGerA2(WK4cXVNLa&@p}`f=^Lhya5S;r?9E zJBm}gh$KGnIj~S0@D_$c`L7rJV=*>}iy0g2(FAi=pp$TQg$M@+kDw9#5%oR$ZHbe! zNLxL6dYL0Eqy*L}w*di35@NL;MCSQsl0p)0ND{=N<|t2X#NFAP>+}Vcb+v`ju_k!q zF?~Tuf_vcOn}?kbo;=cJSCNhBo|EyS7waU?lTQ1BfEkaI6LsIE@-npLNxGAvKPZ?m zfcJdhqjaB%t6(;rb@=uqyr0DIX3;&vFawB>)+Sv~@i@w#a*L+==_+{+&hr7~Hm4pA zP6+PC|59$)Lk!==28;&386;EGG`uNOkvOq5*gQNuaD5~w;wr4qj0w?4=c;f` z>e^>Y7v2QCq$=;rVtg7BuBNgm_tolIupC1-Q*EA6YgXqAXYFq3hbBak8t7Y}BEjU2 zvg;@;?X*2$-AIiW5AP9-qdrmy%1kvhjoOn)jkz_Z9nGz&03V@>JEt4@aJm!e29DWk zVRQNo(Ytcac=%c}sj?h|k#{ez1}-rJ6_6_k*Y2E-J_-;{VQgeAF^{`RNvcHHWOI1R zg`xVcc?>kLsE`;wj$W^tUk`V8D%g|MkeWD@a*&QXN4mm?jCOA(=c`~O1c^?leT`9# zZ26!TE$prn|GGw~Go|E%Q_0xgqb14&|JU>SB_^4udkhg#E|<}hrep*XsfO!pX*+Su zkB!lGwODsKN=jtLOv;FrE&q9aY1Y@|<-q2-QC6bUWUsIw4=J83^6*49 zS28)s4@rDsYoS0%h_D8)%@{CU&9NC##=JzFr)yE>y@>ijDXA4t^}fjJ;T-By*|<%7 zXQnrdVUoi)64P3@6Z%Za}r7ts7F&Yao2mU?zK3M5vtz!?f*dE$MSTU{>0 z*$6CP5LE$(P~+=#3(o?s^8@}{Jye5_OtXm_PH6Ibl96Z;L+0c?lTdw-e;8R~dhcq( zJ7p6Mizo$c!-xV(>3fY42h0+h#)^8P#c%0b8<5tclu{RS}(0R$w z^yPh}@qNcX%jj5R?-F1P5J zOIzh$wIlW(JJv8BQhdeJ=GxsmfJmS&ehzq0{h0gR{*#aXHR(}~p*JR2I_H_m5K(Ta z&67G=h%WY@R>sIs4#`m~nYlHDew`H0i}YCM9kE2YLa)Gmh!Oj^SSD4I0c~C_lN~R| zH<7$wGxQySsCnz1w<$d=HD1_McA@oeC3+3Axh_QwN%G^NO=DF7ei}-KR8EM=hNWQHTCOyw{yeQbi#8GxX?#IP!Y$^_EK zWfR54rM7yH;2x#=j20y9gvQdU&SoS(;X*B39bn6;F5Z@9Mth{RtQ@BDnU4p)8e_e8 zz07HGQ};1ng=+v`FXux;hLBQKdQqqM=?kLqt9VS$gKNJ~*QsRc-aYH;gu^?t9UOz> zdZKp@G0gS&{Gw*KTmzTD$?9#52uTv%Bm;)(l_kB%`cOF*PH+<#bqFB``;w@>l59vc zhNXUmk~xEjId4RO^hS4(56BrEAJb0hNpb>Z97+E@QRa>U2agv|^0-r8FMR5&PBy-D zoN5wjkUu>9u)|-^R=T)fSI_NBR&c=)+zziGXDf!F!#5eq6(*HN8##~dE~tE4Yixj7 ztx7zcqvD}X!1gwtRH!)ovmTms8XgY?PxJds7U~6WW0}W#)z-*AH=PR75YU(qPlb`NAJVq;rDQUwtxtR}E*;pcgB^UNoV8d0Aux@vCb3 z)#5I47+0x?;@s1&kOu^rL&Ysg&zyp!9&+vt7)bB#c8{&=7-_ZZV7Py|vo(vw9+um0 zPvCT;GqC~f;N$xdah+ZV;@*-ph3Mf^Ez{j{xcQzN^P}pVO)Z~@DQ?*Z4BfUHpo~vd zI$QXVZ~1BOS+jZ#!A5MOxcr!`D81TyTP)%UZ9kz}ziIfghXKx_VSEvf@Pfu&QkI^s z@!z$8yXS_tvLR+y(Y^Yxt+aIAgtd?-g0JH#Y z+NcLsTgD%v-4_MVq9bYEKv~{wK1Crts;^)b;UH=6#pY8I<1DvW)x;My z1Xh($EqbG-d-zd&*V@aB?}4Z@vMT&QmSRomZIX|URy(v~#sqO%6Nr62i#7{nq#bjX zTu;=Ty%?v{{XIgi($mw4GZa3D%(1UVBVlA9p@Z9&Yjj(v>uKBy6vDxpG@G~Up2%{f z9-*_}emNGrX_}0veZ!9Xq?Jbl((msbY8w3k6j>OJ4S%O-f?bH8PT8n%kcM2(n`Dz> zd~(;fs_h_pVotNcB($WwhQRu{vXx5clA!ITDHJ&?3m=}Iu(P0-&2e>sp6VpmgSck- zV}Zkt2PgEKWr?FG+WZIF%JcLR#e-XQp=X0cC{AfnJ56{>DeKYvB^SNOkG-Z;-96q< zwALEO=D1ATJQTNF)a7S)8%(YY?s`QS(swpMSqJZj`;~@|!Rao8(*qOz>OB*jlKho) zFM?;ar|Wuq@`ta9-05sH$Mpo#s-0W~2Mm?=I-V0-XZ1Yf_7EULq_E*EdiwPpcXxhX z`h9{b$1?_-hs6sciMGv9?gtrSwUbX{Z+Pvdy$*k3vcbH>g}P;F-=TX!V`_@-_2iLh zhOx~oB6N_vkV?-|>lUh|{idTb1!-WqY6eZZ0nUB2Xpt^axF|Y_w=Y(An$-O)mqtQf zto9>6qo&;;Peb*55l-M}v@Z%LDdVFeu2%C-=hcgMmWvTC&Oss~WVLY4QhaG4o!TcX zCGRozbdfmlISOv8BGh&|>c0-jt`5?Ec=5j^ZbI?oD{tq!*{2amFKuv4 zABaOdGWT4}q^sB#(~T3#2252Y>fowlp5Cco6i~^{IeJ7YmJ}69xsE|kv2XXRBNwX0 zZ60=l%*V&eek(C1ZJRd>>3WFh3hS@sT8kAnc*2y8EfVHFpx9G-7Yv)>E#Id8;U)sgb<* zulvre7Z+^yOHKP#1ydeBBkV^y#dwqI>yJWapf@LJC*-l{yg3x?Z-L2jqpEI_&pI-q zwgbJ(46zK0O!dOz*0O*rDbGtpEIU#Qn@aYE0UVo>ZzcR+ODgaw%HC%A>vlekeTj28 zasRHBbMv^9RI==ez5sou_&vE?OpNLQk{nBu12xjTvZnE~WBG-|x%65cFZYC`vag6N zbJ;O@0uuRaUqvSyGxHD0tzB-6u8b|b-#mFtYk%~3oG|yMa(KG@6GA&T>^F-XF(O%Z ziM1w`T(R?xdlqzf3yxo(E7N8wXGGo?z{LxrN?bnQy5eSvS7V_Tta?Dc3QsSgtjPKZCg ztM2toPz56PrjHm$&^gGH<#??)%0;)j$?kNiaYm1XMsaTQ{bD?qM9Y(Ld0*Y-cWOwC zDjv{$r{rUn_0Mog-csaMp~(994V!4w{C&5*KWwC?1yW=cS=@D0p8K{)L^A&3>sJS{ z7v?J6(OJC?ew@yNbAf$n2Lr478YU81R`mtFZ9Nu@ZAAi~T*g>$`a1RGplprQkI+pZ zyCei*MAIUuxsM9iyQfhVStY%Vm~FP@P^IWw_O4@zTo0sD{xJ0Bj(bHC&t!y>E8m<^ z5&I*Y$JTMEhYck6HgVh1OrdUKkrh>kP$^b&vX9$0F@{FvE8vk1Gl@gCX(siJY#?<^ zyzkRdS0uC_&gn}@#B^DstjjzyJl5-;&7i1Cey+KJMqPl(fYzfz({#)1*-ISo<B1rCBfTe@yNo>7>fMzS%? zGYBfNE=Ilqf^S!(m(6{jMl^VbY%bUVHJa;uM8V~O1#};+^$B|Bwh+OLA5;2~ecS_4 zDPMYTO^3>DyG9%-hnr(|4J4a(+#5L)AIERyG%)Ll*dZ5osUEjb8%$Cmv+MZuOHKNs zB1Sl18B5|zc%;7H_PRK}2qSQuHa6p`@)kqOmL~IeC@#1Foj>JiK6W7JYa787G!Ix^ zg=^0w(8_IKE`5K9jq~v|%t~m7qNgkBAR2BqUQ(S|`YQcXyFb~q<;>}~7-IXbBQ9_= zU)QOZHHWD38K%ZG2UxFSG}6UOC(Ud!)4f;_Ns>iDvhj8(*$a0^Itv?rzoX-&GyYuL z-X24oXFEOWD2>L)g$pciSSxxp<>|$gW2>)vNHa{x6*bUxe6Qw@Qnc7kqF1=ZVkoxG zJ1(D+yFbDbOLcpPFOO zxABfM&U@akM7|#K6ix(@ZoS^uuh{!qC~#0trYS@`{ptSFBWSRHcY@>aT+X_axG#|~ z?);Gx+w(?kZ(rr;yRk-ZZec*Wz>zoS%H_ZqR z{L`sp2B<}~V%xWk#QRNN=e#&g#`^jL_T(Zwi&${Hb@e$%$Ze%O>}l=VLBt4HZ#SsC z6IvgshTCqw$k=+#sOW--P$Y4?R$tRN;!9`6l3UW)t#;%jO4+V_X2XVA^T-O$?qYN8 zrrZ*?itodZx=Q$no!3JD-#Pt1e zNR)>R{it(o{8mIm3U;@aacA&WDCVR)1amSrWPAx$a~`|584J{qn@i@P_9vr36Cd26$A zw2Sa@ZYi>OW4W@l-x_!7-x$A(^5}KMYSh*MN97TVwp zpwt5|dGX4RRfZ+s6pYxii(k=J1?Xs35Dg1|!Xn`2uTOuNkTRYAh*2Y>anLe+dYtdl zXQa-JslXi70JWrabiD|*b9~+fJ$f~3#KN{DmC+-)LZKb&UVBl$_8Qt*ifP%6Q_WG) zf{$%$qNd8ual@Pi3Z@V39))$*j(mEM=(;y2FRHyt()O{CzTzmUDXn#iSOYhe6>ZtL zFWg;_15wG*u|MOHc0NjP7zV*!g#4qFcXT&5iUt)xLbcrH_#wGOwCgYA5B#d?ymQ}T zYky)ts~JkQQTaee<-;lYSTDaw4IRWFZal4Tnq7{U>_6S;wYQ(IHRQVJIJodMmj$dE z9E-6JMT#O9d2&BLK$ES5dx5O$^eCddERm>BNw>R`22Cc&%dG<~#4l!=w2%Db{Ora2 zLwTo)SrxtA7^0-!gV_1m>3(O5C}Bp)zNq$f32m>F;dgqS?a`r=E0+a?r?;&S!~F9Z z6{Niu5j|eTh*QbVs;)IR$aXB2bli~vJ#N*AaKA;Robgr-8`1w1tKoHxt_nEdmGQTn zdD|9d%+Sv==a*|kn&?e*sIm7|bBH`j$**L%4o^Z^R;D2XV1|4$s44YJ2I>uOmSdT! zTGU~-Zx-Rm39H6;urLr<4e?Rc=ekA|qnI-%GoIF#7RJvMD#Pnce--WZsXQyFc`R76 zY-o=;4}H(nvJZ(sR>LW7TfuKy`uJXd0V!&sF#4fS&}WXv-r*b?4<2E4fX z;gu3k*vuYIc&U^Bpg2wESw!<~23m8BJ6p=lpcn8dx*8NVPQlnO>YSc?q|zlp3q?lO zh`h@4msV8E?npj4vuHk(^utV`@p&8;hPIc*#l;1h^&irB!2!1&RY{owpZAJ2SQW0D%rfu)x1l@W$LzlKGNlaX+J} z?eYiRO}?i1?c+=sL?&AabAne$;%00v&ih#JWGHJ<;nmEV8D1lKj1e=F6gIDoz=3og zE!`L$?7X?CXl0P4Cbv4jdgtC7bTq-wcrkZqJu|~qre)RSipKIj8cWZZi)rJLdp$O= z=h$cQ+}EIfs`+y4c&@HYZ0zv>OU{-<>$d2Mn`Mb?|Ei5fi)!?W7!nJ~n8dOWExQPY z{!sbQZq*mpbCQ*5@wUk^ z@*K>kGLPC^WV$A(JMy!J)s8IEqxCb=&F@!#5yvPAN$#Vw6{#HTl4Klp-jVMT-uc*9 z+2qt!)Gf~U?b)G7R-kz3i=(2H-jg6s=vGL9Uhmehef&kcZ_L4?*Af*jTWo1*_wMyV zd*q}V0v7_uTJEkPWP9C>{b;r8CO{pLiH76*4ea>AGvn00&4K9*C>`dCuv@Hur@=}PejN^% zlpYhbp;C5ud2~XRO)*XFUv~mw9%m}^ExseE~2#%->L|~C>2sydXX42q>1PM zV9998{pr|EkuV9bS7OnmxGT&(6;2hmY;qlN7WnxLRi926%L^?gNkY1xBNoe$mnKOw zGBzfFnutaWDW1`b&gjLY#Hn$GJqWDITEstJJHNlnON&=rr%2_;-tlHj5feWB=~Kf{ z)*x>u(g!Vq3)QWX6#dGy6ow7o=7z&g$kE537nkR~AGLNS_AI?$5ofNl&8lc0#`sgj z29lX>ACe2Crv%t*2Vw6OKKg*Bc^IDc^tG3%b9sMmXR^C~>Uv3|W&+qbDdiz*Fgrfz-iNtYN#&T z%6y}^XBkBg`-0Rn5#PsOOJ8}o(v8K)hkqBxtG6r)%^@k{0|EvAOVi$y51%8wY^ab3 zHwSj4zPWm>sIcXBRpWY;x(Q4?tF7m^1Ak+3_Tt=*5of>Yb*DmOE6vxqQb^EdV<7wO zWwACV1LN1b;-!p1aiPOR^2ZgNylEHhGH>un(IIu|cW%tadVbZ7qZuTcH`alF>cY7E`)J=#T! zVs>uPfP7^76r6mc>8N<&Q5Ad8-NyZDOm2~$R~lroGZoU+bT!z?oHo41j2?PJw7FHd zL&gOo(ofpzUg-HPh>Dk6gn6~AE0?c757_V5akz@K9??5eG_g8fjqvIa7pEDT7hC^g z=MoTH_1fAV|KeS-*Qkc_AjiEJ24l%NtTMP&_f_$laT1JvE2W3R@DZbvi`AnBQV(4*!BA2j;Bm3!h!IJbj?Dd2H6S(#M0M$KBdPmmA7%Q()E z6vtBP@folMTmkB5Pu|>v*DCB%8$CLnDJaad3&^Y$uYLPoA^T%P-x9pO; zeS>|u*DJ?*Aru z&dd8X5OnJ0=@sO9a@p7Ma3se*{tRfYYGB$!4SOnF{m}V$cuK3X80ee3M28>q(}N{1 z62m-`KT2uL-~@ktNSRHZbm31x>ZJ3&wqv6W0lx1M)cKZ~OtRms7#@Ymoq;DUFH#50 zc>;{-%e@#k?qrXoCENKt{A?TdMUbFpoy*KIGE#A5&TGDJ#_#GY%AR0>#Qbo*`^rw9 zS6;NpylP;=7nv%~G_ z2&t-1#EX=x)r^t6kG!|odiD{*;fz#A)AmU^P;aH35jkV-xId*Q|LC1KZhjJRG%K$H ziYs(pSz)l?M&4ItEqkI?%0!fVo3BzxD`J<5K)Sbbfc*KntEzc6WmA}?Iy$jNi&~g zRN8$h-$JJq*;*lXUuF?c1TL+*@XKZa;%!3JVTJRqY<&ucK7kK2##ZIGs<*?+J<>-w zDD%NnVoS&qM)T=NdstCNVgAkGGBlJ^p&B_~NzR`mTI&kae@>&S#84WYJARIy#+*lO zqaoE<9zyM(^BR1P8Q{twC^ z3#O1~hRnXN`aVOmkL?>nM$57ATgQi+Z0k5k>-$o@Pj|WXdVQOoTp7-J=Ik_$5c&>z zm(3W`O;^e^l_i*$8co$d@uTDKz#k8(El5jxz#_`uvwu@T2%VVDt>I>~70;Iq1mO=- zN}dXZRW+SiTcjA68V&0oJ^2rx0zP8*?VY?XtW-cIPy z5Du&rG=|V+xj864N2g&yUNR&jq}xKSdu7DZ+ddeP#bE6A(ebU;xn$L=Qz?l%Jn%2g zK1rHy2sp+Ct{XC}wrG}%e92pH)FP|ooYpxCuVWU6%HBnAm2w%$IByS4jCuAEi2^^% ze;0Ui#g(XpJH+F?qC)&#_1u2yypHG)I4`xY807x4-Cw>)9=zlIGE?L(KfXCif7YiPjw2a5($Zd2VU+kovy)?$xs|Wt}{R z@2AbZWL*?IHS||Z5DA%KA#>fZRdHmv zCuiEb(L4>z9Tf>{*bhjcgQXyGlzr4UpG4BIl8Kl`&QGf;m9UNEnjT_7Y9iT6XA@G` zV|g#*_RaI=G4it4I60H~N|1z$eI$-wB8ZkIsI|N;wSJMKH99GYa$|0k{%K^r@)?>z z#vP+`)eZ_GwEFEibLIl1#X!x{J--q+A1=m9q!&tKUJgwq2+|{NlZLpO$Hb4^D8XYN zEy3i^@2Jt;eoBgffj(ftD1h9Aw zbVOO2f#(*yrPF18ZPR`SXLs#sujB3vW^7XshK?W$cfD|~PQ70bu4MH4HU)oIIbM>9 zQRAmtvk{2o0d9_%AIrPw`LQQvlcI@fy;z4QlHQp~z56^a&Z#?Hh-zb*7Wa)r4$&0) z{64m{jZ%}XhPG+lNqy*WIE%rViD;Z#S-IxwaCppFv;R@C;WtKf=+Y~9ge_*}44xy! zsU9{|>m9cj{&j;|R6d3`A%!v$OQ5N4Hx`A*JFE-lTNC9Dt{kE^OytFzU=4W|kXtEO0bX&R9und^`$vNOp;nUUkxJmc=t!1 zpPId2bE*-QSr`oZ9Dg+4=o+8ta+8|Hu7WPlsp(!x0q4WMdasF_9s2=D{uM720YcZm8&s4R1Mu?9TG3sr@EbC8$DRu-ir&Oj8Ta8O}S6M==P(J0v ze|)B=w>LY^@>z8gqsxYNtY6ReP_G1iMnMLbB6f3&S}O$2eW$8FPt_{ha=IES`Zk@& zsvx}n#)B|^DM9K(v9i=`mZK@}y7S}#p)nz?q+;^@X!k6N$WPbd-+PV{BDwb=>3@=c)SZ}ba zJsA7krVhXOOQ$|`j*M9X(XlcKM`5#om|mR}Pn3ODyii-vxYwx<;v zit@WD%l7_@h?on3$v98lMy@ zPF9cu(s-%8x8xLrcr%3-LX=)KkxPubbb;>$W$_@ zz7n-ndbf)~NHXv#qs${j1X|oOBkyTEO1e`78QLngs-lVN_`1#632EbPi9|Qs!Gn3l z9XYa-8IRYmaiv@%G3ARFE=Vn%A}=X(F+Bs}QCi;CT{G2G7Cf&HD?I=&Z z`pvCdhgr`39s;U7F-pe`)zDQE+P2|sMR(%eY0T73W&Lg6w{4B2`PL~P-*l@*c&6Q? z|7aN$l=;|Wv2k*vXyG^^XcgyBF($2Aw0+U5*et}uKT1{d_G#Db-Po*PZXMF6voW>( zOe-rbUfD5P46#jq8i7>j?Oe?vPi9#XSX`%1vM^uDC~qhZ$wy&PX)3M_hR8N?@`fi5 z$hXbnZp>)tkB~_0ti9XL{B-yB@;Ci%;U@pCzIQyYg~WFxzs?_Apsh&S-!OcR;zgm% zoIji!y}SAj!}hRX##g3k!kPK~XOF@)?M=@-dV}Sd4FBh0z2RK^>#gqdYb|Wj=gF6y zY5KQq$jSmQ*i4F3+uHG7NYdKMH!`li5nRG4xLBQ9WUqSklKd-QU(1cjvm+>DF$>R# z&3H{Z-ikTa_FkDnwT!8NHe+r8u0fJiN#rtYvy7 zCAib3*g9{M-$IBX;5QR$|3 z=N&!x#5!MDL^xZ3-0k@7tL(1Igj6ayu~9)(vxnrC&#}j1%xnZF&l23k(4L81`U5u; z_h3>@XJXoS&wGpX`LQA|=E9DB>fb&=#WT|+!Lnm{AcauQY(*+_@#WU!_Uiik%AOSu ze3Hi9PU#D6H9Wg{WitMe#k&_!_buQRjOb z%=0`R9z-A3WLlk-+D*}Xv`7)3ofnrSXuC1-VjZhhQ~3;vsMcxWx7d8%c8Vok%M!q+Kw5}VoRvN!uu=fwNGfV@`xYmW2^{FaA61(s%h z-~?}go=EsGuKeX}2*qh*d-KjX_lR^;0tpGF6!+Svid{Nyp^c_;-R2N!7T2t!&M)}I zJ4^+u7>pZ=1P?8^2M4j1Z3QjkuP_$nRzeQ=`*Ju8V% z$~LVBE7wjh9QRc5Xw+%gkx!S=gX9UHXlEaqqaaz_#(cjd1|P&rO5`~|%Y9DEX*w@W?3Y?fT*)i&+xbEs<)|D7#$h8Eht(5k z1`JY@9ANuTTnB!h`Zq@-&(&}RRVWxqZ~8ZLu*@;qG}k{`;+?BOBZwvm@OpUPS>Lis ziwKV}@0f=)0ByOIKqNkQ*A_HMJ+?Z$rAZ~ zS^mz3Jvx&-*mzfBX!UFev3f&~*t(C=rE47_jlN&Z30vT~;n*D)O)A{^=*>$E3KPMk zvKMa@>K-4JsJ#`uXt42acdz@AD3eET2+&-dQ51{$u^L zGs`ULbU&|Pw}uZgZ_Q6P>=GBm@7cDeqpl?r=9$JzR!>-G;4xLM^B08+epbTiA)4!B zOb}!Zp^nhSpYF#ZnI<1m>pEr1mPNmOg)~KI@;PNXH{?n#t}LB8sjMyg+<=R?hmcfm z?ad3x(LmNqnpgTUIp1(h7|`KuX~hGsB=wEB+D0neDgD|WaU|L|? z%idEju4Wr!leU#tN=h%`{|rQxT$THm(xYz$fCu9Rfw$&=^>F9-@?(5Ax~Wm^QE!~cc^2PgIa&Nl4JOIU#eZ9n)#+qJN`V*&>sLRLyi_#}Ym zHq**-KJH@vD#EM5RQ0JhpR?wB&IK;u3TQDy6DAEM%%_bF1ztuxGT|pd3}SUqV4q7p zZ+kw!nAH=A-59r+I`JgPvl_$WII_8nZFlM&uCI6RanOW@`@N)(eWTO`g(247rD`hv zlZPwSp(ll-_4f`_^^bk8=I*#=A0|-G+%3&(W#bi2#j@ysdC>jJ*JMGfT0U=aY`dVj z`_4oPw=Szb-Dcc3ZY1DExl%NUdq9NOf|2&c|jD~>IW#KhzVE}GR>^I3FLIJsMezST*Kv zO?F2O>#4=NJG}lp;_Yi`pLG~(HZk6zC>wHiWy=MQJ10M^TvAi}S4Yf0LXkV|V)biD#xj+Kuvj{%=@Qm0!pNtdH+#2p$bCtYG2GaWr9Q zPwy{$_~Lo*siS@o-TqZ#{e{(HYe?kwJjvH_{%sv%n!-b#gWWgwPu>nO`&Y}(?sVlU zRgmIuZq9N+lMaKA8hqe7@;w<*mnWx(R9ZEgp8W1DvC+cR_ZKS(F6k#`N_kawXXmcY z!=ID$aQC0S>^QQ2Ad=2<_aS13oJ0r>L`j=OPD?U)^m1^r3r+|G zK?vH(PelVWJ&j(ib;(r|wh{&_3L+1_*3UbMMYIl<7~ALQp?t!dm$PhRz7hXA>YftZ zYX}yP8;ZH0ck`hZbb|wtVBE{oLO?Xy4o`euvFj=!=KbryGl6$0@fbOwL^p$ohzMyp zf;|3`Pv~{0D4th0nzFnK#r)0``NbjL;IFai3nt%LV#Z}FG{crs~f2Q#bgaJ*sTy4K_ zfcLk+`yufDpAS|2hJWBIhOWO&6!@AP82b{@EtrAq=%G7u$C&!Z*lmdg`tkzsUToQ7 zuIPiV0?h_I9yZOT7n9$@RaO-`U6&s08YTAY9Ed4aO1gdgVZV;42P1VfMPlj`x5=#@BXwt*+t- zoHX|1p1pD^GpJOsU|UNsL=t`LfaQBrxzh9gp@^3c@P>)b)|6UR-4K}YAqMn1k}v`a zJ_lCE!nUZAzW&azO73pUpPq=Fke3()b5q31xzpA9!!0TTkC?%nr6{5XrsY|tW{dV1&^945P;bDuy3`}g7oxnKONqNU*}tvt`1MfDSV7CFSovfVZFb_Uy;z1h0STA#r;!k0;Tx- zqz3B`E&pOJX_&|s;yh=UNSb`Oz^SL1VRG{hGaFjd z&S{3*s?PzTLv{oyHe^AicbA9Mzs*Ln*`lU2$^kS+dB9OGu_wDoaM*T4F$jLp8lI;AoHQWwza)kyvhv@tt-zcdx;25? zt|JRB=u0g76P|oa>yk;-gt3EU3w&q5!)0p$&v46|<+E}c$xekq8Wn6nf<$(PmS9>U zTqHB!MD{~88-r^9ZU}XY_+!zgT!?j08xe6{xm4s(w!6fyGa@0DDFj=_exp)Kv?8>i z7&vx6N_LvuQA3PoQeV*uF~ky(CX*n1a)m9V&bPzsmbmPx>h%Mk+0FK?#iderz$$IR z10`W?yMN34-_VrnrlhVm-bQo$dtim3{v&?*zY|0Jzo6-V9atkP^Zz1x|9M#dBZpX| zY8`XHg7BTK$EaPSxw?^f1nuuT+lPlQXV`{(*-~DPW4fNs)m)dQ>!I?)%`7*srcQzG zv=L>>^DxOw{|s=yfs?=ZnE|`2K!H35L5#Saj^IUHP+trXWf+8j4zW{g+NfJ2ZixW+ zYdcVx0rf{!EMZyH4Pw{g`KRdJPlR5HLq}DJh@`q{4ZQs0{2`>rE~-F%7vK}K!)*XG zaQ)Lgn%YQK3dO6TY61u3{r&~3<>mPSLimrxUlj?~eA>+EI?gIYV#9(wpDIb!4j5lq zn`H412w)Lx20|TPTnf0Bf$6$iX5NcBY1Om^03}Q!MCp=tQoB<@A)LN~20_sa_REJQ>i5qQe#P(4J!p)7@~;MlM^BcngAz2m+L-P? zbDTm{9NY{fOd(!|*F$Or9&)6X+_Xe{)qeO=!adtcDcJ@uY&`Z44Q2I~h-#{0mQKE) zP*R&o8#XpJdkxznY#1y39Qn4I_Pr?iEk3!C17(X;HP%aJnay@PIU;;{RrBppY7e4; z=(GX!uB_#yb^QbeANm*R4^I(H+9!x#GV(+GWDOmV0BNO`EQrl+a6REzg!<=!Y*YRh zebcRCWm<*+Y!^w=SZ>`$E`fDU$qju4Cxg!!1yMvm@lN#2 z`L|f=WZppS=4|_S1rKn0jT7J9B_UDl`9O4naf_Rg~?+9~6x{R6ekZ0!u8+UV>}xpBbnY9)r&?)J<^o z6mxDlaej$!k$ukK86L)VU9*w#*BSov-d)c89X*`CYjlw*&BcT6)fr+n-~x=8yh!}} z_)|HJ@?z^QEmVl^K8@&^aom_@@59&?w_b!A{!3aDJc*T^af>HkUK2`oB~^r_X6|=d zpGHSpHT54p>U?UA+in99?w_u-1bsIbg~sppM90C07b({y6Q3aFxl^yIUOqunQql|r zYu+R38J6FBL?{V%i&G|38|W1ura3@K8T+`0-fRD#s9I_C%pEh$4e$k>k%nIL*2fs4 z^evf&RyN23{eJ_Ar~Z&Sp_Cj2*l&vnB@zID(Em3e`7dPoe_%5~s^^_4z1raK?07IM+qk9@{M< zKuXpp%La3QnNzq1usT>cM2r|77A(}E%j6jZdbOhu3E-Uzr5?f|7xZ|zQvz~!orP?+ z;jPLm7eS=rEmt}{z*kO3Q90tn!M9UL z=TLD-%@UM07zIxD^F6MO#vdlMISlmx_)%h((C31_%~x{PWtDu&E)P+A;7D`M7R|G? zFbZ-R@L+76oxyfQ5#BfH1F6P}T!6QEu9i=K7@V#;giKYUT?{@>u;C8&;tJ{l zRBcTr;JMH2CufUmTc06rzaN&E0CPb_{l@$97ySO@3)G%I5QwPPqCCbvNw)3NFa*aH z<;~H=>`gCZA6(e=L-R)T$_Sa$IZwp>$ygFNmPB?%HM51()8=Gxkk#;bkrI6y5 z_UIKBRD}jCA%gb{&y7e>%k42 zlS=+SHiT;oSeI)t!?wBv*?~XOmLux5Xhe9Z=$g9ZnuMQ6%;%$iD*M1Wa50($`TbZs zQ&QGu8(wp664S{&9xn>W8S%`YVXfJ{Kod{A>4_3cM+Q`pk0F6;pM+eWyXg%&R&-5w z;3ycXRIq)=2WGkWC46zl)I^R}QU*z1N1)K#)%KT<3iVNu=g8pdsI)n(q(6Dm_p4gC z)69pPP#s&>8-FK@7lysl$?>_EMEIh@z;yniG(HxhhNRdL|9N|)ykk=mwSMOwf5m*~ z)$U_=L{>;+aKN7*ClBkiO!murxU}J+M+2F3`xgyq~5prOW4`j zOV~+hD5Zr;lr<$q%W5u*CYi8`>_w&RNW~Me(<#4TckTe=Cdz0O_eiE>y9@CnDu!m} zDwQ?b$~x?5CYkr(hbpTKC_gY;a2}VVb3j z%#=1VKJNq4kPe$=Ng!cvl5eQoFK~=cszm)ZJe8U1E^bkKy)`jXwZftju_r}~kEF4$ z(EhiaeWs?j_o2%V^L2QngjHR{&}6RLnae)khhm?{f}e>BI*59yjMaZXu%0tB_^@Eg z2ZE7(1$~w>2)|#@Rw{d%WAJLTYVssi5`(Xz2anS8=P|`okBT@&k^4j5^Lt%$ZsG3w z?fP+}G#R3NuntYy9FX!ry;=nA()QyO@uCq)4AOb~ZO7-^`+3C%9d-XWfh8Y0Fjg)| zV`1&h(gK4&an`QxAeESMv>V)6>2P@NN?in>j2t^3pCkMUYWYbL_Zk$5ZK9?~GFB{v zl2Dk=ywk@*z+%7Z!B!9Ogs!W6(rD>D>dxmKawq5cpo>tRgCuH@hJGvbxafJQO3Hn@ zp99UrfO0A!UU;@-%=F>Qb<&Ho2RC#(U_>d7l0buv8rV3Wf@EC5>(7Bq9vj%(`ALw} zmucY4c0#P>pDwB{+)*w>%yiZQT~IN^cj3Eg=q+ye*{uV;BH2hP^%JzWsY0~&It;gj zekWUPt>bSre`z~K&5&SVj+-qV_7(LYz$Aj7#R>0@wWh$hYL-0zW|0lT{R6A>dm++i zfVl4Yhs=)|q^w^5Vp`^qe-_5MG2i~he#JzSGMoc{N!T~{vW=m#lre~x9Z6T7%~NWV zqIp&*g*N9~Crmq=q!h7o`s_Mm1!vF3jC0h*5%ICO1sG~j#z?2kXAL_GY>3n4HMF39 ze)Rd)LaGPqC-99R*$s$UgiPcWpiR>jp%3p>Gavzd>XFqmaQQQfeu!9RBN!)GL;(Q< zC{5^g6MEf5ETZd(R2*1*;Bv^k!DUlQ;4^{|PK>FkPk(3B z6Z)uy=1zF5g|wjA&;*T(DTA2;$;CJn+Ij8=V2g>O6_=y^XMX}Dw%N4G)>T($DpeU@ zV40$EfeOQrKE;gkzFaFRR8_L>E&~c_ho?=GczCxU>D^0iY;RS=`1={08oM9UAuC+) z-G7uH9&jJQ>~PjCQ=4u?(YwIOGWrgV<#8WS^Bq&ZoiV<#{yqD}vt{Yt*g_(XCZ?}; zzX=PT%40!bd``oNZ*MP8t8pc2Hsqs~|^w@`HQYaoiU4(n5F%^fk=lzSy|(8JK|E+)AY2s5m|ZK?^Efy*p0HGVNC- zsFhm(NpUDjnvv_#X}&VZ+STC6Qf&%fslhSVuVsnQs26F;T%JaoE`*v0={Pm8sHd53_CQP}cleh#yV`aY7E+3(fX{A!Sio|GQ;fj|{U) zfe6dO#l_}1amR9xKwJrd(JbmryS%(Y(3ipc9#j`=6nNK=mNyywI|2rO&?gu;KGIf6dKv0n?$9v!?;en{Y9-dxt3X6sews zhK&c#wSkBm)0*ZbRXne;5XkrER)I*v_J5UkgM3F2t%onMP9#2E9W!hh)uOdyhv7PR zKM=0^3)eozOWSK|9g>?AIP=vrRZ#<8vNzJPsnjH)Q*YL2Xlmw9qllV1Quko4IG+{e zWOlrOPs<&}&afPlEYUwa9uMdHpO;4!5nSg&AYKL=UhC3=an)Z8x+{bz6{snL<_LmSWVw$r($ec}b50XDGX9{X0js7$o-MwT1 z%hMIcA$oclD%9hjzoX|JX=4{i!%g9$zP-j*Kz2n$UkjAscWT zh^`rnq-3$`{vSpHY#f}L`?eoH`)|!E^4Dx<_ubG3*%Fh4DxUxuxHIvlN zlH7kTIwBSx67D)&%3+YXM_^dzUg@<(sCxQBcsdwCmr2LGb&d15!iWnh+YdruD;yaI z7QVi^BO{-o6V5@4^?g1J^@=m>ce>?0!Ua5GpWP64#b9jotS`%eom$s0%i1Vq5`#R- zYmOW3HI1R+{nw!qCjEDBG{X8Sp4xNdI*_$X3FB-9{>?1nrefp@Ur2*$Ad$ulK_y7- zEEpFWfrQ-%#2_6gYooPmUnB&h$CSEFoAKe`<* zBUAZ}M`g*zQ+s6%#W9H*sAQJUuOfMX=Xxa;y{en{SN6BjCDJ8H5+}*3aK=>i&bcb2 z2DOJtLo`vv|MgKcyDX%#BvLUM-y}oz)dr~7&%t(LoHZ3F_jo`16zbysVo)`;SsEHUYvba7cYMDyl&{D*=R;-y5GALbyitMS zWNyvCFdPy_^>>K{#uX>GYr`2eIj{^k_!|)<88ndW#>_~yB1#$JRa?L33md@^Qd}mA zHndP=005s#un>}*tsYR#h(%SyOoaB2Y7jVL=g`NTBls7#G` z3DmgRGMHdIQOHWr z0@gzfEX1S(ruIl1SK-jhucI;nh`isg+Via0~IQza;}ygoyqFt}&0 z6)Pb=Pd2YX&!0l{b||yue8>1#u<%y8Ar!Ow{Su;&DjgoH5jTClxC^{cJkm)WeKUyY zWPP&zob{!3RGkI$3{Av%+W4o+S&%4Xf>&jL1CQr7he^x&`YlWxV8|DCn^%HM zb!}~Z(REXSf|Jc;F&bkx)LCIdY~z|m*u>G;wF{3JM3{VENx#wCmFvLuR*P^;BWT8* zW5cyaj=>D18#ay^Vo{-?h?}U7S%mCUkfvJ?pXiCW7A2=Eh)wgRh7uE;&w*S4xgZNtcj13W&wr2Pw1fEv27Kf?e+G@@!+;yD>#KwGb(wonH^; z3i-zp74JHKM^gyHwaX&~b_PTcHZE--*B2Qx+!Z*}&q* z#)~fTwq@aKZL(0h3`xN*EqTJ_keA&3bxHA(t~W^CF+sa&@=bjZnyURAq+3MLa`jOG z@ha4B>8#=8Iqyz6drx6hehMwcYQFSeF94f$bzNqM?cXrLH!j9__WWSG4(NBkSuWHW zr6R@L-#%jvmb;{KGA{XyyL_}e%-oF6nJ!6e zL#RsL7V4`_Nu6^!akKedkrWDQv}x#vP!0n_a?%ITdD_pL)JtDz#&jWH7D_Ko8|kOt z05&+8B@P0#gib4~FN&5BvRz{q9b$!se;U*CgZrhEtiQhAQVe~oOMgwxqRz%l+fE6A z{R^jDiE`fv8V+7xYE27Ub#u>lMF&+8>r{nD(~int9NLObVlS+E4RgWGuJi4QlBoeW zYfFbH!_8jS0Dw9}mV23#=r0I`KL{f9q6u^nFj4_IGnpWwc73l$Vf*BppZH?dn|FJ zRuRp}{P5p2JUe<#8_FRJ&|q2iQU(3 zxJhkTERM#;o*!KPo?P{8A$7WJcB8K>{M`8y>1vF{J0#4b7d0`MU#6 zQi-U5Y+4wx(szpQITB)I|tx{?ezV5LB+A%5xrdbJQgpz_17!aoPmx? zBs{z(u@WF>cQ?1(>wQQlrsfp{tQU^KStXOEBCNik;A4cme;$=#9USq}3@odKw4Bd> z)Hd5d-5)llvGcC3DT1XwG>an7DCWIV#FK(>W!lvf3?Sp0GnWW0&90r!EL)RY!b8O_ z%T6o3wrHmTqZ^)qIzJ{Qw!NKETxmR?UpJ2{l3i))6m&L>#W+u_pgfnwfPAqB!td{CTBBhkEY>?FT|k8>#VdX7e4DDG0|j0 z+KVo16J1Axo{UtYwo>keEn09@McwzzaL%9{;G)i34Au;i1H!Z);vm$mML%7E6)^U; zlj2hfZ>X1e_mK$DomNlshoK-IKnW`VArS)^#fVH9UCm1rudfKGpG6FTHMfUrOCc?@ z0L6-@<&Gg- zIGMSyEYv@^wrylzKYf0=-jjdle>zZuQTiQtq&1+NIV1h8F)VOwKuH!%Ie(S8_T%IW z@=gx`{sxY?5O;yLX8UVMtTi9`rDvJtwUbW=9E`K2zS`@k?+9ih3-Ss zxbFNDfNLa8W6Q~l>!bX-av@x7SPy|Ed&PN%}&Wax%O%U0C|!I zW%l#=V^I_rNupt*mzcQS6sLIvs-5QC~a*Xa&ZCNrIiABpr^1e zA+x2%mj6ttgz;hGBn%(iqIKU|V^N-XQlDL0?_CN*mg(Qp{gIOwIM|b3b6pqQ;cOlm zsr;rAZ5iv+f`Q;<44_8~P(^BxG-m8fC*OJ`rI?d{hyF}wf)5<7H9i5wykbi>y7Mm1%XR;( zZv}o@V6T;CZEvF9|TEr9Hxpyf4Du3~o zPpwyZZkT$xm6vQqmSn`dtt0w4g>LEQ1H%5Bdg~?waXy^S?Q-6&2v0VcQN8xg9uqN) z#QLshTRr+Z-uws5U!YR+?yqBdg8J6Wfu%4v9J%Usid-aeVqA1AQS#yLwTG9jC#mz& z{$TUSP??izn1m))uv>uT(!Y{n%_rPfRt4cCu_kVHQQld+?)fW+K{tsy5v!$De^XNo zwbf)w6pYG+j6=Oh#(fz%rn1a z@$1Z@6R9g$DWYBfTvr8DuiKggc) zDN*U=Z#*7hCRXf~l;-L%3dn+Uz4>F)-&&XiK_M0P#FNg6$ubP>i-oZ|F3Dd-vu!)_W!XZ#{PHM@4q>^k+t!E za`dGxOJQuzd5X_1{=F}fmaDp~JJ5s+4m%(~radblD}sbAT0a;hXL9fPUk?I72myREtFy^SoF8xf_zlj+{)X)-yC z@HBpnY}rqV$S(mLSn~Z|NHTe$PsHpNa5hg&IdQ{gUwUSrJrH>prnQB2@=adC)sdrh*K1hf zl@}2;?H&q3prRCZCwFdOl$ku1@7H<`S^}`C;@WZS`d2jMwHWcEn8 z$`c{9YsI^hqv+GHD2qJm>8xJNw*k0WaDxcD-9J%u5pJjMriQ|++Y*6#$KHn!9=m#6 zw2YargpCiN_=Kn@*&aj65P-inD%fe2A8wPD#CRAiE;l$!sS7Nl-6f(B-aGOs4I8fg zhI}hwey=n6D_7>O`mN}H1Pyqko(Gxxp)AQZ#;M&;Hvx2(uVQBLs(Ydp; z?e$=DXYw+z7w6j2(L(&Z6I#&H5wdT4F>u|7D8Jo?#l?I)REHfHhw=8%H;5>56Gx;8 zogT+CX>999He1sB#^hpv0*Vk12G~oZZF5L3gw-4beE@NDBAlCPOz*KTChfTq+&>!s z+&d(`Iy_x;(AO$c5FAQYk z%hoH`!}lpo25@`*@LCgfn1Km`VTu?OE(9756C9A=9z+|#Jeh0hyrjIdrn zD7VS{-lN{+XOK`<7*C9+JpPa(vcj=9eA8amXj`P!1V|+9<=~Z+XXEIFO>(M)-7HRF zbl*Lk`Vd4It`?+ea6kSSc`An92a5EdEoW?#-CH2EV11ZcEdsuEy<-Y-FM2C}ZJ+w? z?@MzJ3q20m4NI==BJ5W@sMO;k+}2V2DO)^kpa)hJ{`Hw$!FVb6t>L0Hh2+SbSmCDxcYuD(ZHcnUNE71E--s~w9PIk+T)w; zM>%NFcXtb1kFJG9Ml2=L_uduVMJ=Toj4fKBmQV|oIEG=YDv6Bk}3MtoGJe z_+*Ax=wr|&cC!PB_Ly0Hr~5Bx?E+ubsbgs%T#h|YBq#R;(rWA3!8+3;z8ipvLHcD6 zVeiiFb94WG-yt}nsUiJ0V#j>Y$SCN6#a+@IN90R_Z>;q^Vo?Yv7z{CeRyqi%2>43z zNXW~S^YdAFpjk6lO0pwkUy<-#%moO+#o~XV<)*lYSQhE4AZ5Y^>9jPxg7LX4l-(Xm zjWW|_J;2Aep`6PCxN?j@cHzfnDo0VZW|RHdMVu3gto*>O3Hd7GPt%oUwQ(TVsCg!l z;R?M1Ef_xZ^SNZ$XQ(0PfAjS|{U|x@hg->@G-UP)$Z*HpV+R|;97vteTz5SZNS~N( zf92-Tz$&zg$)zQw*JKlz*Ur4S7-|TGrt+y2m5F!%ql%K(gU3b-7}?DOCD8;vhJb6O zm2<%>ZKxyE5&SJBgs^fjg60$YKx~z{bYQT)GBBA?MLSDmnC^ir;<8i1WjN<}2Ip`M zmJo_GCTlgSu;B>bS_i0u^nT7T$x_BSSm7orJ^&_Gb?BfU?gPg1rxXSZ3GdV^nNJ?5 z>S74r>nyYfME^FNx7x{F$8ou=j$v{CpZSLQ-3!B$-<}z?x*C0F_ZI&(MAhWIi*pZN z#!tl{Ms&2Y(!naoMX69IV0CTnS3D&`)9xR#lMYVysWmv-n*)?^QX)tumbk)ikO<&$ z>Ro@i_+5s-v}V2MPnFSsdp|%b@&9PKW{giU=yowo+a<_WO#pC#AEh+gI;p~ZY6z3&Vhy|iSmjCKh8 z7#@rArU1L_#C~~Ti+E<1dq6Ao88SnzH3fu=%us#GCd$SBy?GWam(;O5fm%gMs^Hi*j2WEFY#GJzph`iTYAHJ`3y&5A6DEC%9x*1vFN0 zY*b#~-vt|k-5^?Vf`D6A&yjJ|zTvUL%IPQb0|Duvj>DJ=F1b6s45gF8K7zJFHyMWp z4#XJhR{zB0Fp`xw*$LRImm(Y<*$^qlNIHz_9#06g^1wVHC2~RG7)ScWex^0Bhl&=t z;v}yMjVdL&@Z=vSei?9Br?O)<&AS1z(74-ylL}!-8)gChszROC=AewpbZ_M&Cp$ z!X~-_Vo^yvW@FP^iTi^Fg=04Pybg?7!wv%uJzQ%c$XE403GSfrdtoG034gNRdV%Bq z^3|rA8O0-U2*@tmpjW@x;))a4l1-B`L>-FbuPE?_b5J}2ps=Pk_5I59z3j}`snM>a zXepKaz&&|INHTF#qp>UfiM*Tk2r8_ZpDZ}KPscghI8Una3~~X->Y= z2|?Wc8j+jEi2i8$9O7utO;ba~NL&=C_lC}PVn(uAHUJZoHCP9|c3^v@fa`wvx|Ecc zz7zl|5U5KuU`8+Fn5=+7r#vJ$07cLvX=81H%Gs;H>Xd%!*O)~094_PxQKMCX4T|jv z^7gY9XR`J{p&&dSb2#1Z+O7sxfu%S&)EdIL15JE$35^B^MY%Wk)`Tkwyjae_FnKgT z8%1-)Q*h_#^~TK;b^~Tu=)fMbA0-Z7emwB0qsZ+|`LbJ93cjO&J|mx7mIID6R%4o3uIKRrT>&|vYa*Y-@q@D3QAorQ z(#9m}QUFV<=!<*LB8BMt_Ns|r7n#?bBP^O|Pg~>#P+e^nL|v~&@MeMox=R?YDuE~e z_2nu0;#YXxz@n8=o#z6@6=LF(HML zB$7v*eH+8wTv5JKxmGWvQbgZeU32fCuLlqz{isx2CD1cKr+}PzSJ;({F+S}RuR;%M zV|CCx1&%#i#N3Jwp-KW*>8d!42PF3s4ED?d8neye(@3JZ4JWOKKhQOADRYWDjY~|MDoTv4{6(U&ju#ZJ4j2u(xC)w8Q*5UQkA|0y0B`s~GC=lA-b~Qf z?2iD(uG~CKE3F8#3()i1Cf~trL|F`d001!r(CoDq_Te+!3Z2?u(iffl)vBV1!}N zHUkcqc6Tk0I`u{|-wJMMb0utbYd&ke_GzMf)9YGR?wqc0_nF_(*-93VPZ+*3LK7T_ zQX;I$k_Kj&4vP)ozxGBqLX-)>YuI`2$Zy`4a)PNCeZk#OCP@yD?r!~faD5gaA3pUY zhH{W$!Xt#j#U3?L@8Xs{Jnr`s^j8i(b2x8us~||Me?7&Jh5hwU(}Pn=AS34-t7m@; zZQCfXEI=MwA8rjKzrQ*HM+tZfFJ!L!cS~99tVLYDki?IX0`O)@F{x(ErZY?Y0*9{q zZ^=<}qx-X+jfppWXM<$CD zycVO{kL*-B9gM#QLOP?c^9`(Tw_H}%f{l3iJO0*xZ3)F=+_K(|(Pqkkt$*cv229o= zOQ_qtD++Iv?fDOWM6oRZ6Naf-Eo$~Bck^J8*oOx$i-Lt@F1k{BP=W8Cy@-;2DO?fM zkYluN++ioqIz`beZ8(ZW-bPT1EyZ{k8`Ktu>vSB5sq+Pw+P_71?J33NDJ$nc8;oCV z6*%=2Iy)7d073eL1p|oQ#8=KmLxw;J>%=vO#*!a$trDY4R)^BnVs}tim=Y5zfWs=F z4v+={uujHhhmM#!7|rM>biV0(Y?RaELFr1Zv_+Z4@gC`c&~jZ6?!4&*z$44T6OUzi z(Y@<^X2v`t>KK^sAw0_D2IbC%c3%NOl(mA@b-@4jz|kp^#ug66aOBLG#87)wib7WK z4ore0Qx@NuxsxuHb1jj*{tC}4NIVL!04MW~;v7qiLP^*iW6wD1B3m}>!fWX0zqCg| zr%P0uvF7tYGlZ87j>!fHdb^wwAQ+dTpeZ6H`jW>qOo_-$+79k?+QfJvGe z1{T(d1p+*6b~~nSPx6IcS^W0?QK01s_MV|eL?+e?_^v&hk>DoQ;jxL_WRvT}`!UDy zz;!W@Rr05`+P6r%g-d1zhQEj6*+fb1O$o{b;>m}b(8jk!bl}$8RiOwD7<*F!@7>f9 z)SHx^RH0cgo>7DaS*NaYx`>m>C3u~@aKX~V@6MV`oWmv)XM#ARwh&8ZM*R^dB zXXvl;E<^9%^*%-K1yynn-}$9)FQqdrr5yn6#2j+_LV*I@Q`z=y4iHeJiaY3w-k(XThkvo^DlHSMzk7HyfNosFn>tFA;_W%dvq$g7K#na8 zwTi#$Dz|D60la{b!TXg~h7mSrfED70hkvIx&wj-;y2uDa?OUR;r}-A@5-ha?Ow*`S zqOeVSrrzKP!TI}y+n2*DLXa?8V~#@j(uT8mwweS^k01S#N=O?%Tn<2+3%^ixj>3)H zYho9&nYixS+XXQoN&4-^Jg+gIR3Tuj zgKZwc{&D#;LXo=GqeIG6?6m}P3dS2sRMCr=QQCZz0y>1U=BLPoK1eC~9qG^29)hN@K%6{tF*$+=js>R<<|kH8onkvQx8 z>joix{Ra2*)AUuucDDexYY4=NyponkXDmf!Xd1cifx*Rvn$Y&8lJ;laj0+ck@c6G| z3BjoTEPz5&!({l5W}=js9I{`L&6R|GS@3&5P7F-H7sP)~T=|Cj=jFo<_YI?@vDs6C zERf0CmiH$p1Q^LihK=Mkso_A%)Wu`7LS?PZ<|P?E2?Qz<`~* z8c}~$1J7^|D~V85ixJf;8bb^@GGZBOR8oiEYcbLdMFRi*z{w#*A$gr=9G^QyjL=O3#1kucHU@$iOqhBi@)tbh}=)o}YZbt44D`BVi+3KICaGpdeV^20PyNzf7 z3p200#3)z+G>7cx3IZPbI-QF*CVif~3|+fN;+EzL3=;s>NZxs4{hVoYNhF9co+Her>|_d+k# zcUi5SQpPD=hQ^VgNZpYwU&-~>7wbjaxibq`p&-q!xHV@?w1PeK>02+&#$thiu{E8G zq=iOMU>uukMWMzS)`Y$&a#$M|jWokuRDxk6%J`NcitNN09NHz9qO{d5zJdxrbdCsW zNZM{Sdepj+-o=4uhVXqZ0>1vSS&@4as%EVoQNVXY!Rb}j+MMgZ*eeKQ7%N(HFVO$) zzbH(OJfywPkE&5@c!X9);_Y08mn_WGW^lfw7lV}*BErPZ^V<3nb3EOVwZj(U+>AQ( zx=UylV5df+hW>Xaf|mdf9n6CH!cq6y%aeThP7hCkLXS3{9lQNXCVWY^rd<`aiRYDS zT)D>)iGG1Obw=zyG1N|G`8{}h;ZTMLg}=_7cpdju3d$bq4u~23JOH1)MdXjw-1q+X zE`P2}=5nPl7e*^*LN(@2gPa{^6P3AhA0V+jvpkl;8OWNpWV%QaihZ(c8wP zbs0+tf`!3W2Oqu76?8k%DFQ4^zlm+|!#OgxT$OB5%N8IIKN9}C!+XLi7rX^L{?b_` z(ts>q<6J)N7)wpuD zL^lF0<69&ot=t8%{i%*Ay$^8w=N4x;c)P-0N6;(ul#`{b-rfY}e-N-z{X%hQ$%BjBsmjj!~Xr8evNCP3Ari3qj=$Dql zm8^r<*rFR(UK~QeAcrUtQd{sV0}x`)Z|f|pe#~GINK=Sv;E?lnz(zP|N-x)tLGw`1 z&%gY7Nm{@2Y>fq~W91qpnJ-eaw|OV;@p>pGGh<=@&h7$ZOLRoo#l7v{7OT)tCb!?_ zZ}uGIFaFXu-W#G@DAT|~C}qHq>#+)Jl5-0po+{84L`j;v0&=4;A$vZDV?crO(x5Ua z@*{A?qi+tovR`m2-4V0dmF{3v9zc}ed{q{;sf2N9*!R}G9K;1e;L~y(N3PsZ)k5+L zIh3tDEJDi`bZIT0!8({9d8GT2=W~@eYUfm!bu2rJ`i(7B*T&aKbg3$pI~c;G6ev~) z`e5+WSsB6)W;e=A!PP!BJk0!K^ADV5ZSyv)V_~e3{@K;cM$GR_T{N2fA*0q0q z0D#{@=V^Gqun!mj%d3z*&ikPfhj0*i5e_dxytu=JsjTiv#UncBg@VQlTrojf$;jZb z-=%zH7cYLCs``KQ5abZKE_)olnW`-wpH^~gFsnWKNVG$cE(^F7x>oGNz%Pb`G!>1@ zH3eYTrQ#lB=T9#5)2j!vU2mc-j&B)8bGV;s{3SoOdo}q*hKYC@iM$Ipqeu8SrAa{_ zhJSQj_Zu;PICy%{ws}v;q!HhW*4}heZ_I?xMyjihVTi&UW7fQL814OYQCI0|7mj?R zdT^n*zA%FuP?DJfVTu|8`?HnS$P)liN`l@RWi{W9&nu8+XKG7$6u}4}QLg?*4CmTcN z$7!ryECWsuhFp}2X`AKicjp9mIia13g}H8#$@wD#urrfF&9&VCrqq*!*Oy**KNOBq zd-%2aRRe_hTC|5ya34fMY=Y%wuH{klW`5Rrk*-!igLzV8M&x2&v+w&BsI&I=$r&?3 zPKf8ItZ+PeJUgQFf{Eww()#FkngIp4wc4^yJ0Fjc>!N>#u?5{9guKtbm)w-&YId%> zIjI(*Eq=yNVU|VERejK$-I<`kX%u-Tr-#i}_X-2dBDpXqXy7+S5Nqi~2Zyjz8_Oc+ z2(`z`Ne z|KTLfr*O)=!j9OlcItfzSSvYrX0Lm9UkXA}Kh(OeRXvw4<=>HQ$jyDKRHD&Gs1Q;w zsu8I%`Z)b)TC#9UQf5-fQ=(jp^D#I3KhHC0{~xTKLzgaH)MZmQZR1JXwr$(CZQHhO z=bN@|+jiznqwY7VYSbU75uG!l5v|jSz2{o}8i zrbd49U@i@9EgB1SMgE@itZPQFtVE=KxR_AxBVgB&Lw;5xP2<9!-dT}E_ARW=o6bgHN$icdVW z5X%X6Ozo;c6>LS%2ccBoW@guK4480FzI>;8FL@ocx1Q&J5_J~;&#k`}E)7#SOp)F_ z@Sk7k7o>+_!T~P>1XJt@bW^GtQm9Qu#}};8!@r1NO2o~>5vGeIO>hKO{B!H`(x95> zD{5e$+4bJd!X!T+-{S==A5qdHSHQdl1ucfaG`JE{D;eQvA5S5~+n(?&ZmF48Pm_}_ z_afFQ(pl%8LZoF6jzVuzG%R_3nj*fD(aCDwh{O)RbM4hE+2{1l@TSHr@e{Ug)#-V< z$9sc;sb}qn57YvzEOYo<5aq<*?3$^lgfia$Z9ufh+5b$=2OqSobjp`Qp-h5lBVI)V zP3V_02S8%uQ>ZEB>KdicqY+SfWB3dUk60ALs3CTe$5LjiL9YsIAJi zpy*-qbOBOBM1I&*!#`L)F&^i|12aQjaAFA9gJ3XZwyXoATx#g!D)!(JR*EH{r2|vx zPYCq(75qg?Y+K2&2&g!?NQ(vk4uIbVKjU1)^CPc>3j)C-dLf<>6sy6uvE}6^en# z(TU0)6N2KTta$&hrov&fZdzx&CF^D&nfx8J00E_{VOXRddcvM7Y=MJ|*AW7EReen? zWb#h{r^JpRA=gV?; zlIKHJRI5$W+wvzDJ)7DaU4Fbh=MG2YkPJ7N$T*|Pa&ZBrch%&up&DAa6WhjPR2=p@ zT8&UtD&+&-G$dYr0}4rG*WOKGK2I=wa8n$xdV5~*K|-@#PvO9IsOJcVOaIa#p5~ zeCd9Ak8bzmA79-BY}QVS1X|fK(ZQx;nI9?T?e-&paA5-1{NmIn>Y+0_0k$_s)(%8z zo(_5p#v8q7@#+cpN!%>zc}8kuI9tQy&~h^{kGF{=K+`55lYhX6HQmDluNO@zim&f( z@B_?W!?9?1@)?CSmsPpZaM$6>kq~_lwSR9HHSb)Kf`F6jt7_C89gMfQg7ssundXSS zOnGGcP%M@3Bi5_D-1UfOT1174?rhE81zWT}gAaI!6>X-#p;$Ra9rki1q4U{XOZ^D; z=q%%Tr^W`Y$+G}0W>X6DKN;5Ii;qdGzgtz`E!ao-cGcfD3Ait=ODb`ZF)mIEYurA-c+t_NsN3j;qr>{ zjG6&F)`W$Lrlbo6PfK|+c0z4V^Jzf3lo1o)EJ4Sn@d$RoMPVJxCMvjop?9hJmlMU|2>E=4#xsd~u;wW2R!!?x zk9DHSj~)lL0|zkpXEb)^f&BTQwak0`*&HET znp=4ywU!)@L+F9Fg)4hM{PNuPT=M$*Tzy|S>J6FknL*$NlC)QxJUL3@xg5N|5%Ruf zsLRKZb8_*h(moOEgCsdd@HpGMrC&H1tI}~W_D8u|PKT=_mVx!=gM*iRnBY=y{W&YP zHAe`g(#I+CRY+EPeplT`UjKg0_V59baLHDAx0a>EQmKEH2=nf{GYzr5!$jS*k(pgq ziGz8sUGUl-I+;t2CjfK?Y!V$I;KO2Y%&3uF^^Huk0pN=JBcP#HGyf8y0=!C=ETdKr z_+J4hEV+`E=G$wa2(hXWZ$Jz;nGpM)IS3XR__g1UU@|S@b0X%p-$92-_eEhEk?Wx*>MSj!? zlzmd8xCwf0NFXonv@hrqGD$q**YWrKY zok3O^(f=LydKD@#Y}Y*W;DBR1n=)l-jz!ouxa4IHFDU{&q9%8d(o^omk|(ZLLnVSlr#%+&1I3DNpqh;)H(;|4$p-k*Yd0e#@vycA90P zqF5I_F2gfqU*aSLQD>M)J}2T6KB83KY=|4h4Dz3=7{Mf)4^ZE^nsyi(^tZsDy9yI) z=69j7FIZchtTUG$Ak#FZLc(Dlrb3t<(&3E@0bF-t0df+T7;Tkj(Sdth=0*h~ztmMd zJ8sHS1_a1zVn}f^)+9fxvC?66TbFKpV!q3dPJ-ht4JUKasPgw|ABQkMl;9Z@Sk-}y zxZ7a2`lhB~{nPHmHsZrOy7vlB-2G06vSy1)r3?e)EXp0uOHo=LX@yvh%A(|xFWTNZ zO0Wyaih`%Nbs_RKYYlC9a;v34V!31E&iD)(_-+JB!XynN>Da8g`bo4=`xkx#vQVj$ z|7aprI7VA2va7 zYg$cA19T@8F0MirM%5*XW4VVFd&j=4^XevhQ~6()Z3=13GdVXV(5AXu-G0I;ABH3g zML6^Hx#u%w0$q6>FE&kFo&ES+#o={*B|-G}#v%iG+li$-;~P7kN4ROC7-0xg8HX*- z$3c72Ge+YFSVlN;mC3e{zE@T_2(?&w4LX?7aKYY-%v~SQlC#EEP}Ne+Na@Dq9sJ@S z3fz)^X5fDW>zM$mEpMy}9j*)lDFJj86x>r@&?P2|M13lC$jqrxLitM*49;a_zF9lm zW%lHMsLbSNnS8lVbCARsMbdSUBqgR7ijt9-J)`$0pH=g-|8DABd-EVGI+P&+Pem#Ofugkld#RDz=iv!Eivw-z+*K=;)?uLn=c z2g zWAJZbFjxKvt<zX+P04j6?)`@2Th0&+QOHmIGQqS$HkKyCim7FR6?C=L62yC8#YzsE_y(9i}S zK?`m~(cg_|>_|2nO8rAjH!LC(O5Q(>s1J4@0n{v}6BXKyEd3z<6EOTg-}Hu!p!@7& zCs-uw{SENx6Zi)1T&z|1^C3?*(2zNW8|fW_Va#8calMj{g*iEv?XJLFxQQ3@bBilZ z;y?ZqhN|39H1OtKszRmdo_6VXH^VnCh454T6;Rd-y3DTfJxQgn`ehC6FRDqS)#!BU zt8?madsyEMeEyTP0rz^UOzsfgfdZc*6R-bTlV6fr(|Wwhb%lV>>-YG)L7%p(+D3)j zn$CG)p@RcGJQ?>$Gj=!P+mhY#(IeIMZio9Cj-5(nRzn?k7lpc|KxpTZFQk`{xBV=k z*H#d`q!cfG2>xTuXQ328^+lV~%i7@?S+|FIIRwUJ%Ehl+Qpv&>iGw`Ol;>v~YxzgQT(3?UQc$U(`sUL_LR3{Xly40q>muc~_ok1>NX% z3v)UXbDZ5&B2-l&`HzVw+XH8)k@VlC1qw$$9Yq|Pe+jdV+6kFjHZx`S#>p!mM{5=R zDgnwv2kJCC($Lul)3%Q+$WSnLd~^Asz>2!=^NuPMU_})i^fE_9nZ(P;&NFgvW7lku zoB#{|@#A-JTnlv%SQK|7`UQ*|uc3*Yy0`-8kn6o;Q0*36>bnlezoyvhzx2-APjHT( ziEhOgei$w!Z7fR?*T)sr+ST{qw61>wdSTP&dcih%XFX33x$`*nt3EH*=Y8wwpKPF<^^Sm|0`8$#3q=}rwrRPIAl2K2->AOcnd@L0o zbMo~1D0c4KF2xF;jp?GxyYJ8mX+>eUrulIYr3X@u1VZa5+`HbUd`8yZs?^gX z)vd3?)9Y7h@Ul+7f2mW9-bIiO&7EP1*OGIL=&|;CabHNg$T}4>Hilrj6=ZZ5t2xpy z599f6?0nSbx^$5tZtq3X5k0m}$2*YoDKQ08j;v--8r_sACL+9H2M7!2(x*ZX0Q9kg z*5c!TjCI(<3&sMf;@g}^5zz-C7itr6Hx8LW5KkV?OBhOW9`9L|#V#k5y~EB2Yxv>g zcpa~EBb;<%1iSR|FKZU+k9n8VQhg){Pwo@MSYrgXph8^l?Vc*8OacxWo*tBJ5i>yn z`d&13ma?t)sKI}p8xjzsA<}&6+&sP$9=-We%0^@Z@5&Cn&zMD_nrJ+f`w=l=Co?^~ zbYQ&<#_Cl8L;n@QXA+)3brYX}o|bcA`xQ^2PbKlOgM*VLP||v;-R92D3xnCKsp2ZA z#PPa!rAVO!QLieHqIBp@l25$u%Uxk;Nxay(3YMbK^vdPCwGhwOJsk z&rpHeZg#c^G|+vm%{I}!R^rs$5N<{0|0bD~)GI!_xZMv2$wiU3HNx zHciopVHgnSa5s~6DulCi*DOm(c-q$R`8y_Rg`O4Bj$4ar9Gbiqvr{fQ?RA>>(Rk-QYT$yT*ap_6O#+9sm1*#M+ zf*Pw0Hu%i>Y^a@S&ZtyyZoj@krtu+FlxHUYQUW?7}QarF=Q79&3{( z-61V^b;*KCs%nnr6vd&>7#8hG%8+)cpf_q@lIqEL*liiN^{@y7x9)ein)m)qP4 zVr;gZ>^hw)k383urY3Noblw4N?y*;lRR9~93z&Nw|{!t3qiBIzp0+Vz&vFyfev zQ&f`A8Famb)ihHfGFiYLN0QZfQhFV@1cWf;<1pD7evWCiuu^FqX8T2u*UANYAM@Yt z&Q_rk8hwZ-lf<3WtCN_t#o}n0kB;X;WoAOgpu!X6MvTDlfiXFePS`D=IOo<2;?kXD z<^-W!Hg9ODVemxROGgxFaERA;h4>1)@suzhMf;+h87k%9s9+q|jv58>k;~M^o?}@` zo)TQStio?&33X}tmH_3j&*bxl+h&mTME+{5%q#mm(%ZPJ%f zIj8e66Yt5pN1(gx7UVhIHCU<|b!Gd=?3sXaDNvxeE>|*?JWP^vUV<TA|3#HN2eF9ze}jkJNtTFXA@|yTbu~V_(Ls3Qk7YE92kuhMd5EsL&b=&I`cE zua_3x<3%aev?$Kt8#8#WVMjo_n|vn1IZg^KQXK;5zLut_VQFS{X%qD=Q^j^qqc3_I zw4h%QpN|n9WeAp=+tFcbdWR#PpK1R|M zQna$|A*r*M_NXdlA#6bI&^`CmyQx}TO6TgJJK-!aHJXeaxqbpy6|ql*A)^2@iikqg z`^P-8H0bnf7*>|8ko*#@hzx3~pB`GJ6Aa`6sBLC0XbAMtE@HvXY)iydQkkG&J=2+Y>#8+O$vRCEbG1rdcuAooIJ;bB84>&Or4dfZU&} z+?M!scBI&MsHQ18<}}n^q7$P#X=>4^qe0z}pfQJPZ}LS*FVu;@)5jBP1L9LPpN&AV zfmAO}!fY&Zdk4lr8p{bWkA7&NjqQGToWc`dk{6{HNcj3kNTzaIh8;*_)W=sPyuwm3 zkGy!oYirxO?phJz+2Z-|%rp@Zh|8*K^S5Uip?sq}GgPSH+j^rs-WH8F|5F2@Bra{T z*y-pKEnR))8$j4xq}wM*HX{K{XDr?ry@|G2504Dvz<5yf+Iu`baCT*g+Zoufo-1P) z`OvyI+HZdM=I~QWWWlxxOI^PpGax-_GQ|a8^8gc8TB@^cfznZydmG&gB#}2ipS$fe z#D|H@geXBEJ#>d83N-|b2+4w*^>c-37D?#B?+8c=RCaGZ)aG60(eS8(u38ReCs60# z#qVM7V+0k2(Lu(->yJ~=pRKGhRmB)tcu0}pyrC^vM$!tv%4;%Z(GE!l85`~dC6e-} z!S*qE9An3h#=j95{+DS(*|&YLgmRiW=LVd>e_>PbkHVuj%blbZ8N+zToPI7W#LgVrqsW`S^F1bbXjV(%t~ z^unSBO?2~#A>{EmZ^_d~1IQ>LdQ}>Ofx&j9SQkRG$_feLTp;oGZVVpkPLy0;Uq}#( zf>S0W1fp1gRmSt`>y@w=Vo~LEXwVOg{y(7JM&81%n^Y-8sLaBJ{_sl?UN4#et%(SS zXA8hMrL57YK#_d3KQt{^` z9Gppap_8*}W4w>3vFo*3>1!yD&Lo`ZE-Mz?MU0jh#mzdNliE)tbKG-;gtOuw2#4NK z=kRaA#i?=?J>{c48?A0 z!Dk{dupJK`xR{Ko2H9W~r)uQXO5UQkRmK&6is-FdntwC5r_2#gM33j`c@IFqhO9&X)s!aXDndI8Xjcuu$?*#+eY0i}0%kmYOI=pg%SS1SFJrKPIR` z!1x*1Wh4ZKT1Q~=yeJMfg9*zCFcDJL-U_0tZN9DK>sq>gytTl*F=4D{gWAy zPMTko4c;qG5bSfc!8^9nI&(mh3}RN^_LuCc6iC4S12UB>4-l;z+ej-7zMEbS+doe& z8+Pjc)NJSgmlh)Ic=O%m*C8^A!hF6l+U+oE{5CV?ka3y;?Et-9mKkyV)fyocg<37wR zDzf`&igKHcIDo?sVt%ulUk&j8jE_AjGWZ296=P^ZQ6(*7;H~3z)Le+!mWMP+SMaks z{R+ep(l{t)$3~9G*_LJi6oXp>;U0}GtndUD>84Cy6q^~;%D`{HnWf`YL^voIhH<|2ZLE= z@%!1XTtf+sNt>)BKV0Xc)6b^e1xULHh;UF#B!L8-jMeD``JJK&Rod=6ZNs-!v?o=<|vWedZuqhtEXy~p6_ zDRh}{)<%*^2+>BMI9-|J6_+1-{N+*{2OA8~TB0Gm;i!3|)6Nc(r0=7(uJWC5LYwj3IDqlFx}I!YJg7b5IRr; ze9A2R=@S=4GYVBVDWI_z$>9T67pvdJKQQ>|dz~?O1dTTp=}1Cx zpT>=)9gxNtAETV|n8uVAtitTTzyR{yN$uujC{t~btlq(ibvlqb`57+$%ePJ_fs6~? zvA^}lxIP|t9*t=|GL(5=!3(#ZGz0ED2wMtkAeeR|##>+%i`(LD6H*;tpY<+RFg0f1 zi68?E_;^_JKX~hr`tREBp1lul?K`g(h!so-%_MY-T!G|P>^Cxr)HhBw6XM>4u|5Jk z!}`#FEEoKtam}-%me-DLHj36M5POIaQ$-+;7PEoe#bm_v8^*t(j#415F#j%V|2Y9v z)#b7CQxlcdZr03RvBGWHGpA4`$^0AgGqOWyp+Dk*8qudhJAhbsT6WeSLKDMAVPUqB7nEbcUFS|G+GFgH)5xxhJp1}oR|%_`f}`l0lNkq zaN*gKj{QMOJXWUDU&$el zO0`66ppYx4(Bvq~cQMDSWz_A7b)<9GqW}D;Ty{AivMCb#LIc+lT3!tW5dP!`wpQOD zMTgbgV_-(9KSkAqQT>^K5ji{(NIv1LGS8k~YuFIEOPkbbH*VX!AW0R~SO`P#poYwa zEHfeUm6?V;K?Vl_u|CmZ|2}$KqENW|l_+xY8C)wNbO}lQ;&3k{wR3&&Iou*;7)=yK zKmPMHhh`t^t-ze4z~lz`-|`7m8VAT!7HaNp<-|--S>im;=>zhp^OIe@9FLH>j|0}S zRi5<3&@_^>Fg&=TcBmIjCi!x|;>bl1Op1I8x|ZIY?bBa&FM0{{a>j2f+9zb)0{%;O z-Ye%TFwhfP=Gkb-nHf;H-=cLZO+slQWIjXj`1Ba4%I=^!xLhPTabr~AK&;O2ST%=> ziwb;B+IxdaBC2}#9B9ZH>U5%(=9QS?C)rGJi6E>G<`xEuKh}taB=f1H!~~h5b`L^Tg`bXeLEUj~N8Ehae(W}YE(7PjO6cp7A(Wv6L#Eq0><_Dz z6NoGOB07U;zJtILm~ze0Eve|VnFlrHzhS)#$Lq4KG!BeDfB{?T~tF znE6W{q_3sGNj&<3*Fm1a4$?`^tT2+z>U&OH5+^N5nN7&zA!_-EMiP-POxO~Kf?c$6 zTlwMI3Am0!&vaaAR&kQBqBH7Y@s4~d4V}OpsHw_%=`uP1f>RewOb1kM*9k+rgX0> zF+CW$#CVEk$J)O|29$ayAg2H|WU5>}$MulqS1rnIQVALRpzJr;mawVYQV-HpPo=|H zH0=cGz}p$V7lj=CtJX>jpMUnrQ6M87NIB{U(T`_*@T$klAAI~~ymWQ}h3 zGd=&9B_ZEFM)$fTaW}yw(RAs61Ln)vO|_I&998efkQk|ViCligPZC+mF_jQ|fQz^u zJ*wwr3eGL;shgmf7-N<0uE1v=rVxv@YfOR>vlAY{SyewjO{i}x!)yX5n9CbJaXa}d zWFOz?e0xyNTKQtMTUDe`Ocohf7BPs~kh`b^sn>6;cig!bQCcL{1-JVhyoEUvxh$y| zZ<8v`o>LCK*ismr(uU;Ce)fW~Dj$mtA=+BSJH;;Y_7VouG%T3TW7zn2*npBbYVk}Q zqOPelD&XI>s8-Nkyn%HZauB()qpBs@tFtXhO$m%e2Dv4Bqq`F)5`$i`C$Y8Xh=(pE z($x_w3OA5T|JNL?UU?q*-`SsM78_cz!>J-O1ffos%AXwQ(G8@+5-)Y?`T=V*g@%&^ z7cs$og}SS7g)yr9+aY_*N^HJ|)zhRvC%0s6mq)7}C zqKu;%gv$53WW;4+UdaRwZuNz+@!XJ|+q%v30I`PThf#6*dX*>AbJG8~Fm^LOiaGVl zH<&M3^(V_&gUjyT71OzkN7N7^9nGi(KBykhm(B`t<| zkAqd?!l&VCFJVFEDyYFv z^xbYSgwHx)NGoRPDrR)*=sQZvb?E0-L`EjaHN7LLgm(ae5q!0~Z>#TJLe-=iu^|JwAl{eqfi2b>;t%CY_h$Ma3f`|DxFHmxAuVIEPgb%=ae z`OL8R=;<&{bsjh?jplW0QErqFY>9JHh!bk-{WZ0pu753F96p!x z-$DBkj~|N<3ua8-HxmFhZ+-6CJl@}v&4*+M0RmHuhx9;hjm~+0&WG(uxQrzh+bP6I zw8LP6Z(dKvYdy6Z=6w)-rCk7xeVQZU2<=mGGR}R2H4;duCCzvI^`C>x8P?@Jq`9es z{|%wjre3szUZDZSS`8mCR*TDD5tZF(Q8WcrT@+P&r}c+yS1)MUEgZtb^rclg{sDlD zaDP^NVR0x@ud9S(^%z5{TaUYE|B!iU#36sf-okNl%I1E$@3l>R^dAn~1D*!P95C&B zpreLz*)j)`X@|^p<$OAqcb-N)v+~Nfl;vj!``x7t(dAOD?1C^^tlhe?1@T%`wgX9AG5!O5F~#RR zK%~$Q@1X8laDTXG+^63KbU1-$c%o4rnJzqE(nz`xLV!$Skw_0Gn0CtoF(@nR()e-H zCPDJ;`x~MfI~mixZq}KX(VQkljU8zmAjq~?L3oKQ%=E*wO@)d}{|#1~E2;-+gbR$$ zHlI0{lzSv%HK8+!6@^D?zzl_m;8Z9IqGC6Qird8&uE~d%S?{7Ud&-_8JN(kG+o|s_ zf;kk`TRxOPzcaUifwe+r>|_&X*F{wHU0Gwr$*GzVEKc=qqJf1a!FaxV%1(>`9qef$ zirM6f^JnH^+3Kl~aaGEH(hXy+k~lUXdn+ zPSM>WT#_5h`4)>OAY-SSc~^=l49n&RJ*XWf0#p1w>Z7XW831+d2{tf191k=p?axu9 zv4Dad9{OV`fU-W+^P41Xcd2yK+U{6wQF;i13k@ojO%>G&w@Mj48#$itBZVcdfK<5% z$}3YhUJ84K%QszkG^C?9bic#5&(K3_zcMbx1%9oNClc0c(K-e^uDpj3a>fgfe8HIa z@Sop9>amL0;bNJWT#wY8KBl#IeNEY%?cchcVOhbnZdwaHd^NN=hS&8`IX1iunnbeu zXobM)r)<+E$wJsR2%M%opSF6t4Ozf0Y34vdO_^g}vIhvZ?o_C(yMfP3B-O*tRg|+{ z`owPsxvizGwtm08S#Xxvx+RhjKfiFr@7qK*{m_0gSCe{4G<4diKZ}#296jJUB88!f zdjse^ZvuAq^&_E8abz!8va17)cS#l_+~Lg*7IUVCy9Vzj0qL|0^?urO zn$iE5dJImstRSoXFsdwH?FwT)P`O_3n{)sNc?Pi|{wMP#?*n?MlPzN&Ciw@qe?}#? z3VE|S^PqKFp$+t7oOYG3nYvXAIqo}OsA_(1EhF;f{a@wqzHV2v5cCe5!$4IzPMgU& zcuCIt?j8hbcY?!$bm>z}tJ@iePss-?aAzeCE!9!cicmRt38TNT-<~wzI-LJy2WiR& zMpU&f(+;vo^T?6!UPUz^@LzuxwmsXPwoVsjTUF)H-oZb` z@{S#a!ka_SWzQ1}07NWX^Zn(qsx2d~A_`2%F~E zTDAP$4(4WI&D|o_mK2+aA#Yd*6A$W3$Zxtr#EpGes+lNT` zyk#k)V)x-eZ|7j&;0A_A$PUVV`cfu+qq_?jLo{x;NN!0dE;nS4kD9M(Sf<#V>QJYvtR+cB5-N+O}Wh)@1Z$d&5G^&U$e#b9Ryho2!+ z>Roc$5$X*}_EbIbV%MN?9CYdF;f?tFc#JJov(q`yJSz zlKu$a+I0|yQbNWI5SiFvi0MjG6@IlUBJpv17qc7;6w5aYk)K`V@Cm%@B~6 zXri*EdnT2f*s3s28>ldlj9!6-(}D#CxwU7zXg?9P=p;Rf?7<&h-<#R?{>f`LKpKF3 zbxp_n2BPbO0M8^JKXWGu0H5Kk_BV}-%f!wY?-{=Kmxk#QeJIk#1mZub-j0-406q4t zCBd)Aref7rl+7B(=Y6GObXPPNT~o>@x_0KNKK^_*pG>aGGo~91=uw_;_mZGqT6Yb4 zbBJ$>N4aSk_lCdfQ-yd>N+ads7s!iQ7+Y+TW(tS6I0mWq6er^z*Iva6lL>Qx0gDls z6h+Wusn6pf;)U(q96=uB`bUbCUe~5QNJ7ub%p>M(7`ReD?w{8(lk)bUG-{T? zWOXcIJz$M)*#>wZFKiU&C0wRH7>#PvJcd3Of%M&T0uWS(M1q};M!4YhaJ|)p%qiua z%dl6iG-{7^(o=;|Je0$gTWJJlBZJ%yY|+tLF~v>BRHScIK>+& zZ8R_K7-O2FB59Vk!f45?Ofq^~;k+p0>oWhgv9tS$TXj{>r@AJ8#xVB=fy{VCS$(z3 zrbuZVlQC*6d3}R_lYkBq!U2kmg>>8KR(#7KFy#bXJ(+ob+7dm&_>Ii9?6@r*cRZg6 zD-}s}S3$KovQ-UkWRW>0F;!(DzpPdXi?!R?H)@a+qGGV32jg#R7}7=epj=i6xRXsv z0+hVkJ>6TJ>34~1e{OMWjlJzQEM;880NTWkbK+u5qOHR1k=LccFn!cfPw(eCi`cDHef2&PE`2v1RcqjlW7!LLV~c31ngKv+haH=GMAT-1{4&uis^r&gnfphs#etT^P1Oq*ehlLCJdgdmg& ze(r+qDw*OWZy>nwjw&y*>ZSw z@gYY>Z;=@_L+FB3?b*f49zwqM;$i4W+JbbJS8(Bn%men(XMoZ}AN_~_YeB8g1e4se z&cYa?#9XAY4gexnSnT+y=N-{Sh>9qNULI7n~n#!z?0w5)Pg+sK)eqDn&H>9ev? zGZln>P8q^>E|5s-zztJGAv9sf-%ySpIMfA=Tt3V4j9v#iEfcm+Kh!j3ntmBy zO%agDB9Q<)GyijurqC4IlOb-Q4;R=p<)afQf3C4529;J0knEJ;aMhYnV#uKlZs>C`4y2b{u!APM>P7y;~C@a3i397{0 zE6;vy0WAsd2ns!fnIkADU_{&M2C5d8FdDbOeDa8jb$8`T2d5Yn-snQ0`SLdvFFtr~ zw?LF213Im7vtmjg9YOFAqzY>QIOjMZ7>nb`<91zn3uqQPVl;5|9@brM#Uii7Y5IPA z7OOcXtAP5@5)=92;)C~KLYfsBejZCcc=@a@@AJSUEAC4`Zu|Kw)S<{S3ZbY!_?`Ex zPp3o;%xpX+#$|e0CK)+KqCh!0AP`Zp`)pB3@t&=QltzCa#CYh#l5?x7HeuW%8UYLV z$p$5@`b?lTL^ES)Jk-;Gz7F$GL#d4ME%g2AquJ4WI#U@{2|vZAy3mq%4MgCx1s8)o z0j9wc>M4%&8yt0bc3S@6;GqLbk~N{bpfjjTFc7Ff zLrq@QMtDULVog7ib8T^d3mwo}ze)o#1Lw9B+SK44a0L)c2nd8H#sVM62$;J~ffGWy zLYeTJ7nv{?3Y(>FDh=3A;WwBn^zkC0jT`}W%}jCbQBSbCwzmLdfgO&U;7D3dY@Oczkpzg9brSQi6e=x856T#ldxEDCJM zX)PTAC$Sh5%fexp#D+;~8Ik&G%qvY-W)yT5z|G_l{2J(UW4wK=aDrtdLlkMVU=sPP z0e{Vz=Wz}B!9JRy1aJs)h!%=>VE~-5hUUn@oR(179*i9v#FqsV^&p9|^=jgcDZ#_q zxLrdO9g9xdLH7~H`0f*;kYYcn&j27oUU^7xpbMeN$V0wir+s*nfbqvU#Dt9we4ry> zG%@C5NR94jRT9G1TR=5dm!PQhY17ntzr`|E-VXkK$GH3YI zgbZ(EP54FJn^?=3H12g2v!jP*JMa*7E6UY%7fMCIZsG$% zPiT>6uKYO-&G$LC8@%P_s03Yz4lnnySYT>4Et1hzH%50V)$+6qKj#IdaU;caGK=!O zq<`NWSKT2$HcjOxL@wCzH^VMv1Y>!QmmaYpcB^)*1g4cXH37d+nX@_ycv^WcuiMQ# zEgdVzS!r3>!=#v$S#-(N_1n!tz00V-3pzxwy%g*%6g}{P56#rO;uY4n&I*V#r zO584AKmbY|6p|P=Q}Rq7l*K$zhcVr64$C4ct5CRCgXJNGptoejLb<>$au~bKIPU|y zS-MGv>vVzfxGvS_(LO*u%=n>dvkhv3BoR0_Kr*@D3v}a`JXK78PA-?Jr2zKWT87ve z9P}Wol@TIegsHt0?i_H7)^->$83}QSlw>28BsJ3) zAWl0qGIR*pP8suYLv$3P zuLM?6OAk=jwl z*F@+B?`fOdBrSwzib$x)`Z)1rsPhxy_#xRQ$cy#yRphILeDGl|2!HPd2s}7O2{4O8 z^_J|1*8}9Zu!^$R+%<$m*Cm-5?}aym3`G{~fU<0?dJFL;vOS9uIuE_$Ee59{3L_rT z!tUX8Va$EBpCHJ>cz4*f_F3Ks$l;=VEhBQK(AzQ&ydL`{C874Jk_{1KZyM}F{PHPr zUCA|WoCtYXG9E5Z$-`s6q8oL=dl!h>wgaE3Q7G(Ct@v+=MHeXz40*sTn&^AmPYOYZ zqVpj8=MH*GkPy1yg7g9poJWYb&1xni#*&e2S!3pi3$olz)~OC5-gN;`w{ z!jiV1CyIe9RrsLz8=*L}3=$I495q}SjMiXM)VwJv1_$o;2l{>sNSfHZ-q3zI1r2&0 zQ)br)a8F)0da~Wj5vY7!xv!i-M(A4LCN(-HSlqbfaC3~Ad=;YaTGbHSv&4}XzDiJBgd79?V3G9(^xUBpoxg8y5)Z4<;*!yK5Z9Mcf!B=lE>P*yADv>HWf zwa88NQZ8A}OJsB1>XH(lxUvc}VsYl|NAzNub%WA4PFwG#=9QmFmhqhl$A)J2_c*0> ztbB!H?y!NE$?Fm~DvSb9*p#uKcbV_TA93PT_4SdwN>>b7lnMM;RkFunlq+W`z0a3@ zD#I*pl9Xl$HfyT+$&#N(w!>ciIJmvIdu;G7ZLFg|4-ada$Uq!IXIGWB)!c!2=zOf5 z_}cJh^bXA56xib-n(ylrQYn$v46l~)>g!ZRrKS1`Co9mdfB{QeR8g@T(X);TnlWJJ zn2b(w?f(s+ONJ5>wu2n*;+GtG!Q~AOF9zq{n6?mSpvh;`h2nD^>74}?@xFjT@1Hq37j-ABtH`6Pza%PQbG@^m)_Qx{dXy}&TlED0@q|Qr1JOG> z(bq#9)5_rI?JCJSvUmL@t`EUFQ;RytnKSf9Zgocvh?wzWTKHhbUtvDhDUf>TY~J;| zmPh1QhOe=5kHgF&+b+~Mgy4wjmOTxL>=2jE7dp*s=iiZG)*ls<+4yb`OXT^i2Ll-G z)nn-t?9P5oUDO?QH&&vYqLc;h2^H}I>eFSCoaFrzU7xm(&e?piJPV?5$YtL1nT(yh z%xkb4?=iPo0BwMt+b)tMw-e#Zxcf_--hH*2aZwdKUFnh}6W|(;*YvMTux#^*E{HS( zOVAOaosqA@=gPTv^E%S?Y%>IyMdga!S9nLCG8GNCT$XlRA7Wiqwk@F}V|$a-=r8T+Xy_WMn0}c-k&d~f6OHTR z;l6o34k}DqM~rW0+bqsD=XQwCz^ebG40C)My%$)33Ncl(z`br+nCakWhN%AZ*j+>T z(I_uik1Ffv=ENtMWVMiUdV#x$7d1W@F-dGdl+TtGzhx$JV^7brrsqsJ-_}>Z?Tqzh z;vg~`LHEq*+pp$Xoi-gy*bdL9(C4bhp_TH69GFBQ&0SxPz6h(V>4#vu__4ugPCmB? zbVw}r(!eIjL|&p^<(x}H%hIzmLzeWUHt5`lvFUi}*Sc{rLjIt7Iwo_Nr4#}GJ(pYy z3PHqvKOb=iMNIHKR58?F=+Nfj5@M-j!^RdI5e9LfUU$%dgdK+1=>R&u;JlrIMr7nl zJDYG#c(r<`SUYQ+=p*Nh=$S=d$P=d6?dWMX)6t192yjSm%8jrypH4DIrPxHZVnW)D zOt%#`NV$Isbndr8r3<5e=b!-Sp4OrB-oIFf-u#@Oo8n=Z*d5kZr^i{OjF!zQA=Lgx*93MT(v05)J{qIERayOzu2Q6+JRRgG&U{=soL zs547m=Vb4oP+g_+Z?n8@iRLl~3fnmG!!#$*M4+aXU=t zK3XszNmz6w%%G;UoMv>g9?lkfOkNQO-Iiu}KgYdnFeWrZ=v@W3iqJkL7LQH^LS;u3 z>SdHCT=bW2io7e1sme)0qSKFS?r-k37q!;y`yIOs=R1(+#U}NP?vr!?XFqYVz#zg1n;hH(4rwe_k4THn zmU%y-=FnULp~7M36aaxCrkmB*U>@Zzt~9)My;4lSXhhcOe4(7xq53P?gEm@tw3lFzBeHv^ zu(Ba!CS{U-ri8QhlQ8iC(PSvag-V+N#c3$Ap}E{rzw!qg8t*goobQ&n{R0%Pc6l}s z!vp4rfm;41634B*25yK70%26`C-bZ@DrB0ihvQT=e@R&b`$MtjNrk%XROBe$45J@JQ#Z*NoRj-J??!@g*|M;mp;{*fRVGU312h4tkBa zjkEr9w;Lsace=QSPa>-{aNG#Ly>v~U>Lyc8wsAs~G>||=qn^tHB4Ix$=YV3AGeI|E zgifj7T%H`4q>3c=xe{_$%EVi9J%U?g_rr@I+4MIC8>S&}9~dkz?MA2OMeZUxtoD8>esfUqm;(8ZECBA5n<}ce5*^ zyocf6((KGbEX8fa!);>=wZ7VS${hA%z!%^O2qwHOi`6}$jE5EqScBNymkl}VCpnj} zk)Kft}iOw7L`Y6Ji%jJ5NNkUd~Cypib-|V{F>si z6)WjtsZ{GSwYD^NsG63ksm0j^|Iks=>YcIvBHKVZRN>lSWPH?7=U-HV%9*K8^|04C{W(IxC% z`7KdhcRHyuZ94t>Qpu5iynfc9a=#)XaUoAg>q|roIGmkja)boK+zqQJoE#GFjiTnlr(R&Xv!ujZtSQ7UE zN4O?oL?0|!8}p;d2$2LX7r2koiBiG^EM~O@HM86&)+Yf)@u5f)X&rqtP_XWhYR7_o z!qHWt!yt883*N!cWfa9ub=`#K<*t22Hcv4pi1J4dWh@I2ZnGUJx=|wE=D1DW@Ty$W zPgLfxG6Dm-2_P#Yvz#-fuI7@J*TgN2TiT?BeGE1s=FeGM8)r&vC3zu;S8Y^Lv6Syn z&eG8>!?e3quN-+_mA{&$`#pOJAGNI;cXf;HB_qD(4ybFCV(xe}ThL!r4XV~)eP>IC zli4?r?nJ8@Y+gdH`G#|?b{6?g^G5VA$X!Q|IGF!rf31fbVSFw4i;rYN> zuIRyZ4$SVS)K;VbtSANle8TQ<4gUnn;vJ>&!IZQpKXrNuU~Y_uYkauG`PV7h@Os_L z9>NcXbth3Io2_X_7+RG1N%)iiR07)$bNLwQCdr&Z;eF7NK=0+C((Y30&Ali+CcU>d z#fteeZtMGtb|1*DyKTQ+5MAE9V|BLY@)LdKXPOhE`B2?HW{>Q5tRJ7cpj`aQ4k%uJ z)J4A1X>o^5fFa{Xw7q%_L~;X4%fBvY|=hA!i1gdT%t4 zLOe}WbZ>u$Z$(h^QKuNsyCLxLa7A;JU>P;{5;kUKu3G&jO^q{-)3fYMVZHL9VPO#A zmm5B}vmU5l)r#bCUjQe^$x zQ7{!cl^FvOMmu*I4#{@-ul^AeXEivN=zYcd?EFgyecYRDIbpt>@RI!W zvf#o&C;B^TGvZ<7EwlXopE-bH>fV9n3!w*W{K-oRm(>y0*;c_Ryckic#0cDTJ}?fU*+O95_3<%xJA$4>;Z%5mNV+})I^LP?mEqM9QF9&RrhTxSEy6v;}Hu4ytEaavCKU*U1Ebq zGV=7ljN;1;i4pUxZXlhUA{UhumSFC1O&Pj11n|Y2%KLIC)hR_Bf$-}$pJ1LR;e6&r zsFQs-60?~TIq`B@y5%fUPYe`j<|xsN;N_&>xWCO9ZChMxq`b+Yiyf9`_xD8>?8@m= zSkwfrAtOJg`mtz<3qsX5MbT}wm6TA@ZOVtL*mH63e@eG#*IrUWL7~cPdT@Kr%P7=3 z0^{->>Kc8x07QPUP&~c2GIKXzuPW6%alTXW$Gkt?P9fClB9$JaZF*PZH?B|MH_Q%@ z;=Fl&|?6#-_vOBtj3f;Emf@TDrm2Tr8+{Mm{Ky@tF+c56@vUJBbo z+Vrze)k4zn;m?EbHdXl*nJyM^bc?g$tTes|rd+Yax6uU{{u)#>r?fN{0yBJNpiQAn zW9WGFTSviXR-`kdEQ5n;!hV4xs2D49#Z>J!0%1`huQM?X@TL$C>UC!BGv}WMpRs>T zBzJ-8;l<+1Fy^GoRfq|p<_K443mlV^6~_3L7_P{0?T`($5fp6LnJyN-F50Uy!b zYwDNM{5EM_ZM zxAJ(A!XT0iA}tJ|_{?7r$38*XEW?OrbPZdnry-Ca+AU0Rhs*7gF@+=e7WL5Alse3cax4)=b^J9 zPO$9>dT}m@H7v6TV z#+=P7XZ|Go(deXu%bHX$ua_TM^(`2CA0oVvL3$-)vVi9!P9!;=+*eOZ|AHUZ1{UD^ zK_iD5I8gA|)(5g##z_V?vA>GbX3qIXw~7i~X567uZlYU4oxIHU5IH$o;x7Z;!NHh& z^9UJ8n6SfzDdUfAup4gTb-4x^?27DvtgCg>XevL>!3iS7whP3t#SrY|Oyz4>;&Qwn z?A7rMS&qgll7if0-SC>WhmM_D>8YJNh6>`V1~9quDtU1%il-6_E<+2yJ*>^0YkZwt z7pEYE)o*~6N+@`@k8eK0rWw|9{Iai^KLI|K3w$>tv366c`zsOoZTx_kkhr&Y2ix!8KaitnC?JA0l&}D154F zA~rvJ&&ag*aIV|k=2C8l3G`FF&3=vM(nE8HVTrind%XfBorE}4meYs;rvvW`Y=r*` zAVpRT#uE!MA#ti#*8b&`2yIS$;(~>9xL#Qkh2B}&*kNld<&aiY+VY^^VxOTv0?`ik zq;*~lI=@V0!5zo%=4YN(l@Xez9J$kFiIqyce$Hj5lZ&6b!~*H#ekai=LL`qdp|rSW z5NV~&N^Yh@Q(im$oXdx5H6hpxFo6iSR+Iha{AMm-paPJ!PInW2)A-e^~Ik z&uH*9*8bAAWK~7dPCsi-NFzSqYwf>i@1U9u^_r%apD>yr3B#ePCGH;XU6riq)1#xU zl{|rG`r-NQ=NV{l*FZci<)W&A;yI3w78$)ji1iz0BV0c#FFZ%+lIV8HiB3IN-x~A_emP7H+eS+Um&j46P#k9M zM<4k~6{xiIbHIa14yQ;?zCDT(FxFpIe->CS!k8`8Ag#OC) zK$i>K2t%Nf?_KoqHb%wuK2@}?9N;XHaYS|P>xazKfr4-3J#$I9Qk>mBPO8rCXi1rp z`ACwb_^i{$;9#l7n1piVbcRwfV8oQ|_pnOnZ?!yb!q|LCVdne<+%!D=lZ$lV`I$S^^OXYhh}d_*OchcXCub}!-Vduu2~kSG4GWtz$eSwLAExbx{|Do5*LEet$>B! ziMg=vn%sq@(!?zp&b-d<)>I~xS-uXefjhc2imAeXeZ(9-n zt==Bz1LZOWkH9ITfE&()R0 z?3m{^)A z)wgDw#dopuwIQPt9P;jSuzS8{By{0#F zMfEl}S=99@*TpQb`)^H`Ukf`ZoAgDC$Pq8{I&q)n9fKLjXbo;6zV9WSxXRDTNGt!? zD>|V(DOY6(TM>xd12;l`Br1GknKL)N+lVzKHBHOqySUJucYAMb||9K^G4E7Yz$`MUe_)6K+do+ZI_ zC5H0A%CedT!Qsrt{a4J**xEo9NPad4;T6^7TFH z%R8rGa(_yIt!$>%K$4;~ccm~ops~w8m36iq0kf*;t|3F#9Dz)e9%;1P>P(mv z7exnm(Ha(Wx03Is*&tMW5m@tCDuFh5mRveV{}l8ze|IEHlMBqbqw`Ge#yedT&h|mF z5Vvac=xuk=obLYhvh0d}o@_FE(Qp#0pS`{XJ#1Y00vQ?p?{k~{0| zV5;UA9;q{2TbCeuOl6=?{+QN1E2Y`Z-eX(_dVoNitw{RfNe^DHn?@N1U++_*n>fKp zza0&GefhB2BP4--`aSOh>6daEdg8ejG{VZa=__D<`2bbog#v1#+lP|D|QU{ zz@+hYt=Dp`$tZ;&czo(g)p4byeoswS!)?R{t5Rl5u_+Obuj%8r%%*eS=6$i$97Re8BK zHay;QT($a_7B3sA{h-S{a41ot226J8)=lhbnlGBhls>3tAM(ta52=q8R}Jg2M);^Q zAWEOrI+KiYu^znizJ?rjdwaDtt^F+K{n|^|W+a8WS}P~-_Ru0PPkZ}S!`2WynJbcb z9u&Nxh{u#`f;G1p3VFRZ@3H12xUZM-mIquQ_c5q+m>3G2OiPk+>t~<2*(WgQ6P~aA zRQ;9urf!!>ENK4Ly%xM;l5ej2JDTmt1J}z|c9HgLYPT2d$u;G*O?I~kMlwe794a+% zvs73P+WluzIv;<`SNI#1evu*e3<}N@W^@)ly>ow(B9ZF)K2b~**03cuYCqeB!CqOy zcaZgAnI12gnVnuJDd>`VawLE--#^HTI{=Jl_bORp1mPYRCF4y)}iw5 zd^i_5{``Iz37<5>wOFw?txs+sy`b}y+kkY6cegRxy2dx#=IPq$%?I4_rvYKi;G^cL zOHIh@(VLea6?K@ycSZ8jKa`N&o-Rs1`^xU1HhtTTTc9tEnm$+eBmO-33al3m^h*Ol zMkB+?57EWPmBzY0T#8Zx&HOWiw>`7-xO{Z&IvZma&zSAeQdtj+~qX)1Di?P>C-IhLoPyf#KM({WCQ7}IB`m#?Ts-#jyGUg znIPLDZ5O%KlVdp{t6G+u0F~>~1A8t{CHZ(%E#u@0_Z?47>U1VppmS*r)uKH2d%P2pQx7H=@E@9FV5TUzgcg^ij$^qY_T5(ERP-1T zq-r`ElD_E?F2SFjg%@hDj)n}fru7Onx|~xetS-$wHAQ(^gTftXQ8w{oUMb1Yl9}3! zvcsR4laRsG8EcUvI}33E-l?1A>%{h-YZSSna3UGoC$5u!$a>$IiV!X{o8Kgd*oPH>0g--1{7pK8eeT|@7mu4N_UZhn z*z&?vj@~L_Onu{`tp&d9Z18H+$jY!m7OD5SKP={Bp%x@H_wjrpqfxcJp!@!seQS@* z)^WsK{i%vDy0j)gk7vXXJ?AP;;Is{!cTezaTA+_PxhalA!EE^HV^rBM!Ehp!bT zR~r>#nDp|eK7anKWY=Okfh7W=eyK@qgHaXPGT)WvZ?wC%H0qCEQ0cMgke=45@7XH<5E(*>aYEx0s9$L6^(;8)msYn|RG_@r*TX zsq0Mo+8fB{@bO=kd@U>Pa%N5o#|NNS*tkz6?)Io8@KqT;@T(w8(z}vu3HWdAdfK}B zrxV*l9*>jPJl7Al_BF}BpT{#A}zY!PI3P04D#~uUG;iWTH~?>f=iOG zD)&n41NuCU&5Kctk7v1KSoORKU3;h2hKo3bqvc0?BFj^Ws4sRu*i=ZoW7|_Ke7Kb8 zi_dZU@k3i$0%JW%^d7eMzDRXoWqly4JnAvh#!TyK$UFz9t6-m#kY9rFee z>d>9tvvQXOPEGjgN47|PmUgcH9sxSHCNE6l zFB~#g6qNR0{UJ(h1@^o23hp^sK`ny{@9MHaKAU!P13`dc0BPVjVAHjCx;U;#W&A0+ zfpPWRl-GAixBFm2z^;dRV$;p3DBF$UQR$^wFI;jA6H+@0C19g8>{2jEU*r~j_}vW0 zZ91f}JX~Jfe3kr(0}9hq;)xbLcER;w+J-f6JLR*%RsbNys{(qV-*m1cY+Pin1wrR2 zG>Y8nR~Qf5XkF0E3*Z!Jt=`$D718kpIg}#sH+4@}aVMipMDKLd_@eW0E9ApHqs5jHX!gAhR;}(`lD%XrEbo~voetu3 zFJ4}MRpFl&^INGsS9%?+3(;pFUb$Ov zIiKY^o)^<^yT{Gm=w2Kc^KLY-6hV1sX1U1j3gZFSJ%_r@!24-tgw zFnc`u=r`E{s;}`5)#H56zW+jw8vLoLFDqCXLoML#;TK;%x6Cu^EOoTjV@4N78vSlK zhS*$^pI&-7*3f|46hkXKSSp`>m3`BEx@WK!{ziqc*;9*r8$AP)cQ7w%sPKGA8qmKtJ=!^ZGEw2p+r% zs&#YGpeIyAx$rCnP3Z!bya|woE7miexb_7r({uJ38$DTjDE(yV1CzfHQLx<2l32j7 z)>H`=%SawZd3YE{T)jp;!5$W`PdzwwD z$n=%|pHIt+w!*7Z6~=EHLIMC@NB{umzxTAfg{h5=k)gA`DszJ@DaUpSQE~)8mFQ z%pWZ^^7SKw*y=|(k!?QCB5D==t(^NCo|vUfA;tCAaM*$y@kWKw`>zJ7r6%0*KiCs$ zSF(c%+edQ_Mz!7uh9HM>BY*BZC3P53fpK+v~>!q(2yBIGzcYMH;ZPKojJQ_GQZM-{0KWrGhfPc zLauEmU*hk#2VJ0ei3sUt7UGdaScm#T_MnsxTOEu?|>m<-{SCY1is=b$pVDv&P3=G4lFMk~nO5*8{#kbJL zwZ|h*$fb|Q@|OPn8PkR@`&efiw~Aw8@_D%BsEq0(e8ALUZCD-D61hbODz1`SM&J&&knj>kfAPQ$bU6{4>Upx@<;%Ri1^wX z(0C2P=_Z|9QcK5j(gCe+ULM-q)mneQWHc8ILde*3w*cBrl1MveIp?v)7R|Qo-x^%4%R!_E~nK_q)VMSe)Ze z^f@|jl3)#OXYNTO!diBgmjw)^E7I|k1V+YMdw4_C;nY-mi~J1hc!Z8|UANJM%=&X> zQZMZCinAyLK4JS1ZaQN@{pTbQU$1RI*Uci7Q~^axLQFf!19A|QR!Sl{oDUO^3Uv;+ z6$`dj&_N(xg;uIMuGb`TP&G}1AiV|26$&&ea+su?%AyOuq3)eEMJ0{094Oh5%U65X z^i-<4=^`uJHA=;Am$pZtxlpJD>t*IF*a_2BhbK~3kODsv?D%=ZUA(bJWNB7tUr79G z8-uV}!89sL*;gV+nlAAwBneLs;_+VkP77Zd?oCk&tcV-LHzPaBWfdpbV7+vy5PCVy z1t`CBI7CrvKyp3F+<&XYTE15UZ6OL~HNTyG$4kj}oL&DJ4ZFt`S2{h2AaU!ehQjFR zvleQ`!)!O6a8f+ZjS1$>a~{3%)k6Eh`OTxZ`RW9;SPI|9vnwlx&cd(a20H4;#4pdo zj>gj4(H{nGa9ukC7q>%TQLiY4^dB}dw~m0X_MCw+G4gwIIF!r%E=}KtnYffYmr$-W zo1uf5pVdOc-YR?j1rl#}*OnBz=lrHEk377?nSLS{NBx0I*b}U6lx@T5hp04j-}u>= z<;VTH9>21ix1P!yUnMH8o=a_qH8V8<{Bk0FTylla4SHzDp$-8u0J$yqcG(@x(E@lF zfu`=Vsu2WCxws=DkBfJjATH@U>O#FkF8Nbi+=!eX)fgCNdY_%7WvwCLg>Xkz>bzdL z1!^SWaYnvoS7svh3>LveT=1^&(OUXbS^A@IvRNdC4Lqh}5&24;X)R7baZTjE&}Y*G zUd-QB{zJj1osxqWlwv#)Mk$oO> z)S%2UHUX8xkNGBffxTFa;VBVAJ=i4sNpM}dJB=-*iGo;CZlpWUlfdN@+UM`BC{MsB z(CkD!jgNp_M>3-&tDGvq!mFI#z~3dJNGGGIG@;F*&E87ipjRs0{%~(g zMt62`k^ClEcAV}3OEkjSsRQ_@u-333>RE=`esMrS-+_e#0QqkV3slFM4k+~dJ19`p zl;}Fxeg>@IM}duPi7JTvonIYKNOmXj#g+(zUs?R5OZYlycM9kbq1?O)#P@Vd&%xQ= z(sYYBKAyj}&*D+%o?gUHZP(VY(Cl&B%!tJj;^0s*C7V9mQ?IuBH(V<@gHe!H@AfLV z)(1zy$%;(J?Y|fEMVtI=sZ&|JPR)N=Kw=ZIeg+X2x-KxTGoZ@(r>ayv?`nQe-#{0E zYAygn0?z+XRi=OHnyn~kHNb$>NqP5y4 zlYd;q`{@&RVfJ#u!U!yyoXi-Tlt^MRW-$~c1S1|>jK5^=khHZc@(gG34PE-i<$h5P zbBw_2;2z%D422+X{=Jjt=dtc|X49C)4#(TjN;d2|!_1JYhxWkRY}21w@P6#N?9bQsSYCs|3_;#0~XOgK?}J4mr$Uwo&K;gaBpX5YpVaZ zhV~EZ|1nPdjywgOQ3Did_=W>f&A=k^C!`Vge~2_O{d?5{>-(?7YrvGo=ZDdEX`p3O zfUQpWPed7DrT@>p`R~d({j=E_+Ijq;DzN)9&@uhRedKv4Yp9R5eL4UFg<=2Ne_w&! z`9A;}+gSb$2E1+jldtkN_@+T5B}WMf^np|;0D#b+v=alG_dkIBqXYe|Q~ia96C
Yf_`{OrK7rIYH90Oa@WROx@i{;$}{*2Tuz(&>-8e>w*z#@~CyPdEi_ zW$M-^BNYI^9R&m+^*aRMWAyJ({@w`;9UR;ofnPxXNB!M_Fm^L)zhn179Rf5)(&|2vq!M!vsu{xwYfowN5JaQ-W3{hji! l5#sNZsf&MKn?ERjix(B7A%HOj0DunsD8m2%U{`+}{ePlXsp0?t literal 0 HcmV?d00001 diff --git a/src/bootsupport/modules/punk/repl-0.1.2.tm b/src/bootsupport/modules/punk/repl-0.1.2.tm index f2977c09..f976ae57 100644 --- a/src/bootsupport/modules/punk/repl-0.1.2.tm +++ b/src/bootsupport/modules/punk/repl-0.1.2.tm @@ -3,9 +3,7 @@ #todo - make repls configurable/pluggable packages -#list/string-rep bug -global run_commandstr "" - +# ----------------------------------- set stdin_info [chan configure stdin] if {[dict exists $stdin_info -inputmode]} { #this is the only way I currently know to detect console on windows.. doesn't work on Alma linux. @@ -19,37 +17,46 @@ if {[dict exists $stdin_info -mode]} { } #give up for now set tcl_interactive 1 +unset stdin_info +# ----------------------------------- + #------------------------------------------------------------------------------------- if {[package provide punk::libunknown] eq ""} { #maintenance - also in src/vfs/_config/punk_main.tcl - set libunks [list] - foreach tm_path [tcl::tm::list] { - set punkdir [file join $tm_path punk] - if {![file exists $punkdir]} {continue} - lappend libunks {*}[glob -nocomplain -dir $punkdir -type f libunknown-*.tm] - } - set libunknown "" - set libunknown_version_sofar "" - foreach lib $libunks { - #expecting to be of form libunknown-.tm - set vtail [lindex [split [file tail $lib] -] 1] - set thisver [file rootname $vtail] ;#file rootname x.y.z.tm - if {$libunknown_version_sofar eq ""} { - set libunknown_version_sofar $thisver - set libunknown $lib - } else { - if {[package vcompare $thisver $libunknown_version_sofar] == 1} { - set libunknown_version_sofar $thisver - set libunknown $lib + namespace eval ::punk::libunknown::boot { + variable libunknown_boot + set libunknown_boot {{} { + set libunks [list] + foreach tm_path [tcl::tm::list] { + set punkdir [file join $tm_path punk] + if {![file exists $punkdir]} {continue} + lappend libunks {*}[glob -nocomplain -dir $punkdir -type f libunknown-*.tm] } - } - } - if {$libunknown ne ""} { - source $libunknown - if {[catch {punk::libunknown::init -caller triggered_by_repl_package_require} errM]} { - puts "error initialising punk::libunknown\n$errM" - } + set libunknown "" + set libunknown_version_sofar "" + foreach lib $libunks { + #expecting to be of form libunknown-.tm + set vtail [lindex [split [file tail $lib] -] 1] + set thisver [file rootname $vtail] ;#file rootname x.y.z.tm + if {$libunknown_version_sofar eq ""} { + set libunknown_version_sofar $thisver + set libunknown $lib + } else { + if {[package vcompare $thisver $libunknown_version_sofar] == 1} { + set libunknown_version_sofar $thisver + set libunknown $lib + } + } + } + if {$libunknown ne ""} { + uplevel 1 [list source $libunknown] + if {[catch {punk::libunknown::init -caller triggered_by_repl_package_require} errM]} { + puts "error initialising punk::libunknown\n$errM" + } + } + }} + apply $libunknown_boot } } else { #This should be reasonably common - a punk shell will generally have libunknown loaded @@ -2817,38 +2824,41 @@ namespace eval repl { namespace eval ::punk::libunknown {} set ::punk::libunknown::epoch %lib_epoch% - set libunks [list] - foreach tm_path [tcl::tm::list] { - set punkdir [file join $tm_path punk] - if {![file exists $punkdir]} {continue} - lappend libunks {*}[glob -nocomplain -dir $punkdir -type f libunknown-*.tm] - } - set libunknown "" - set libunknown_version_sofar "" - foreach lib $libunks { - #expecting to be of form libunknown-.tm - set vtail [lindex [split [file tail $lib] -] 1] - set thisver [file rootname $vtail] ;#file rootname x.y.z.tm - if {$libunknown_version_sofar eq ""} { - set libunknown_version_sofar $thisver - set libunknown $lib - } else { - if {[package vcompare $thisver $libunknown_version_sofar] == 1} { + apply {{} { + set libunks [list] + foreach tm_path [tcl::tm::list] { + set punkdir [file join $tm_path punk] + if {![file exists $punkdir]} {continue} + lappend libunks {*}[glob -nocomplain -dir $punkdir -type f libunknown-*.tm] + } + set libunknown "" + set libunknown_version_sofar "" + foreach lib $libunks { + #expecting to be of form libunknown-.tm + set vtail [lindex [split [file tail $lib] -] 1] + set thisver [file rootname $vtail] ;#file rootname x.y.z.tm + if {$libunknown_version_sofar eq ""} { set libunknown_version_sofar $thisver set libunknown $lib + } else { + if {[package vcompare $thisver $libunknown_version_sofar] == 1} { + set libunknown_version_sofar $thisver + set libunknown $lib + } } } - } - if {$libunknown ne ""} { - source $libunknown - if {[catch {punk::libunknown::init -caller "repl::init init_script parent interp"} errM]} { - puts "repl::init problem - error initialising punk::libunknown\n$errM" + if {$libunknown ne ""} { + uplevel 1 [list source $libunknown] + if {[catch {punk::libunknown::init -caller "repl::init init_script parent interp"} errM]} { + puts "repl::init problem - error initialising punk::libunknown\n$errM" + } + #package require punk::lib + #puts [punk::libunknown::package_query snit] + } else { + puts "repl::init problem - can't load punk::libunknown" } - #package require punk::lib - #puts [punk::libunknown::package_query snit] - } else { - puts "repl::init problem - can't load punk::libunknown" - } + }} + #----------------------------------------------------------------------------- package require punk::packagepreference @@ -3543,34 +3553,38 @@ namespace eval repl { if {[package provide punk::libunknown] eq ""} { namespace eval ::punk::libunknown {} set ::punk::libunknown::epoch %lib_epoch% - set libunks [list] - foreach tm_path [tcl::tm::list] { - set punkdir [file join $tm_path punk] - if {![file exists $punkdir]} {continue} - lappend libunks {*}[glob -nocomplain -dir $punkdir -type f libunknown-*.tm] - } - set libunknown "" - set libunknown_version_sofar "" - foreach lib $libunks { - #expecting to be of form libunknown-.tm - set vtail [lindex [split [file tail $lib] -] 1] - set thisver [file rootname $vtail] ;#file rootname x.y.z.tm - if {$libunknown_version_sofar eq ""} { - set libunknown_version_sofar $thisver - set libunknown $lib - } else { - if {[package vcompare $thisver $libunknown_version_sofar] == 1} { + + apply {{} { + set libunks [list] + foreach tm_path [tcl::tm::list] { + set punkdir [file join $tm_path punk] + if {![file exists $punkdir]} {continue} + lappend libunks {*}[glob -nocomplain -dir $punkdir -type f libunknown-*.tm] + } + set libunknown "" + set libunknown_version_sofar "" + foreach lib $libunks { + #expecting to be of form libunknown-.tm + set vtail [lindex [split [file tail $lib] -] 1] + set thisver [file rootname $vtail] ;#file rootname x.y.z.tm + if {$libunknown_version_sofar eq ""} { set libunknown_version_sofar $thisver set libunknown $lib + } else { + if {[package vcompare $thisver $libunknown_version_sofar] == 1} { + set libunknown_version_sofar $thisver + set libunknown $lib + } } } - } - if {$libunknown ne ""} { - source $libunknown - if {[catch {punk::libunknown::init -caller "repl::init init_script code interp for punk"} errM]} { - puts "error initialising punk::libunknown\n$errM" + if {$libunknown ne ""} { + uplevel 1 [list source $libunknown] + if {[catch {punk::libunknown::init -caller "repl::init init_script code interp for punk"} errM]} { + puts "error initialising punk::libunknown\n$errM" + } } - } + }} + } else { puts stderr "punk::libunknown [package provide punk::libunknown] already loaded" } @@ -3594,6 +3608,9 @@ namespace eval repl { } else { puts stderr "repl code interp loaded vfs,vfs::zip lag:[expr {[clock millis] - $tsstart}]" } + unset errM + unset tsstart + #puts stderr "package unknown: [package unknown]" #puts stderr ----- @@ -3634,6 +3651,8 @@ namespace eval repl { puts stderr "========================" lappend ::codethread_initstatus "error $errM" error "$errM" + } else { + unset errM } } } @@ -3682,7 +3701,8 @@ namespace eval repl { thread::id } set init_script [string map $scriptmap $init_script] - + #REVIEW - the same initscript sent for all values of $safe and it switches on values of $safe provided in %args% + #we already know $safe in this thread when generating the script - so why send the large script to the thread to then switch on that? #thread::send $codethread $init_script if {![catch { diff --git a/src/bootsupport/modules/punk/zip-0.1.0.tm b/src/bootsupport/modules/punk/zip-0.1.0.tm deleted file mode 100644 index 44af7472..00000000 --- a/src/bootsupport/modules/punk/zip-0.1.0.tm +++ /dev/null @@ -1,761 +0,0 @@ -# -*- tcl -*- -# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'pmix make' or bin/punkmake to update from -buildversion.txt -# module template: shellspy/src/decktemplates/vendor/punk/modules/template_module-0.0.3.tm -# -# 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) 2024 JMN -# (C) 2009 Path Thoyts -# -# @@ Meta Begin -# Application punk::zip 0.1.0 -# Meta platform tcl -# Meta license -# @@ Meta End - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# doctools header -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -#*** !doctools -#[manpage_begin shellspy_module_punk::zip 0 0.1.0] -#[copyright "2024"] -#[titledesc {Module API}] [comment {-- Name section and table of contents description --}] -#[moddesc {-}] [comment {-- Description at end of page heading --}] -#[require punk::zip] -#[keywords module] -#[description] -#[para] - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - -#*** !doctools -#[section Overview] -#[para] overview of punk::zip -#[subsection Concepts] -#[para] - - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Requirements -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - -#*** !doctools -#[subsection dependencies] -#[para] packages used by punk::zip -#[list_begin itemized] - -package require Tcl 8.6- -package require punk::args -#*** !doctools -#[item] [package {Tcl 8.6}] -#[item] [package {punk::args}] - -#*** !doctools -#[list_end] - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - -#*** !doctools -#[section API] - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# oo::class namespace -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -#tcl::namespace::eval punk::zip::class { - #*** !doctools - #[subsection {Namespace punk::zip::class}] - #[para] class definitions - #if {[tcl::info::commands [tcl::namespace::current]::interface_sample1] eq ""} { - #*** !doctools - #[list_begin enumerated] - - # oo::class create interface_sample1 { - # #*** !doctools - # #[enum] CLASS [class interface_sample1] - # #[list_begin definitions] - - # method test {arg1} { - # #*** !doctools - # #[call class::interface_sample1 [method test] [arg arg1]] - # #[para] test method - # puts "test: $arg1" - # } - - # #*** !doctools - # #[list_end] [comment {-- end definitions interface_sample1}] - # } - - #*** !doctools - #[list_end] [comment {--- end class enumeration ---}] - #} -#} -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# Base namespace -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -tcl::namespace::eval punk::zip { - tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase - #variable xyz - - #*** !doctools - #[subsection {Namespace punk::zip}] - #[para] Core API functions for punk::zip - #[list_begin definitions] - - proc Path_a_atorbelow_b {path_a path_b} { - return [expr {[StripPath $path_b $path_a] ne $path_a}] - } - proc Path_a_at_b {path_a path_b} { - return [expr {[StripPath $path_a $path_b] eq "." }] - } - - proc Path_strip_alreadynormalized_prefixdepth {path prefix} { - if {$prefix eq ""} { - return $path - } - set pathparts [file split $path] - set prefixparts [file split $prefix] - if {[llength $prefixparts] >= [llength $pathparts]} { - return "" - } - return [file join \ - {*}[lrange \ - $pathparts \ - [llength $prefixparts] \ - end]] - } - - #StripPath - borrowed from tcllib fileutil - # ::fileutil::stripPath -- - # - # If the specified path references/is a path in prefix (or prefix itself) it - # is made relative to prefix. Otherwise it is left unchanged. - # In the case of it being prefix itself the result is the string '.'. - # - # Arguments: - # prefix prefix to strip from the path. - # path path to modify - # - # Results: - # path The (possibly) modified path. - - if {[string equal $::tcl_platform(platform) windows]} { - # Windows. While paths are stored with letter-case preserved al - # comparisons have to be done case-insensitive. For reference see - # SF Tcllib Bug 2499641. - - proc StripPath {prefix path} { - # [file split] is used to generate a canonical form for both - # paths, for easy comparison, and also one which is easy to modify - # using list commands. - - set prefix [file split $prefix] - set npath [file split $path] - - if {[string equal -nocase $prefix $npath]} { - return "." - } - - if {[string match -nocase "${prefix} *" $npath]} { - set path [eval [linsert [lrange $npath [llength $prefix] end] 0 file join ]] - } - return $path - } - } else { - proc StripPath {prefix path} { - # [file split] is used to generate a canonical form for both - # paths, for easy comparison, and also one which is easy to modify - # using list commands. - - set prefix [file split $prefix] - set npath [file split $path] - - if {[string equal $prefix $npath]} { - return "." - } - - if {[string match "${prefix} *" $npath]} { - set path [eval [linsert [lrange $npath [llength $prefix] end] 0 file join ]] - } - return $path - } - } - - proc Timet_to_dos {time_t} { - #*** !doctools - #[call [fun Timet_to_dos] [arg time_t]] - #[para] convert a unix timestamp into a DOS timestamp for ZIP times. - #[example { - # DOS timestamps are 32 bits split into bit regions as follows: - # 24 16 8 0 - # +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+ - # |Y|Y|Y|Y|Y|Y|Y|m| |m|m|m|d|d|d|d|d| |h|h|h|h|h|m|m|m| |m|m|m|s|s|s|s|s| - # +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+ - #}] - set s [clock format $time_t -format {%Y %m %e %k %M %S}] - scan $s {%d %d %d %d %d %d} year month day hour min sec - expr {(($year-1980) << 25) | ($month << 21) | ($day << 16) - | ($hour << 11) | ($min << 5) | ($sec >> 1)} - } - - proc walk {args} { - #*** !doctools - #[call [fun walk] [arg ?options?] [arg base]] - #[para] Walk a directory tree rooted at base - #[para] the -excludes list can be a set of glob expressions to match against files and avoid - #[para] e.g - #[example { - # punk::zip::walk -exclude {CVS/* *~.#*} library - #}] - - set argd [punk::args::get_dict { - *proc -name punk::zip::walk - -excludes -default "" -help "list of glob expressions to match against files and exclude" - -subpath -default "" - *values -min 1 -max -1 - base - fileglobs -default {*} -multiple 1 - } $args] - set base [dict get $argd values base] - set fileglobs [dict get $argd values fileglobs] - set subpath [dict get $argd opts -subpath] - set excludes [dict get $argd opts -excludes] - - - set imatch [list] - foreach fg $fileglobs { - lappend imatch [file join $subpath $fg] - } - - set result {} - #set imatch [file join $subpath $match] - set files [glob -nocomplain -tails -types f -directory $base -- {*}$imatch] - foreach file $files { - set excluded 0 - foreach glob $excludes { - if {[string match $glob $file]} { - set excluded 1 - break - } - } - if {!$excluded} {lappend result $file} - } - foreach dir [glob -nocomplain -tails -types d -directory $base -- [file join $subpath *]] { - set subdir_entries [walk -subpath $dir -excludes $excludes $base {*}$fileglobs] - if {[llength $subdir_entries]>0} { - #NOTE: trailing slash required for entries to be recognised as 'file type' = "directory" - #This is true for 2024 Tcl9 mounted zipfs at least. zip utilities such as 7zip seem(icon correct) to recognize dirs with or without trailing slash - #Although there are attributes on some systems to specify if entry is a directory - it appears trailing slash should always be used for folder names. - set result [list {*}$result "$dir/" {*}$subdir_entries] - } - } - return $result - } - - - proc extract_zip_prefix {infile outfile} { - set inzip [open $infile r] - fconfigure $inzip -encoding iso8859-1 -translation binary - if {[file exists $outfile]} { - error "outfile $outfile already exists - please remove first" - } - chan seek $inzip 0 end - set insize [tell $inzip] ;#faster (including seeks) than calling out to filesystem using file size - but should be equivalent - chan seek $inzip 0 start - #only scan last 64k - cover max signature size?? review - if {$insize < 65559} { - set tailsearch_start 0 - } else { - set tailsearch_start [expr {$insize - 65559}] - } - chan seek $inzip $tailsearch_start start - set scan [read $inzip] - #EOCD - End Of Central Directory record - set start_of_end [string last "\x50\x4b\x05\x06" $scan] - puts stdout "==>start_of_end: $start_of_end" - - if {$start_of_end == -1} { - #no zip cdr - consider entire file to be the zip prefix - set baseoffset $insize - } else { - set filerelative_eocd_posn [expr {$start_of_end + $tailsearch_start}] - chan seek $inzip $filerelative_eocd_posn - set cdir_record_plus [read $inzip] ;#can have trailing data - binary scan $cdir_record_plus issssiis eocd(signature) eocd(disknbr) eocd(ctrldirdisk) \ - eocd(numondisk) eocd(totalnum) eocd(dirsize) eocd(diroffset) eocd(comment_len) - #rule out a false positive from within a nonzip (e.g plain exe) - #There exists for example a PK\5\6 in a plain tclsh, but it doesn't appear to be zip related. - #It doesn't seem to occur near the end - so perhaps not an issue - but we'll do some basic checks anyway - #we only support single disk - so we'll validate a bit more by requiring disknbr and ctrldirdisk to be zeros - #todo - just search for Pk\5\6\0\0\0\0 in the first place? //review - if {$eocd(disknbr) + $eocd(ctrldirdisk) != 0} { - #review - should keep searching? - #for now we assume not a zip - set baseoffset $insize - } else { - #use the central dir size to jump back tko start of central dir - #determine if diroffset is file or archive relative - - set filerelative_cdir_start [expr {$filerelative_eocd_posn - $eocd(dirsize)}] - puts stdout "---> [read $inzip 4]" - if {$filerelative_cdir_start > $eocd(diroffset)} { - #easy case - 'archive' offset - (and one of the reasons I prefer archive-offset - it makes finding the 'prefix' easier - #though we are assuming zip offsets are not corrupted - set baseoffset [expr {$filerelative_cdir_start - $eocd(diroffset)}] - } else { - #hard case - either no prefix - or offsets have been adjusted to be file relative. - #we could scan from top (ugly) - and with binary prefixes we could get false positives in the data that look like PK\3\4 headers - #we could either work out the format for all possible executables that could be appended (across all platforms) and understand where they end? - #or we just look for the topmost PK\3\4 header pointed to by a CDR record - and assume the CDR is complete - - #step one - read all the CD records and find the highest pointed to local file record (which isn't necessarily the first - but should get us above most if not all of the zip data) - #we can't assume they're ordered in any particular way - so we in theory have to look at them all. - set baseoffset "unknown" - chan seek $inzip $filerelative_cdir_start start - #binary scan $cdir_record_plus issssiis eocd(signature) eocd(disknbr) eocd(ctrldirdisk) \ - # eocd(numondisk) eocd(totalnum) eocd(dirsize) eocd(diroffset) eocd(comment_len) - #load the whole central dir into cdir - - #todo! loop through all cdr file headers - find highest offset? - #tclZipfs.c just looks at first file header in Central Directory - #looking at all entries would be more robust - but we won't work harder than tclZipfs.c for now //REVIEW - - set cdirdata [read $inzip $eocd(dirsize)] - binary scan $cdirdata issssssiiisssssii cdir(signature) cdir(_vermadeby) cdir(_verneeded) cdir(gpbitflag) cdir(compmethod) cdir(lastmodifiedtime) cdir(lastmodifieddate)\ - cdir(uncompressedcrc32) cdir(compressedsize) cdir(uncompressedsize) cdir(filenamelength) cdir(extrafieldlength) cdir(filecommentlength) cdir(disknbr)\ - cdir(internalfileattributes) cdir(externalfileatributes) cdir(relativeoffset) - - #since we're in this branch - we assume cdir(relativeoffset) is from the start of the file - chan seek $inzip $cdir(relativeoffset) - #let's at least check that we landed on a local file header.. - set local_file_header_beginning [read $inzip 28]; #local_file_header without the file name and extra field - binary scan $local_file_header_beginning isssssiiiss lfh(signature) lfh(_verneeded) lfh(gpbitflag) lfh(compmethod) lfh(lastmodifiedtime) lfh(lastmodifieddate)\ - lfh(uncompressedcrc32) lfh(compressedsize) lfh(uncompressedsize) lfh(filenamelength) lfh(extrafieldlength) - #dec2hex 67324752 = 4034B50 = PK\3\4 - puts stdout "1st local file header sig: $lfh(signature)" - if {$lfh(signature) == 67324752} { - #looks like a local file header - #use our cdir(relativeoffset) as the start of the zip-data (//review - possible embedded password + end marker preceeding this) - set baseoffset $cdir(relativeoffset) - } - } - puts stdout "filerel_cdirstart: $filerelative_cdir_start recorded_offset: $eocd(diroffset)" - } - } - puts stdout "baseoffset: $baseoffset" - #expect CDFH PK\1\2 - #above the CDFH - we expect a bunch of PK\3\4 records - (possibly not all of them pointed to by the CDR) - #above that we expect: *possibly* a stored password with trailing marker - then the prefixed exe/script - - if {![string is integer -strict $baseoffset]} { - error "unable to determine zip baseoffset of file $infile" - } - - if {$baseoffset < $insize} { - set out [open $outfile w] - fconfigure $out -encoding iso8859-1 -translation binary - chan seek $inzip 0 start - chan copy $inzip $out -size $baseoffset - close $out - close $inzip - } else { - close $inzip - file copy $infile $outfile - } - } - - - - # Mkzipfile -- - # - # FIX ME: should handle the current offset for non-seekable channels - # - proc Mkzipfile {zipchan base path {comment ""}} { - #*** !doctools - #[call [fun Mkzipfile] [arg zipchan] [arg base] [arg path] [arg ?comment?]] - #[para] Add a single file to a zip archive - #[para] The zipchan channel should already be open and binary. - #[para] You can provide a -comment for the file. - #[para] The return value is the central directory record that will need to be used when finalizing the zip archive. - - set fullpath [file join $base $path] - set mtime [Timet_to_dos [file mtime $fullpath]] - set utfpath [encoding convertto utf-8 $path] - set utfcomment [encoding convertto utf-8 $comment] - set flags [expr {(1<<11)}] ;# utf-8 comment and path - set method 0 ;# store 0, deflate 8 - set attr 0 ;# text or binary (default binary) - set version 20 ;# minumum version req'd to extract - set extra "" - set crc 0 - set size 0 - set csize 0 - set data "" - set seekable [expr {[tell $zipchan] != -1}] - if {[file isdirectory $fullpath]} { - set attrex 0x41ff0010 ;# 0o040777 (drwxrwxrwx) - #set attrex 0x40000010 - } elseif {[file executable $fullpath]} { - set attrex 0x81ff0080 ;# 0o100777 (-rwxrwxrwx) - } else { - set attrex 0x81b60020 ;# 0o100666 (-rw-rw-rw-) - if {[file extension $fullpath] in {".tcl" ".txt" ".c"}} { - set attr 1 ;# text - } - } - - if {[file isfile $fullpath]} { - set size [file size $fullpath] - if {!$seekable} {set flags [expr {$flags | (1 << 3)}]} - } - - - set offset [tell $zipchan] - set local [binary format a4sssiiiiss PK\03\04 \ - $version $flags $method $mtime $crc $csize $size \ - [string length $utfpath] [string length $extra]] - append local $utfpath $extra - puts -nonewline $zipchan $local - - if {[file isfile $fullpath]} { - # If the file is under 2MB then zip in one chunk, otherwize we use - # streaming to avoid requiring excess memory. This helps to prevent - # storing re-compressed data that may be larger than the source when - # handling PNG or JPEG or nested ZIP files. - if {$size < 0x00200000} { - set fin [open $fullpath rb] - set data [read $fin] - set crc [zlib crc32 $data] - set cdata [zlib deflate $data] - if {[string length $cdata] < $size} { - set method 8 - set data $cdata - } - close $fin - set csize [string length $data] - puts -nonewline $zipchan $data - } else { - set method 8 - set fin [open $fullpath rb] - set zlib [zlib stream deflate] - while {![eof $fin]} { - set data [read $fin 4096] - set crc [zlib crc32 $data $crc] - $zlib put $data - if {[string length [set zdata [$zlib get]]]} { - incr csize [string length $zdata] - puts -nonewline $zipchan $zdata - } - } - close $fin - $zlib finalize - set zdata [$zlib get] - incr csize [string length $zdata] - puts -nonewline $zipchan $zdata - $zlib close - } - - if {$seekable} { - # update the header if the output is seekable - set local [binary format a4sssiiii PK\03\04 \ - $version $flags $method $mtime $crc $csize $size] - set current [tell $zipchan] - seek $zipchan $offset - puts -nonewline $zipchan $local - seek $zipchan $current - } else { - # Write a data descriptor record - set ddesc [binary format a4iii PK\7\8 $crc $csize $size] - puts -nonewline $zipchan $ddesc - } - } - - #PK\x01\x02 Cdentral directory file header - #set v1 0x0317 ;#upper byte 03 -> UNIX lower byte 23 -> 2.3 - set v1 0x0017 ;#upper byte 00 -> MS_DOS and OS/2 (FAT/VFAT/FAT32 file systems) - - set hdr [binary format a4ssssiiiisssssii PK\01\02 $v1 \ - $version $flags $method $mtime $crc $csize $size \ - [string length $utfpath] [string length $extra]\ - [string length $utfcomment] 0 $attr $attrex $offset] - append hdr $utfpath $extra $utfcomment - return $hdr - } - - #### REVIEW!!! - #JMN - review - this looks to be offset relative to start of file - (same as 2024 Tcl 'mkzip mkimg') - # we probably want offsets to start of archive for exe/script-prefixed zips.on windows (editability with 7z,peazip) - #### - - # zip::mkzip -- - # - # eg: zip my.zip -directory Subdir -runtime unzipsfx.exe *.txt - # - proc mkzip {args} { - #*** !doctools - #[call [fun mkzip] [arg ?options?] [arg filename]] - #[para] Create a zip archive in 'filename' - #[para] If a file already exists, an error will be raised. - set argd [punk::args::get_dict { - *proc -name punk::zip::mkzip -help "Create a zip archive in 'filename'" - *opts - -return -default "pretty" -choices {pretty list none} -help "mkzip can return a list of the files and folders added to the archive - the option -return pretty is the default and uses the punk::lib pdict/plist system - to return a formatted list for the terminal - " - -zipkit -default 0 -type none -help "" - -runtime -default "" -help "specify a prefix file - e.g punk::zip::mkzip -runtime unzipsfx.exe -directory subdir output.zip - will create a self-extracting zip archive from the subdir/ folder. - " - -comment -default "" -help "An optional comment for the archive" - -directory -default "" -help "The new zip archive will scan for contents within this folder or current directory if not provided" - -base -default "" -help "The new zip archive will be rooted in this directory if provided - it must be a parent of -directory" - -exclude -default {CVS/* */CVS/* *~ ".#*" "*/.#*"} - *values -min 1 -max -1 - filename -default "" -help "name of zipfile to create" - globs -default {*} -multiple 1 -help "list of glob patterns to match. - Only directories with matching files will be included in the archive" - } $args] - - set filename [dict get $argd values filename] - if {$filename eq ""} { - error "mkzip filename cannot be empty string" - } - if {[regexp {[?*]} $filename]} { - #catch a likely error where filename is omitted and first glob pattern is misinterpreted as zipfile name - error "mkzip filename should not contain glob characters ? *" - } - if {[file exists $filename]} { - error "mkzip filename:$filename already exists" - } - dict for {k v} [dict get $argd opts] { - switch -- $k { - -comment { - dict set argd opts $k [encoding convertto utf-8 $v] - } - -directory - -base { - dict set argd opts $k [file normalize $v] - } - } - } - - array set opts [dict get $argd opts] - - - if {$opts(-directory) ne ""} { - if {$opts(-base) ne ""} { - #-base and -directory have been normalized already - if {![Path_a_atorbelow_b $opts(-directory) $opts(-base)]} { - error "punk::zip::mkzip -base $opts(-base) must be above -directory $opts(-directory)" - } - set base $opts(-base) - set relpath [Path_strip_alreadynormalized_prefixdepth $opts(-directory) $opts(-base)] - } else { - set base $opts(-directory) - set relpath "" - } - set paths [walk -exclude $opts(-exclude) -subpath $relpath -- $base {*}[dict get $argd values globs]] - - set norm_filename [file normalize $filename] - set norm_dir [file normalize $opts(-directory)] ;#we only care if filename below -directory (which is where we start scanning) - if {[Path_a_atorbelow_b $norm_filename $norm_dir]} { - #check that we aren't adding the zipfile to itself - #REVIEW - now that we open zipfile after scanning - this isn't really a concern! - #keep for now in case we can add an -update or a -force facility (or in case we modify to add to zip as we scan for members?) - #In the case of -force - we may want to delay replacement of original until scan is done? - - #try to avoid looping on all paths and performing (somewhat) expensive file normalizations on each - #1st step is to check the patterns and see if our zipfile is already excluded - in which case we need not check the paths - set self_globs_match 0 - foreach g [dict get $argd values globs] { - if {[string match $g [file tail $filename]]} { - set self_globs_match 1 - break - } - } - if {$self_globs_match} { - #still dangerous - set self_excluded 0 - foreach e $opts(-exclude) { - if {[string match $e [file tail $filename]]} { - set self_excluded 1 - break - } - } - if {!$self_excluded} { - #still dangerous - likely to be in resultset - check each path - #puts stderr "zip file $filename is below directory $opts(-directory)" - set self_is_matched 0 - set i 0 - foreach p $paths { - set norm_p [file normalize [file join $opts(-directory) $p]] - if {[Path_a_at_b $norm_filename $norm_p]} { - set self_is_matched 1 - break - } - incr i - } - if {$self_is_matched} { - puts stderr "WARNING - zipfile being created '$filename' was matched. Excluding this file. Relocate the zip, or use -exclude patterns to avoid this message" - set paths [lremove $paths $i] - } - } - } - } - } else { - set paths [list] - set dir [pwd] - if {$opts(-base) ne ""} { - if {![Path_a_atorbelow_b $dir $opts(-base)]} { - error "punk::zip::mkzip -base $opts(-base) must be above current directory" - } - set relpath [Path_strip_alreadynormalized_prefixdepth [file normalize $dir] [file normalize $opts(-base)]] - } else { - set relpath "" - } - set base $opts(-base) - - set matches [glob -nocomplain -type f -- {*}[dict get $argd values globs]] - foreach m $matches { - if {$m eq $filename} { - #puts stderr "--> excluding $filename" - continue - } - set isok 1 - foreach e [concat $opts(-exclude) $filename] { - if {[string match $e $m]} { - set isok 0 - break - } - } - if {$isok} { - lappend paths [file join $relpath $m] - } - } - } - - if {![llength $paths]} { - return "" - } - - set zf [open $filename wb] - if {$opts(-runtime) ne ""} { - set rt [open $opts(-runtime) rb] - fcopy $rt $zf - close $rt - } elseif {$opts(-zipkit)} { - #TODO - update to zipfs ? - #see modpod - set zkd "#!/usr/bin/env tclkit\n\# This is a zip-based Tcl Module\n" - append zkd "package require vfs::zip\n" - append zkd "vfs::zip::Mount \[info script\] \[info script\]\n" - append zkd "if {\[file exists \[file join \[info script\] main.tcl\]\]} {\n" - append zkd " source \[file join \[info script\] main.tcl\]\n" - append zkd "}\n" - append zkd \x1A - puts -nonewline $zf $zkd - } - - #todo - subtract this from the endrec offset.. and any ... ? - set dataStartOffset [tell $zf] ;#the overall file offset of the start of data section //JMN 2024 - - set count 0 - set cd "" - - set members [list] - foreach path $paths { - #puts $path - lappend members $path - append cd [Mkzipfile $zf $base $path] ;#path already includes relpath - incr count - } - set cdoffset [tell $zf] - set endrec [binary format a4ssssiis PK\05\06 0 0 \ - $count $count [string length $cd] $cdoffset\ - [string length $opts(-comment)]] - append endrec $opts(-comment) - puts -nonewline $zf $cd - puts -nonewline $zf $endrec - close $zf - - set result "" - switch -exact -- $opts(-return) { - list { - set result $members - } - pretty { - if {[info commands showlist] ne ""} { - set result [plist -channel none members] - } else { - set result $members - } - } - none { - set result "" - } - } - return $result - } - - - #*** !doctools - #[list_end] [comment {--- end definitions namespace punk::zip ---}] -} -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# Secondary API namespace -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -tcl::namespace::eval punk::zip::lib { - tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase - tcl::namespace::path [tcl::namespace::parent] - #*** !doctools - #[subsection {Namespace punk::zip::lib}] - #[para] Secondary functions that are part of the API - #[list_begin definitions] - - #proc utility1 {p1 args} { - # #*** !doctools - # #[call lib::[fun utility1] [arg p1] [opt {?option value...?}]] - # #[para]Description of utility1 - # return 1 - #} - - - - #*** !doctools - #[list_end] [comment {--- end definitions namespace punk::zip::lib ---}] -} -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -#*** !doctools -#[section Internal] -#tcl::namespace::eval punk::zip::system { - #*** !doctools - #[subsection {Namespace punk::zip::system}] - #[para] Internal functions that are not part of the API - - - -#} -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready -package provide punk::zip [tcl::namespace::eval punk::zip { - variable pkg punk::zip - variable version - set version 0.1.0 -}] -return - -#*** !doctools -#[manpage_end] - diff --git a/src/bootsupport/modules/shellfilter-0.1.9.tm b/src/bootsupport/modules/shellfilter-0.1.9.tm deleted file mode 100644 index 73ea752c..00000000 --- a/src/bootsupport/modules/shellfilter-0.1.9.tm +++ /dev/null @@ -1,3209 +0,0 @@ -#copyright 2023 Julian Marcel Noble -#license: BSD (revised 3-clause) -# -#Note shellfilter is currently only directly useful for unidirectional channels e.g stdin,stderr,stdout, or for example fifo2 where only one direction is being used. -#To generalize this to bidrectional channels would require shifting around read & write methods on transform objects in a very complicated manner. -#e.g each transform would probably be a generic transform container which holds sub-objects to which read & write are indirected. -#This is left as a future exercise...possibly it's best left as a concept for uni-directional channels anyway -# - as presumably the reads/writes from a bidirectional channel could be diverted off to unidirectional pipelines for processing with less work -# (and maybe even better speed/efficiency if the data volume is asymmetrical and there is significant processing on one direction) -# - - -tcl::namespace::eval shellfilter::log { - variable allow_adhoc_tags 1 - variable open_logs [tcl::dict::create] - variable is_enabled 0 - - proc disable {} { - variable is_enabled - set is_enabled 0 - proc ::shellfilter::log::open {tag settingsdict} {} - proc ::shellfilter::log::write {tag msg} {} - proc ::shellfilter::log::write_sync {tag msg} {} - proc ::shellfilter::log::close {tag} {} - } - - proc enable {} { - variable is_enabled - set is_enabled 1 - #'tag' is an identifier for the log source. - # each tag will use it's own thread to write to the configured log target - proc ::shellfilter::log::open {tag {settingsdict {}}} { - upvar ::shellfilter::sources sourcelist - if {![dict exists $settingsdict -tag]} { - tcl::dict::set settingsdict -tag $tag - } else { - #review - if {$tag ne [tcl::dict::get $settingsdict -tag]} { - error "shellfilter::log::open first argument tag: '$tag' does not match -tag '[tcl::dict::get $settingsdict -tag]' omit -tag, or supply same value" - } - } - if {$tag ni $sourcelist} { - lappend sourcelist $tag - } - - #note new_worker - set worker_tid [shellthread::manager::new_worker $tag $settingsdict] - #puts stderr "shellfilter::log::open this_threadid: [thread::id] tag: $tag worker_tid: $worker_tid" - return $worker_tid - } - proc ::shellfilter::log::write {tag msg} { - upvar ::shellfilter::sources sourcelist - variable allow_adhoc_tags - if {!$allow_adhoc_tags} { - if {$tag ni $sourcelist} { - error "shellfilter::log::write tag '$tag' hasn't been initialised with a call to shellfilter::log::open $tag , and allow_adhoc_tags has been set false. use shellfilter::log::require_open false to allow adhoc tags" - } - } - shellthread::manager::write_log $tag $msg - } - #write_sync - synchronous processing with logging thread, slower but potentially useful for debugging/testing or forcing delay til log written - proc ::shellfilter::log::write_sync {tag msg} { - shellthread::manager::write_log $tag $msg -async 0 - } - proc ::shellfilter::log::close {tag} { - #shellthread::manager::close_worker $tag - shellthread::manager::unsubscribe [list $tag]; #workertid will be added back to free list if no tags remain subscribed - } - - } - - #review - #configure whether we can call shellfilter::log::write without having called open first - proc require_open {{is_open_required {}}} { - variable allow_adhoc_tags - if {![string length $is_open_required]} { - return $allow_adhoc_tags - } else { - set truevalues [list y yes true 1] - set falsevalues [list n no false 0] - if {[string tolower $is_open_required] in $truevalues} { - set allow_adhoc_tags 1 - } elseif {[string tolower $is_open_required] in $falsevalues} { - set allow_adhoc_tags 0 - } else { - error "shellfilter::log::require_open unrecognised value '$is_open_required' try one of $truevalues or $falsevalues" - } - } - } - if {[catch {package require shellthread}]} { - shellfilter::log::disable - } else { - shellfilter::log::enable - } - -} -namespace eval shellfilter::pipe { - #write channel for program. workerthread reads other end of fifo2 and writes data somewhere - proc open_out {tag_pipename {pipesettingsdict {}}} { - set defaultsettings {-buffering full} - set settingsdict [dict merge $defaultsettings $pipesettingsdict] - package require shellthread - #we are only using the fifo in a single direction to pipe to another thread - # - so whilst wchan and rchan could theoretically each be both read & write we're only using them for one operation each - if {![catch {package require Memchan}]} { - lassign [fifo2] wchan rchan - } else { - package require tcl::chan::fifo2 - lassign [tcl::chan::fifo2] wchan rchan - } - #default -translation for both types of fifo on windows is {auto crlf} - # -encoding is as per '[encoding system]' on the platform - e.g utf-8 (e.g windows when beta-utf8 enabled) - chan configure $wchan -buffering [dict get $settingsdict -buffering] ;# - #application end must not be binary for our filters to operate on it - - - #chan configure $rchan -buffering [dict get $settingsdict -buffering] -translation binary ;#works reasonably.. - chan configure $rchan -buffering [dict get $settingsdict -buffering] -translation lf - - set worker_tid [shellthread::manager::new_pipe_worker $tag_pipename $settingsdict] - #puts stderr "worker_tid: $worker_tid" - - #set_read_pipe does the thread::transfer of the rchan end. -buffering setting is maintained during thread transfer - shellthread::manager::set_pipe_read_from_client $tag_pipename $worker_tid $rchan - - set pipeinfo [list localchan $wchan remotechan $rchan workertid $worker_tid direction out] - return $pipeinfo - } - - #read channel for program. workerthread writes to other end of fifo2 from whereever it's reading (stdin, file?) - proc open_in {tag_pipename {settingsdict {} }} { - package require shellthread - package require tcl::chan::fifo2 - lassign [tcl::chan::fifo2] wchan rchan - set program_chan $rchan - set worker_chan $wchan - chan configure $worker_chan -buffering [dict get $settingsdict -buffering] - chan configure $program_chan -buffering [dict get $settingsdict -buffering] - - chan configure $program_chan -blocking 0 - chan configure $worker_chan -blocking 0 - set worker_tid [shellthread::manager::new_worker $tag_pipename $settingsdict] - - shellthread::manager::set_pipe_write_to_client $tag_pipename $worker_tid $worker_chan - - set pipeinfo [list localchan $program_chan remotechan $worker_chan workertid $worker_tid direction in] - puts stderr "|jn>pipe::open_in returning $pipeinfo" - puts stderr "program_chan: [chan conf $program_chan]" - return $pipeinfo - } - -} - - - -namespace eval shellfilter::ansi { - #maint warning - - #ansistrip from punk::ansi is better/more comprehensive - proc stripcodes {text} { - #obsolete? - #single "final byte" in the range 0x40–0x7E (ASCII @A–Z[\]^_`a–z{|}~). - dict set escape_terminals CSI [list @ \\ ^ _ ` | ~ 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 "\{" "\}"] - #dict set escape_terminals CSI [list J K m n A B C D E F G s u] ;#basic - dict set escape_terminals OSC [list \007 \033\\] ;#note mix of 1 and 2-byte terminals - #we process char by char - line-endings whether \r\n or \n should be processed as per any other character. - #line endings can theoretically occur within an ansi escape sequence (review e.g title?) - set inputlist [split $text ""] - set outputlist [list] - - #self-contained 2 byte ansi escape sequences - review more? - set 2bytecodes_dict [dict create\ - "reset_terminal" "\033c"\ - "save_cursor_posn" "\u001b7"\ - "restore_cursor_posn" "\u001b8"\ - "cursor_up_one" "\u001bM"\ - ] - set 2bytecodes [dict values $2bytecodes_dict] - - set in_escapesequence 0 - #assumption - undertext already 'rendered' - ie no backspaces or carriagereturns or other cursor movement controls - set i 0 - foreach u $inputlist { - set v [lindex $inputlist $i+1] - set uv ${u}${v} - if {$in_escapesequence eq "2b"} { - #2nd byte - done. - set in_escapesequence 0 - } elseif {$in_escapesequence != 0} { - set escseq [dict get $escape_terminals $in_escapesequence] - if {$u in $escseq} { - set in_escapesequence 0 - } elseif {$uv in $escseq} { - set in_escapseequence 2b ;#flag next byte as last in sequence - } - } else { - #handle both 7-bit and 8-bit CSI and OSC - if {[regexp {^(?:\033\[|\u009b)} $uv]} { - set in_escapesequence CSI - } elseif {[regexp {^(?:\033\]|\u009c)} $uv]} { - set in_escapesequence OSC - } elseif {$uv in $2bytecodes} { - #self-contained e.g terminal reset - don't pass through. - set in_escapesequence 2b - } else { - lappend outputlist $u - } - } - incr i - } - return [join $outputlist ""] - } - -} -namespace eval shellfilter::chan { - set testobj ::shellfilter::chan::var - if {$testobj ni [info commands $testobj]} { - - oo::class create var { - variable o_datavar - variable o_trecord - variable o_enc - variable o_is_junction - constructor {tf} { - set o_trecord $tf - set o_enc [dict get $tf -encoding] - set settingsdict [dict get $tf -settings] - set varname [dict get $settingsdict -varname] - set o_datavar $varname - if {[dict exists $tf -junction]} { - set o_is_junction [dict get $tf -junction] - } else { - set o_is_junction 1 ;# as a var is diversionary - default it to be a jucntion - } - } - method initialize {ch mode} { - return [list initialize finalize write] - } - method finalize {ch} { - my destroy - } - method watch {ch events} { - # must be present but we ignore it because we do not - # post any events - } - #method read {ch count} { - # return ? - #} - method write {ch bytes} { - set stringdata [encoding convertfrom $o_enc $bytes] - append $o_datavar $stringdata - return "" - } - method meta_is_redirection {} { - return $o_is_junction - } - method meta_buffering_supported {} { - return [list line full none] - } - } - - #todo - something similar for multiple grep specs each with own -pre & -post .. store to dict? - oo::class create tee_grep_to_var { - variable o_datavar - variable o_lastxlines - variable o_trecord - variable o_grepfor - variable o_prelines - variable o_postlines - variable o_postcountdown - variable o_enc - variable o_is_junction - constructor {tf} { - set o_trecord $tf - set o_enc [tcl::dict::get $tf -encoding] - set o_lastxlines [list] - set o_postcountdown 0 - set defaults [tcl::dict::create -pre 1 -post 1] - set settingsdict [tcl::dict::get $tf -settings] - set settings [tcl::dict::merge $defaults $settingsdict] - set o_datavar [tcl::dict::get $settings -varname] - set o_grepfor [tcl::dict::get $settings -grep] - set o_prelines [tcl::dict::get $settings -pre] - set o_postlines [tcl::dict::get $settings -post] - 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 finalize write] - } - method finalize {transform_handle} { - my destroy - } - method watch {transform_handle events} { - } - #method read {transform_handle count} { - # return ? - #} - method write {transform_handle bytes} { - set logdata [tcl::encoding::convertfrom $o_enc $bytes] - set lastx $o_lastxlines - lappend o_lastxlines $logdata - - if {$o_postcountdown > 0} { - append $o_datavar $logdata - if {[regexp $o_grepfor $logdata]} { - #another match in postlines - set o_postcountdown $o_postlines - } else { - incr o_postcountdown -1 - } - } else { - if {[regexp $o_grepfor $logdata]} { - append $o_datavar [join $lastx] - append $o_datavar $logdata - set o_postcountdown $o_postlines - } - } - - if {[llength $o_lastxlines] > $o_prelines} { - set o_lastxlines [lrange $o_lastxlines 1 end] - } - return $bytes - } - method meta_is_redirection {} { - return $o_is_junction - } - method meta_buffering_supported {} { - return [list line] - } - } - - oo::class create tee_to_var { - variable o_datavars - variable o_trecord - variable o_enc - variable o_is_junction - constructor {tf} { - set o_trecord $tf - set o_enc [tcl::dict::get $tf -encoding] - set settingsdict [tcl::dict::get $tf -settings] - set varname [tcl::dict::get $settingsdict -varname] - set o_datavars $varname - if {[tcl::dict::exists $tf -junction]} { - set o_is_junction [tcl::dict::get $tf -junction] - } else { - set o_is_junction 0 - } - } - method initialize {ch mode} { - return [list initialize finalize write flush clear] - } - method finalize {ch} { - my destroy - } - method clear {ch} { - return - } - method watch {ch events} { - # must be present but we ignore it because we do not - # post any events - } - #method read {ch count} { - # return ? - #} - method flush {ch} { - return "" - } - method write {ch bytes} { - set stringdata [tcl::encoding::convertfrom $o_enc $bytes] - foreach v $o_datavars { - append $v $stringdata - } - return $bytes - } - method meta_is_redirection {} { - return $o_is_junction - } - } - oo::class create tee_to_pipe { - variable o_logsource - variable o_localchan - variable o_enc - variable o_trecord - variable o_is_junction - constructor {tf} { - set o_trecord $tf - set o_enc [tcl::dict::get $tf -encoding] - set settingsdict [tcl::dict::get $tf -settings] - if {![dict exists $settingsdict -tag]} { - error "tee_to_pipe constructor settingsdict missing -tag" - } - set o_localchan [tcl::dict::get $settingsdict -pipechan] - set o_logsource [tcl::dict::get $settingsdict -tag] - 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 read drain write flush clear finalize] - } - method finalize {transform_handle} { - ::shellfilter::log::close $o_logsource - my destroy - } - method watch {transform_handle events} { - # must be present but we ignore it because we do not - # post any events - } - method clear {transform_handle} { - return - } - method drain {transform_handle} { - return "" - } - method read {transform_handle bytes} { - set logdata [tcl::encoding::convertfrom $o_enc $bytes] - #::shellfilter::log::write $o_logsource $logdata - puts -nonewline $o_localchan $logdata - return $bytes - } - method flush {transform_handle} { - return "" - } - method write {transform_handle bytes} { - set logdata [tcl::encoding::convertfrom $o_enc $bytes] - #::shellfilter::log::write $o_logsource $logdata - puts -nonewline $o_localchan $logdata - return $bytes - } - #a tee is not a redirection - because data still flows along the main path - method meta_is_redirection {} { - return $o_is_junction - } - - } - oo::class create tee_to_log { - variable o_tid - variable o_logsource - variable o_trecord - variable o_enc - variable o_is_junction - constructor {tf} { - set o_trecord $tf - set o_enc [tcl::dict::get $tf -encoding] - set settingsdict [tcl::dict::get $tf -settings] - if {![tcl::dict::exists $settingsdict -tag]} { - error "tee_to_log constructor settingsdict missing -tag" - } - set o_logsource [tcl::dict::get $settingsdict -tag] - set o_tid [::shellfilter::log::open $o_logsource $settingsdict] - if {[tcl::dict::exists $tf -junction]} { - set o_is_junction [tcl::dict::get $tf -junction] - } else { - set o_is_junction 0 - } - } - method initialize {ch mode} { - return [list initialize read write finalize] - } - method finalize {ch} { - ::shellfilter::log::close $o_logsource - my destroy - } - method watch {ch events} { - # must be present but we ignore it because we do not - # post any events - } - method read {ch bytes} { - set logdata [tcl::encoding::convertfrom $o_enc $bytes] - ::shellfilter::log::write $o_logsource $logdata - return $bytes - } - method write {ch bytes} { - set logdata [tcl::encoding::convertfrom $o_enc $bytes] - ::shellfilter::log::write $o_logsource $logdata - return $bytes - } - method meta_is_redirection {} { - return $o_is_junction - } - } - - - oo::class create logonly { - variable o_tid - variable o_logsource - variable o_trecord - variable o_enc - constructor {tf} { - set o_trecord $tf - set o_enc [dict get $tf -encoding] - set settingsdict [dict get $tf -settings] - if {![dict exists $settingsdict -tag]} { - error "logonly constructor settingsdict missing -tag" - } - set o_logsource [dict get $settingsdict -tag] - set o_tid [::shellfilter::log::open $o_logsource $settingsdict] - } - method initialize {transform_handle mode} { - return [list initialize finalize write] - } - method finalize {transform_handle} { - ::shellfilter::log::close $o_logsource - my destroy - } - method watch {transform_handle events} { - # must be present but we ignore it because we do not - # post any events - } - #method read {transform_handle count} { - # return ? - #} - method write {transform_handle bytes} { - set logdata [encoding convertfrom $o_enc $bytes] - if 0 { - if {"utf-16le" in [encoding names]} { - set logdata [encoding convertfrom utf-16le $bytes] - } else { - set logdata [encoding convertto utf-8 $bytes] - #set logdata [encoding convertfrom unicode $bytes] - #set logdata $bytes - } - } - #set logdata $bytes - #set logdata [string map [list \r -r- \n -n-] $logdata] - #if {[string equal [string range $logdata end-1 end] "\r\n"]} { - # set logdata [string range $logdata 0 end-2] - #} - #::shellfilter::log::write_sync $o_logsource $logdata - ::shellfilter::log::write $o_logsource $logdata - #return $bytes - return - } - method meta_is_redirection {} { - return 1 - } - } - - #review - we should probably provide a more narrow filter than only strips color - and one that strips most(?) - # - but does it ever really make sense to strip things like "esc(0" and "esc(B" which flip to the G0 G1 characters? (once stripped - things like box-lines become ordinary letters - unlikely to be desired?) - #punk::ansi::ansistrip converts at least some of the box drawing G0 chars to unicode - todo - more complete conversion - #assumes line-buffering. a more advanced filter required if ansicodes can arrive split across separate read or write operations! - oo::class create ansistrip { - variable o_trecord - variable o_enc - variable o_is_junction - constructor {tf} { - package require punk::ansi - set o_trecord $tf - set o_enc [dict get $tf -encoding] - if {[dict exists $tf -junction]} { - set o_is_junction [dict get $tf -junction] - } else { - set o_is_junction 0 - } - } - method initialize {transform_handle mode} { - return [list initialize read write clear flush drain finalize] - } - method finalize {transform_handle} { - my destroy - } - method clear {transform_handle} { - return - } - method watch {transform_handle events} { - } - method drain {transform_handle} { - return "" - } - method read {transform_handle bytes} { - set instring [encoding convertfrom $o_enc $bytes] - set outstring [punk::ansi::ansistrip $instring] - return [encoding convertto $o_enc $outstring] - } - method flush {transform_handle} { - return "" - } - method write {transform_handle bytes} { - set instring [encoding convertfrom $o_enc $bytes] - set outstring [punk::ansi::ansistrip $instring] - return [encoding convertto $o_enc $outstring] - } - method meta_is_redirection {} { - return $o_is_junction - } - } - - #a test - oo::class create reconvert { - variable o_trecord - variable o_enc - constructor {tf} { - set o_trecord $tf - set o_enc [dict get $tf -encoding] - } - method initialize {transform_handle mode} { - return [list initialize read write finalize] - } - method finalize {transform_handle} { - my destroy - } - method watch {transform_handle events} { - } - method read {transform_handle bytes} { - set instring [encoding convertfrom $o_enc $bytes] - - set outstring $instring - - return [encoding convertto $o_enc $outstring] - } - method write {transform_handle bytes} { - set instring [encoding convertfrom $o_enc $bytes] - - set outstring $instring - - return [encoding convertto $o_enc $outstring] - } - } - oo::define reconvert { - method meta_is_redirection {} { - return 0 - } - } - - - #this isn't a particularly nice thing to do to a stream - especially if someone isn't expecting ansi codes sprinkled through it. - #It can be useful for test/debugging - #Due to chunking at random breaks - we have to check if an ansi code in the underlying stream has been split - otherwise our wrapping will break the existing ansi - # - set sixelstart_re {\x1bP([;0-9]*)q} ;#7-bit - todo 8bit - #todo kitty graphics \x1b_G... - #todo iterm graphics - - oo::class create ansiwrap { - variable o_trecord - variable o_enc - variable o_colour - variable o_do_colour - variable o_do_normal - variable o_is_junction - variable o_codestack - variable o_gx_state ;#on/off alt graphics - variable o_buffered - constructor {tf} { - package require punk::ansi - set o_trecord $tf - set o_enc [tcl::dict::get $tf -encoding] - set settingsdict [tcl::dict::get $tf -settings] - if {[tcl::dict::exists $settingsdict -colour]} { - set o_colour [tcl::dict::get $settingsdict -colour] - set o_do_colour [punk::ansi::a+ {*}$o_colour] - set o_do_normal [punk::ansi::a] - } else { - set o_colour {} - set o_do_colour "" - set o_do_normal "" - } - set o_codestack [list] - set o_gx_state [expr {off}] - set o_buffered "" ;#hold back data that potentially contains partial ansi codes - if {[tcl::dict::exists $tf -junction]} { - set o_is_junction [tcl::dict::get $tf -junction] - } else { - set o_is_junction 0 - } - } - - - #todo - track when in sixel,iterm,kitty graphics data - can be very large - method Trackcodes {chunk} { - #note - caller can use 2 resets in a single unit to temporarily reset to no sgr (override ansiwrap filter) - #e.g [a+ reset reset] (0;0m vs 0;m) - - #puts stdout "===[ansistring VIEW -lf 1 $o_buffered]" - set buf $o_buffered$chunk - set emit "" - if {[string last \x1b $buf] >= 0} { - #detect will detect ansi SGR and gron groff and other codes - if {[punk::ansi::ta::detect $buf]} { - #split_codes_single regex faster than split_codes - but more resulting parts - #'single' refers to number of escapes - but can still contain e.g multiple SGR codes (or mode set operations etc) - set parts [punk::ansi::ta::split_codes_single $buf] - #process all pt/code pairs except for trailing pt - foreach {pt code} [lrange $parts 0 end-1] { - #puts "<==[ansistring VIEW -lf 1 $pt]==>" - switch -- [llength $o_codestack] { - 0 { - append emit $o_do_colour$pt$o_do_normal - } - 1 { - if {[punk::ansi::codetype::is_sgr_reset [lindex $o_codestack 0]]} { - append emit $o_do_colour$pt$o_do_normal - set o_codestack [list] - } else { - #append emit [lindex $o_codestack 0]$pt - append emit [punk::ansi::codetype::sgr_merge_singles [list $o_do_colour {*}$o_codestack]]$pt - } - } - default { - append emit [punk::ansi::codetype::sgr_merge_singles [list $o_do_colour {*}$o_codestack]]$pt - } - } - #if {( ![llength $o_codestack] || ([llength $o_codestack] == 1 && [punk::ansi::codetype::is_sgr_reset [lindex $o_codestack 0]]))} { - # append emit $o_do_colour$pt$o_do_normal - # #append emit $pt - #} else { - # append emit $pt - #} - - set c1c2 [tcl::string::range $code 0 1] - set leadernorm [tcl::string::range [tcl::string::map [list\ - \x1b\[ 7CSI\ - \x9b 8CSI\ - \x1b\( 7GFX\ - ] $c1c2] 0 3] - switch -- $leadernorm { - 7CSI - 8CSI { - if {[punk::ansi::codetype::is_sgr_reset $code]} { - set o_codestack [list "\x1b\[m"] - } elseif {[punk::ansi::codetype::has_sgr_leadingreset $code]} { - set o_codestack [list $code] - } elseif {[punk::ansi::codetype::is_sgr $code]} { - #todo - make caching is_sgr method - set dup_posns [lsearch -all -exact $o_codestack $code] - set o_codestack [lremove $o_codestack {*}$dup_posns] - lappend o_codestack $code - } else { - - } - } - 7GFX { - switch -- [tcl::string::index $code 2] { - "0" { - set o_gx_state on - } - "B" { - set o_gx_state off - } - } - } - default { - #other ansi codes - } - } - append emit $code - } - - - set trailing_pt [lindex $parts end] - if {[string first \x1b $trailing_pt] >= 0} { - #puts stdout "...[ansistring VIEW -lf 1 $trailing_pt]...buffered:<[ansistring VIEW $o_buffered]> '[ansistring VIEW -lf 1 $emit]'" - #may not be plaintext after all - set o_buffered $trailing_pt - #puts stdout "=-=[ansistring VIEWCODES $o_buffered]" - } else { - #puts [a+ yellow]???[ansistring VIEW "'$o_buffered'<+>'$trailing_pt'"]???[a] - switch -- [llength $o_codestack] { - 0 { - append emit $o_do_colour$trailing_pt$o_do_normal - } - 1 { - if {[punk::ansi::codetype::is_sgr_reset [lindex $o_codestack 0]]} { - append emit $o_do_colour$trailing_pt$o_do_normal - set o_codestack [list] - } else { - #append emit [lindex $o_codestack 0]$trailing_pt - append emit [punk::ansi::codetype::sgr_merge_singles [list $o_do_colour {*}$o_codestack]]$trailing_pt - } - } - default { - append emit [punk::ansi::codetype::sgr_merge_singles [list $o_do_colour {*}$o_codestack]]$trailing_pt - } - } - #if {![llength $o_codestack] || ([llength $o_codestack] ==1 && [punk::ansi::codetype::is_sgr_reset [lindex $o_codestack 0]])} { - # append emit $o_do_colour$trailing_pt$o_do_normal - #} else { - # append emit $trailing_pt - #} - #the previous o_buffered formed the data we emitted - nothing new to buffer because we emitted all parts including the trailing plaintext - set o_buffered "" - } - - - } else { - #REVIEW - this holding a buffer without emitting as we go is ugly. - # - we may do better to detect and retain the opener, then use that opener to avoid false splits within the sequence. - # - we'd then need to detect the appropriate close to restart splitting and codestacking - # - we may still need to retain and append the data to the opener (in some cases?) - which is a slight memory issue - but at least we would emit everything immediately. - - - #puts "-->esc but no detect" - #no complete ansi codes - but at least one esc is present - if {[string index $buf end] eq "\x1b" && [string first \x1b $buf] == [string length $buf]-1} { - #string index in first part of && clause to avoid some unneeded scans of whole string for this test - #we can't use 'string last' - as we need to know only esc is last char in buf - #puts ">>trailing-esc<<" - set o_buffered \x1b - set emit $o_do_colour[string range $buf 0 end-1]$o_do_normal - #set emit [string range $buf 0 end-1] - set buf "" - } else { - set emit_anyway 0 - #todo - ensure non-ansi escapes in middle of chunks don't lead to ever growing buffer - if {[punk::ansi::ta::detect_st_open $buf]} { - #no detect - but we have an ST open (privacy msg etc) - allow a larger chunk before we give up - could include newlines (and even nested codes - although not widely interpreted that way in terms) - set st_partial_len [expr {[string length $buf] - [string last \x1b $buf]}] ;#length of unclosed ST code - #todo - configurable ST max - use 1k for now - if {$st_partial_len < 1001} { - append o_buffered $chunk - set emit "" - set buf "" - } else { - set emit_anyway 1 - set o_buffered "" - } - } else { - set possible_code_len [expr {[string length $buf] - [string last \x1b $buf]}] ;#length of possible code - #most opening sequences are 1,2 or 3 chars - review? - set open_sequence_detected [punk::ansi::ta::detect_open $buf] - if {$possible_code_len > 10 && !$open_sequence_detected} { - set emit_anyway 1 - set o_buffered "" - } else { - #could be composite sequence with params - allow some reasonable max sequence length - #todo - configurable max sequence length - #len 40-50 quite possible for SGR sequence using coloured underlines etc, even without redundancies - # - allow some headroom for redundant codes when the caller didn't merge. - if {$possible_code_len < 101} { - append o_buffered $chunk - set buf "" - set emit "" - } else { - #allow a little more grace if we at least have an opening ansi sequence of any type.. - if {$open_sequence_detected && $possible_code_len < 151} { - append o_buffered $chunk - set buf "" - set emit "" - } else { - set emit_anyway 1 - set o_buffered "" - } - } - } - } - if {$emit_anyway} { - #assert: any time emit_anyway == 1 buf already contains all of previous o_buffered and o_buffered has been cleared. - - #looked ansi-like - but we've given enough length without detecting close.. - #treat as possible plain text with some esc or unrecognised ansi sequence - switch -- [llength $o_codestack] { - 0 { - set emit $o_do_colour$buf$o_do_normal - } - 1 { - if {[punk::ansi::codetype::is_sgr_reset [lindex $o_codestack 0]]} { - set emit $o_do_colour$buf$o_do_normal - set o_codestack [list] - } else { - #set emit [lindex $o_codestack 0]$buf - set emit [punk::ansi::codetype::sgr_merge_singles [list $o_do_colour {*}$o_codestack]]$buf - } - } - default { - #set emit [punk::ansi::codetype::sgr_merge_singles $o_codestack]$buf - set emit [punk::ansi::codetype::sgr_merge_singles [list $o_do_colour {*}$o_codestack]]$buf - } - } - #if {( ![llength $o_codestack] || ([llength $o_codestack] == 1 && [punk::ansi::codetype::is_sgr_reset [lindex $o_codestack 0]]))} { - # set emit $o_do_colour$buf$o_do_normal - #} else { - # set emit $buf - #} - } - } - } - } else { - #no esc - #puts stdout [a+ yellow]...[a] - #test! - switch -- [llength $o_codestack] { - 0 { - set emit $o_do_colour$buf$o_do_normal - } - 1 { - if {[punk::ansi::codetype::is_sgr_reset [lindex $o_codestack 0]]} { - set emit $o_do_colour$buf$o_do_normal - set o_codestack [list] - } else { - #set emit [lindex $o_codestack 0]$buf - set emit [punk::ansi::codetype::sgr_merge_singles [list $o_do_colour {*}$o_codestack]]$buf - } - } - default { - #set emit [punk::ansi::codetype::sgr_merge_singles $o_codestack]$buf - set emit [punk::ansi::codetype::sgr_merge_singles [list $o_do_colour {*}$o_codestack]]$buf - } - } - set o_buffered "" - } - return [dict create emit $emit stacksize [llength $o_codestack]] - } - method initialize {transform_handle mode} { - #clear undesirable in terminal output channels (review) - return [list initialize write flush read drain finalize] - } - method finalize {transform_handle} { - my destroy - } - method watch {transform_handle events} { - } - method clear {transform_handle} { - #In the context of stderr/stdout - we probably don't want clear to run. - #Terminals might call it in the middle of a split ansi code - resulting in broken output. - #Leave clear of it the init call - puts stdout "" - set emit [tcl::encoding::convertto $o_enc $o_buffered] - set o_buffered "" - return $emit - } - method flush {transform_handle} { - #puts stdout "" - set emit [tcl::encoding::convertto $o_enc $o_buffered] - set o_buffered "" - return $emit - return - } - method write {transform_handle bytes} { - set instring [tcl::encoding::convertfrom $o_enc $bytes] - set streaminfo [my Trackcodes $instring] - set emit [dict get $streaminfo emit] - - #review - wrapping already done in Trackcodes - #if {[dict get $streaminfo stacksize] == 0} { - # #no ansi on the stack - we can wrap - # #review - # set outstring "$o_do_colour$emit$o_do_normal" - #} else { - #} - #if {[llength $o_codestack]} { - # set outstring [punk::ansi::codetype::sgr_merge_singles $o_codestack]$emit - #} else { - # set outstring $emit - #} - - set outstring $emit - - #puts stdout "decoded >>>[ansistring VIEWCODES $outstring]<<<" - #puts stdout "re-encoded>>>[ansistring VIEW [tcl::encoding::convertto $o_enc $outstring]]<<<" - return [tcl::encoding::convertto $o_enc $outstring] - } - method Write_naive {transform_handle bytes} { - set instring [tcl::encoding::convertfrom $o_enc $bytes] - set outstring "$o_do_colour$instring$o_do_normal" - #set outstring ">>>$instring" - return [tcl::encoding::convertto $o_enc $outstring] - } - method drain {transform_handle} { - return "" - } - method read {transform_handle bytes} { - set instring [tcl::encoding::convertfrom $o_enc $bytes] - set outstring "$o_do_colour$instring$o_do_normal" - return [tcl::encoding::convertto $o_enc $outstring] - } - method meta_is_redirection {} { - return $o_is_junction - } - } - #todo - something - oo::class create rebuffer { - variable o_trecord - variable o_enc - constructor {tf} { - set o_trecord $tf - set o_enc [dict get $tf -encoding] - } - method initialize {transform_handle mode} { - return [list initialize read write finalize] - } - method finalize {transform_handle} { - my destroy - } - method watch {transform_handle events} { - } - method read {transform_handle bytes} { - set instring [encoding convertfrom $o_enc $bytes] - - set outstring $instring - - return [encoding convertto $o_enc $outstring] - } - method write {transform_handle bytes} { - set instring [encoding convertfrom $o_enc $bytes] - - #set outstring [string map [list \n ] $instring] - set outstring $instring - - return [encoding convertto $o_enc $outstring] - #return [encoding convertto utf-16le $outstring] - } - } - oo::define rebuffer { - method meta_is_redirection {} { - return 0 - } - } - - #has slight buffering/withholding of lone training cr - we can't be sure that a cr at end of chunk is part of \r\n sequence - oo::class create tounix { - variable o_trecord - variable o_enc - variable o_last_char_was_cr - variable o_is_junction - constructor {tf} { - set o_trecord $tf - set o_enc [dict get $tf -encoding] - set settingsdict [dict get $tf -settings] - if {[dict exists $tf -junction]} { - set o_is_junction [dict get $tf -junction] - } else { - set o_is_junction 0 - } - set o_last_char_was_cr 0 - } - method initialize {transform_handle mode} { - return [list initialize write finalize] - } - method finalize {transform_handle} { - my destroy - } - method watch {transform_handle events} { - } - #don't use read - method read {transform_handle bytes} { - set instring [encoding convertfrom $o_enc $bytes] - - set outstring $instring - - return [encoding convertto $o_enc $outstring] - } - method write {transform_handle bytes} { - set instring [encoding convertfrom $o_enc $bytes] - #set outstring [string map [list \n ] $instring] - - if {$o_last_char_was_cr} { - set instring "\r$instring" - } - - set outstring [string map {\r\n \n} $instring] - set lastchar [string range $outstring end end] - if {$lastchar eq "\r"} { - set o_last_char_was_cr 1 - set outstring [string range $outstring 0 end-1] - } else { - set o_last_char_was_cr 0 - } - #review! can we detect eof here on the transform_handle? - #if eof, we don't want to strip a trailing \r - - return [encoding convertto $o_enc $outstring] - #return [encoding convertto utf-16le $outstring] - } - } - oo::define tounix { - method meta_is_redirection {} { - return $o_is_junction - } - } - #write to handle case where line-endings already \r\n too - oo::class create towindows { - variable o_trecord - variable o_enc - variable o_last_char_was_cr - variable o_is_junction - constructor {tf} { - set o_trecord $tf - set o_enc [dict get $tf -encoding] - set settingsdict [dict get $tf -settings] - if {[dict exists $tf -junction]} { - set o_is_junction [dict get $tf -junction] - } else { - set o_is_junction 0 - } - set o_last_char_was_cr 0 - } - method initialize {transform_handle mode} { - return [list initialize write finalize] - } - method finalize {transform_handle} { - my destroy - } - method watch {transform_handle events} { - } - #don't use read - method read {transform_handle bytes} { - set instring [encoding convertfrom $o_enc $bytes] - - set outstring $instring - - return [encoding convertto $o_enc $outstring] - } - method write {transform_handle bytes} { - set instring [encoding convertfrom $o_enc $bytes] - #set outstring [string map [list \n ] $instring] - - if {$o_last_char_was_cr} { - set instring "\r$instring" - } - - set outstring [string map {\r\n \uFFFF} $instring] - set outstring [string map {\n \r\n} $outstring] - set outstring [string map {\uFFFF \r\n} $outstring] - - set lastchar [string range $outstring end end] - if {$lastchar eq "\r"} { - set o_last_char_was_cr 1 - set outstring [string range $outstring 0 end-1] - } else { - set o_last_char_was_cr 0 - } - #review! can we detect eof here on the transform_handle? - #if eof, we don't want to strip a trailing \r - - return [encoding convertto $o_enc $outstring] - #return [encoding convertto utf-16le $outstring] - } - } - oo::define towindows { - method meta_is_redirection {} { - return $o_is_junction - } - } - - } -} - -# ---------------------------------------------------------------------------- -#review float/sink metaphor. -#perhaps something with the concept of upstream and downstream? -#need concepts for push towards data, sit in middle where placed, and lag at tail of data stream. -## upstream for stdin is at the bottom of the stack and for stdout is the top of the stack. -#upstream,neutral-upstream,downstream,downstream-aside,downstream-replace (default neutral-upstream - require action 'stack' to use standard channel stacking concept and ignore other actions) -#This is is a bit different from the float/sink metaphor which refers to the channel stacking order as opposed to the data-flow direction. -#The idea would be that whether input or output -# upstream additions go to the side closest to the datasource -# downstream additions go furthest from the datasource -# - all new additions go ahead of any diversions as the most upstream diversion is the current end of the stream in a way. -# - this needs review regarding subsequent removal of the diversion and whether filters re-order in response.. -# or if downstream & neutral additions are reclassified upon insertion if they land among existing upstreams(?) -# neutral-upstream goes to the datasource side of the neutral-upstream list. -# No 'neutral' option provided so that we avoid the need to think forwards or backwards when adding stdin vs stdout shellfilter does the necessary pop/push reordering. -# No 'neutral-downstream' to reduce complexity. -# downstream-replace & downstream-aside head downstream to the first diversion they encounter. ie these actions are no longer referring to the stack direction but only the dataflow direction. -# -# ---------------------------------------------------------------------------- -# -# 'filters' are transforms that don't redirect -# - limited range of actions to reduce complexity. -# - any requirement not fulfilled by float,sink,sink-replace,sink-sideline should be done by multiple pops and pushes -# -#actions can float to top of filters or sink to bottom of filters -#when action is of type sink, it can optionally replace or sideline the first non-filter it encounters (highest redirection on the stack.. any lower are starved of the stream anyway) -# - sideline means to temporarily replace the item and keep a record, restoring if/when we are removed from the transform stack -# -##when action is of type float it can't replace or sideline anything. A float is added above any existing floats and they stay in the same order relative to each other, -#but non-floats added later will sit below all floats. -#(review - float/sink initially designed around output channels. For stdin the dataflow is reversed. implement float-aside etc?) -# -# -#action: float sink sink-replace,sink-sideline -# -# -## note - whether stack is for input or output we maintain it in the same direction - which is in sync with the tcl chan pop chan push concept. -## -namespace eval shellfilter::stack { - namespace export {[a-z]*} - namespace ensemble create - #todo - implement as oo ? - variable pipelines [list] - - proc items {} { - #review - stdin,stdout,stderr act as pre-existing pipelines, and we can't create a new one with these names - so they should probably be autoconfigured and listed.. - # - but in what contexts? only when we find them in [chan names]? - variable pipelines - return [dict keys $pipelines] - } - proc item {pipename} { - variable pipelines - return [dict get $pipelines $pipename] - } - proc item_tophandle {pipename} { - variable pipelines - set handle "" - if {[dict exists $pipelines $pipename stack]} { - set stack [dict get $pipelines $pipename stack] - set topstack [lindex $stack end] ;#last item in stack is top (for output channels anyway) review comment. input chans? - if {$topstack ne ""} { - if {[dict exists $topstack -handle]} { - set handle [dict get $topstack -handle] - } - } - } - return $handle - } - proc status {{pipename *} args} { - variable pipelines - set pipecount [dict size $pipelines] - set tabletitle "$pipecount pipelines active" - set t [textblock::class::table new $tabletitle] - $t add_column -headers [list channel-ident] - $t add_column -headers [list device-info localchan] - $t configure_column 1 -header_colspans {3} - $t add_column -headers [list "" remotechan] - $t add_column -headers [list "" tid] - $t add_column -headers [list stack-info] - foreach k [dict keys $pipelines $pipename] { - set lc [dict get $pipelines $k device localchan] - set rc [dict get $pipelines $k device remotechan] - if {[dict exists $k device workertid]} { - set tid [dict get $pipelines $k device workertid] - } else { - set tid "-" - } - set stack [dict get $pipelines $k stack] - if {![llength $stack]} { - set stackinfo "" - } else { - set tbl_inner [textblock::class::table new] - $tbl_inner configure -show_edge 0 - foreach rec $stack { - set handle [punk::lib::dict_getdef $rec -handle ""] - set id [punk::lib::dict_getdef $rec -id ""] - set transform [namespace tail [punk::lib::dict_getdef $rec -transform ""]] - set settings [punk::lib::dict_getdef $rec -settings ""] - $tbl_inner add_row [list $id $transform $handle $settings] - } - set stackinfo [$tbl_inner print] - $tbl_inner destroy - } - $t add_row [list $k $lc $rc $tid $stackinfo] - } - set result [$t print] - $t destroy - return $result - } - proc status1 {{pipename *} args} { - variable pipelines - - set pipecount [dict size $pipelines] - set tableprefix "$pipecount pipelines active\n" - foreach p [dict keys $pipelines] { - append tableprefix " " $p \n - } - package require overtype - #todo -verbose - set table "" - set ac1 [string repeat " " 15] - set ac2 [string repeat " " 42] - set ac3 [string repeat " " 70] - append table "[overtype::left $ac1 channel-ident] " - append table "[overtype::left $ac2 device-info] " - append table "[overtype::left $ac3 stack-info]" - append table \n - - - set bc1 [string repeat " " 5] ;#stack id - set bc2 [string repeat " " 25] ;#transform - set bc3 [string repeat " " 50] ;#settings - - foreach k [dict keys $pipelines $pipename] { - set lc [dict get $pipelines $k device localchan] - if {[dict exists $k device workertid]} { - set tid [dict get $pipelines $k device workertid] - } else { - set tid "" - } - - - set col1 [overtype::left $ac1 $k] - set col2 [overtype::left $ac2 "localchan: $lc tid:$tid"] - - set stack [dict get $pipelines $k stack] - if {![llength $stack]} { - set col3 $ac3 - } else { - set rec [lindex $stack 0] - set bcol1 [overtype::left $bc1 [dict get $rec -id]] - set bcol2 [overtype::left $bc2 [namespace tail [dict get $rec -transform]]] - set bcol3 [overtype::left $bc3 [dict get $rec -settings]] - set stackrow "$bcol1 $bcol2 $bcol3" - set col3 [overtype::left $ac3 $stackrow] - } - - append table "$col1 $col2 $col3\n" - - - foreach rec [lrange $stack 1 end] { - set col1 $ac1 - set col2 $ac2 - if {[llength $rec]} { - set bc1 [overtype::left $bc1 [dict get $rec -id]] - set bc2 [overtype::left $bc2 [namespace tail [dict get $rec -transform]]] - set bc3 [overtype::left $bc3 [dict get $rec -settings]] - set stackrow "$bc1 $bc2 $bc3" - set col3 [overtype::left $ac3 $stackrow] - } else { - set col3 $ac3 - } - append table "$col1 $col2 $col3\n" - } - - } - return $tableprefix$table - } - #used for output channels - we usually want to sink redirections below the floaters and down to topmost existing redir - proc _get_stack_floaters {stack} { - set floaters [list] - foreach t [lreverse $stack] { - switch -- [dict get $t -action] { - float { - lappend floaters $t - } - default { - break - } - } - } - return [lreverse $floaters] - } - - - - #for output-channel sinking - proc _get_stack_top_redirection {stack} { - set r 0 ;#reverse index - foreach t [lreverse $stack] { - set obj [dict get $t -obj] - if {[$obj meta_is_redirection]} { - set idx [expr {[llength $stack] - ($r + 1) }] ;#forward index - return [list index $idx record $t] - } - incr r - } - #not found - return [list index -1 record {}] - } - #exclude float-locked, locked, sink-locked - proc _get_stack_top_redirection_replaceable {stack} { - set r 0 ;#reverse index - foreach t [lreverse $stack] { - set action [dict get $t -action] - if {![string match "*locked*" $action]} { - set obj [dict get $t -obj] - if {[$obj meta_is_redirection]} { - set idx [expr {[llength $stack] - ($r + 1) }] ;#forward index - return [list index $idx record $t] - } - } - incr r - } - #not found - return [list index -1 record {}] - } - - - #for input-channels ? - proc _get_stack_bottom_redirection {stack} { - set i 0 - foreach t $stack { - set obj [dict get $t -obj] - if {[$obj meta_is_redirection]} { - return [linst index $i record $t] - } - incr i - } - #not found - return [list index -1 record {}] - } - - - proc get_next_counter {pipename} { - variable pipelines - #use dictn incr ? - set counter [dict get $pipelines $pipename counter] - incr counter - dict set pipelines $pipename counter $counter - return $counter - } - - proc unwind {pipename} { - variable pipelines - set stack [dict get $pipelines $pipename stack] - set localchan [dict get $pipelines $pipename device localchan] - foreach tf [lreverse $stack] { - chan pop $localchan - } - dict set pipelines $pipename [list] - } - #todo - proc delete {pipename {wait 0}} { - variable pipelines - set pipeinfo [dict get $pipelines $pipename] - set deviceinfo [dict get $pipeinfo device] - set localchan [dict get $deviceinfo localchan] - unwind $pipename - - #release associated thread - set tid [dict get $deviceinfo workertid] - if {$wait} { - thread::release -wait $tid - } else { - thread::release $tid - } - - #Memchan closes without error - tcl::chan::fifo2 raises something like 'can not find channel named "rc977"' - REVIEW. why? - catch {chan close $localchan} - } - #review - proc name clarity is questionable. remove_stackitem? - proc remove {pipename remove_id} { - variable pipelines - if {![dict exists $pipelines $pipename]} { - puts stderr "WARNING: shellfilter::stack::remove pipename '$pipename' not found in pipelines dict: '$pipelines' [info level -1]" - return - } - set stack [dict get $pipelines $pipename stack] - set localchan [dict get $pipelines $pipename device localchan] - set posn 0 - set idposn -1 - set asideposn -1 - foreach t $stack { - set id [dict get $t -id] - if {$id eq $remove_id} { - set idposn $posn - break - } - #look into asides (only can be one for now) - if {[llength [dict get $t -aside]]} { - set a [dict get $t -aside] - if {[dict get $a -id] eq $remove_id} { - set asideposn $posn - break - } - } - incr posn - } - - if {$asideposn > 0} { - #id wasn't found directly in stack, but in an -aside. we don't need to pop anything - just clear this aside record - set container [lindex $stack $asideposn] - dict set container -aside {} - lset stack $asideposn $container - dict set pipelines $pipename stack $stack - } else { - if {$idposn < 0} { - ::shellfilter::log::write shellfilter "ERROR shellfilter::stack::remove $pipename id '$remove_id' not found" - puts stderr "|WARNING>shellfilter::stack::remove $pipename id '$remove_id' not found" - return 0 - } - set removed_item [lindex $stack $idposn] - - #include idposn in poplist - set poplist [lrange $stack $idposn end] - set stack [lreplace $stack $idposn end] - #pop all chans before adding anything back in! - foreach p $poplist { - chan pop $localchan - } - - if {[llength [dict get $removed_item -aside]]} { - set restore [dict get $removed_item -aside] - set t [dict get $restore -transform] - set tsettings [dict get $restore -settings] - set obj [$t new $restore] - set h [chan push $localchan $obj] - dict set restore -handle $h - dict set restore -obj $obj - lappend stack $restore - } - - #put popped back except for the first one, which we want to remove - foreach p [lrange $poplist 1 end] { - set t [dict get $p -transform] - set tsettings [dict get $p -settings] - set obj [$t new $p] - set h [chan push $localchan $obj] - dict set p -handle $h - dict set p -obj $obj - lappend stack $p - } - dict set pipelines $pipename stack $stack - } - #JMNJMN 2025 review! - #show_pipeline $pipename -note "after_remove $remove_id" - return 1 - } - - #pop a number of items of the top of the stack, add our transform record, and add back all (or the tail of poplist if pushstartindex > 0) - proc insert_transform {pipename stack transformrecord poplist {pushstartindex 0}} { - variable pipelines - set bottom_pop_posn [expr {[llength $stack] - [llength $poplist]}] - set poplist [lrange $stack $bottom_pop_posn end] - set stack [lreplace $stack $bottom_pop_posn end] - - set localchan [dict get $pipelines $pipename device localchan] - foreach p [lreverse $poplist] { - chan pop $localchan - } - set transformname [dict get $transformrecord -transform] - set transformsettings [dict get $transformrecord -settings] - set obj [$transformname new $transformrecord] - set h [chan push $localchan $obj] - dict set transformrecord -handle $h - dict set transformrecord -obj $obj - dict set transformrecord -note "insert_transform" - lappend stack $transformrecord - foreach p [lrange $poplist $pushstartindex end] { - set t [dict get $p -transform] - set tsettings [dict get $p -settings] - set obj [$t new $p] - set h [chan push $localchan $obj] - #retain previous -id - code that added it may have kept reference and not expecting it to change - dict set p -handle $h - dict set p -obj $obj - dict set p -note "re-added" - - lappend stack $p - } - return $stack - } - - #fifo2 - proc new {pipename args} { - variable pipelines - if {($pipename in [dict keys $pipelines]) || ($pipename in [chan names])} { - error "shellfilter::stack::new error: pipename '$pipename' already exists" - } - - set opts [dict merge {-settings {}} $args] - set defaultsettings [dict create -raw 1 -buffering line -direction out] - set targetsettings [dict merge $defaultsettings [dict get $opts -settings]] - - set direction [dict get $targetsettings -direction] - - #pipename is the source/facility-name ? - if {$direction eq "out"} { - set pipeinfo [shellfilter::pipe::open_out $pipename $targetsettings] - } else { - puts stderr "|jn> pipe::open_in $pipename $targetsettings" - set pipeinfo [shellfilter::pipe::open_in $pipename $targetsettings] - } - #open_out/open_in will configure buffering based on targetsettings - - set program_chan [dict get $pipeinfo localchan] - set worker_chan [dict get $pipeinfo remotechan] - set workertid [dict get $pipeinfo workertid] - - - set deviceinfo [dict create pipename $pipename localchan $program_chan remotechan $worker_chan workertid $workertid direction $direction] - dict set pipelines $pipename [list counter 0 device $deviceinfo stack [list]] - - return $deviceinfo - } - #we 'add' rather than 'push' because transforms can float,sink and replace/sideline so they don't necessarily go to the top of the transform stack - proc add {pipename transformname args} { - variable pipelines - #chan names doesn't reflect available channels when transforms are in place - #e.g stdout may exist but show as something like file191f5b0dd80 - if {($pipename ni [dict keys $pipelines])} { - if {[catch {eof $pipename} is_eof]} { - error "shellfilter::stack::add no existing chan or pipename matching '$pipename' in channels:[chan names] or pipelines:$pipelines use stdin/stderr/stdout or shellfilter::stack::new " - } - } - set args [dict merge {-action "" -settings {}} $args] - set action [dict get $args -action] - set transformsettings [dict get $args -settings] - if {[string first "::" $transformname] < 0} { - set transformname ::shellfilter::chan::$transformname - } - if {![llength [info commands $transformname]]} { - error "shellfilter::stack::push unknown transform '$transformname'" - } - - - if {![dict exists $pipelines $pipename]} { - #pipename must be in chan names - existing device/chan - #record a -read and -write end even if the device is only being used as one or the other - set deviceinfo [dict create pipename $pipename localchan $pipename remotechan {}] - dict set pipelines $pipename [list counter 0 device $deviceinfo stack [list]] - } else { - set deviceinfo [dict get $pipelines $pipename device] - } - - set id [get_next_counter $pipename] - set stack [dict get $pipelines $pipename stack] - set localchan [dict get $deviceinfo localchan] - - #we redundantly store chan in each transform - makes debugging clearer - # -encoding similarly could be stored only at the pipeline level (or even queried directly each filter-read/write), - # but here it may help detect unexpected changes during lifetime of the stack and avoids the chance of callers incorrectly using the transform handle?) - # jn - set transform_record [list -id $id -chan $pipename -encoding [chan configure $localchan -encoding] -transform $transformname -aside {} {*}$args] - switch -glob -- $action { - float - float-locked { - set obj [$transformname new $transform_record] - set h [chan push $localchan $obj] - dict set transform_record -handle $h - dict set transform_record -obj $obj - lappend stack $transform_record - } - "" - locked { - set floaters [_get_stack_floaters $stack] - if {![llength $floaters]} { - set obj [$transformname new $transform_record] - set h [chan push $localchan $obj] - dict set transform_record -handle $h - dict set transform_record -obj $obj - lappend stack $transform_record - } else { - set poplist $floaters - set stack [insert_transform $pipename $stack $transform_record $poplist] - } - } - "sink*" { - set redirinfo [_get_stack_top_redirection $stack] - set idx_existing_redir [dict get $redirinfo index] - if {$idx_existing_redir == -1} { - #no existing redirection transform on the stack - #pop everything.. add this record as the first redirection on the stack - set poplist $stack - set stack [insert_transform $pipename $stack $transform_record $poplist] - } else { - switch -glob -- $action { - "sink-replace" { - #include that index in the poplist - set poplist [lrange $stack $idx_existing_redir end] - #pop all from idx_existing_redir to end, but put back 'lrange $poplist 1 end' - set stack [insert_transform $pipename $stack $transform_record $poplist 1] - } - "sink-aside*" { - set existing_redir_record [lindex $stack $idx_existing_redir] - if {[string match "*locked*" [dict get $existing_redir_record -action]]} { - set put_aside 0 - #we can't aside this one - sit above it instead. - set poplist [lrange $stack $idx_existing_redir+1 end] - set stack [lrange $stack 0 $idx_existing_redir] - } else { - set put_aside 1 - dict set transform_record -aside [lindex $stack $idx_existing_redir] - set poplist [lrange $stack $idx_existing_redir end] - set stack [lrange $stack 0 $idx_existing_redir-1] - } - foreach p $poplist { - chan pop $localchan - } - set transformname [dict get $transform_record -transform] - set transform_settings [dict get $transform_record -settings] - set obj [$transformname new $transform_record] - set h [chan push $localchan $obj] - dict set transform_record -handle $h - dict set transform_record -obj $obj - dict set transform_record -note "insert_transform-with-aside" - lappend stack $transform_record - #add back poplist *except* the one we transferred into -aside (if we were able) - foreach p [lrange $poplist $put_aside end] { - set t [dict get $p -transform] - set tsettings [dict get $p -settings] - set obj [$t new $p] - set h [chan push $localchan $obj] - #retain previous -id - code that added it may have kept reference and not expecting it to change - dict set p -handle $h - dict set p -obj $obj - dict set p -note "re-added-after-sink-aside" - lappend stack $p - } - } - default { - #plain "sink" - #we only sink to the topmost redirecting filter - which makes sense for an output channel - #For stdin.. this is more problematic as we're more likely to want to intercept the bottom most redirection. - #todo - review. Consider making default insert position for input channels to be at the source... and float/sink from there. - # - we don't currently know from the stack api if adding input vs output channel - so this needs work to make intuitive. - # consider splitting stack::add to stack::addinput stack::addoutput to split the different behaviour - set poplist [lrange $stack $idx_existing_redir+1 end] - set stack [insert_transform $pipename $stack $transform_record $poplist] - } - } - } - } - default { - error "shellfilter::stack::add unimplemented action '$action'" - } - } - - dict set pipelines $pipename stack $stack - #puts stdout "==" - #puts stdout "==>stack: $stack" - #puts stdout "==" - - #JMNJMN - #show_pipeline $pipename -note "after_add $transformname $args" - return $id - } - proc show_pipeline {pipename args} { - variable pipelines - set stack [dict get $pipelines $pipename stack] - set tag "SHELLFILTER::STACK" - #JMN - load from config - #::shellfilter::log::open $tag {-syslog 127.0.0.1:514} - if {[catch { - ::shellfilter::log::open $tag {-syslog ""} - } err]} { - #e.g safebase interp can't load required modules such as shellthread (or Thread) - puts stderr "shellfilter::show_pipeline cannot open log" - return - } - ::shellfilter::log::write $tag "transform stack for $pipename $args" - foreach tf $stack { - ::shellfilter::log::write $tag " $tf" - } - - } -} - - -namespace eval shellfilter { - variable sources [list] - variable stacks [dict create] - - proc ::shellfilter::redir_channel_to_log {chan args} { - variable sources - set default_logsettings [dict create \ - -tag redirected_$chan -syslog "" -file ""\ - ] - if {[dict exists $args -action]} { - set action [dict get $args -action] - } else { - # action "sink" is a somewhat reasonable default for an output redirection transform - # but it can make it harder to configure a plain ordered stack if the user is not expecting it, so we'll default to stack - # also.. for stdin transform sink makes less sense.. - #todo - default "stack" instead of empty string - set action "" - } - if {[dict exists $args -settings]} { - set logsettings [dict get $args -settings] - } else { - set logsettings {} - } - - set logsettings [dict merge $default_logsettings $logsettings] - set tag [dict get $logsettings -tag] - if {$tag ni $sources} { - lappend sources $tag - } - - set id [shellfilter::stack::add $chan logonly -action $action -settings $logsettings] - return $id - } - - proc ::shellfilter::redir_output_to_log {tagprefix args} { - variable sources - - set default_settings [list -tag ${tagprefix} -syslog "" -file ""] - - set opts [dict create -action "" -settings {}] - set opts [dict merge $opts $args] - set optsettings [dict get $opts -settings] - set settings [dict merge $default_settings $optsettings] - - set tag [dict get $settings -tag] - if {$tag ne $tagprefix} { - error "shellfilter::redir_output_to_log -tag value must match supplied tagprefix:'$tagprefix'. Omit -tag, or make it the same. It will automatically be suffixed with stderr and stdout. Use redir_channel_to_log if you want to separately configure each channel" - } - lappend sources ${tagprefix}stdout ${tagprefix}stderr - - set stdoutsettings $settings - dict set stdoutsettings -tag ${tagprefix}stdout - set stderrsettings $settings - dict set stderrsettings -tag ${tagprefix}stderr - - set idout [redir_channel_to_log stdout -action [dict get $opts -action] -settings $stdoutsettings] - set iderr [redir_channel_to_log stderr -action [dict get $opts -action] -settings $stderrsettings] - - return [list $idout $iderr] - } - - #eg try: set v [list #a b c] - #vs set v {#a b c} - proc list_is_canonical l { - #courtesy DKF via wiki https://wiki.tcl-lang.org/page/BNF+for+Tcl - if {[catch {llength $l}]} {return 0} - string equal $l [list {*}$l] - } - - #return a dict keyed on numerical list index showing info about each element - # - particularly - # 'wouldbrace' to indicate that the item would get braced by Tcl when added to another list - # 'head_tail_chars' to show current first and last character (in case it's wrapped e.g in double or single quotes or an existing set of braces) - proc list_element_info {inputlist} { - set i 0 - set info [dict create] - set testlist [list] - foreach original_item $inputlist { - #--- - # avoid sharing internal rep with original items in the list (avoids shimmering of rep in original list for certain items such as paths) - unset -nocomplain item - append item $original_item {} - #--- - - set iteminfo [dict create] - set itemlen [string length $item] - lappend testlist $item - set tcl_len [string length $testlist] - set diff [expr {$tcl_len - $itemlen}] - if {$diff == 0} { - dict set iteminfo wouldbrace 0 - dict set iteminfo wouldescape 0 - } else { - #test for escaping vs bracing! - set testlistchars [split $testlist ""] - if {([lindex $testlistchars 0] eq "\{") && ([lindex $testlistchars end] eq "\}")} { - dict set iteminfo wouldbrace 1 - dict set iteminfo wouldescape 0 - } else { - dict set iteminfo wouldbrace 0 - dict set iteminfo wouldescape 1 - } - } - set testlist [list] - set charlist [split $item ""] - set char_a [lindex $charlist 0] - set char_b [lindex $charlist 1] - set char_ab ${char_a}${char_b} - set char_y [lindex $charlist end-1] - set char_z [lindex $charlist end] - set char_yz ${char_y}${char_z} - - if { ("{" in $charlist) || ("}" in $charlist) } { - dict set iteminfo has_braces 1 - set innerchars [lrange $charlist 1 end-1] - if {("{" in $innerchars) || ("}" in $innerchars)} { - dict set iteminfo has_inner_braces 1 - } else { - dict set iteminfo has_inner_braces 0 - } - } else { - dict set iteminfo has_braces 0 - dict set iteminfo has_inner_braces 0 - } - - #todo - brace/char counting to determine if actually 'wrapped' - #e.g we could have list element {((abc)} - which appears wrapped if only looking at first and last chars. - #also {(x) (y)} as a list member.. how to treat? - if {$itemlen <= 1} { - dict set iteminfo apparentwrap "not" - } else { - #todo - switch on $char_a$char_z - if {($char_a eq {"}) && ($char_z eq {"})} { - dict set iteminfo apparentwrap "doublequotes" - } elseif {($char_a eq "'") && ($char_z eq "'")} { - dict set iteminfo apparentwrap "singlequotes" - } elseif {($char_a eq "(") && ($char_z eq ")")} { - dict set iteminfo apparentwrap "brackets" - } elseif {($char_a eq "\{") && ($char_z eq "\}")} { - dict set iteminfo apparentwrap "braces" - } elseif {($char_a eq "^") && ($char_z eq "^")} { - dict set iteminfo apparentwrap "carets" - } elseif {($char_a eq "\[") && ($char_z eq "\]")} { - dict set iteminfo apparentwrap "squarebrackets" - } elseif {($char_a eq "`") && ($char_z eq "`")} { - dict set iteminfo apparentwrap "backquotes" - } elseif {($char_a eq "\n") && ($char_z eq "\n")} { - dict set iteminfo apparentwrap "lf-newline" - } elseif {($char_ab eq "\r\n") && ($char_yz eq "\r\n")} { - dict set iteminfo apparentwrap "crlf-newline" - } else { - dict set iteminfo apparentwrap "not-determined" - } - - } - dict set iteminfo wrapbalance "unknown" ;#a hint to caller that apparentwrap is only a guide. todo - possibly make wrapbalance indicate 0 for unbalanced.. and positive numbers for outer-count of wrappings. - #e.g {((x)} == 0 {((x))} == 1 {(x) (y (z))} == 2 - dict set iteminfo head_tail_chars [list $char_a $char_z] - set namemap [list \ - \r cr\ - \n lf\ - {"} doublequote\ - {'} singlequote\ - "`" backquote\ - "^" caret\ - \t tab\ - " " sp\ - "\[" lsquare\ - "\]" rsquare\ - "(" lbracket\ - ")" rbracket\ - "\{" lbrace\ - "\}" rbrace\ - \\ backslash\ - / forwardslash\ - ] - if {[string length $char_a]} { - set char_a_name [string map $namemap $char_a] - } else { - set char_a_name "emptystring" - } - if {[string length $char_z]} { - set char_z_name [string map $namemap $char_z] - } else { - set char_z_name "emptystring" - } - - dict set iteminfo head_tail_names [list $char_a_name $char_z_name] - dict set iteminfo len $itemlen - dict set iteminfo difflen $diff ;#2 for braces, 1 for quoting?, or 0. - dict set info $i $iteminfo - incr i - } - return $info - } - - - #parse bracketed expression (e.g produced by vim "shellxquote=(" ) into a tcl (nested) list - #e.g {(^c:/my spacey/path^ >^somewhere^)} - #e.g {(blah (etc))}" - #Result is always a list - even if only one toplevel set of brackets - so it may need [lindex $result 0] if input is the usual case of {( ...)} - # - because it also supports the perhaps less likely case of: {( ...) unbraced (...)} etc - # Note that - #maintenance warning - duplication in branches for bracketed vs unbracketed! - proc parse_cmd_brackets {str} { - #wordwrappers currently best suited to non-bracket entities - no bracket matching within - anything goes until end-token reached. - # - but.. they only take effect where a word can begin. so a[x y] may be split at the space unless it's within some other wraper e.g " a[x y]" will not break at the space - # todo - consider extending the in-word handling of word_bdepth which is currently only applied to () i.e aaa(x y) is supported but aaa[x y] is not as the space breaks the word up. - set wordwrappers [list \ - "\"" [list "\"" "\"" "\""]\ - {^} [list "\"" "\"" "^"]\ - "'" [list "'" "'" "'"]\ - "\{" [list "\{" "\}" "\}"]\ - {[} [list {[} {]} {]}]\ - ] ;#dict mapping start_character to {replacehead replacetail expectedtail} - set shell_specials [list "|" "|&" "<" "<@" "<<" ">" "2>" ">&" ">>" "2>>" ">>&" ">@" "2>@" "2>@1" ">&@" "&" "&&" ] ;#words/chars that may precede an opening bracket but don't merge with the bracket to form a word. - #puts "pb:$str" - set in_bracket 0 - set in_word 0 - set word "" - set result {} - set word_bdepth 0 - set word_bstack [list] - set wordwrap "" ;#only one active at a time - set bracketed_elements [dict create] - foreach char [split $str ""] { - #puts "c:$char bracketed:$bracketed_elements" - if {$in_bracket > 0} { - if {$in_word} { - if {[string length $wordwrap]} { - #anything goes until end-char - #todo - lookahead and only treat as closing if before a space or ")" ? - lassign [dict get $wordwrappers $wordwrap] _open closing endmark - if {$char eq $endmark} { - set wordwrap "" - append word $closing - dict lappend bracketed_elements $in_bracket $word - set word "" - set in_word 0 - } else { - append word $char - } - } else { - if {$word_bdepth == 0} { - #can potentially close off a word - or start a new one if word-so-far is a shell-special - if {$word in $shell_specials} { - if {$char eq ")"} { - dict lappend bracketed_elements $in_bracket $word - set subresult [dict get $bracketed_elements $in_bracket] - dict set bracketed_elements $in_bracket [list] - incr in_bracket -1 - if {$in_bracket == 0} { - lappend result $subresult - } else { - dict lappend bracketed_elements $in_bracket $subresult - } - set word "" - set in_word 0 - } elseif {[regexp {[\s]} $char]} { - dict lappend bracketed_elements $in_bracket $word - set word "" - set in_word 0 - } elseif {$char eq "("} { - dict lappend bracketed_elements $in_bracket $word - set word "" - set in_word 0 - incr in_bracket - } else { - #at end of shell-specials is another point to look for word started by a wordwrapper char - #- expect common case of things like >^/my/path^ - if {$char in [dict keys $wordwrappers]} { - dict lappend bracketed_elements $in_bracket $word - set word "" - set in_word 1 ;#just for explicitness.. we're straight into the next word. - set wordwrap $char - set word [lindex [dict get $wordwrappers $char] 0] ;#replace trigger char with the start value it maps to. - } else { - #something unusual.. keep going with word! - append word $char - } - } - } else { - - if {$char eq ")"} { - dict lappend bracketed_elements $in_bracket $word - set subresult [dict get $bracketed_elements $in_bracket] - dict set bracketed_elements $in_bracket [list] - incr in_bracket -1 - if {$in_bracket == 0} { - lappend result $subresult - } else { - dict lappend bracketed_elements $in_bracket $subresult - } - set word "" - set in_word 0 - } elseif {[regexp {[\s]} $char]} { - dict lappend bracketed_elements $in_bracket $word - set word "" - set in_word 0 - } elseif {$char eq "("} { - #ordinary word up-against and opening bracket - brackets are part of word. - incr word_bdepth - append word "(" - } else { - append word $char - } - } - } else { - #currently only () are used for word_bdepth - todo add all or some wordwrappers chars so that the word_bstack can have multiple active. - switch -- $char { - "(" { - incr word_bdepth - lappend word_bstack $char - append word $char - } - ")" { - incr word_bdepth -1 - set word_bstack [lrange $word_bstack 0 end-1] - append word $char - } - default { - #spaces and chars added to word as it's still in a bracketed section - append word $char - } - } - } - } - } else { - - if {$char eq "("} { - incr in_bracket - - } elseif {$char eq ")"} { - set subresult [dict get $bracketed_elements $in_bracket] - dict set bracketed_elements $in_bracket [list] - incr in_bracket -1 - if {$in_bracket == 0} { - lappend result $subresult - } else { - dict lappend bracketed_elements $in_bracket $subresult - } - } elseif {[regexp {[\s]} $char]} { - # - } else { - #first char of word - look for word-wrappers - if {$char in [dict keys $wordwrappers]} { - set wordwrap $char - set word [lindex [dict get $wordwrappers $char] 0] ;#replace trigger char with the start value it maps to. - } else { - set word $char - } - set in_word 1 - } - } - } else { - if {$in_word} { - if {[string length $wordwrap]} { - lassign [dict get $wordwrappers $wordwrap] _open closing endmark - if {$char eq $endmark} { - set wordwrap "" - append word $closing - lappend result $word - set word "" - set in_word 0 - } else { - append word $char - } - } else { - - if {$word_bdepth == 0} { - if {$word in $shell_specials} { - if {[regexp {[\s]} $char]} { - lappend result $word - set word "" - set in_word 0 - } elseif {$char eq "("} { - lappend result $word - set word "" - set in_word 0 - incr in_bracket - } else { - #at end of shell-specials is another point to look for word started by a wordwrapper char - #- expect common case of things like >^/my/path^ - if {$char in [dict keys $wordwrappers]} { - lappend result $word - set word "" - set in_word 1 ;#just for explicitness.. we're straight into the next word. - set wordwrap $char - set word [lindex [dict get $wordwrappers $char] 0] ;#replace trigger char with the start value it maps to. - } else { - #something unusual.. keep going with word! - append word $char - } - } - - } else { - if {[regexp {[\s)]} $char]} { - lappend result $word - set word "" - set in_word 0 - } elseif {$char eq "("} { - incr word_bdepth - append word $char - } else { - append word $char - } - } - } else { - switch -- $char { - "(" { - incr word_bdepth - append word $char - } - ")" { - incr word_bdepth -1 - append word $char - } - default { - append word $char - } - } - } - } - } else { - if {[regexp {[\s]} $char]} { - #insig whitespace(?) - } elseif {$char eq "("} { - incr in_bracket - dict set bracketed_elements $in_bracket [list] - } elseif {$char eq ")"} { - error "unbalanced bracket - unable to proceed result so far: $result bracketed_elements:$bracketed_elements" - } else { - #first char of word - look for word-wrappers - if {$char in [dict keys $wordwrappers]} { - set wordwrap $char - set word [lindex [dict get $wordwrappers $char] 0] ;#replace trigger char with the start value it maps to. - } else { - set word $char - } - set in_word 1 - } - } - } - #puts "----$bracketed_elements" - } - if {$in_bracket > 0} { - error "shellfilter::parse_cmd_brackets missing close bracket. input was '$str'" - } - if {[dict exists $bracketed_elements 0]} { - #lappend result [lindex [dict get $bracketed_elements 0] 0] - lappend result [dict get $bracketed_elements 0] - } - if {$in_word} { - lappend result $word - } - return $result - } - - #only double quote if argument not quoted with single or double quotes - proc dquote_if_not_quoted {a} { - set wrapchars [string cat [string range $a 0 0] [string range $a end end]] - switch -- $wrapchars { - {""} - {''} { - return $a - } - default { - set newinner [string map [list {"} "\\\""] $a] - return "\"$newinner\"" - } - } - } - - #proc dquote_if_not_bracketed/braced? - - #wrap in double quotes if not double-quoted - proc dquote_if_not_dquoted {a} { - set wrapchars [string cat [string range $a 0 0] [string range $a end end]] - switch -- $wrapchars { - {""} { - return $a - } - default { - #escape any inner quotes.. - set newinner [string map [list {"} "\\\""] $a] - return "\"$newinner\"" - } - } - } - proc dquote {a} { - #escape any inner quotes.. - set newinner [string map [list {"} "\\\""] $a] - return "\"$newinner\"" - } - proc get_scriptrun_from_cmdlist_dquote_if_not {cmdlist {shellcmdflag ""}} { - set scr [auto_execok "script"] - if {[string length $scr]} { - #set scriptrun "( $c1 [lrange $cmdlist 1 end] )" - set arg1 [lindex $cmdlist 0] - if {[string first " " $arg1]>0} { - set c1 [dquote_if_not_quoted $arg1] - #set c1 "\"$arg1\"" - } else { - set c1 $arg1 - } - - if {[string length $shellcmdflag]} { - set scriptrun "$shellcmdflag \$($c1 " - } else { - set scriptrun "\$($c1 " - } - #set scriptrun "$c1 " - foreach a [lrange $cmdlist 1 end] { - #set a [string map [list "/" "//"] $a] - #set a [string map [list "\"" "\\\""] $a] - if {[string first " " $a] > 0} { - append scriptrun [dquote_if_not_quoted $a] - } else { - append scriptrun $a - } - append scriptrun " " - } - set scriptrun [string trim $scriptrun] - append scriptrun ")" - #return [list $scr -q -e -c $scriptrun /dev/null] - return [list $scr -e -c $scriptrun /dev/null] - } else { - return $cmdlist - } - } - - proc ::shellfilter::trun {commandlist args} { - #jmn - } - - - # run a command (or tcl script) with tees applied to stdout/stderr/stdin (or whatever channels are being used) - # By the point run is called - any transforms should already be in place on the channels if they're needed. - # The tees will be inline with none,some or all of those transforms depending on how the stack was configured - # (upstream,downstream configured via -float,-sink etc) - proc ::shellfilter::run {commandlist args} { - #must be a list. If it was a shell commandline string. convert it elsewhere first. - - variable sources - set runtag "shellfilter-run" - #set tid [::shellfilter::log::open $runtag [list -syslog 127.0.0.1:514]] - set tid [::shellfilter::log::open $runtag [list -syslog ""]] - if {[catch {llength $commandlist} listlen]} { - set listlen "" - } - ::shellfilter::log::write $runtag " commandlist:'$commandlist' listlen:$listlen strlen:[string length $commandlist]" - - #flush stdout - #flush stderr - - #adding filters with sink-aside will temporarily disable the existing redirection - #All stderr/stdout from the shellcommand will now tee to the underlying stderr/stdout as well as the configured syslog - - set defaults [dict create \ - -teehandle command \ - -outchan stdout \ - -errchan stderr \ - -inchan stdin \ - -tclscript 0 \ - ] - set opts [dict merge $defaults $args] - - # -- --- --- --- --- --- --- --- --- --- --- --- --- --- - set outchan [dict get $opts -outchan] - set errchan [dict get $opts -errchan] - set inchan [dict get $opts -inchan] - set teehandle [dict get $opts -teehandle] - # -- --- --- --- --- --- --- --- --- --- --- --- --- --- - set is_script [dict get $opts -tclscript] - dict unset opts -tclscript ;#don't pass it any further - # -- --- --- --- --- --- --- --- --- --- --- --- --- --- - set teehandle_out ${teehandle}out ;#default commandout - set teehandle_err ${teehandle}err - set teehandle_in ${teehandle}in - - - #puts stdout "shellfilter initialising tee_to_pipe transforms for in/out/err" - - # sources should be added when stack::new called instead(?) - foreach source [list $teehandle_out $teehandle_err] { - if {$source ni $sources} { - lappend sources $source - } - } - set outdeviceinfo [dict get $::shellfilter::stack::pipelines $teehandle_out device] - set outpipechan [dict get $outdeviceinfo localchan] - set errdeviceinfo [dict get $::shellfilter::stack::pipelines $teehandle_err device] - set errpipechan [dict get $errdeviceinfo localchan] - - #set indeviceinfo [dict get $::shellfilter::stack::pipelines $teehandle_in device] - #set inpipechan [dict get $indeviceinfo localchan] - - #NOTE:These transforms are not necessarily at the top of each stack! - #The float/sink mechanism, along with whether existing transforms are diversionary decides where they sit. - set id_out [shellfilter::stack::add $outchan tee_to_pipe -action sink-aside -settings [list -tag $teehandle_out -pipechan $outpipechan]] - set id_err [shellfilter::stack::add $errchan tee_to_pipe -action sink-aside -settings [list -tag $teehandle_err -pipechan $errpipechan]] - - # need to use os level channel handle for stdin - try named pipes (or even sockets) instead of fifo2 for this - # If non os-level channel - the command can't be run with the redirection - # stderr/stdout can be run with non-os handles in the call - - # but then it does introduce issues with terminal-detection and behaviour for stdout at least - # - # input is also a tee - we never want to change the source at this point - just log/process a side-channel of it. - # - #set id_in [shellfilter::stack::add $inchan tee_to_pipe -action sink-aside -settings [list -tag commandin -pipechan $inpipechan]] - - - #set id_out [shellfilter::stack::add stdout tee_to_log -action sink-aside -settings [list -tag shellstdout -syslog 127.0.0.1:514 -file ""]] - #set id_err [shellfilter::stack::add stderr tee_to_log -action sink-aside -settings [list -tag shellstderr -syslog 127.0.0.1:514 -file "stderr.txt"]] - - #we need to catch errors - and ensure stack::remove calls occur. - #An error can be raised if the command couldn't even launch, as opposed to a non-zero exitcode and stderr output from the command itself. - # - if {!$is_script} { - set experiment 0 - if {$experiment} { - try { - set results [exec {*}$commandlist] - set exitinfo [list exitcode 0] - } trap CHILDSTATUS {results options} { - set exitcode [lindex [dict get $options -errorcode] 2] - set exitinfo [list exitcode $exitcode] - } - } else { - if {[catch { - #run process with stdout/stderr/stdin or with configured channels - #set exitinfo [shellcommand_stdout_stderr $commandlist $outchan $errchan $inpipechan {*}$opts] - set exitinfo [shellcommand_stdout_stderr $commandlist $outchan $errchan stdin {*}$opts] - #puts stderr "---->exitinfo $exitinfo" - - #subprocess result should usually have an "exitcode" key - #but for background execution we will get a "pids" key of process ids. - } errMsg]} { - set exitinfo [list error "$errMsg" source shellcommand_stdout_stderr] - } - } - } else { - if {[catch { - #script result - set exitinfo [list result [uplevel #0 [list eval $commandlist]]] - } errMsg]} { - set exitinfo [list error "$errMsg" errorCode $::errorCode errorInfo "$::errorInfo"] - } - } - - - #the previous redirections on the underlying inchan/outchan/errchan items will be restored from the -aside setting during removal - #Remove execution-time Tees from stack - shellfilter::stack::remove stdout $id_out - shellfilter::stack::remove stderr $id_err - #shellfilter::stack::remove stderr $id_in - - - #chan configure stderr -buffering line - #flush stdout - - - ::shellfilter::log::write $runtag " return '$exitinfo'" - ::shellfilter::log::close $runtag - return $exitinfo - } - proc ::shellfilter::logtidyup { {tags {}} } { - variable sources - set worker_errorlist [list] - set tidied_sources [list] - set tidytag "logtidy" - - - # opening a thread or writing to a log/syslog close to possible process exit is probably not a great idea. - # we should ensure the thread already exists early on if we really need logging here. - # - #set tid [::shellfilter::log::open $tidytag {-syslog 127.0.0.1:514}] - #::shellfilter::log::write $tidytag " logtidyuptags '$tags'" - - foreach s $sources { - if {$s eq $tidytag} { - continue - } - #puts "logtidyup source $s" - set close 1 - if {[llength $tags]} { - if {$s ni $tags} { - set close 0 - } - } - if {$close} { - lappend tidied_sources $s - shellfilter::log::close $s - lappend worker_errorlist {*}[shellthread::manager::get_and_clear_errors $s] - } - } - set remaining_sources [list] - foreach s $sources { - if {$s ni $tidied_sources} { - lappend remaining_sources $s - } - } - - #set sources [concat $remaining_sources $tidytag] - set sources $remaining_sources - - #shellfilter::stack::unwind stdout - #shellfilter::stack::unwind stderr - return [list tidied $tidied_sources errors $worker_errorlist] - } - - #package require tcl::chan::null - # e.g set errchan [tcl::chan::null] - # e.g chan push stdout [shellfilter::chan::var new ::some_var] - proc ::shellfilter::shellcommand_stdout_stderr {commandlist outchan errchan inchan args} { - set valid_flags [list \ - -timeout \ - -outprefix \ - -errprefix \ - -debug \ - -copytempfile \ - -outbuffering \ - -errbuffering \ - -inbuffering \ - -readprocesstranslation \ - -outtranslation \ - -stdinhandler \ - -outchan \ - -errchan \ - -inchan \ - -teehandle\ - ] - - set runtag shellfilter-run2 - #JMN - load from config - #set tid [::shellfilter::log::open $runtag [list -syslog "127.0.0.1:514"]] - set tid [::shellfilter::log::open $runtag [list -syslog ""]] - - if {[llength $args] % 2} { - error "Trailing arguments after any positional arguments must be in pairs of the form -argname argvalue. Valid flags are:'$valid_flags'" - } - set invalid_flags [list] - foreach {k -} $args { - switch -- $k { - -timeout - - -outprefix - - -errprefix - - -debug - - -copytempfile - - -outbuffering - - -errbuffering - - -inbuffering - - -readprocesstranslation - - -outtranslation - - -stdinhandler - - -outchan - - -errchan - - -inchan - - -teehandle { - } - default { - lappend invalid_flags $k - } - } - } - if {[llength $invalid_flags]} { - error "Unknown option(s)'$invalid_flags': must be one of '$valid_flags'" - } - #line buffering generally best for output channels.. keeps relative output order of stdout/stdin closer to source order - #there may be data where line buffering is inappropriate, so it's configurable per std channel - #reading inputs with line buffering can result in extraneous newlines as we can't detect trailing data with no newline before eof. - set defaults [dict create \ - -outchan stdout \ - -errchan stderr \ - -inchan stdin \ - -outbuffering none \ - -errbuffering none \ - -readprocesstranslation auto \ - -outtranslation lf \ - -inbuffering none \ - -timeout 900000\ - -outprefix ""\ - -errprefix ""\ - -debug 0\ - -copytempfile 0\ - -stdinhandler ""\ - ] - - - - set args [dict merge $defaults $args] - set outbuffering [dict get $args -outbuffering] - set errbuffering [dict get $args -errbuffering] - set inbuffering [dict get $args -inbuffering] - set readprocesstranslation [dict get $args -readprocesstranslation] - set outtranslation [dict get $args -outtranslation] - set timeout [dict get $args -timeout] - set outprefix [dict get $args -outprefix] - set errprefix [dict get $args -errprefix] - set debug [dict get $args -debug] - set copytempfile [dict get $args -copytempfile] - set stdinhandler [dict get $args -stdinhandler] - - set debugname "shellfilter-debug" - - if {$debug} { - set tid [::shellfilter::log::open $debugname [list -syslog "127.0.0.1:514"]] - ::shellfilter::log::write $debugname " commandlist '$commandlist'" - } - #'clock micros' good enough id for shellcommand calls unless one day they can somehow be called concurrently or sequentially within a microsecond and within the same interp. - # a simple counter would probably work too - #consider other options if an alternative to the single vwait in this function is used. - set call_id [tcl::clock::microseconds] ; - set ::shellfilter::shellcommandvars($call_id,exitcode) "" - set waitvar ::shellfilter::shellcommandvars($call_id,waitvar) - if {$debug} { - ::shellfilter::log::write $debugname " waitvar '$waitvar'" - } - lassign [chan pipe] rderr wrerr - chan configure $wrerr -blocking 0 - - set custom_stderr "" - set lastitem [lindex $commandlist end] - #todo - ensure we can handle 2> file (space after >) - - #review - reconsider the handling of redirections such that tcl-style are handled totally separately to other shell syntaxes! - # - #note 2>@1 must ocur as last word for tcl - but 2@stdout can occur elsewhere - #(2>@stdout echoes to main stdout - not into pipeline) - #To properly do pipelines it looks like we will have to split on | and call this proc multiple times and wire it up accordingly (presumably in separate threads) - - switch -- [string trim $lastitem] { - {&} { - set name [lindex $commandlist 0] - #background execution - stdout and stderr from child still comes here - but process is backgrounded - #FIX! - this is broken for paths with backslashes for example - #set pidlist [exec {*}[concat $name [lrange $commandlist 1 end]]] - set pidlist [exec {*}$commandlist] - return [list pids $pidlist] - } - {2>&1} - {2>@1} { - set custom_stderr {2>@1} ;#use the tcl style - set commandlist [lrange $commandlist 0 end-1] - } - default { - # 2> filename - # 2>> filename - # 2>@ openfileid - set redir2test [string range $lastitem 0 1] - if {$redir2test eq "2>"} { - set custom_stderr $lastitem - set commandlist [lrange $commandlist 0 end-1] - } - } - } - set lastitem [lindex $commandlist end] - - set teefile "" ;#empty string, write, append - #an ugly hack.. because redirections seem to arrive wrapped - review! - #There be dragons here.. - #Be very careful with list manipulation of the commandlist string.. backslashes cause havoc. commandlist must always be a well-formed list. generally avoid string manipulations on entire list or accidentally breaking a list element into parts if it shouldn't be.. - #The problem here - is that we can't always know what was intended on the commandline regarding quoting - - ::shellfilter::log::write $runtag "checking for redirections in $commandlist" - #sometimes we see a redirection without a following space e.g >C:/somewhere - #normalize - switch -regexp -- $lastitem\ - {^>[/[:alpha:]]+} { - set lastitem "> [string range $lastitem 1 end]" - }\ - {^>>[/[:alpha:]]+} { - set lastitem ">> [string range $lastitem 2 end]" - } - - - #for a redirection, we assume either a 2-element list at tail of form {> {some path maybe with spaces}} - #or that the tail redirection is not wrapped.. x y z > {some path maybe with spaces} - #we can't use list methods such as llenth on a member of commandlist - set wordlike_parts [regexp -inline -all {\S+} $lastitem] - - if {([llength $wordlike_parts] >= 2) && ([lindex $wordlike_parts 0] in [list ">>" ">"])} { - #wrapped redirection - but maybe not 'well' wrapped (unquoted filename) - set lastitem [string trim $lastitem] ;#we often see { > something} - - #don't use lassign or lrange on the element itself without checking first - #we can treat the commandlist as a whole as a well formed list but not neccessarily each element within. - #lassign $lastitem redir redirtarget - #set commandlist [lrange $commandlist 0 end-1] - # - set itemchars [split $lastitem ""] - set firstchar [lindex $itemchars 0] - set lastchar [lindex $itemchars end] - - #NAIVE test for double quoted only! - #consider for example {"a" x="b"} - #testing first and last is not decisive - #We need to decide what level of drilling down is even appropriate here.. - #if something was double wrapped - it was perhaps deliberate so we don't interpret it as something(?) - set head_tail_chars [list $firstchar $lastchar] - set doublequoted [expr {[llength [lsearch -all $head_tail_chars "\""]] == 2}] - if {[string equal "\{" $firstchar] && [string equal "\}" $lastchar]} { - set curlyquoted 1 - } else { - set curlyquoted 0 - } - - if {$curlyquoted} { - #these are not the tcl protection brackets but ones supplied in the argument - #it's still not valid to use list operations on a member of the commandlist - set inner [string range $lastitem 1 end-1] - #todo - fix! we still must assume there could be list-breaking data! - set innerwords [regexp -inline -all {\S+} $inner] ;#better than [split $inner] because we don't get extra empty elements for each whitespace char - set redir [lindex $innerwords 0] ;#a *potential* redir - to be tested below - set redirtarget [lrange $innerwords 1 end] ;#all the rest - } elseif {$doublequoted} { - ::shellfilter::log::write $debugname "doublequoting at tail of command '$commandlist'" - set inner [string range $lastitem 1 end-1] - set innerwords [regexp -inline -all {\S+} $inner] - set redir [lindex $innerwords 0] - set redirtarget [lrange $innerwords 1 end] - } else { - set itemwords [regexp -inline -all {\S+} $lastitem] - # e.g > c:\test becomes > {c:\test} - # but > c/mnt/c/test/temp.txt stays as > /mnt/c/test/temp.txt - set redir [lindex $itemwords 0] - set redirtarget [lrange $itemwords 1 end] - } - set commandlist [lrange $commandlist 0 end-1] - - } elseif {[lindex $commandlist end-1] in [list ">>" ">"]} { - #unwrapped redirection - #we should be able to use list operations like lindex and lrange here as the command itself is hopefully still a well formed list - set redir [lindex $commandlist end-1] - set redirtarget [lindex $commandlist end] - set commandlist [lrange $commandlist 0 end-2] - } else { - #no redirection - set redir "" - set redirtarget "" - #no change to command list - } - - - switch -- $redir { - ">>" - ">" { - set redirtarget [string trim $redirtarget "\""] - ::shellfilter::log::write $runtag " have redirection '$redir' to '$redirtarget'" - - set winfile $redirtarget ;#default assumption - switch -glob -- $redirtarget { - "/c/*" { - set winfile "c:/[string range $redirtarget 3 end]" - } - "/mnt/c/*" { - set winfile "c:/[string range $redirtarget 7 end]" - } - } - - if {[file exists [file dirname $winfile]]} { - #containing folder for target exists - if {$redir eq ">"} { - set teefile "write" - } else { - set teefile "append" - } - ::shellfilter::log::write $runtag "Directory exists '[file dirname $winfile]' operation:$teefile" - } else { - #we should be writing to a file.. but can't - ::shellfilter::log::write $runtag "cannot verify directory exists '[file dirname $winfile]'" - } - } - default { - ::shellfilter::log::write $runtag "No redir found!!" - } - } - - #often first element of command list is wrapped and cannot be run directly - #e.g {{ls -l} {> {temp.tmp}}} - #we will assume that if there is a single element which is a pathname containing a space - it is doubly wrapped. - # this may not be true - and the command may fail if it's just {c:\program files\etc} but it is the less common case and we currently have no way to detect. - #unwrap first element.. will not affect if not wrapped anyway (subject to comment above re spaces) - set commandlist [concat [lindex $commandlist 0] [lrange $commandlist 1 end]] - - #todo? - #child process environment. - # - to pass a different environment to the child - we would need to save the env array, modify as required, and then restore the env array. - - #to restore buffering states after run - set remember_in_out_err_buffering [list \ - [chan configure $inchan -buffering] \ - [chan configure $outchan -buffering] \ - [chan configure $errchan -buffering] \ - ] - - set remember_in_out_err_translation [list \ - [chan configure $inchan -translation] \ - [chan configure $outchan -translation] \ - [chan configure $errchan -translation] \ - ] - - - - - - chan configure $inchan -buffering $inbuffering -blocking 0 ;#we are setting up a readable handler for this - so non-blocking ok - chan configure $errchan -buffering $errbuffering - #chan configure $outchan -blocking 0 - chan configure $outchan -buffering $outbuffering ;#don't configure non-blocking. weird duplicate of *second* line occurs if you do. - # - - #-------------------------------------------- - #Tested on windows. Works to stop in output when buffering is none, reading from channel with -translation auto - #cmd, pwsh, tcl - #chan configure $outchan -translation lf - #chan configure $errchan -translation lf - #-------------------------------------------- - chan configure $outchan -translation $outtranslation - chan configure $errchan -translation $outtranslation - - #puts stderr "chan configure $wrerr [chan configure $wrerr]" - if {$debug} { - ::shellfilter::log::write $debugname "COMMAND [list $commandlist] strlen:[string length $commandlist] llen:[llength $commandlist]" - } - #todo - handle custom redirection of stderr to a file? - if {[string length $custom_stderr]} { - #::shellfilter::log::write $runtag "LAUNCH open |[concat $commandlist $custom_stderr] a+" - #set rdout [open |[concat $commandlist $custom_stderr] a+] - ::shellfilter::log::write $runtag "LAUNCH open |[concat $commandlist [list $custom_stderr <@$inchan]] [list RDONLY]" - set rdout [open |[concat $commandlist [list <@$inchan $custom_stderr]] [list RDONLY]] - set rderr "bogus" ;#so we don't wait for it - } else { - ::shellfilter::log::write $runtag "LAUNCH open |[concat $commandlist [list 2>@$wrerr <@$inchan]] [list RDONLY]" - #set rdout [open |[concat $commandlist [list 2>@$wrerr]] a+] - #set rdout [open |[concat $commandlist [list 2>@$wrerr]] [list RDWR]] - - # If we don't redirect stderr to our own tcl-based channel - then the transforms don't get applied. - # This is the whole reason we need these file-event loops. - # Ideally we need something like exec,open in tcl that interacts with transformed channels directly and emits as it runs, not only at termination - # - and that at least appears like a terminal to the called command. - #set rdout [open |[concat $commandlist [list 2>@stderr <@$inchan]] [list RDONLY]] - - - set rdout [open |[concat $commandlist [list 2>@$wrerr <@$inchan]] [list RDONLY]] - - chan configure $rderr -buffering $errbuffering -blocking 0 - chan configure $rderr -translation $readprocesstranslation - } - - - - set command_pids [pid $rdout] - #puts stderr "command_pids: $command_pids" - #tcl::process ensemble only available in 8.7+ - and it didn't prove useful here anyway - # the child process generally won't shut down until channels are closed. - # premature EOF on grandchild process launch seems to be due to lack of terminal emulation when redirecting stdin/stdout. - # worked around in punk/repl using 'script' command as a fake tty. - #set subprocesses [tcl::process::list] - #puts stderr "subprocesses: $subprocesses" - #if {[lindex $command_pids 0] ni $subprocesses} { - # puts stderr "pid [lindex $command_pids 0] not running $errMsg" - #} else { - # puts stderr "pid [lindex $command_pids 0] is running" - #} - - - if {$debug} { - ::shellfilter::log::write $debugname "pipeline pids: $command_pids" - } - - #jjj - - - chan configure $rdout -buffering $outbuffering -blocking 0 - chan configure $rdout -translation $readprocesstranslation - - if {![string length $custom_stderr]} { - chan event $rderr readable [list apply {{chan other wrerr outchan errchan waitfor errprefix errbuffering debug debugname pids} { - if {$errbuffering eq "line"} { - set countchunk [chan gets $chan chunk] ;#only get one line so that order between stderr and stdout is more likely to be preserved - #errprefix only applicable to line buffered output - if {$countchunk >= 0} { - if {[chan eof $chan]} { - puts -nonewline $errchan ${errprefix}$chunk - } else { - puts $errchan "${errprefix}$chunk" - } - } - } else { - set chunk [chan read $chan] - if {[string length $chunk]} { - puts -nonewline $errchan $chunk - } - } - if {[chan eof $chan]} { - flush $errchan ;#jmn - #set subprocesses [tcl::process::list] - #puts stderr "subprocesses: $subprocesses" - #if {[lindex $pids 0] ni $subprocesses} { - # puts stderr "stderr reader: pid [lindex $pids 0] no longer running" - #} else { - # puts stderr "stderr reader: pid [lindex $pids 0] still running" - #} - chan close $chan - #catch {chan close $wrerr} - if {$other ni [chan names]} { - set $waitfor stderr - } - } - }} $rderr $rdout $wrerr $outchan $errchan $waitvar $errprefix $errbuffering $debug $debugname $command_pids] - } - - #todo - handle case where large amount of stdin coming in faster than rdout can handle - #as is - arbitrary amount of memory could be used because we aren't using a filevent for rdout being writable - # - we're just pumping it in to the non-blocking rdout buffers - # ie there is no backpressure and stdin will suck in as fast as possible. - # for most commandlines this probably isn't too big a deal.. but it could be a problem for multi-GB disk images etc - # - # - - ## Note - detecting trailing missing nl before eof is basically the same here as when reading rdout from executable - # - but there is a slight difference in that with rdout we get an extra blocked state just prior to the final read. - # Not known if that is significant - ## with inchan configured -buffering line - #c:\repo\jn\punk\test>printf "test\netc\n" | tclsh punk.vfs/main.tcl -r cat - #warning reading input with -buffering line. Cannot detect missing trailing-newline at eof - #instate b:0 eof:0 pend:-1 count:4 - #test - #instate b:0 eof:0 pend:-1 count:3 - #etc - #instate b:0 eof:1 pend:-1 count:-1 - - #c:\repo\jn\punk\test>printf "test\netc" | tclsh punk.vfs/main.tcl -r cat - #warning reading input with -buffering line. Cannot detect missing trailing-newline at eof - #instate b:0 eof:0 pend:-1 count:4 - #test - #instate b:0 eof:1 pend:-1 count:3 - #etc - - if 0 { - chan event $inchan readable [list apply {{chan wrchan inbuffering waitfor} { - #chan copy stdin $chan ;#doesn't work in a chan event - if {$inbuffering eq "line"} { - set countchunk [chan gets $chan chunk] - #puts $wrchan "stdinstate b:[chan blocked $chan] eof:[chan eof $chan] pend:[chan pending output $chan] count:$countchunk" - if {$countchunk >= 0} { - if {[chan eof $chan]} { - puts -nonewline $wrchan $chunk - } else { - puts $wrchan $chunk - } - } - } else { - set chunk [chan read $chan] - if {[string length $chunk]} { - puts -nonewline $wrchan $chunk - } - } - if {[chan eof $chan]} { - puts stderr "|stdin_reader>eof [chan configure stdin]" - chan event $chan readable {} - #chan close $chan - chan close $wrchan write ;#half close - #set $waitfor "stdin" - } - }} $inchan $rdout $inbuffering $waitvar] - - if {[string length $stdinhandler]} { - chan configure stdin -buffering line -blocking 0 - chan event stdin readable $stdinhandler - } - } - - set actual_proc_out_buffering [chan configure $rdout -buffering] - set actual_outchan_buffering [chan configure $outchan -buffering] - #despite whatever is configured - we match our reading to how we need to output - set read_proc_out_buffering $actual_outchan_buffering - - - - if {[string length $teefile]} { - set logname "redir_[string map {: _} $winfile]_[tcl::clock::microseconds]" - set tid [::shellfilter::log::open $logname {-syslog 127.0.0.1:514}] - if {$teefile eq "write"} { - ::shellfilter::log::write $logname "opening '$winfile' for write" - set fd [open $winfile w] - } else { - ::shellfilter::log::write $logname "opening '$winfile' for appending" - set fd [open $winfile a] - } - #chan configure $fd -translation lf - chan configure $fd -translation $outtranslation - chan configure $fd -encoding utf-8 - - set tempvar_bytetotal [namespace current]::totalbytes[tcl::clock::microseconds] - set $tempvar_bytetotal 0 - chan event $rdout readable [list apply {{chan other wrerr outchan errchan read_proc_out_buffering waitfor outprefix call_id debug debugname writefile writefilefd copytempfile bytevar logtag} { - #review - if we write outprefix to normal stdout.. why not to redirected file? - #usefulness of outprefix is dubious - upvar $bytevar totalbytes - if {$read_proc_out_buffering eq "line"} { - #set outchunk [chan read $chan] - set countchunk [chan gets $chan outchunk] ;#only get one line so that order between stderr and stdout is more likely to be preserved - if {$countchunk >= 0} { - if {![chan eof $chan]} { - set numbytes [expr {[string length $outchunk] + 1}] ;#we are assuming \n not \r\n - but count won't/can't be completely accurate(?) - review - puts $writefilefd $outchunk - } else { - set numbytes [string length $outchunk] - puts -nonewline $writefilefd $outchunk - } - incr totalbytes $numbytes - ::shellfilter::log::write $logtag "${outprefix} wrote $numbytes bytes to $writefile" - #puts $outchan "${outprefix} wrote $numbytes bytes to $writefile" - } - } else { - set outchunk [chan read $chan] - if {[string length $outchunk]} { - puts -nonewline $writefilefd $outchunk - set numbytes [string length $outchunk] - incr totalbytes $numbytes - ::shellfilter::log::write $logtag "${outprefix} wrote $numbytes bytes to $writefile" - } - } - if {[chan eof $chan]} { - flush $writefilefd ;#jmn - #set blocking so we can get exit code - chan configure $chan -blocking 1 - catch {::shellfilter::log::write $logtag "${outprefix} total bytes $totalbytes written to $writefile"} - #puts $outchan "${outprefix} total bytes $totalbytes written to $writefile" - catch {close $writefilefd} - if {$copytempfile} { - catch {file copy $writefile "[file rootname $writefile]_copy[file extension $writefile]"} - } - try { - chan close $chan - set ::shellfilter::shellcommandvars($call_id,exitcode) 0 - if {$debug} { - ::shellfilter::log::write $debugname "(teefile) -- child process returned no error. (exit code 0) --" - } - } trap CHILDSTATUS {result options} { - set code [lindex [dict get $options -errorcode] 2] - if {$debug} { - ::shellfilter::log::write $debugname "(teefile) CHILD PROCESS EXITED with code: $code" - } - set ::shellfilter::shellcommandvars($call_id,exitcode) $code - } - catch {chan close $wrerr} - if {$other ni [chan names]} { - set $waitfor stdout - } - } - }} $rdout $rderr $wrerr $outchan $errchan $read_proc_out_buffering $waitvar $outprefix $call_id $debug $debugname $winfile $fd $copytempfile $tempvar_bytetotal $logname] - - } else { - - # This occurs when we have outbuffering set to 'line' - as the 'input' from rdout which comes from the executable is also configured to 'line' - # where b:0|1 is whether chan blocked $chan returns 0 or 1 - # pend is the result of chan pending $chan - # eof is the resot of chan eof $chan - - - ##------------------------- - ##If we still read with gets,to retrieve line by line for output to line-buffered output - but the input channel is configured with -buffering none - ## then we can detect the difference - # there is an extra blocking read - but we can stil use eof with data to detect the absent newline and avoid passing an extra one on. - #c:\repo\jn\punk\test>printf "test\netc\n" | tclsh punk.vfs/main.tcl /c cat - #instate b:0 eof:0 pend:-1 count:4 - #test - #instate b:0 eof:0 pend:-1 count:3 - #etc - #instate b:0 eof:1 pend:-1 count:-1 - - #c:\repo\jn\punk\test>printf "test\netc" | tclsh punk.vfs/main.tcl /u/c cat - #instate b:0 eof:0 pend:-1 count:4 - #test - #instate b:1 eof:0 pend:-1 count:-1 - #instate b:0 eof:1 pend:-1 count:3 - #etc - ##------------------------ - - - #this should only occur if upstream is coming from stdin reader that has line buffering and hasn't handled the difference properly.. - ###reading with gets from line buffered input with trailing newline - #c:\repo\jn\punk\test>printf "test\netc\n" | tclsh punk.vfs/main.tcl /c cat - #instate b:0 eof:0 pend:-1 count:4 - #test - #instate b:0 eof:0 pend:-1 count:3 - #etc - #instate b:0 eof:1 pend:-1 count:-1 - - ###reading with gets from line buffered input with trailing newline - ##No detectable difference! - #c:\repo\jn\punk\test>printf "test\netc" | tclsh punk.vfs/main.tcl /c cat - #instate b:0 eof:0 pend:-1 count:4 - #test - #instate b:0 eof:0 pend:-1 count:3 - #etc - #instate b:0 eof:1 pend:-1 count:-1 - ##------------------------- - - #Note that reading from -buffering none and writing straight out gives no problem because we pass the newlines through as is - - - #set ::shellfilter::chan::lastreadblocked_nodata_noeof($rdout) 0 ;#a very specific case of readblocked prior to eof.. possibly not important - #this detection is disabled for now - but left for debugging in case it means something.. or changes - chan event $rdout readable [list apply {{chan other wrerr outchan errchan read_proc_out_buffering waitfor outprefix call_id debug debugname pids} { - #set outchunk [chan read $chan] - - if {$read_proc_out_buffering eq "line"} { - set countchunk [chan gets $chan outchunk] ;#only get one line so that order between stderr and stdout is more likely to be preserved - #countchunk can be -1 before eof e.g when blocked - #debugging output inline with data - don't leave enabled - #puts $outchan "instate b:[chan blocked $chan] eof:[chan eof $chan] pend:[chan pending output $chan] count:$countchunk" - if {$countchunk >= 0} { - if {![chan eof $chan]} { - puts $outchan ${outprefix}$outchunk - } else { - puts -nonewline $outchan ${outprefix}$outchunk - #if {$::shellfilter::chan::lastreadblocked_nodata_noeof($chan)} { - # seems to be the usual case - #} else { - # #false alarm, or ? we've reached eof with data but didn't get an empty blocking read just prior - # #Not known if this occurs - # #debugging output inline with data - don't leave enabled - # puts $outchan "!!!prev read didn't block: instate b:[chan blocked $chan] eof:[chan eof $chan] pend:[chan pending output $chan] count:$countchunk" - #} - } - #set ::shellfilter::chan::lastreadblocked_nodata_noeof($chan) 0 - } else { - #set ::shellfilter::chan::lastreadblocked_nodata_noeof($chan) [expr {[chan blocked $chan] && ![chan eof $chan]}] - } - } else { - #puts $outchan "read CHANNEL $chan [chan configure $chan]" - #puts $outchan "write CHANNEL $outchan b:[chan configure $outchan -buffering] t:[chan configure $outchan -translation] e:[chan configure $outchan -encoding]" - set outchunk [chan read $chan] - #puts $outchan "instate b:[chan blocked $chan] eof:[chan eof $chan] pend:[chan pending output $chan] count:[string length $outchunk]" - if {[string length $outchunk]} { - #set stringrep [encoding convertfrom utf-8 $outchunk] - #set newbytes [encoding convertto utf-16 $stringrep] - #puts -nonewline $outchan $newbytes - puts -nonewline $outchan $outchunk - } - } - - if {[chan eof $chan]} { - flush $outchan ;#jmn - #for now just look for first element in the pid list.. - #set subprocesses [tcl::process::list] - #puts stderr "subprocesses: $subprocesses" - #if {[lindex $pids 0] ni $subprocesses} { - # puts stderr "stdout reader pid: [lindex $pids 0] no longer running" - #} else { - # puts stderr "stdout reader pid: [lindex $pids 0] still running" - #} - - #puts $outchan "instate b:[chan blocked $chan] eof:[chan eof $chan] pend:[chan pending output $chan]" - chan configure $chan -blocking 1 ;#so we can get exit code - try { - chan close $chan - set ::shellfilter::shellcommandvars($call_id,exitcode) 0 - if {$debug} { - ::shellfilter::log::write $debugname " -- child process returned no error. (exit code 0) --" - } - } trap CHILDSTATUS {result options} { - set code [lindex [dict get $options -errorcode] 2] - set ::shellfilter::shellcommandvars($call_id,exitcode) $code - if {$debug} { - ::shellfilter::log::write $debugname " CHILD PROCESS EXITED with code: $code" - } - } trap CHILDKILLED {result options} { - #set code [lindex [dict get $options -errorcode] 2] - #set ::shellfilter::shellcommandvars(%id%,exitcode) $code - set ::shellfilter::shellcommandvars($call_id,exitcode) "childkilled" - if {$debug} { - ::shellfilter::log::write $debugname " CHILD PROCESS EXITED with result:'$result' options:'$options'" - } - - } finally { - #puts stdout "HERE" - #flush stdout - - } - catch {chan close $wrerr} - if {$other ni [chan names]} { - set $waitfor stdout - } - - } - }} $rdout $rderr $wrerr $outchan $errchan $read_proc_out_buffering $waitvar $outprefix $call_id $debug $debugname $command_pids] - } - - #todo - add ability to detect activity/data-flow and change timeout to only apply for period with zero data - #e.g x hrs with no data(?) - #reset timeout when data detected. - after $timeout [string map [list %w% $waitvar %id% $call_id %wrerr% $wrerr %rdout% $rdout %rderr% $rderr %debug% $debug %debugname% $debugname] { - if {[info exists ::shellfilter::shellcommandvars(%id%,exitcode)]} { - if {[set ::shellfilter::shellcommandvars(%id%,exitcode)] ne ""} { - catch { chan close %wrerr% } - catch { chan close %rdout%} - catch { chan close %rderr%} - } else { - chan configure %rdout% -blocking 1 - try { - chan close %rdout% - set ::shellfilter::shellcommandvars(%id%,exitcode) 0 - if {%debug%} { - ::shellfilter::log::write %debugname% "(timeout) -- child process returned no error. (exit code 0) --" - } - } trap CHILDSTATUS {result options} { - set code [lindex [dict get $options -errorcode] 2] - if {%debug%} { - ::shellfilter::log::write %debugname% "(timeout) CHILD PROCESS EXITED with code: $code" - } - set ::shellfilter::shellcommandvars(%id%,exitcode) $code - } trap CHILDKILLED {result options} { - set code [lindex [dict get $options -errorcode] 2] - #set code [dict get $options -code] - #set ::shellfilter::shellcommandvars(%id%,exitcode) $code - #set ::shellfilter::shellcommandvars($call_id,exitcode) "childkilled-timeout" - set ::shellfilter::shellcommandvars(%id%,exitcode) "childkilled-timeout" - if {%debug%} { - ::shellfilter::log::write %debugname% "(timeout) CHILDKILLED with code: $code" - ::shellfilter::log::write %debugname% "(timeout) result:$result options:$options" - } - - } - catch { chan close %wrerr% } - catch { chan close %rderr%} - } - set %w% "timeout" - } - }] - - - vwait $waitvar - - set exitcode [set ::shellfilter::shellcommandvars($call_id,exitcode)] - if {![string is digit -strict $exitcode]} { - puts stderr "Process exited with non-numeric code: $exitcode" - flush stderr - } - if {[string length $teefile]} { - #cannot be called from within an event handler above.. vwait reentrancy etc - catch {::shellfilter::log::close $logname} - } - - if {$debug} { - ::shellfilter::log::write $debugname " closed by: [set $waitvar] with exitcode: $exitcode" - catch {::shellfilter::log::close $debugname} - } - array unset ::shellfilter::shellcommandvars $call_id,* - - - #restore buffering to pre shellfilter::run state - lassign $remember_in_out_err_buffering bin bout berr - chan configure $inchan -buffering $bin - chan configure $outchan -buffering $bout - chan configure $errchan -buffering $berr - - lassign $remember_in_out_err_translation tin tout terr - chan configure $inchan -translation $tin - chan configure $outchan -translation $tout - chan configure $errchan -translation $terr - - - #in channel probably closed..(? review - should it be?) - catch { - chan configure $inchan -buffering $bin - } - - - return [list exitcode $exitcode] - } - -} - -package provide shellfilter [namespace eval shellfilter { - variable version - set version 0.1.9 -}] diff --git a/src/bootsupport/modules/uuid-1.0.7.tm b/src/bootsupport/modules/uuid-1.0.7.tm deleted file mode 100644 index fbd43f3d..00000000 --- a/src/bootsupport/modules/uuid-1.0.7.tm +++ /dev/null @@ -1,245 +0,0 @@ -# uuid.tcl - Copyright (C) 2004 Pat Thoyts -# -# UUIDs are 128 bit values that attempt to be unique in time and space. -# -# Reference: -# http://www.opengroup.org/dce/info/draft-leach-uuids-guids-01.txt -# -# uuid: scheme: -# http://www.globecom.net/ietf/draft/draft-kindel-uuid-uri-00.html -# -# Usage: uuid::uuid generate -# uuid::uuid equal $idA $idB - -package require Tcl 8.5 - -namespace eval uuid { - variable accel - array set accel {critcl 0} - - namespace export uuid - - variable uid - if {![info exists uid]} { - set uid 1 - } - - proc K {a b} {set a} -} - -### -# Optimization -# Caches machine info after the first pass -### - -proc ::uuid::generate_tcl_machinfo {} { - variable machinfo - if {[info exists machinfo]} { - return $machinfo - } - lappend machinfo [clock seconds]; # timestamp - lappend machinfo [clock clicks]; # system incrementing counter - lappend machinfo [info hostname]; # spatial unique id (poor) - lappend machinfo [pid]; # additional entropy - lappend machinfo [array get ::tcl_platform] - - ### - # If we have /dev/urandom just stream 128 bits from that - ### - if {[file exists /dev/urandom]} { - set fin [open /dev/urandom r] - binary scan [read $fin 128] H* machinfo - close $fin - } elseif {[catch {package require nettool}]} { - # More spatial information -- better than hostname. - # bug 1150714: opening a server socket may raise a warning messagebox - # with WinXP firewall, using ipconfig will return all IP addresses - # including ipv6 ones if available. ipconfig is OK on win98+ - if {[string equal $::tcl_platform(platform) "windows"]} { - catch {exec ipconfig} config - lappend machinfo $config - } else { - catch { - set s [socket -server void -myaddr [info hostname] 0] - K [fconfigure $s -sockname] [close $s] - } r - lappend machinfo $r - } - - if {[package provide Tk] != {}} { - lappend machinfo [winfo pointerxy .] - lappend machinfo [winfo id .] - } - } else { - ### - # If the nettool package works on this platform - # use the stream of hardware ids from it - ### - lappend machinfo {*}[::nettool::hwid_list] - } - return $machinfo -} - -# Generates a binary UUID as per the draft spec. We generate a pseudo-random -# type uuid (type 4). See section 3.4 -# -proc ::uuid::generate_tcl {} { - package require md5 2 - variable uid - - set tok [md5::MD5Init] - md5::MD5Update $tok [incr uid]; # package incrementing counter - foreach string [generate_tcl_machinfo] { - md5::MD5Update $tok $string - } - set r [md5::MD5Final $tok] - binary scan $r c* r - - # 3.4: set uuid versioning fields - lset r 8 [expr {([lindex $r 8] & 0x3F) | 0x80}] - lset r 6 [expr {([lindex $r 6] & 0x0F) | 0x40}] - - return [binary format c* $r] -} - -if {[string equal $tcl_platform(platform) "windows"] - && [package provide critcl] != {}} { - namespace eval uuid { - critcl::ccode { - #define WIN32_LEAN_AND_MEAN - #define STRICT - #include - #include - typedef long (__stdcall *LPFNUUIDCREATE)(UUID *); - typedef const unsigned char cu_char; - } - critcl::cproc generate_c {Tcl_Interp* interp} ok { - HRESULT hr = S_OK; - int r = TCL_OK; - UUID uuid = {0}; - HMODULE hLib; - LPFNUUIDCREATE lpfnUuidCreate = NULL; - hLib = LoadLibraryA(("rpcrt4.dll")); - if (hLib) - lpfnUuidCreate = (LPFNUUIDCREATE) - GetProcAddress(hLib, "UuidCreate"); - if (lpfnUuidCreate) { - Tcl_Obj *obj; - lpfnUuidCreate(&uuid); - obj = Tcl_NewByteArrayObj((cu_char *)&uuid, sizeof(uuid)); - Tcl_SetObjResult(interp, obj); - } else { - Tcl_SetResult(interp, "error: failed to create a guid", - TCL_STATIC); - r = TCL_ERROR; - } - return r; - } - } -} - -# Convert a binary uuid into its string representation. -# -proc ::uuid::tostring {uuid} { - binary scan $uuid H* s - foreach {a b} {0 7 8 11 12 15 16 19 20 end} { - append r [string range $s $a $b] - - } - return [string tolower [string trimright $r -]] -} - -# Convert a string representation of a uuid into its binary format. -# -proc ::uuid::fromstring {uuid} { - return [binary format H* [string map {- {}} $uuid]] -} - -# Compare two uuids for equality. -# -proc ::uuid::equal {left right} { - set l [fromstring $left] - set r [fromstring $right] - return [string equal $l $r] -} - -# Call our generate uuid implementation -proc ::uuid::generate {} { - variable accel - if {$accel(critcl)} { - return [generate_c] - } else { - return [generate_tcl] - } -} - -# uuid generate -> string rep of a new uuid -# uuid equal uuid1 uuid2 -# -proc uuid::uuid {cmd args} { - switch -exact -- $cmd { - generate { - if {[llength $args] != 0} { - return -code error "wrong # args:\ - should be \"uuid generate\"" - } - return [tostring [generate]] - } - equal { - if {[llength $args] != 2} { - return -code error "wrong \# args:\ - should be \"uuid equal uuid1 uuid2\"" - } - return [eval [linsert $args 0 equal]] - } - default { - return -code error "bad option \"$cmd\":\ - must be generate or equal" - } - } -} - -# ------------------------------------------------------------------------- - -# LoadAccelerator -- -# -# This package can make use of a number of compiled extensions to -# accelerate the digest computation. This procedure manages the -# use of these extensions within the package. During normal usage -# this should not be called, but the test package manipulates the -# list of enabled accelerators. -# -proc ::uuid::LoadAccelerator {name} { - variable accel - set r 0 - switch -exact -- $name { - critcl { - if {![catch {package require tcllibc}]} { - set r [expr {[info commands ::uuid::generate_c] != {}}] - } - } - default { - return -code error "invalid accelerator package:\ - must be one of [join [array names accel] {, }]" - } - } - set accel($name) $r -} - -# ------------------------------------------------------------------------- - -# Try and load a compiled extension to help. -namespace eval ::uuid { - variable e {} - foreach e {critcl} { - if {[LoadAccelerator $e]} break - } - unset e -} - -package provide uuid 1.0.7 - -# ------------------------------------------------------------------------- -# Local variables: -# mode: tcl -# indent-tabs-mode: nil -# End: diff --git a/src/bootsupport/modules/uuid-1.0.8.tm b/src/bootsupport/modules/uuid-1.0.8.tm deleted file mode 100644 index c5cffa67..00000000 --- a/src/bootsupport/modules/uuid-1.0.8.tm +++ /dev/null @@ -1,246 +0,0 @@ -# uuid.tcl - Copyright (C) 2004 Pat Thoyts -# -# UUIDs are 128 bit values that attempt to be unique in time and space. -# -# Reference: -# http://www.opengroup.org/dce/info/draft-leach-uuids-guids-01.txt -# -# uuid: scheme: -# http://www.globecom.net/ietf/draft/draft-kindel-uuid-uri-00.html -# -# Usage: uuid::uuid generate -# uuid::uuid equal $idA $idB - -package require Tcl 8.5 9 - -namespace eval uuid { - variable accel - array set accel {critcl 0} - - namespace export uuid - - variable uid - if {![info exists uid]} { - set uid 1 - } - - proc K {a b} {set a} -} - -### -# Optimization -# Caches machine info after the first pass -### - -proc ::uuid::generate_tcl_machinfo {} { - variable machinfo - if {[info exists machinfo]} { - return $machinfo - } - lappend machinfo [clock seconds]; # timestamp - lappend machinfo [clock clicks]; # system incrementing counter - lappend machinfo [info hostname]; # spatial unique id (poor) - lappend machinfo [pid]; # additional entropy - lappend machinfo [array get ::tcl_platform] - - ### - # If we have /dev/urandom just stream 128 bits from that - ### - if {[file exists /dev/urandom]} { - set fin [open /dev/urandom r] - fconfigure $fin -encoding binary - binary scan [read $fin 128] H* machinfo - close $fin - } elseif {[catch {package require nettool}]} { - # More spatial information -- better than hostname. - # bug 1150714: opening a server socket may raise a warning messagebox - # with WinXP firewall, using ipconfig will return all IP addresses - # including ipv6 ones if available. ipconfig is OK on win98+ - if {[string equal $::tcl_platform(platform) "windows"]} { - catch {exec ipconfig} config - lappend machinfo $config - } else { - catch { - set s [socket -server void -myaddr [info hostname] 0] - K [fconfigure $s -sockname] [close $s] - } r - lappend machinfo $r - } - - if {[package provide Tk] != {}} { - lappend machinfo [winfo pointerxy .] - lappend machinfo [winfo id .] - } - } else { - ### - # If the nettool package works on this platform - # use the stream of hardware ids from it - ### - lappend machinfo {*}[::nettool::hwid_list] - } - return $machinfo -} - -# Generates a binary UUID as per the draft spec. We generate a pseudo-random -# type uuid (type 4). See section 3.4 -# -proc ::uuid::generate_tcl {} { - package require md5 2 - variable uid - - set tok [md5::MD5Init] - md5::MD5Update $tok [incr uid]; # package incrementing counter - foreach string [generate_tcl_machinfo] { - md5::MD5Update $tok $string - } - set r [md5::MD5Final $tok] - binary scan $r c* r - - # 3.4: set uuid versioning fields - lset r 8 [expr {([lindex $r 8] & 0x3F) | 0x80}] - lset r 6 [expr {([lindex $r 6] & 0x0F) | 0x40}] - - return [binary format c* $r] -} - -if {[string equal $tcl_platform(platform) "windows"] - && [package provide critcl] != {}} { - namespace eval uuid { - critcl::ccode { - #define WIN32_LEAN_AND_MEAN - #define STRICT - #include - #include - typedef long (__stdcall *LPFNUUIDCREATE)(UUID *); - typedef const unsigned char cu_char; - } - critcl::cproc generate_c {Tcl_Interp* interp} ok { - HRESULT hr = S_OK; - int r = TCL_OK; - UUID uuid = {0}; - HMODULE hLib; - LPFNUUIDCREATE lpfnUuidCreate = NULL; - hLib = LoadLibraryA(("rpcrt4.dll")); - if (hLib) - lpfnUuidCreate = (LPFNUUIDCREATE) - GetProcAddress(hLib, "UuidCreate"); - if (lpfnUuidCreate) { - Tcl_Obj *obj; - lpfnUuidCreate(&uuid); - obj = Tcl_NewByteArrayObj((cu_char *)&uuid, sizeof(uuid)); - Tcl_SetObjResult(interp, obj); - } else { - Tcl_SetResult(interp, "error: failed to create a guid", - TCL_STATIC); - r = TCL_ERROR; - } - return r; - } - } -} - -# Convert a binary uuid into its string representation. -# -proc ::uuid::tostring {uuid} { - binary scan $uuid H* s - foreach {a b} {0 7 8 11 12 15 16 19 20 end} { - append r [string range $s $a $b] - - } - return [string tolower [string trimright $r -]] -} - -# Convert a string representation of a uuid into its binary format. -# -proc ::uuid::fromstring {uuid} { - return [binary format H* [string map {- {}} $uuid]] -} - -# Compare two uuids for equality. -# -proc ::uuid::equal {left right} { - set l [fromstring $left] - set r [fromstring $right] - return [string equal $l $r] -} - -# Call our generate uuid implementation -proc ::uuid::generate {} { - variable accel - if {$accel(critcl)} { - return [generate_c] - } else { - return [generate_tcl] - } -} - -# uuid generate -> string rep of a new uuid -# uuid equal uuid1 uuid2 -# -proc uuid::uuid {cmd args} { - switch -exact -- $cmd { - generate { - if {[llength $args] != 0} { - return -code error "wrong # args:\ - should be \"uuid generate\"" - } - return [tostring [generate]] - } - equal { - if {[llength $args] != 2} { - return -code error "wrong \# args:\ - should be \"uuid equal uuid1 uuid2\"" - } - return [eval [linsert $args 0 equal]] - } - default { - return -code error "bad option \"$cmd\":\ - must be generate or equal" - } - } -} - -# ------------------------------------------------------------------------- - -# LoadAccelerator -- -# -# This package can make use of a number of compiled extensions to -# accelerate the digest computation. This procedure manages the -# use of these extensions within the package. During normal usage -# this should not be called, but the test package manipulates the -# list of enabled accelerators. -# -proc ::uuid::LoadAccelerator {name} { - variable accel - set r 0 - switch -exact -- $name { - critcl { - if {![catch {package require tcllibc}]} { - set r [expr {[info commands ::uuid::generate_c] != {}}] - } - } - default { - return -code error "invalid accelerator package:\ - must be one of [join [array names accel] {, }]" - } - } - set accel($name) $r -} - -# ------------------------------------------------------------------------- - -# Try and load a compiled extension to help. -namespace eval ::uuid { - variable e {} - foreach e {critcl} { - if {[LoadAccelerator $e]} break - } - unset e -} - -package provide uuid 1.0.8 - -# ------------------------------------------------------------------------- -# Local variables: -# mode: tcl -# indent-tabs-mode: nil -# End: diff --git a/src/bootsupport/modules/zipper-0.14.tm b/src/bootsupport/modules/zipper-0.14.tm new file mode 100644 index 0000000000000000000000000000000000000000..fcb76636a0670797560a57e80a0d00bf7c4fb42d GIT binary patch literal 9910 zcmch6dpwkB|Np4Aw#4daD|CfI>sYJJ6gH(zDU?u5+-B}!n3K6@oDWZIN@q$3gi4f< z5{lCHXp;(U(!r^sT9VEbI()C|o*9Q`c=q@FzOV1}$Bg^FuFv&3zCZ8l(-_e2qZQ2J z115`&g8-J$8#vP0fX%}gxB&14I3MRSaE2jRjr)mM0-OLiTmxTuidbwRiwodhCZP{_ z0^rXis8l3M$O9anh${pE-bg5X#D@~b^g9t~En*9C0T&ap{Bd>=5OL8yf(L}&m=NHB zLIFk>;tZh0;W79;h5;X=`(j?Wfj=%FSUfIZ^4Lf{76G6J1jfOoPcQ-)3OS@P-yGj++7@HN016LN8$pZvkz~T#OVYDz1GGHfi3@#8r z7ivn5C%qvQd5Rw!g0)=C6M7OlmVraRaadd&=`VuM_?Xb!5a{xG1i?aU2#kqCufSD& z0K+8|u;@bQGQv_%bHJft1OCGJd>Dq15GWMsE>A;bpSI*Z!2N)xCI}4$Gh9hq@jw*5|o{-c&OgdvvIB$L;>wZG+=HHjNxJdE))s4 zAS6uI+p^oN{_AZPz_s7ugDHtlL;*ukq`gSSV)Pn)(2_+!+iJ)KRzMqyk-J2`snUZ( zGda1TC4*Hc_X&vQ5T$q^00(r83$qw?3aG4r#}}|5K(m8nltrFo z(=h^f7Xz<5fqQXqE(9D`1aMq0h>UDrKyRJ()eEfYL8??CUAcS&6Nn^;SyK|5jpe-v{7VXhl$S874KWj)Vm1r-ONRx2~+C89FUB&RNJ)qPj zihS!a?SW^~$a3u~yl>wArz%9~(@%f40ONYWe%Id)F&NYO756u10GOsUus};hz-|V! z02jbkgrdy=NW5J0kqbOwvH8kE2;X(f4O6PH5 z-vk4)2(E(bafSg51!7aE6G|J2%o$+-XTv}Yp0oWOfFwz5lo5nNBv;x0 zH+9Cy2qq&(;vt>K;lK_{0J2IEJ%bFCG?oS+L(Pix-^d6C0O=-Xu(0F6=deOB7*AmUPvA@PU0EJD zAlXR2z}~=s)ED^TP+?cu1Q{GwHI0nKsbmDxTU=6u24E%cZPpy&>r}t~XrrZ<|sD zq~E012qA>RzB?!Z@1GVH7X4CJf~{a73Jbgi_tk?1V8S*BFZpg5Dz&owfoc`YfOk0eQ9Ra?G?y~NR$Pc~!8%{g^W10S zX(DAhXf6af7IGfxbkwlmZ!|;E?#F2c*HwNf!{noY7Q`a4s|V06K!`lyodjORd9d^` zb^vOps1+iz0kwmpwcdFXyd%L|Ke{7{If*~cWx-_-Q2PdCko}o)6ghp}X`borR z<8aglOdt=3+y-_PkpR++|1#>b&2vcFsKvzCY){B{QH7yy04q>Rs^n^`waUs6I77Zc z(il1<`mmiM-;lI`14lLJ0dyn*4B#XZHb3}IoH&r$K$4B90s&;XBPvVT!qXN{fBFDs z$dW?)rC9t8WAC-6TN4#Q@{U^Ja0H$ZJcms*s$r?g=D)v3h zR&spI0G>gRIdVlX_>vJXpF~_3E3yK6OA%dt*l;XhIC$|PZNJgf5y~M4$8fp~AX|d8 z0)-x)CMg(r^+F^9O2?%0VMM$8#>)MHR9b!HG?@<#g#{@YGed$VRdr|u#UP{&T`4!K zkqtxE30ir;BI1k1IV5Q)Dnu^|;k za{dnx9UUVd)dzngfBhivDr5CObF++Z1|Av~CYi8&JDHaJ4+HHR;6wkv(_14jry&6M z4LzsYuNXdJB85Wvo|3?JcP;8!^Xcel3WcRkp=iRV(k4cV5EvL6n*5AzM{r0({)SEU z;<_H9?&`QNw1__wA~mnmuczq;v7I|@={hTCy}7gI#vwmFr{TkXd#kD9!KdgQeEPMK z_d(exlKrCA;Of5D=jzG|t6bG@TZV`KHbGr)Ox%42OM_t(%+Gxt9KZ4zR4iqbzXi&*_+^Wm*|?~{2}hax%p z)0GPX=F}Y1x_0ljUA|@X_C2|uxi6;GgeT72c%j~+jEPis|~S+i_1z2lo!E}Usu zQpF72GxL#^`SQ1p%l6FMTe0`g<4;6eCapIqKXE1XH%IL*U!w8p=L4Y^FP;v?)7 z?q(O&54+Rq*qPM${N|Xpg09Cr zvn2hqMhA~}JX`i~eR1a(+mi>CnUrRybsmaY$Az?ISElDSwkq<*WPhrQQ{{d%`*(HJ z#ispp9x)F$shmAkSGs(Xvt}pUzx}j>MQoq3fJ6||{MX9azxCnJl#L~ti z9qFMVKi*V1zN}(`d4)n&*?GMcpYJaTzZ$tCc5$pj$n59^d9ymLZ60m=;JasGi2s`l zzZ}o7b8xA^^7Bvl7G1;AHY8o~nbi8@lS8%X`DV7Z=~zm>gFT;Gb^OwUt8A-MusqUr z=i&1y8^_-5tS{|u(NeEy)lEB^($Zp}e(|CGuGYYh4wnyPo+vN7^KRp-gzkp6*NoxW zei7#PZ>71F+1&eWewO8J*Wkrl6z81bZ~suJbo$Z1bAP-&!^f?#E$oF-vSnL}+Xf5E z!x0YmLPCOqE(bIwuB=Wt!aH4+NZX)1(!Z>}y(Rcr&B@E<>4stZGE9`TlrlPgKV8OH zYOwIe`l5Y|(Tb&OvF##_w&L@-FNGB2_e-ofo=R04LTacT#kAR0&ZiC;ctmL{S8VZF zHKprni{2CcEFWw2?fOn{pWAJop0nZT6@Faw75d)Dkji~Tj(>FN*3w4iGQNvdaA#St z=XVj7<2{Wu_TQ|#@KbD$sX{{Xq^>p3f5|2;{V{S&40U8|f*;jH?e60Di{qB8U1**2 zcFgWXrZOX2$2DPzC!0MEBX%e!6yz=q{?4zYXJ>tN)c&3>-l)p(arL9p@8A70#n))Z zUncA`9v)^2{E`D&rBf^8lP*nr{$%HK3m*7-6ueS)zFy!^pyaB(bj5D4kUgWb_3()D#dS6}Zv~_(wWe=*@bm98 zqjdMD8MCZtYnMOLvdKQ*&>&Eut`;4<%?}|N8+Ww{B~5BLZhO&f4*Bh@Mw=$z`S*R}hnxAgAQ(MH2Z1#TdQEu9;AbbHg9YV!y0COl{7_cR#Y zi)x!Y%;|ISmvs?*i;|Xm6IvsSlaIU(h|W9+eFrC<}z@nyRV;JzT>@1OApt@MNRLS;?$pyeB4+_)c79{U!%LN&G(jm z&aBkN@Ra)Kd(2YxDWg5oEPVW%OR>_P6~w$#mwFs>u4jDEFD!1ZCVvZ#*<1Hpm&x6XG*nGf@SIO}nI z&GdVxM!#J*1N4l$txr8Twq0dsqV>!6BY5zq{e{jt5#A3pXfXn#R`X5C`c!9YX12x0lsi{X#iUhv8 zh>Nv5HB#2kHh*qzylT8&dBTy!jh=}`+r8E~pZ&?v=c4Hmuy#eZ)1;{BU%I=M{I+-1 zTM+)m=fZvR>Z-q3A7wQ*t9sov%5rwQRlOrHL1#;GN>*XvOy5hWvx1KTjw2fiBKd}Vac8j&Atyp2bS-aawiF5cAyd<}p#uokgvT#J zcw@KG@ZKl$N0UugZhv8lH6$OKZE`08Ia`z+0UxV}` zT-NRTNnd?|uS4wh>ld#nd>z?G@nY1hT%)>ziYpZ;6yM<#$_&cLAt;{VYU@QyR$71k zI*dY52-~xgS7$snx~lpVh*Yo6YTznFdwlPI?Zo2KYqn`jjM*7;EpGO8zdi1jw^tQ0 z?>|fAJpUYMdrGl(x!ci3meidfvIIAB-^LLl1(Tq1-L(0wYJcCFX{Tg%I9ao0ejuAY z{rQ2%<(r;#{-GO}oN{XAw5{}KHqKGYKY8kTH~JKgpJ&R$o<-(&&V1`ws#R=tKHc-? z2j`PlDpL(p6-(YbzGi~v=`hkWX`0fW?t~udUurwz&&Ed_ z+oih3#$wf^SaGKfx literal 0 HcmV?d00001 diff --git a/src/modules/modpodtest-buildversion.txt b/src/modules/modpodtest-buildversion.txt index 7eeee9b0..4ae5e35c 100644 --- a/src/modules/modpodtest-buildversion.txt +++ b/src/modules/modpodtest-buildversion.txt @@ -1,3 +1,3 @@ -0.1.0 +0.1.1 #First line must be a tm version number #all other lines are ignored. diff --git a/src/modules/punk/args-999999.0a1.0.tm b/src/modules/punk/args-999999.0a1.0.tm index e449c6b8..12d29adb 100644 --- a/src/modules/punk/args-999999.0a1.0.tm +++ b/src/modules/punk/args-999999.0a1.0.tm @@ -4950,7 +4950,7 @@ tcl::namespace::eval punk::args { set argd [punk::args::parse $args withid ::myns::myfunc] lassign [dict values $argd] leaders opts values received solos if {[dict exists $received] -configfile} { - puts "have option for existing file [dict get $opts -configfile]" + puts "have option for existing file [dict get $opts -configfile]" } } }]} @@ -6515,7 +6515,7 @@ tcl::namespace::eval punk::args { set range [lindex $ranges $clausecolumn] #todo - small-value double comparisons with error-margin? review lassign $range low high - if {$low$high ne ""} { + if {"$low$high" ne ""} { if {$low eq ""} { #lowside unspecified - check only high if {$e_check > $high} { diff --git a/src/modules/punk/mix/templates-buildversion.txt b/src/modules/punk/mix/templates-buildversion.txt index 32568297..71fa630d 100644 --- a/src/modules/punk/mix/templates-buildversion.txt +++ b/src/modules/punk/mix/templates-buildversion.txt @@ -1,3 +1,3 @@ -0.1.2 +0.1.3 #First line must be a semantic version number #all other lines are ignored. diff --git a/src/modules/punk/repl-999999.0a1.0.tm b/src/modules/punk/repl-999999.0a1.0.tm index 9e3c98bd..ed8e932a 100644 --- a/src/modules/punk/repl-999999.0a1.0.tm +++ b/src/modules/punk/repl-999999.0a1.0.tm @@ -3,9 +3,7 @@ #todo - make repls configurable/pluggable packages -#list/string-rep bug -global run_commandstr "" - +# ----------------------------------- set stdin_info [chan configure stdin] if {[dict exists $stdin_info -inputmode]} { #this is the only way I currently know to detect console on windows.. doesn't work on Alma linux. @@ -19,37 +17,46 @@ if {[dict exists $stdin_info -mode]} { } #give up for now set tcl_interactive 1 +unset stdin_info +# ----------------------------------- + #------------------------------------------------------------------------------------- if {[package provide punk::libunknown] eq ""} { #maintenance - also in src/vfs/_config/punk_main.tcl - set libunks [list] - foreach tm_path [tcl::tm::list] { - set punkdir [file join $tm_path punk] - if {![file exists $punkdir]} {continue} - lappend libunks {*}[glob -nocomplain -dir $punkdir -type f libunknown-*.tm] - } - set libunknown "" - set libunknown_version_sofar "" - foreach lib $libunks { - #expecting to be of form libunknown-.tm - set vtail [lindex [split [file tail $lib] -] 1] - set thisver [file rootname $vtail] ;#file rootname x.y.z.tm - if {$libunknown_version_sofar eq ""} { - set libunknown_version_sofar $thisver - set libunknown $lib - } else { - if {[package vcompare $thisver $libunknown_version_sofar] == 1} { - set libunknown_version_sofar $thisver - set libunknown $lib + namespace eval ::punk::libunknown::boot { + variable libunknown_boot + set libunknown_boot {{} { + set libunks [list] + foreach tm_path [tcl::tm::list] { + set punkdir [file join $tm_path punk] + if {![file exists $punkdir]} {continue} + lappend libunks {*}[glob -nocomplain -dir $punkdir -type f libunknown-*.tm] } - } - } - if {$libunknown ne ""} { - source $libunknown - if {[catch {punk::libunknown::init -caller triggered_by_repl_package_require} errM]} { - puts "error initialising punk::libunknown\n$errM" - } + set libunknown "" + set libunknown_version_sofar "" + foreach lib $libunks { + #expecting to be of form libunknown-.tm + set vtail [lindex [split [file tail $lib] -] 1] + set thisver [file rootname $vtail] ;#file rootname x.y.z.tm + if {$libunknown_version_sofar eq ""} { + set libunknown_version_sofar $thisver + set libunknown $lib + } else { + if {[package vcompare $thisver $libunknown_version_sofar] == 1} { + set libunknown_version_sofar $thisver + set libunknown $lib + } + } + } + if {$libunknown ne ""} { + uplevel 1 [list source $libunknown] + if {[catch {punk::libunknown::init -caller triggered_by_repl_package_require} errM]} { + puts "error initialising punk::libunknown\n$errM" + } + } + }} + apply $libunknown_boot } } else { #This should be reasonably common - a punk shell will generally have libunknown loaded @@ -2817,38 +2824,41 @@ namespace eval repl { namespace eval ::punk::libunknown {} set ::punk::libunknown::epoch %lib_epoch% - set libunks [list] - foreach tm_path [tcl::tm::list] { - set punkdir [file join $tm_path punk] - if {![file exists $punkdir]} {continue} - lappend libunks {*}[glob -nocomplain -dir $punkdir -type f libunknown-*.tm] - } - set libunknown "" - set libunknown_version_sofar "" - foreach lib $libunks { - #expecting to be of form libunknown-.tm - set vtail [lindex [split [file tail $lib] -] 1] - set thisver [file rootname $vtail] ;#file rootname x.y.z.tm - if {$libunknown_version_sofar eq ""} { - set libunknown_version_sofar $thisver - set libunknown $lib - } else { - if {[package vcompare $thisver $libunknown_version_sofar] == 1} { + apply {{} { + set libunks [list] + foreach tm_path [tcl::tm::list] { + set punkdir [file join $tm_path punk] + if {![file exists $punkdir]} {continue} + lappend libunks {*}[glob -nocomplain -dir $punkdir -type f libunknown-*.tm] + } + set libunknown "" + set libunknown_version_sofar "" + foreach lib $libunks { + #expecting to be of form libunknown-.tm + set vtail [lindex [split [file tail $lib] -] 1] + set thisver [file rootname $vtail] ;#file rootname x.y.z.tm + if {$libunknown_version_sofar eq ""} { set libunknown_version_sofar $thisver set libunknown $lib + } else { + if {[package vcompare $thisver $libunknown_version_sofar] == 1} { + set libunknown_version_sofar $thisver + set libunknown $lib + } } } - } - if {$libunknown ne ""} { - source $libunknown - if {[catch {punk::libunknown::init -caller "repl::init init_script parent interp"} errM]} { - puts "repl::init problem - error initialising punk::libunknown\n$errM" + if {$libunknown ne ""} { + uplevel 1 [list source $libunknown] + if {[catch {punk::libunknown::init -caller "repl::init init_script parent interp"} errM]} { + puts "repl::init problem - error initialising punk::libunknown\n$errM" + } + #package require punk::lib + #puts [punk::libunknown::package_query snit] + } else { + puts "repl::init problem - can't load punk::libunknown" } - #package require punk::lib - #puts [punk::libunknown::package_query snit] - } else { - puts "repl::init problem - can't load punk::libunknown" - } + }} + #----------------------------------------------------------------------------- package require punk::packagepreference @@ -3543,34 +3553,38 @@ namespace eval repl { if {[package provide punk::libunknown] eq ""} { namespace eval ::punk::libunknown {} set ::punk::libunknown::epoch %lib_epoch% - set libunks [list] - foreach tm_path [tcl::tm::list] { - set punkdir [file join $tm_path punk] - if {![file exists $punkdir]} {continue} - lappend libunks {*}[glob -nocomplain -dir $punkdir -type f libunknown-*.tm] - } - set libunknown "" - set libunknown_version_sofar "" - foreach lib $libunks { - #expecting to be of form libunknown-.tm - set vtail [lindex [split [file tail $lib] -] 1] - set thisver [file rootname $vtail] ;#file rootname x.y.z.tm - if {$libunknown_version_sofar eq ""} { - set libunknown_version_sofar $thisver - set libunknown $lib - } else { - if {[package vcompare $thisver $libunknown_version_sofar] == 1} { + + apply {{} { + set libunks [list] + foreach tm_path [tcl::tm::list] { + set punkdir [file join $tm_path punk] + if {![file exists $punkdir]} {continue} + lappend libunks {*}[glob -nocomplain -dir $punkdir -type f libunknown-*.tm] + } + set libunknown "" + set libunknown_version_sofar "" + foreach lib $libunks { + #expecting to be of form libunknown-.tm + set vtail [lindex [split [file tail $lib] -] 1] + set thisver [file rootname $vtail] ;#file rootname x.y.z.tm + if {$libunknown_version_sofar eq ""} { set libunknown_version_sofar $thisver set libunknown $lib + } else { + if {[package vcompare $thisver $libunknown_version_sofar] == 1} { + set libunknown_version_sofar $thisver + set libunknown $lib + } } } - } - if {$libunknown ne ""} { - source $libunknown - if {[catch {punk::libunknown::init -caller "repl::init init_script code interp for punk"} errM]} { - puts "error initialising punk::libunknown\n$errM" + if {$libunknown ne ""} { + uplevel 1 [list source $libunknown] + if {[catch {punk::libunknown::init -caller "repl::init init_script code interp for punk"} errM]} { + puts "error initialising punk::libunknown\n$errM" + } } - } + }} + } else { puts stderr "punk::libunknown [package provide punk::libunknown] already loaded" } @@ -3594,6 +3608,9 @@ namespace eval repl { } else { puts stderr "repl code interp loaded vfs,vfs::zip lag:[expr {[clock millis] - $tsstart}]" } + unset errM + unset tsstart + #puts stderr "package unknown: [package unknown]" #puts stderr ----- @@ -3634,6 +3651,8 @@ namespace eval repl { puts stderr "========================" lappend ::codethread_initstatus "error $errM" error "$errM" + } else { + unset errM } } } @@ -3682,7 +3701,8 @@ namespace eval repl { thread::id } set init_script [string map $scriptmap $init_script] - + #REVIEW - the same initscript sent for all values of $safe and it switches on values of $safe provided in %args% + #we already know $safe in this thread when generating the script - so why send the large script to the thread to then switch on that? #thread::send $codethread $init_script if {![catch { diff --git a/src/modules/zipper-buildversion.txt b/src/modules/zipper-buildversion.txt index a49e6497..acbbfacc 100644 --- a/src/modules/zipper-buildversion.txt +++ b/src/modules/zipper-buildversion.txt @@ -1,3 +1,3 @@ -0.12 +0.14 #First line must be a tm version number #all other lines are ignored. diff --git a/src/vfs/_vfscommon.vfs/modules/modpod-0.1.3.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/modpod-0.1.5.tm similarity index 92% rename from src/vfs/_vfscommon.vfs/modules/modpod-0.1.3.tm rename to src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/modpod-0.1.5.tm index 540a1696..63875951 100644 --- a/src/vfs/_vfscommon.vfs/modules/modpod-0.1.3.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/modpod-0.1.5.tm @@ -7,7 +7,7 @@ # (C) 2024 # # @@ Meta Begin -# Application modpod 0.1.3 +# Application modpod 0.1.5 # Meta platform tcl # Meta license # @@ Meta End @@ -17,7 +17,7 @@ # doctools header # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #*** !doctools -#[manpage_begin modpod_module_modpod 0 0.1.3] +#[manpage_begin modpod_module_modpod 0 0.1.5] #[copyright "2024"] #[titledesc {Module API}] [comment {-- Name section and table of contents description --}] #[moddesc {-}] [comment {-- Description at end of page heading --}] @@ -63,38 +63,11 @@ package require punk::args #*** !doctools #[section API] -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# oo::class namespace -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -namespace eval modpod::class { - #*** !doctools - #[subsection {Namespace modpod::class}] - #[para] class definitions - if {[info commands [namespace current]::interface_sample1] eq ""} { - #*** !doctools - #[list_begin enumerated] - - # oo::class create interface_sample1 { - # #*** !doctools - # #[enum] CLASS [class interface_sample1] - # #[list_begin definitions] - - # method test {arg1} { - # #*** !doctools - # #[call class::interface_sample1 [method test] [arg arg1]] - # #[para] test method - # puts "test: $arg1" - # } - - # #*** !doctools - # #[list_end] [comment {-- end definitions interface_sample1}] - # } - - #*** !doctools - #[list_end] [comment {--- end class enumeration ---}] - } -} -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#changes +#0.1.5 - Reduce pollution of global namespace with procs,variables +#0.1.4 - when mounting with vfs::zip (because zipfs not available) - mount relative to executable folder instead of module dir +# (given just a module name it's easier to find exepath than look at package ifneeded script to get module path) # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ # Base namespace @@ -124,13 +97,6 @@ namespace eval modpod { - #proc sample1 {p1 args} { - # #*** !doctools - # #[call [fun sample1] [arg p1] [opt {?option value...?}]] - # #[para]Description of sample1 - # return "ok" - #} - #old tar connect mechanism - review - not needed? proc connect {args} { puts stderr "modpod::connect--->>$args" @@ -351,24 +317,23 @@ namespace eval modpod::lib { set opt_offsettype [dict get $argd opts -offsettype] + #mount_stub should not pollute global namespace. set mount_stub [string map [list %offsettype% $opt_offsettype] { #zip file with Tcl loader prepended. Requires either builtin zipfs, or vfs::zip to mount while zipped. #Alternatively unzip so that extracted #modpod-package-version folder is in same folder as .tm file. #generated using: modpod::lib::make_zip_modpod -offsettype %offsettype% - if {[catch {file normalize [info script]} modfile]} { + if {[catch {file normalize [info script]}]} { error "modpod zip stub error. Unable to determine module path. (possible safe interp restrictions?)" } - if {$modfile eq "" || ![file exists $modfile]} { - error "modpod zip stub error. Unable to determine module path" - } - set moddir [file dirname $modfile] - set mod_and_ver [file rootname [file tail $modfile]] - lassign [split $mod_and_ver -] moduletail version - if {[file exists $moddir/#modpod-$mod_and_ver]} { - source $moddir/#modpod-$mod_and_ver/$mod_and_ver.tm - } else { - #determine module namespace so we can mount appropriately - proc intersect {A B} { + apply {{modfile} { + if {$modfile eq "" || ![file exists $modfile]} { + error "modpod zip stub error. Unable to determine module path" + } + set moddir [file dirname $modfile] + set exedir [file dirname [file normalize [info nameofexecutable]]] + set mod_and_ver [file rootname [file tail $modfile]] + lassign [split $mod_and_ver -] moduletail version + set do_intersect {{A B} { if {[llength $A] == 0} {return {}} if {[llength $B] == 0} {return {}} if {[llength $B] > [llength $A]} { @@ -384,12 +349,13 @@ namespace eval modpod::lib { } } return $res - } + }} + #determine module namespace so we can mount appropriately set lcase_tmfile_segments [string tolower [file split $moddir]] set lcase_modulepaths [string tolower [tcl::tm::list]] foreach lc_mpath $lcase_modulepaths { set mpath_segments [file split $lc_mpath] - if {[llength [intersect $lcase_tmfile_segments $mpath_segments]] == [llength $mpath_segments]} { + if {[llength [apply $do_intersect $lcase_tmfile_segments $mpath_segments]] == [llength $mpath_segments]} { set tail_segments [lrange [file split $moddir] [llength $mpath_segments] end] ;#use properly cased tail break } @@ -429,27 +395,29 @@ namespace eval modpod::lib { } } # #modpod-$mod_and_ver subdirectory always present in the archive so it can be conveniently extracted and run in that form - source //zipfs:/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm + uplevel 1 [list source //zipfs:/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm] } else { #fallback to slower vfs::zip #NB. We don't create the intermediate dirs - but the mount still works - if {![file exists $moddir/$mount_at]} { + + if {![file exists $exedir/$mount_at]} { if {[catch {package require vfs::zip} errM]} { set msg "Unable to load vfs::zip package to mount module $mod_and_ver (and zipfs not available either)" append msg \n "If neither zipfs or vfs::zip are available - the module can still be loaded by manually unzipping the file $modfile in place." append msg \n "The unzipped data will all be contained in a folder named #modpod-$mod_and_ver in the same parent folder as $modfile" error $msg } else { - set fd [vfs::zip::Mount $modfile $moddir/$mount_at] - if {![file exists $moddir/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm]} { - vfs::zip::Unmount $fd $moddir/$mount_at + set fd [vfs::zip::Mount $modfile $exedir/$mount_at] + if {![file exists $exedir/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm]} { + vfs::zip::Unmount $fd $exedir/$mount_at error "Unable to find $mod_and_ver.tm in $modfile for module $fullpackage" } } } - source $moddir/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm + uplevel 1 [list source $exedir/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm] } - } + }} [file normalize [info script]] + #zipped data follows }] #todo - test if supplied zipfile has #modpod-loadcript.tcl or some other script/executable before even creating? @@ -700,7 +668,7 @@ namespace eval modpod::system { package provide modpod [namespace eval modpod { variable pkg modpod variable version - set version 0.1.3 + set version 0.1.5 }] return diff --git a/src/vendormodules/overtype-1.6.6.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/overtype-1.7.1.tm similarity index 96% rename from src/vendormodules/overtype-1.6.6.tm rename to src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/overtype-1.7.1.tm index b4e59ec6..18fa78ea 100644 --- a/src/vendormodules/overtype-1.6.6.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/overtype-1.7.1.tm @@ -7,9 +7,9 @@ # (C) Julian Noble 2003-2023 # # @@ Meta Begin -# Application overtype 1.6.6 +# Application overtype 1.7.1 # Meta platform tcl -# Meta license BSD +# Meta license BSD # @@ Meta End @@ -17,10 +17,10 @@ # doctools header # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #*** !doctools -#[manpage_begin overtype_module_overtype 0 1.6.6] +#[manpage_begin overtype_module_overtype 0 1.7.1] #[copyright "2024"] #[titledesc {overtype text layout - ansi aware}] [comment {-- Name section and table of contents description --}] -#[moddesc {overtype text layout}] [comment {-- Description at end of page heading --}] +#[moddesc {overtype text layout}] [comment {-- Description at end of page heading --}] #[require overtype] #[keywords module text ansi] #[description] @@ -30,7 +30,7 @@ #*** !doctools #[section Overview] -#[para] overview of overtype +#[para] overview of overtype #[subsection Concepts] #[para] - @@ -41,7 +41,7 @@ #*** !doctools #[subsection dependencies] -#[para] packages used by overtype +#[para] packages used by overtype #[list_begin itemized] package require Tcl 8.6- @@ -81,23 +81,23 @@ package require punk::assertion #[section API] -#Julian Noble - 2003 +#Julian Noble - 2003 #Released under standard 'BSD license' conditions. # #todo - ellipsis truncation indicator for center,right -#v1.4 2023-07 - naive ansi color handling - todo - fix tcl::string::range +#v1.4 2023-07 - naive ansi color handling - todo - fix tcl::string::range # - need to extract and replace ansi codes? tcl::namespace::eval overtype { namespace import ::punk::assertion::assert - punk::assertion::active true + punk::assertion::active true namespace path ::punk::lib - namespace export * - variable default_ellipsis_horizontal "..." ;#fallback - variable default_ellipsis_vertical "..." + namespace export * + variable default_ellipsis_horizontal "..." ;#fallback + variable default_ellipsis_vertical "..." tcl::namespace::eval priv { proc _init {} { upvar ::overtype::default_ellipsis_horizontal e_h @@ -110,14 +110,14 @@ tcl::namespace::eval overtype { #set e [format %c 0x2504] ;#punk::char::charshort boxd_ltdshhz - Box Drawings Light Triple Dash Horizontal #if {![catch {package require punk::char}]} { - # set e [punk::char::charshort boxd_ltdshhz] + # set e [punk::char::charshort boxd_ltdshhz] #} } } priv::_init } proc overtype::about {} { - return "Simple text formatting. Author JMN. BSD-License" + return "Simple text formatting. Author JMN. BSD-License" } tcl::namespace::eval overtype { @@ -126,8 +126,8 @@ tcl::namespace::eval overtype { variable escape_terminals #single "final byte" in the range 0x40–0x7E (ASCII @A–Z[\]^_`a–z{|}~). tcl::dict::set escape_terminals CSI [list @ \\ ^ _ ` | ~ 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 "\{" "\}"] - #tcl::dict::set escape_terminals CSI [list J K m n A B C D E F G s u] ;#basic - tcl::dict::set escape_terminals OSC [list \007 \033\\] ;#note mix of 1 and 2-byte terminals + #tcl::dict::set escape_terminals CSI [list J K m n A B C D E F G s u] ;#basic + tcl::dict::set escape_terminals OSC [list \007 \033\\] ;#note mix of 1 and 2-byte terminals #self-contained 2 byte ansi escape sequences - review more? variable ansi_2byte_codes_dict @@ -157,29 +157,29 @@ proc overtype::string_columns {text} { } #todo - consider a way to merge overtype::left/centre/right -#These have similar algorithms/requirements - and should be refactored to be argument-wrappers over a function called something like overtype::renderblock +#These have similar algorithms/requirements - and should be refactored to be argument-wrappers over a function called something like overtype::renderblock #overtype::renderblock could render the input to a defined (possibly overflowing in x or y) rectangle overlapping the underlay. #(i.e not even necessariy having it's top left within the underlay) tcl::namespace::eval overtype::priv { } -#could return larger than renderwidth +#could return larger than renderwidth proc _get_row_append_column {row} { #obsolete? - upvar outputlines outputlines + upvar outputlines outputlines set idx [expr {$row -1}] if {$row <= 1 || $row > [llength $outputlines]} { return 1 } else { - upvar opt_expand_right expand_right - upvar renderwidth renderwidth + upvar opt_expand_right expand_right + upvar renderwidth renderwidth set existinglen [punk::ansi::printing_length [lindex $outputlines $idx]] set endpos [expr {$existinglen +1}] if {$expand_right} { return $endpos } else { if {$endpos > $renderwidth} { - return $renderwidth + 1 + return [expr {$renderwidth + 1}] } else { return $endpos } @@ -190,7 +190,7 @@ proc _get_row_append_column {row} { tcl::namespace::eval overtype { #*** !doctools #[subsection {Namespace overtype}] - #[para] Core API functions for overtype + #[para] Core API functions for overtype #[list_begin definitions] @@ -201,14 +201,14 @@ tcl::namespace::eval overtype { #The overlay may just be an ansi-colourised block - or may contain ansi cursor movements and cursor save/restore calls - in which case the apparent length and width of the overlay can't be determined as if it was a block of text. #This is a single-shot rendering of strings - ie there is no way to chain another call containing a cursor-restore to previously rendered output and have it know about any cursor-saves in the first call. # a cursor start position other than top-left is a possible addition to consider. - #see editbuf in punk::repl for a more stateful ansi-processor. Both systems use loops over overtype::renderline + #see editbuf in punk::repl for a more stateful ansi-processor. Both systems use loops over overtype::renderline proc renderspace {args} { #*** !doctools #[call [fun overtype::renderspace] [arg args] ] - #[para] usage: ?-transparent [lb]0|1[rb]? ?-expand_right [lb]1|0[rb]? ?-ellipsis [lb]1|0[rb]? ?-ellipsistext ...? undertext overtext + #[para] usage: ?-transparent [lb]0|1[rb]? ?-expand_right [lb]1|0[rb]? ?-ellipsis [lb]1|0[rb]? ?-ellipsistext ...? undertext overtext - # @c overtype starting at left (overstrike) - # @c can/should we use something like this?: 'format "%-*s" $len $overtext + # @c overtype starting at left (overstrike) + # @c can/should we use something like this?: 'format "%-*s" $len $overtext variable default_ellipsis_horizontal if {[llength $args] < 2} { @@ -257,9 +257,9 @@ tcl::namespace::eval overtype { # it does not necessarily mean the viewport grows. (which further implies need for horizontal scrolling) # - it does need to be within some concept of terminal width - as columns must be addressable by ansi sequences. # - This implies the -width option value must grow if it is tied to the concept of renderspace terminal width! REVIEW. - # - further implication is that if expand_right grows the virtual renderspace terminal width - + # - further implication is that if expand_right grows the virtual renderspace terminal width - # then some sort of reflow/rerender needs to be done for preceeding lines? - # possibly not - as expand_right is distinct from a normal terminal-width change event, + # possibly not - as expand_right is distinct from a normal terminal-width change event, # expand_right being primarily to support other operations such as textblock::table #todo - viewport width/height as separate concept to terminal width/height? @@ -269,14 +269,14 @@ tcl::namespace::eval overtype { -looplimit - -width - -height - -startcolumn - -bias - -ellipsis - -ellipsistext - -ellipsiswhitespace - -transparent - -exposed1 - -exposed2 - -experimental - -expand_right - -appendlines - - -reverse_mode - -crm_mode - -insert_mode + - -reverse_mode - -crm_mode - -insert_mode - -cp437 - -info - -console { tcl::dict::set opts $k $v } -wrap - -autowrap_mode { #temp alias -autowrap_mode for consistency with renderline - #todo - + #todo - tcl::dict::set opts -wrap $v } default { @@ -286,8 +286,8 @@ tcl::namespace::eval overtype { } #set opts [tcl::dict::merge $defaults $argsflags] # -- --- --- --- --- --- - #review - expand_left for RTL text? - set opt_expand_right [tcl::dict::get $opts -expand_right] + #review - expand_left for RTL text? + set opt_expand_right [tcl::dict::get $opts -expand_right] #for repl - standard output line indicator is a dash - todo, add a different indicator for a continued line. set opt_width [tcl::dict::get $opts -width] set opt_height [tcl::dict::get $opts -height] @@ -304,7 +304,7 @@ tcl::namespace::eval overtype { set opt_insert_mode [tcl::dict::get $opts -insert_mode] ##### # review -wrap should map onto DECAWM terminal mode - the wrap 2 idea may not fit in with this?. - set opt_autowrap_mode [tcl::dict::get $opts -wrap] + set opt_autowrap_mode [tcl::dict::get $opts -wrap] #??? wrap 1 is hard wrap cutting word at exact column, or 1 column early for 2w-glyph, wrap 2 is for language-based word-wrap algorithm (todo) ##### # -- --- --- --- --- --- @@ -330,7 +330,6 @@ tcl::namespace::eval overtype { } } # ---------------------------- - set underblock [tcl::string::map {\r\n \n} $underblock] set overblock [tcl::string::map {\r\n \n} $overblock] @@ -342,9 +341,9 @@ tcl::namespace::eval overtype { #only non-cursor affecting and non-width occupying ANSI codes should be present. #ie SGR codes and perhaps things such as PM - although generally those should have been pushed to the application already #renderwidth & renderheight were originally used with reference to rendering into a 'column' of output e.g a table column - before cursor row/col was implemented. - + if {$opt_width eq "\uFFEF" || $opt_height eq "\uFFEF"} { - lassign [blocksize $underblock] _w renderwidth _h renderheight + lassign [blocksize $underblock] _w renderwidth _h renderheight if {$opt_width ne "\uFFEF"} { set renderwidth $opt_width } @@ -368,9 +367,9 @@ tcl::namespace::eval overtype { #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 + set vtstate $initial_state - # -- --- --- --- + # -- --- --- --- #REVIEW - do we need ansi resets in the underblock? if {$underblock eq ""} { set underlines [lrepeat $renderheight ""] @@ -386,16 +385,16 @@ tcl::namespace::eval overtype { # #lines_as_list -ansiresets 1 will do nothing if -ansiresets 1 isn't specified - REVIEW # set underlines [lines_as_list -ansiresets 1 $underblock] #} - # -- --- --- --- + # -- --- --- --- #todo - reconsider the 'line' as the natural chunking mechanism for the overlay. - #In practice an overlay ANSI stream can be a single line with ansi moves/restores etc - or even have no moves or newlines, just relying on wrapping at the output renderwidth + #In practice an overlay ANSI stream can be a single line with ansi moves/restores etc - or even have no moves or newlines, just relying on wrapping at the output renderwidth #In such cases - we process the whole shebazzle for the first output line - only reducing by the applied amount at the head each time, reprocessing the long tail each time. #(in cases where there are interline moves or cursor jumps anyway) #This works - but doesn't seem efficient. #On the other hand.. maybe it depends on the data. For simpler files it's more efficient than splitting first - #a hack until we work out how to avoid infinite loops... + #a hack until we work out how to avoid infinite loops... # set looplimit [tcl::dict::get $opts -looplimit] if {$looplimit eq "\uFFEF"} { @@ -434,7 +433,7 @@ tcl::namespace::eval overtype { } } 3 { - #it turns out line based chunks are faster than the above.. probably because some of those end up doing the regex splitting twice + #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 { @@ -462,23 +461,23 @@ tcl::namespace::eval overtype { - set replay_codes_underlay [tcl::dict::create 1 ""] + set replay_codes_underlay [tcl::dict::create 1 ""] #lappend replay_codes_overlay "" set replay_codes_overlay "[punk::ansi::a]" set unapplied "" - set cursor_saved_position [tcl::dict::create] + set cursor_saved_position [tcl::dict::create] set cursor_saved_attributes "" - set outputlines $underlines + 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] + # set col [_get_row_append_column $row] #} else { - set col $opt_startcolumn + set col $opt_startcolumn #} set instruction_stats [tcl::dict::create] @@ -492,9 +491,9 @@ tcl::namespace::eval overtype { if {![tcl::string::length $overtext]} { incr loop continue - } + } #puts "----->[ansistring VIEW -lf 1 -vt 1 -nul 1 $overtext]<----" - set undertext [lindex $outputlines [expr {$row -1}]] + set undertext [lindex $outputlines [expr {$row -1}]] set renderedrow $row #renderline pads each underaly line to width with spaces and should track where end of data is @@ -505,7 +504,7 @@ tcl::namespace::eval overtype { 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 - + #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\ -cp437 $opt_cp437\ @@ -534,7 +533,7 @@ tcl::namespace::eval overtype { # - review - the answer is probably that we don't need to - it is set/reset only during application of overtext #Note carefully the difference betw overflow_right and unapplied. - #overflow_right may need to be included in next run before the unapplied data + #overflow_right may need to be included in next run before the unapplied data #overflow_right most commonly has data when in insert_mode set rendered [tcl::dict::get $rinfo result] set overflow_right [tcl::dict::get $rinfo overflow_right] @@ -557,7 +556,7 @@ tcl::namespace::eval overtype { puts stderr "---->[ansistring VIEW $replay_codes_overlay] rendered: $rendered" #review #JMN3 - set existing_reverse_state 0 + set existing_reverse_state 0 #split_codes_single is single esc sequence - but could have multiple sgr codes within one esc sequence #e.g \x1b\[0;31;7m has a reset,colour red and reverse set codeinfo [punk::ansi::codetype::sgr_merge [list $replay_codes_overlay] -info 1] @@ -609,7 +608,7 @@ tcl::namespace::eval overtype { #todo - handle potential insertion mode as above for cursor restore? #keeping separate branches for debugging - review and merge as appropriate when stable set instruction_type [lindex $instruction 0] ;#some instructions have params - tcl::dict::incr instruction_stats $instruction_type + tcl::dict::incr instruction_stats $instruction_type switch -- $instruction_type { reset { #reset the 'renderspace terminal' (not underlying terminal) @@ -630,7 +629,7 @@ tcl::namespace::eval overtype { } else { puts stderr "renderspace end of input line - has unapplied: [ansistring VIEW $unapplied] (review)" } - set col $opt_startcolumn + set col $opt_startcolumn } up { @@ -644,7 +643,7 @@ tcl::namespace::eval overtype { #puts stderr "up $post_render_row" #puts stderr "$rinfo" - #puts stdout "1 row:$row col $col" + #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 @@ -652,18 +651,18 @@ tcl::namespace::eval overtype { 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 + #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 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 col $renderwidth } } - - #puts stdout "2 row:$row col $col" + + #puts stdout "2 row:$row col $col" #puts stdout "-----------------------" #puts stdout $rinfo #flush stdout @@ -680,7 +679,7 @@ tcl::namespace::eval overtype { lappend outputlines "" } } - set row $post_render_row + set row $post_render_row set col $post_render_col } else { if {$post_render_row > [llength $outputlines]} { @@ -692,12 +691,12 @@ tcl::namespace::eval overtype { lappend outputlines "" } } - set existingdata [lindex $outputlines [expr {$post_render_row -1}]] + 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 col $renderwidth } } @@ -711,7 +710,7 @@ tcl::namespace::eval overtype { set 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 + #lset replay_codes_overlay [expr $overidx+1] $cursor_saved_attributes set replay_codes_overlay [tcl::dict::get $rinfo replay_codes_overlay]$cursor_saved_attributes #set replay_codes_overlay $cursor_saved_attributes set cursor_saved_position [tcl::dict::create] @@ -728,7 +727,7 @@ tcl::namespace::eval overtype { #wrap before restore? - possible effect on saved cursor position #this overflow data has previously been rendered so has no cursor movements or further save/restore operations etc #we can just insert another call to renderline to solve this.. ? - #It would perhaps be more properly handled as a queue of instructions from our initial renderline call + #It would perhaps be more properly handled as a queue of instructions from our initial renderline call #we don't need to worry about overflow next call (?)- but we should carry forward our gx and ansi stacks puts stdout ">>>[a+ red bold]overflow_right during restore_cursor[a]" @@ -743,7 +742,7 @@ tcl::namespace::eval overtype { $overflow_right\ ] set foldline [tcl::dict::get $sub_info result] - tcl::dict::set vtstate insert_mode [tcl::dict::get $sub_info insert_mode] ;#probably not needed..? + tcl::dict::set vtstate insert_mode [tcl::dict::get $sub_info insert_mode] ;#probably not needed..? tcl::dict::set vtstate autowrap_mode [tcl::dict::get $sub_info autowrap_mode] ;#nor this.. linsert outputlines $renderedrow $foldline #review - row & col set by restore - but not if there was no save.. @@ -791,8 +790,8 @@ tcl::namespace::eval overtype { 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 - + " " - - - _ - ! - @ - # - $ - % - ^ - & - * - = - + - : - . - , - / - | - ? - + 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 } @@ -816,21 +815,21 @@ tcl::namespace::eval overtype { #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] - + } lf_start { - #raw newlines + #raw newlines # ---------------------- #test with fruit.ans #test - treating as newline below... #append rendered $overflow_right #set overflow_right "" set row $renderedrow - incr row + incr row if {$row > [llength $outputlines]} { lappend outputlines "" } - set col $opt_startcolumn + set col $opt_startcolumn # ---------------------- } lf_mid { @@ -842,7 +841,7 @@ tcl::namespace::eval overtype { set unapplied "" set row $post_render_row #set col $post_render_col - set col $opt_startcolumn + set col $opt_startcolumn if {$row > [llength $outputlines]} { lappend outputlines {*}[lrepeat 1 ""] } @@ -862,22 +861,22 @@ tcl::namespace::eval overtype { if {[tcl::dict::get $vtstate autowrap_mode]} { set outputlines [linsert $outputlines $renderedrow $overflow_right] set overflow_right "" - set row [expr {$renderedrow + 2}] + set 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 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 add "" set addlen $visualwidth foreach g $graphemes { set w [overtype::grapheme_width_cached $g] @@ -885,9 +884,9 @@ tcl::namespace::eval overtype { append add $g incr addlen $w } else { - set filled 1 + set filled 1 break - } + } } append rendered $add } @@ -901,7 +900,7 @@ tcl::namespace::eval overtype { } } set row $post_render_row - set col $opt_startcolumn + set col $opt_startcolumn if {$row > [llength $outputlines]} { lappend outputlines {*}[lrepeat 1 ""] } @@ -911,7 +910,7 @@ tcl::namespace::eval overtype { append rendered $overflow_right set overflow_right "" set row $post_render_row - set col $opt_startcolumn + set col $opt_startcolumn if {$row > [llength $outputlines]} { lappend outputlines {*}[lrepeat 1 ""] } @@ -936,12 +935,12 @@ tcl::namespace::eval overtype { set row $post_render_row #set row $renderedrow - #incr row + #incr row #only add newline if we're at the bottom if {$row > [llength $outputlines]} { lappend outputlines {*}[lrepeat 1 ""] } - set col $opt_startcolumn + set col $opt_startcolumn } newlines_above { @@ -956,7 +955,7 @@ tcl::namespace::eval overtype { set col $post_render_col if {$insert_lines_above > 0} { set row $renderedrow - set outputlines [linsert $outputlines $renderedrow-1 {*}[lrepeat $insert_lines_above ""]] + set outputlines [linsert $outputlines $renderedrow-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 #? set row $post_render_row #can renderline tell us? } @@ -977,7 +976,7 @@ tcl::namespace::eval overtype { #} #puts [textblock::join $lhs $rhs] - #rendered + #rendered append rendered $overflow_right # @@ -989,7 +988,7 @@ tcl::namespace::eval overtype { lappend outputlines {*}[lrepeat $insert_lines_below ""] } incr row $insert_lines_below - set col $opt_startcolumn + set col $opt_startcolumn } } else { set row $post_render_row @@ -1002,12 +1001,12 @@ tcl::namespace::eval overtype { lappend outputlines "" } } else { - set existingdata [lindex $outputlines [expr {$post_render_row -1}]] + 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 col $renderwidth } } } @@ -1016,7 +1015,7 @@ tcl::namespace::eval overtype { #doesn't seem to be used by fruit.ans testfile #used by dzds.ans #note that cursor_forward may move deep into the next line - or even span multiple lines !TODO - set c $renderwidth + set c $renderwidth set r $post_render_row if {$post_render_col > $renderwidth} { set i $c @@ -1028,10 +1027,10 @@ tcl::namespace::eval overtype { lappend outputlines "" } } - set c $opt_startcolumn + set c $opt_startcolumn } else { incr c - } + } incr i } set col $c @@ -1039,7 +1038,7 @@ tcl::namespace::eval overtype { #why are we getting this instruction then? puts stderr "wrapmoveforward - test" set r [expr {$post_render_row +1}] - set c $post_render_col + set c $post_render_col } set row $r set col $c @@ -1048,7 +1047,7 @@ tcl::namespace::eval overtype { set c $renderwidth set r $post_render_row if {$post_render_col < 1} { - set c 1 + set c 1 set i $c while {$i >= $post_render_col} { if {$c == 0} { @@ -1083,7 +1082,7 @@ tcl::namespace::eval overtype { } else { set col $post_render_col #set unapplied "" ;#this seems wrong? - #set unapplied [tcl::string::range $unapplied 1 end] + #set unapplied [tcl::string::range $unapplied 1 end] #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' @@ -1102,7 +1101,7 @@ tcl::namespace::eval overtype { #we need to run the reduced unapplied on the same line - further graphemes will just overflow again, but codes or control chars could trigger jumps to other lines set overflow_handled 1 - #handled by dropping overflow if any + #handled by dropping overflow if any } } overflow_splitchar { @@ -1129,7 +1128,7 @@ tcl::namespace::eval overtype { } } else { set overflow_handled 1 - #handled by dropping entire overflow if any + #handled by dropping entire overflow if any if {$renderwidth < 2} { set idx 0 set triggering_grapheme_index -1 @@ -1167,7 +1166,7 @@ tcl::namespace::eval overtype { if {!$opt_expand_right && ![tcl::dict::get $vtstate autowrap_mode]} { - #not allowed to overflow column or wrap therefore we get overflow data to truncate + #not allowed to overflow column or wrap therefore we get overflow data to truncate if {[tcl::dict::get $opts -ellipsis]} { set show_ellipsis 1 if {!$opt_ellipsiswhitespace} { @@ -1205,7 +1204,7 @@ tcl::namespace::eval overtype { if {$opt_appendlines} { lappend outputlines $rendered } else { - #? + #? lset outputlines [expr {$renderedrow-1}] $rendered } } @@ -1254,7 +1253,7 @@ tcl::namespace::eval overtype { append debugmsg "${Y}[string repeat - [string length $sep_header]]$RST" \n puts stdout $debugmsg - #todo - config regarding error dumps rather than just dumping in working dir + #todo - config regarding error dumps rather than just dumping in working dir set fd [open [pwd]/error_overtype.txt w] puts $fd $debugmsg close $fd @@ -1262,10 +1261,10 @@ tcl::namespace::eval overtype { break } } - + set result [join $outputlines \n] if {!$opt_info} { - return $result + return $result } else { #emit to debug window like basictelnet does? make debug configurable as syslog or even a telnet server to allow on 2nd window? #append result \n$instruction_stats\n @@ -1288,7 +1287,7 @@ tcl::namespace::eval overtype { if {[llength $args] < 2} { error {usage: ?-transparent [0|1]? ?-bias [left|right]? ?-overflow [1|0]? undertext overtext} } - + foreach {underblock overblock} [lrange $args end-1 end] break #todo - vertical vs horizontal overflow for blocks @@ -1330,9 +1329,9 @@ tcl::namespace::eval overtype { set underlines [split $underblock \n] #set renderwidth [tcl::mathfunc::max {*}[lmap v $underlines {punk::ansi::printing_length $v}]] - lassign [blocksize $underblock] _w renderwidth _h renderheight + lassign [blocksize $underblock] _w renderwidth _h renderheight set overlines [split $overblock \n] - lassign [blocksize $overblock] _w overblock_width _h overblock_height + lassign [blocksize $overblock] _w overblock_width _h overblock_height set under_exposed_max [expr {$renderwidth - $overblock_width}] if {$under_exposed_max > 0} { #background block is wider @@ -1360,7 +1359,7 @@ tcl::namespace::eval overtype { } set replay_codes_underlay "" set replay_codes_overlay "" - foreach undertext $underlines overtext $overlines { + foreach undertext $underlines overtext $overlines { set overtext_datalen [punk::ansi::printing_length $overtext] set ulen [punk::ansi::printing_length $undertext] if {$ulen < $renderwidth} { @@ -1469,17 +1468,17 @@ tcl::namespace::eval overtype { set opt_exposed2 [tcl::dict::get $opts -exposed2] set opt_align [tcl::dict::get $opts -align] # -- --- --- --- --- --- - + set underblock [tcl::string::map {\r\n \n} $underblock] set overblock [tcl::string::map {\r\n \n} $overblock] set underlines [split $underblock \n] - lassign [blocksize $underblock] _w renderwidth _h renderheight + lassign [blocksize $underblock] _w renderwidth _h renderheight set overlines [split $overblock \n] #set overblock_width [tcl::mathfunc::max {*}[lmap v $overlines {punk::ansi::printing_length $v}]] - lassign [blocksize $overblock] _w overblock_width _h overblock_height + lassign [blocksize $overblock] _w overblock_width _h overblock_height set under_exposed_max [expr {max(0,$renderwidth - $overblock_width)}] - set left_exposed $under_exposed_max + set left_exposed $under_exposed_max @@ -1491,7 +1490,7 @@ tcl::namespace::eval overtype { } set replay_codes_underlay "" set replay_codes_overlay "" - foreach undertext $underlines overtext $overlines { + foreach undertext $underlines overtext $overlines { set overtext_datalen [punk::ansi::printing_length $overtext] set ulen [punk::ansi::printing_length $undertext] if {$ulen < $renderwidth} { @@ -1503,17 +1502,17 @@ tcl::namespace::eval overtype { set odiff [expr {$overblock_width - $overtext_datalen}] switch -- $opt_align { left { - set startoffset 0 + set startoffset 0 } right { - set startoffset $odiff + set startoffset $odiff } default { set half [expr {$odiff / 2}] #set lhs [string repeat { } $half] #set righthalf [expr {$odiff - $half}] ;#remainder - may be one more - so we are biased left #set rhs [string repeat { } $righthalf] - set startoffset $half + set startoffset $half } } } else { @@ -1524,7 +1523,7 @@ tcl::namespace::eval overtype { set overtext $replay_codes_overlay$overtext set overflowlength [expr {$overtext_datalen - $renderwidth}] - if {$overflowlength > 0} { + if {$overflowlength > 0} { #raw overtext wider than undertext column set rinfo [renderline\ -info 1\ @@ -1555,7 +1554,7 @@ tcl::namespace::eval overtype { } lappend outputlines $rendered } else { - #padded overtext + #padded overtext #lappend outputlines [renderline -insert_mode 0 -transparent $opt_transparent -startcolumn [expr {$left_exposed + 1}] $undertext $overtext] #Note - we still need overflow(exapnd_right) here - as although the overtext is short - it may oveflow due to the startoffset set rinfo [renderline -info 1 -insert_mode 0 -transparent $opt_transparent -expand_right $opt_overflow -startcolumn [expr {$left_exposed + 1 + $startoffset}] $undertext $overtext] @@ -1622,15 +1621,15 @@ tcl::namespace::eval overtype { set opt_blockalign "centre" } # -- --- --- --- --- --- - + set underblock [tcl::string::map {\r\n \n} $underblock] set overblock [tcl::string::map {\r\n \n} $overblock] set underlines [split $underblock \n] - lassign [blocksize $underblock] _w renderwidth _h renderheight + lassign [blocksize $underblock] _w renderwidth _h renderheight set overlines [split $overblock \n] #set overblock_width [tcl::mathfunc::max {*}[lmap v $overlines {punk::ansi::printing_length $v}]] - lassign [blocksize $overblock] _w overblock_width _h overblock_height + lassign [blocksize $overblock] _w overblock_width _h overblock_height set under_exposed_max [expr {max(0,$renderwidth - $overblock_width)}] switch -- $opt_blockalign { @@ -1638,7 +1637,7 @@ tcl::namespace::eval overtype { set left_exposed 0 } right { - set left_exposed $under_exposed_max + set left_exposed $under_exposed_max } centre { if {$under_exposed_max > 0} { @@ -1674,7 +1673,7 @@ tcl::namespace::eval overtype { } set replay_codes_underlay "" set replay_codes_overlay "" - foreach undertext $underlines overtext $overlines { + foreach undertext $underlines overtext $overlines { set overtext_datalen [punk::ansi::printing_length $overtext] set ulen [punk::ansi::printing_length $undertext] if {$ulen < $renderwidth} { @@ -1686,17 +1685,17 @@ tcl::namespace::eval overtype { set odiff [expr {$overblock_width - $overtext_datalen}] switch -- $opt_textalign { left { - set startoffset 0 + set startoffset 0 } right { - set startoffset $odiff + set startoffset $odiff } default { set half [expr {$odiff / 2}] #set lhs [string repeat { } $half] #set righthalf [expr {$odiff - $half}] ;#remainder - may be one more - so we are biased left #set rhs [string repeat { } $righthalf] - set startoffset $half + set startoffset $half } } } else { @@ -1707,7 +1706,7 @@ tcl::namespace::eval overtype { set overtext $replay_codes_overlay$overtext set overflowlength [expr {$overtext_datalen - $renderwidth}] - if {$overflowlength > 0} { + if {$overflowlength > 0} { #raw overtext wider than undertext column set rinfo [renderline -info 1 -insert_mode 0 -transparent $opt_transparent -exposed1 $opt_exposed1 -exposed2 $opt_exposed2 -expand_right $opt_overflow -startcolumn [expr {1 + $startoffset}] $undertext $overtext] set replay_codes [tcl::dict::get $rinfo replay_codes] @@ -1755,7 +1754,7 @@ tcl::namespace::eval overtype { } lappend outputlines $rendered } else { - #padded overtext + #padded overtext #lappend outputlines [renderline -insert_mode 0 -transparent $opt_transparent -startcolumn [expr {$left_exposed + 1}] $undertext $overtext] #Note - we still need expand_right here - as although the overtext is short - it may oveflow due to the startoffset set rinfo [renderline -info 1 -insert_mode 0 -transparent $opt_transparent -expand_right $opt_overflow -startcolumn [expr {$left_exposed + 1 + $startoffset}] $undertext $overtext] @@ -1775,8 +1774,8 @@ tcl::namespace::eval overtype { variable optimise_ptruns 10 ;# can be set to zero to disable the ptruns branches # ## ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### - # renderline written from a left-right line orientation perspective as a first-shot at getting something useful. - # ultimately right-to-left, top-to-bottom and bottom-to-top are probably needed. + # renderline written from a left-right line orientation perspective as a first-shot at getting something useful. + # ultimately right-to-left, top-to-bottom and bottom-to-top are probably needed. # ## ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### # # @@ -1791,7 +1790,7 @@ tcl::namespace::eval overtype { #*** !doctools #[call [fun overtype::renderline] [arg args] ] #[para] renderline is the core engine for overtype string processing (frames & textblocks), and the raw mode commandline repl for the Tcl Punk Shell - #[para] It is also a central part of an ansi (micro) virtual terminal-emulator of sorts + #[para] It is also a central part of an ansi (micro) virtual terminal-emulator of sorts #[para] This system does a half decent job at rendering 90's ANSI art to manipulable colour text blocks that can be joined & framed for layout display within a unix or windows terminal #[para] Renderline helps maintain ANSI text styling reset/replay codes so that the styling of one block doesn't affect another. #[para] Calling on the punk::ansi library - it can coalesce codes to keep the size down. @@ -1799,7 +1798,7 @@ tcl::namespace::eval overtype { #[para] renderline is part of the Unicode and ANSI aware Overtype system which 'renders' a block of text onto a static underlay #[para] The underlay is generally expected to be an ordered set of lines or a rectangular text block analogous to a terminal screen - but it can also be ragged in line length, or just blank. #[para] The overlay couuld be similar - in which case it may often be used to overwrite a column or section of the underlay. - #[para] The overlay could however be a sequence of ANSI-laden text that jumps all over the place. + #[para] The overlay could however be a sequence of ANSI-laden text that jumps all over the place. # #[para] renderline itself only deals with a single line - or sometimes a single character. It is generally called from a loop that does further terminal-like or textblock processing. #[para] By suppyling the -info 1 option - it can return various fields indicating the state of the render. @@ -1867,7 +1866,7 @@ tcl::namespace::eval overtype { set opt_width [tcl::dict::get $opts -width] set opt_etabs [tcl::dict::get $opts -etabs] set opt_expand_right [tcl::dict::get $opts -expand_right] - set opt_colstart [tcl::dict::get $opts -startcolumn] ;#lhs limit for overlay - an offset to cursor_column - first visible column is 1. 0 or < 0 are before the start of the underlay + set opt_colstart [tcl::dict::get $opts -startcolumn] ;#lhs limit for overlay - an offset to cursor_column - first visible column is 1. 0 or < 0 are before the start of the underlay set opt_colcursor [tcl::dict::get $opts -cursor_column];#start cursor column relative to overlay set opt_row_context [tcl::dict::get $opts -cursor_row] if {[string length $opt_row_context]} { @@ -1875,7 +1874,7 @@ tcl::namespace::eval overtype { error "overtype::renderline -cursor_row must be empty for unspecified/unknown or a non-zero positive integer. received: '$opt_row_context'" } } - # -- --- --- --- --- --- --- --- --- --- --- --- + # -- --- --- --- --- --- --- --- --- --- --- --- #The _mode flags correspond to terminal modes that can be set/reset via escape sequences (e.g DECAWM wraparound mode) set opt_insert_mode [tcl::dict::get $opts -insert_mode];#should usually be 1 for each new line in editor mode but must be initialised to 1 externally (review) #default is for overtype @@ -1886,7 +1885,7 @@ tcl::namespace::eval overtype { # -- --- --- --- --- --- --- --- --- --- --- --- set temp_cursor_saved [tcl::dict::get $opts -cursor_restore_attributes] - set cp437_glyphs [tcl::dict::get $opts -cp437] + set cp437_glyphs [tcl::dict::get $opts -cp437] set cp437_map [tcl::dict::create] if {$cp437_glyphs} { set cp437_map [set ::punk::ansi::cp437_map] @@ -1896,7 +1895,7 @@ tcl::namespace::eval overtype { tcl::dict::unset cp437_map \n } - set opt_transparent [tcl::dict::get $opts -transparent] + set opt_transparent [tcl::dict::get $opts -transparent] if {$opt_transparent eq "0"} { set do_transparency 0 } else { @@ -1941,7 +1940,7 @@ tcl::namespace::eval overtype { if {!$opt_etabs} { if {[string first \t $under] >= 0} { #set under [textutil::tabify::untabify2 $under] - set under [textutil::tabify::untabifyLine $under $tw] + set under [textutil::tabify::untabifyLine $under $tw] } if {[string first \t $over] >= 0} { #set overdata [textutil::tabify::untabify2 $over] @@ -1972,7 +1971,7 @@ tcl::namespace::eval overtype { set pm_list [list] set i_u -1 ;#underlay may legitimately be empty - set undercols [list] + set undercols [list] set u_codestack [list] #u_gx_stack probably isn't really a stack - I don't know if g0 g1 can stack or not - for now we support only g0 anyway set u_gx_stack [list] ;#separate stack for g0 (g1 g2 g3?) graphics on and off (DEC special graphics) @@ -1990,12 +1989,12 @@ tcl::namespace::eval overtype { set p1 [tcl::string::index $pt 0] set hex [format %x [scan $p1 %c]] ;#punk::char::char_hex set re [tcl::string::cat {^[} \\U$hex {]+$}] - set is_ptrun [regexp $re $pt] + set is_ptrun [regexp $re $pt] } if {$is_ptrun} { #switch -- $p1 { - # " " - - - _ - ! - @ - # - $ - % - ^ - & - * - = - + - : - . - , - / - | - ? - - # 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 - + # " " - - - _ - ! - @ - # - $ - % - ^ - & - * - = - + - : - . - , - / - | - ? - + # 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 { # set width 1 # } @@ -2014,7 +2013,7 @@ tcl::namespace::eval overtype { set ptlen [string length $pt] if {$width <= 1} { #review - 0 and 1? - incr i_u $ptlen + incr i_u $ptlen lappend understacks {*}[lrepeat $ptlen $u_codestack] lappend understacks_gx {*}[lrepeat $ptlen $u_gx_stack] lappend undercols {*}[lrepeat $ptlen $p1] @@ -2023,7 +2022,7 @@ tcl::namespace::eval overtype { set 2ptlen [expr {$ptlen * 2}] lappend understacks {*}[lrepeat $2ptlen $u_codestack] lappend understacks_gx {*}[lrepeat $2ptlen $u_gx_stack] - set l [concat {*}[lrepeat $ptlen [list $p1 ""]] + set l [concat {*}[lrepeat $ptlen [list $p1 ""]]] lappend undercols {*}$l unset l } @@ -2034,8 +2033,8 @@ tcl::namespace::eval overtype { #.. but even 0.5uS per char (grapheme_width_cached) adds up quickly when stitching lots of lines together. #todo - test decimal value instead, compare performance 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 - + " " - - - _ - ! - @ - # - $ - % - ^ - & - * - = - + - : - . - , - / - | - ? - + 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 { set width 1 } @@ -2050,24 +2049,24 @@ tcl::namespace::eval overtype { set width [grapheme_width_cached $grapheme] #we still want most controls and other zero-length codepoints such as \u200d (zero width joiner) to stay zero-length #we substitute lone ESC that weren't captured within ANSI context as a debugging aid to see malformed ANSI - #todo - default to off and add a flag (?) to enable this substitution + #todo - default to off and add a flag (?) to enable this substitution set sub_stray_escapes 0 if {$sub_stray_escapes && $width == 0} { if {$grapheme eq "\x1b"} { set gvis [ansistring VIEW $grapheme] ;#can only use with graphemes that have a single replacement char.. set grapheme $gvis - set width 1 + set width 1 } } } } } - + #set width [grapheme_width_cached $grapheme] incr i_u lappend understacks $u_codestack lappend understacks_gx $u_gx_stack - + lappend undercols $grapheme if {$width > 1} { #presumably there are no triple-column or wider unicode chars.. until the aliens arrive.(?) @@ -2084,7 +2083,7 @@ tcl::namespace::eval overtype { } #underlay should already have been rendered and not have non-sgr codes - but let's retain the check for them and not stack them if other codes are here - #only stack SGR (graphics rendition) codes - not title sets, cursor moves etc + #only stack SGR (graphics rendition) codes - not title sets, cursor moves etc #keep any remaining PMs in place if {$code ne ""} { set c1c2 [tcl::string::range $code 0 1] @@ -2099,13 +2098,13 @@ tcl::namespace::eval overtype { switch -- $leadernorm { 7CSI - 8CSI { - #need to exclude certain leaders after the lb e.g < for SGR 1006 mouse + #need to exclude certain leaders after the lb e.g < for SGR 1006 mouse #REVIEW - what else could end in m but be mistaken as a normal SGR code here? set maybemouse "" if {[tcl::string::index $c1c2 0] eq "\x1b"} { set maybemouse [tcl::string::index $code 2] } - + if {$maybemouse ne "<" && [tcl::string::index $code end] eq "m"} { if {[punk::ansi::codetype::is_sgr_reset $code]} { set u_codestack [list "\x1b\[m"] @@ -2131,7 +2130,7 @@ tcl::namespace::eval overtype { } 7PMX - 7SOS { #we can have PMs or SOS (start of string) in the underlay - though mostly the PMs should have been processed.. - #attach the PM/SOS (entire ANSI sequence) to the previous grapheme! + #attach the PM/SOS (entire ANSI sequence) to the previous grapheme! #It should not affect the size - but terminal display may get thrown out if terminal doesn't support them. #note that there may in theory already be ANSI stored - we don't assume it was a pure grapheme string @@ -2143,7 +2142,7 @@ tcl::namespace::eval overtype { } lset undercols end $graphemeplus #The grapheme_width_cached function will be called on this later - and doesn't account for ansi. - #we need to manually cache the item with it's proper width + #we need to manually cache the item with it's proper width variable grapheme_widths #stripped and plus version keys pointing to same length dict set grapheme_widths $graphemeplus [grapheme_width_cached [::punk::ansi::ansistrip $graphemeplus]] @@ -2160,11 +2159,11 @@ tcl::namespace::eval overtype { #} elseif {[punk::ansi::codetype::has_sgr_leadingreset $code]} { #} elseif {[punk::ansi::codetype::is_sgr $code]} { #} else { - # #leave SGR stack as is + # #leave SGR stack as is # if {[punk::ansi::codetype::is_gx_open $code]} { # } elseif {[punk::ansi::codetype::is_gx_close $code]} { - # } - #} + # } + #} } #consider also if there are other codes that should be stacked..? } @@ -2207,7 +2206,7 @@ tcl::namespace::eval overtype { lappend understacks $u_codestack lappend understacks_gx $u_gx_stack } else { - #in case overlay onto emptystring as underlay + #in case overlay onto emptystring as underlay lappend understacks [list] lappend understacks_gx [list] } @@ -2244,20 +2243,20 @@ tcl::namespace::eval overtype { #todo - detect plain ascii no-ansi input line (aside from leading ansi reset) #will that allow some optimisations? - + #todo - detect repeated transparent char in overlay #regexp {^(.)\1+$} ;#backtracking regexp - relatively slow. # - try set c [string index $data 0]; regexp [string map [list %c% $c] {^[%c%]+$}] $data - #we should be able to optimize to pass through the underlay?? + #we should be able to optimize to pass through the underlay?? #??? set colcursor $opt_colstart #TODO - make a little virtual column object - #we need to refer to column1 or columnmin? or columnmax without calculating offsets due to to startcolumn + #we need to refer to column1 or columnmin? or columnmax without calculating offsets due to to startcolumn #need to lock-down what start column means from perspective of ANSI codes moving around - the offset perspective is unclear and a mess. - #set re_diacritics {[\u0300-\u036f]+|[\u1ab0-\u1aff]+|[\u1dc0-\u1dff]+|[\u20d0-\u20ff]+|[\ufe20-\ufe2f]+} + #set re_diacritics {[\u0300-\u036f]+|[\u1ab0-\u1aff]+|[\u1dc0-\u1dff]+|[\u20d0-\u20ff]+|[\ufe20-\ufe2f]+} #as at 2024-02 punk::char::grapheme_split uses these - not aware of more complex graphemes set overstacks [list] @@ -2266,8 +2265,8 @@ tcl::namespace::eval overtype { set o_codestack [list]; #SGR codestack (not other codes such as movement,insert key etc) set o_gxstack [list] set pt_overchars "" - set i_o 0 - set overlay_grapheme_control_list [list] ;#tag each with g, sgr or other. 'other' are things like cursor-movement or insert-mode or codes we don't recognise/use + set i_o 0 + set overlay_grapheme_control_list [list] ;#tag each with g, sgr or other. 'other' are things like cursor-movement or insert-mode or codes we don't recognise/use #experiment set overlay_grapheme_control_stacks [list] foreach {pt code} $overmap { @@ -2284,32 +2283,32 @@ tcl::namespace::eval overtype { if {$optimise_ptruns && [tcl::string::length $pt] >= $optimise_ptruns} { set p1 [tcl::string::index $pt 0] set re [tcl::string::cat {^[} \\U[format %x [scan $p1 %c]] {]+$}] - set is_ptrun [regexp $re $pt] + set is_ptrun [regexp $re $pt] #leading only? we would have to check for graphemes at the trailing boundary? #set re [tcl::string::cat {^[} \\U[format %x [scan $p1 %c]] {]+}] - #set is_ptrun [regexp -indices $re $pt runrange] + #set is_ptrun [regexp -indices $re $pt runrange] #if {$is_ptrun && 1} { #} } if {$is_ptrun} { - #review - in theory a run over a certain length won't be part of some grapheme combo (graphemes can be long e.g 44?, but not as runs(?)) + #review - in theory a run over a certain length won't be part of some grapheme combo (graphemes can be long e.g 44?, but not as runs(?)) #could be edge cases for runs at line end? (should be ok as we include trailing \n in our data) set len [string length $pt] set g_element [list g $p1] #lappend overstacks {*}[lrepeat $len $o_codestack] #lappend overstacks_gx {*}[lrepeat $len $o_gxstack] - #incr i_o $len + #incr i_o $len #lappend overlay_grapheme_control_list {*}[lrepeat $len [list g $p1]] #lappend overlay_grapheme_control_stacks {*}[lrepeat $len $o_codestack] set pi 0 - incr i_o $len + incr i_o $len while {$pi < $len} { lappend overstacks $o_codestack lappend overstacks_gx $o_gxstack - lappend overlay_grapheme_control_list $g_element + lappend overlay_grapheme_control_list $g_element lappend overlay_grapheme_control_stacks $o_codestack incr pi } @@ -2317,7 +2316,7 @@ tcl::namespace::eval overtype { foreach grapheme [punk::char::grapheme_split $pt] { lappend overstacks $o_codestack lappend overstacks_gx $o_gxstack - incr i_o + incr i_o lappend overlay_grapheme_control_list [list g $grapheme] lappend overlay_grapheme_control_stacks $o_codestack } @@ -2334,7 +2333,7 @@ tcl::namespace::eval overtype { } else { lappend overstacks $o_codestack lappend overstacks_gx $o_gxstack - incr i_o + incr i_o lappend overlay_grapheme_control_list [list g $grapheme] lappend overlay_grapheme_control_stacks $o_codestack } @@ -2345,7 +2344,7 @@ tcl::namespace::eval overtype { } } - #only stack SGR (graphics rendition) codes - not title sets, cursor moves etc + #only stack SGR (graphics rendition) codes - not title sets, cursor moves etc #order of if-else based on assumptions: # that pure resets are fairly common - more so than leading resets with other info # that non-sgr codes are not that common, so ok to check for resets before verifying it is actually SGR at all. @@ -2358,7 +2357,7 @@ tcl::namespace::eval overtype { } #else crm_mode could be set either way from options if {$crm_mode && $code ne "\x1b\[00001E"} { - #treat the code as type 'g' like above - only allow through codes to reset mode REVIEW for now just \x1b\[3l ? + #treat the code as type 'g' like above - only allow through codes to reset mode REVIEW for now just \x1b\[3l ? #we need to somehow convert further \n in the graphical rep to an instruction for newline that will bypass further crm_mode processing or we would loop. set code_as_pt [ansistring VIEW -nul 1 -lf 1 -vt 1 -ff 1 $code] #split using standard split for first foreach loop - grapheme based split when processing 2nd foreach loop @@ -2366,7 +2365,7 @@ tcl::namespace::eval overtype { set codeparts [list] ;#list of 2-el lists each element {crmcontrol } or {g } foreach c $chars { if {$c eq "\n"} { - #use CNL (cursor next line) \x1b\[00001E ;#leading zeroes ok for this processor - used as debugging aid to distinguish + #use CNL (cursor next line) \x1b\[00001E ;#leading zeroes ok for this processor - used as debugging aid to distinguish lappend codeparts [list crmcontrol "\x1b\[00001E"] } else { if {[llength $codeparts] > 0 && [lindex $codeparts end 0] eq "g"} { @@ -2383,11 +2382,11 @@ tcl::namespace::eval overtype { lassign $record rtype rval switch -exact -- $rtype { g { - append pt_overchars $rval + append pt_overchars $rval foreach grapheme [punk::char::grapheme_split $rval] { lappend overstacks $o_codestack lappend overstacks_gx $o_gxstack - incr i_o + incr i_o lappend overlay_grapheme_control_list [list g $grapheme] lappend overlay_grapheme_control_stacks $o_codestack } @@ -2401,7 +2400,7 @@ tcl::namespace::eval overtype { } } else { lappend overlay_grapheme_control_stacks $o_codestack - #there will always be an empty code at end due to foreach on 2 vars with odd-sized list ending with pt (overmap coming from perlish split) + #there will always be an empty code at end due to foreach on 2 vars with odd-sized list ending with pt (overmap coming from perlish split) if {[punk::ansi::codetype::is_sgr_reset $code]} { set o_codestack [list "\x1b\[m"] ;#reset better than empty list - fixes some ansi art issues lappend overlay_grapheme_control_list [list sgr $code] @@ -2423,7 +2422,7 @@ tcl::namespace::eval overtype { } elseif {[regexp {\x1b8|\x1b\[u} $code]} { #experiment #cursor_restore - for the replays - set o_codestack [list $temp_cursor_saved] + set o_codestack [list $temp_cursor_saved] lappend overlay_grapheme_control_list [list other $code] } else { #review @@ -2460,18 +2459,18 @@ tcl::namespace::eval overtype { #potential problem - combinining diacritics directly following control chars like \r \b # -- --- --- - #we need to initialise overflow_idx before any potential row-movements - as they need to perform a loop break and force in_excess to 1 + #we need to initialise overflow_idx before any potential row-movements - as they need to perform a loop break and force in_excess to 1 if {$opt_expand_right} { #expand_right true means we can have lines as long as we want, but either way there can be excess data that needs to be thrown back to the calling loop. #we currently only support horizontal expansion to the right (review regarding RTL text!) set overflow_idx -1 } else { - #expand_right zero - we can't grow beyond our column width - so we get ellipsis or truncation + #expand_right zero - we can't grow beyond our column width - so we get ellipsis or truncation if {$opt_width ne "\uFFEF"} { set overflow_idx [expr {$opt_width}] } else { - #review - this is also the cursor position when adding a char at end of line? - set overflow_idx [expr {[llength $undercols]}] ;#index at which we would be *in* overflow a row move may still override it + #review - this is also the cursor position when adding a char at end of line? + set overflow_idx [expr {[llength $undercols]}] ;#index at which we would be *in* overflow a row move may still override it } } # -- --- --- @@ -2483,21 +2482,21 @@ tcl::namespace::eval overtype { set insert_lines_above 0 ;#return key set insert_lines_below 0 - set instruction "" + set instruction "" - # -- --- --- + # -- --- --- #cursor_save_dec, cursor_restore_dec etc set cursor_restore_required 0 - set cursor_saved_attributes "" + set cursor_saved_attributes "" set cursor_saved_position "" - # -- --- --- + # -- --- --- #set idx 0 ;# line index (cursor - 1) #set idx [expr {$opt_colstart + $opt_colcursor} -1] #idx is the per column output index set idx [expr {$opt_colcursor -1}] ;#don't use opt_colstart here - we have padded and won't start emitting until idx reaches opt_colstart-1 - #cursor_column is usually one above idx - but we have opt_colstart which is like a margin - todo: remove cursor_column from the following loop and calculate it's offset when breaking or at end. + #cursor_column is usually one above idx - but we have opt_colstart which is like a margin - todo: remove cursor_column from the following loop and calculate it's offset when breaking or at end. #(for now we are incrementing/decrementing both in sync - which is a bit silly) set cursor_column $opt_colcursor @@ -2507,9 +2506,9 @@ tcl::namespace::eval overtype { #movements only occur within the overlay range. #an underlay is however not necessary.. e.g - #renderline -expand_right 1 "" data + #renderline -expand_right 1 "" data - #set re_mode {\x1b\[\?([0-9]*)(h|l)} ;#e.g DECAWM + #set re_mode {\x1b\[\?([0-9]*)(h|l)} ;#e.g DECAWM #set re_col_move {\x1b\[([0-9]*)(C|D|G)$} #set re_row_move {\x1b\[([0-9]*)(A|B)$} #set re_both_move {\x1b\[([0-9]*)(?:;){0,1}([0-9]*)H$} ;# or "f" ? @@ -2525,19 +2524,19 @@ tcl::namespace::eval overtype { #puts "-->overflow_idx: $overflow_idx" for {set gci 0} {$gci < [llength $overlay_grapheme_control_list]} {incr gci} { set gc [lindex $overlay_grapheme_control_list $gci] - lassign $gc type item - + lassign $gc type item + #emit plaintext chars first using existing SGR codes from under/over stack as appropriate #then check if the following code is a cursor movement within the line and adjust index if so #foreach ch $overlay_graphemes {} switch -- $type { - g { - set ch $item - #crm_mode affects both graphic and control + g { + set ch $item + #crm_mode affects both graphic and control if {0 && $crm_mode} { set chars [ansistring VIEW -nul 1 -lf 2 -vt 2 -ff 2 $ch] set chars [string map [list \n "\x1b\[00001E"] $chars] - if {[llength [split $chars ""]] > 1} { + if {[llength [split $chars ""]] > 1} { priv::render_unapplied $overlay_grapheme_control_list $gci #prefix the unapplied controls with the string version of this control set unapplied_list [linsert $unapplied_list 0 {*}[split $chars ""]] @@ -2548,19 +2547,19 @@ tcl::namespace::eval overtype { set ch $chars } } - incr idx_over; #idx_over (until unapplied reached anyway) is per *grapheme* in the overlay - not per col. + incr idx_over; #idx_over (until unapplied reached anyway) is per *grapheme* in the overlay - not per col. if {($idx < ($opt_colstart -1))} { incr idx [grapheme_width_cached $ch] continue } - #set within_undercols [expr {$idx <= [llength $undercols]-1}] ;#within our active data width + #set within_undercols [expr {$idx <= [llength $undercols]-1}] ;#within our active data width set within_undercols [expr {$idx <= $renderwidth-1}] #https://www.enigma.com/resources/blog/the-secret-world-of-newline-characters #\x85 NEL in the c1 control set is treated by some terminal emulators (e.g Hyper) as a newline, #on some it's invisble but doesn't change the line, on some it's a visible glyph of width 1. #This is hard to process in any standard manner - but I think the Hyper behaviour of doing what it was intended is perhaps most reasonable - #We will map it to the same behaviour as lf here for now... but we need also to consider the equivalent ANSI sequence: \x1bE + #We will map it to the same behaviour as lf here for now... but we need also to consider the equivalent ANSI sequence: \x1bE set chtest [tcl::string::map [list \n \x85 \b \r \v \x7f ] $ch] #puts --->chtest:$chtest @@ -2572,13 +2571,13 @@ tcl::namespace::eval overtype { #puts "---a at col 1" #linefeed at column 1 #leave the overflow_idx ;#? review - set instruction lf_start ;#specific instruction for newline at column 1 + set instruction lf_start ;#specific instruction for newline at column 1 priv::render_unapplied $overlay_grapheme_control_list $gci break } elseif {$overflow_idx != -1 && $idx == $overflow_idx} { #linefeed after final column - #puts "---c at overflow_idx=$overflow_idx" - incr cursor_row + #puts "---c at overflow_idx=$overflow_idx" + incr cursor_row set overflow_idx $idx ;#override overflow_idx even if it was set to -1 due to expand_right = 1 set instruction lf_overflow ;#only special treatment is to give it it's own instruction in case caller needs to handle differently priv::render_unapplied $overlay_grapheme_control_list $gci @@ -2587,7 +2586,7 @@ tcl::namespace::eval overtype { #linefeed occurred in middle or at end of text #puts "---mid-or-end-text-linefeed idx:$idx overflow_idx:$overflow_idx" if {$insert_mode == 0} { - incr cursor_row + incr cursor_row if {$idx == -1 || $overflow_idx > $idx} { #don't set overflow_idx higher if it's already set lower and we're adding graphemes to overflow set overflow_idx $idx ;#override overflow_idx even if it was set to -1 due to expand_right = 1 @@ -2596,10 +2595,10 @@ tcl::namespace::eval overtype { priv::render_unapplied $overlay_grapheme_control_list $gci break } else { - incr cursor_row + incr cursor_row #don't adjust the overflow_idx priv::render_unapplied $overlay_grapheme_control_list $gci - set instruction lf_mid + set instruction lf_mid break ;# could have overdata following the \n - don't keep processing } } @@ -2608,15 +2607,15 @@ tcl::namespace::eval overtype { "" { #will we want/need to use raw for keypresses in terminal? (terminal with LNM in standard reset mode means enter= this is the usual config for terminals) #So far we are assuming the caller has translated to and handle above.. REVIEW. - + #consider also the old space-carriagereturn softwrap convention used in some terminals. - #In the context of rendering to a block of text - this works similarly in that the space gets eaten so programs emitting space-cr at the terminal width col will pretty much get what they expect. + #In the context of rendering to a block of text - this works similarly in that the space gets eaten so programs emitting space-cr at the terminal width col will pretty much get what they expect. set idx [expr {$opt_colstart -1}] set cursor_column $opt_colstart ;#? } "" { - #literal backspace char - not necessarily from keyboard - #review - backspace effect on double-width chars - we are taking a column-editing perspective in overtype + #literal backspace char - not necessarily from keyboard + #review - backspace effect on double-width chars - we are taking a column-editing perspective in overtype #(important for -transparent option - hence replacement chars for half-exposed etc) #review - overstrike support as per nroff/less (generally considered an old technology replaced by unicode mechanisms and/or ansi SGR) if {$idx > ($opt_colstart -1)} { @@ -2633,19 +2632,19 @@ tcl::namespace::eval overtype { } } "" { - #literal del character - some terminals send just this for what is generally expected to be a destructive backspace + #literal del character - some terminals send just this for what is generally expected to be a destructive backspace #We instead treat this as a pure delete at current cursor position - it is up to the repl or terminal to remap backspace key to a sequence that has the desired effect. priv::render_delchar $idx } "" { - #end processing this overline. rest of line is remainder. cursor for column as is. + #end processing this overline. rest of line is remainder. cursor for column as is. #REVIEW - this theoretically depends on terminal's vertical tabulation setting (name?) #e.g it could be configured to jump down 6 rows. #On the other hand I've seen indications that some modern terminal emulators treat it pretty much as a linefeed. #todo? incr cursor_row set overflow_idx $idx - #idx_over has already been incremented as this is both a movement-control and in some sense a grapheme + #idx_over has already been incremented as this is both a movement-control and in some sense a grapheme priv::render_unapplied $overlay_grapheme_control_list $gci set instruction vt break @@ -2667,12 +2666,12 @@ tcl::namespace::eval overtype { #change the overflow_idx set overflow_idx $idx incr idx - incr idx_over -1 ;#set overlay grapheme index back one so that sgr stack from previous overlay grapheme used + incr idx_over -1 ;#set overlay grapheme index back one so that sgr stack from previous overlay grapheme used priv::render_unapplied $overlay_grapheme_control_list [expr {$gci-1}] ;#note $gci-1 instead of just gci #throw back to caller's loop - add instruction to caller as this is not the usual case #caller may for example choose to render a single replacement char to this line and omit the grapheme, or wrap it to the next line set instruction overflow_splitchar - break + break } elseif {$owidth > 2} { #? tab? #TODO! @@ -2682,7 +2681,7 @@ tcl::namespace::eval overtype { } elseif {$idx >= $overflow_idx} { #REVIEW set next_gc [lindex $overlay_grapheme_control_list $gci+1] ;#next grapheme or control - lassign $next_gc next_type next_item + lassign $next_gc next_type next_item if {$autowrap_mode || $next_type ne "g"} { set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci-1]] #set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] @@ -2698,13 +2697,13 @@ tcl::namespace::eval overtype { #without this branch - renderline would be called with overtext reducing only by one grapheme per call #processing a potentially long overtext each time (ie - very slow) set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] - #JMN4 + #JMN4 } } } else { #review. - #overflow_idx = -1 + #overflow_idx = -1 #This corresponds to expand_right being true (at least until overflow_idx is in some cases forced to a value when throwing back to calling loop) } @@ -2723,7 +2722,7 @@ tcl::namespace::eval overtype { #JMN set uwidth [grapheme_width_cached $g] if {[lindex $outcols $idx] eq ""} { - #2nd col of 2-wide char in underlay + #2nd col of 2-wide char in underlay incr idx incr cursor_column } elseif {$uwidth == 0} { @@ -2737,11 +2736,11 @@ tcl::namespace::eval overtype { if {$owidth > 1} { incr idx incr cursor_column - } + } } elseif {$uwidth > 1} { if {[grapheme_width_cached $ch] == 1} { if {!$insert_mode} { - #normal singlewide transparent overlay onto double-wide underlay + #normal singlewide transparent overlay onto double-wide underlay set next_pt_overchar [tcl::string::index $pt_overchars $idx_over+1] ;#lookahead of next plain-text char in overlay if {$next_pt_overchar eq ""} { #special-case trailing transparent - no next_pt_overchar @@ -2752,7 +2751,7 @@ tcl::namespace::eval overtype { incr idx incr cursor_column } else { - #next overlay char is not transparent.. first-half of underlying 2wide char is exposed + #next overlay char is not transparent.. first-half of underlying 2wide char is exposed #priv::render_addchar $idx $opt_exposed1 [tcl::dict::get $overstacks $idx_over] [tcl::dict::get $overstacks_gx $idx_over] $insert_mode priv::render_addchar $idx $opt_exposed1 [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode incr idx @@ -2781,27 +2780,27 @@ tcl::namespace::eval overtype { } else { set uwidth [grapheme_width_cached $idxchar] } - if {$within_undercols} { + if {$within_undercols} { if {$idxchar eq ""} { #2nd col of 2wide char in underlay if {!$insert_mode} { - priv::render_addchar $idx $ch [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] 0 - #JMN - this has to expose if our startposn chopped an underlay - but not if we already overwrote the first half of the widechar underlay grapheme + priv::render_addchar $idx $ch [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] 0 + #JMN - this has to expose if our startposn chopped an underlay - but not if we already overwrote the first half of the widechar underlay grapheme #e.g renderline \uFF21\uFF21--- a\uFF23\uFF23 #vs # renderline -startcolumn 2 \uFF21---- \uFF23 if {[lindex $outcols $idx-1] != ""} { #verified it's an empty following a filled - so it's a legit underlay remnant (REVIEW - when would it not be??) #reset previous to an exposed 1st-half - but leave understacks code as is - priv::render_addchar [expr {$idx-1}] $opt_exposed1 [lindex $understacks $idx-1] [lindex $understacks_gx $idx-1] 0 + priv::render_addchar [expr {$idx-1}] $opt_exposed1 [lindex $understacks $idx-1] [lindex $understacks_gx $idx-1] 0 } incr idx } else { set prevcolinfo [lindex $outcols $idx-1] - #for insert mode - first replace the empty 2ndhalf char with exposed2 before shifting it right + #for insert mode - first replace the empty 2ndhalf char with exposed2 before shifting it right #REVIEW - this leaves a replacement character permanently in our columns.. but it is consistent regarding length (?) #The alternative is to disallow insertion at a column cursor that is at 2nd half of 2wide char - #perhaps by inserting after the char - this may be worthwhile - but may cause other surprises + #perhaps by inserting after the char - this may be worthwhile - but may cause other surprises #It is perhaps best avoided at another level and try to make renderline do exactly as it's told #the advantage of this 2w splitting method is that the inserted character ends up in exactly the column we expect. priv::render_addchar $idx $opt_exposed2 [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] 0 ;#replace not insert @@ -2870,7 +2869,7 @@ tcl::namespace::eval overtype { } else { #2wide over 2wide priv::render_addchar $idx $ch [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode - incr idx 2 + incr idx 2 incr cursor_column 2 } @@ -2902,7 +2901,7 @@ tcl::namespace::eval overtype { #prefix the unapplied controls with the string version of this control set unapplied_list [linsert $unapplied_list 0 {*}[split $chars ""]] set unapplied [join $unapplied_list ""] - + break } } @@ -2919,8 +2918,8 @@ tcl::namespace::eval overtype { set c1 [tcl::string::index $code 0] set c1c2c3 [tcl::string::range $code 0 2] - #set re_ST_open {(?:\033P|\u0090|\033X|\u0098|\033\^|\u009e|\033_|\u009f)} - #tcl 8.7 - faster to use inline list than to store it in a local var outside of loop. + #set re_ST_open {(?:\033P|\u0090|\033X|\u0098|\033\^|\u009e|\033_|\u009f)} + #tcl 8.7 - faster to use inline list than to store it in a local var outside of loop. #(somewhat surprising) set leadernorm [tcl::string::range [tcl::string::map [list\ \x1b\[< 1006\ @@ -2932,9 +2931,9 @@ tcl::namespace::eval overtype { \x1b\] 7OSC\ \x9d 8OSC\ \x1b 7ESC\ - ] $c1c2c3] 0 3] ;#leadernorm is 1st 1,2 or 3 chars mapped to 4char normalised indicator - or is original first chars (1,2 or 3 len) + ] $c1c2c3] 0 3] ;#leadernorm is 1st 1,2 or 3 chars mapped to 4char normalised indicator - or is original first chars (1,2 or 3 len) - #we leave the tail of the code unmapped for now + #we leave the tail of the code unmapped for now switch -- $leadernorm { 1006 { #https://invisible-island.net/xterm/ctlseqs/ctlseqs.html @@ -2956,7 +2955,7 @@ tcl::namespace::eval overtype { } 7MAP { #map to another type of code to share implementation branch - set codenorm $leadernorm[tcl::string::range $code 1 end] + set codenorm $leadernorm[tcl::string::range $code 1 end] } 7ESC { #set codenorm [tcl::string::cat $leadernorm [tcl::string::range $code 1 end]] @@ -2968,7 +2967,7 @@ tcl::namespace::eval overtype { default { puts stderr "Sequence detected as ANSI, but not handled in leadernorm switch. code: [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" #we haven't made a mapping for this - #could in theory be 1,2 or 3 in len + #could in theory be 1,2 or 3 in len #although we shouldn't be getting here if the regexp for ansi codes is kept in sync with our switch branches set codenorm $code } @@ -2984,7 +2983,7 @@ tcl::namespace::eval overtype { #shouldn't really get here or need this branch if ansi splitting was done correctly puts stderr "overtype::renderline ESC Y recognised as vt52 move, but incorrect parameters length ([string length $params] vs expected 2) [ansistring VIEW -lf 1 -vt 1 -nul 1 $code] not implemented codenorm:[ansistring VIEW -lf 1 -vt 1 -nul 1 $codenorm]" } - set line [tcl::string::index $params 5] + set line [tcl::string::index $params 5] set column [tcl::string::index $params 1] set r [expr {[scan $line %c] -31}] set c [expr {[scan $column %c] -31}] @@ -3023,7 +3022,7 @@ tcl::namespace::eval overtype { #Row move - up set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] #todo - lassign [split $param {;}] num modifierkey + lassign [split $param {;}] num modifierkey if {$modifierkey ne ""} { puts stderr "modifierkey:$modifierkey" } @@ -3040,12 +3039,12 @@ tcl::namespace::eval overtype { priv::render_unapplied $overlay_grapheme_control_list $gci set instruction up #retain cursor_column - break + break } B { #CUD - Cursor Down #Row move - down - lassign [split $param {;}] num modifierkey + lassign [split $param {;}] num modifierkey set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] #move down if {$modifierkey ne ""} { @@ -3055,11 +3054,11 @@ tcl::namespace::eval overtype { incr cursor_row $num - incr idx_over ;#idx_over hasn't encountered a grapheme and hasn't advanced yet + incr idx_over ;#idx_over hasn't encountered a grapheme and hasn't advanced yet priv::render_unapplied $overlay_grapheme_control_list $gci set instruction down #retain cursor_column - break + break } C { #CUF - Cursor Forward @@ -3068,13 +3067,13 @@ tcl::namespace::eval overtype { #todo - consider right-to-left cursor mode (e.g Hebrew).. some day. #cursor forward #right-arrow/move forward - lassign [split $param {;}] num modifierkey + lassign [split $param {;}] num modifierkey if {$modifierkey ne ""} { puts stderr "modifierkey:$modifierkey" } if {$num eq ""} {set num 1} - - #todo - retrict to moving 1 position past datalen? restrict to column width? + + #todo - retrict to moving 1 position past datalen? restrict to column width? #should ideally wrap to next line when interactive and not on last row #(some ansi art seems to expect this behaviour) #This presumably depends on the terminal's wrap mode @@ -3107,14 +3106,14 @@ tcl::namespace::eval overtype { #we may have both overflow_right and unapplied data #(can have overflow_right if we were in insert_mode and processed chars prior to this movement) #leave row as is - caller will need to determine how many rows the column-movement has consumed - incr cursor_column $num ;#give our caller the necessary info as columns from start of row + incr cursor_column $num ;#give our caller the necessary info as columns from start of row #incr idx_over - #should be gci following last one applied + #should be gci following last one applied priv::render_unapplied $overlay_grapheme_control_list $gci set instruction wrapmoveforward break } else { - set cursor_column $max + set cursor_column $max set idx [expr {$cursor_column -1}] } } @@ -3129,7 +3128,7 @@ tcl::namespace::eval overtype { #overtype mode set idxstart $idx set idxend [llength $outcols] - set moveend [expr {$idxend - $idxstart}] + set moveend [expr {$idxend - $idxstart}] if {$moveend < 0} {set moveend 0} ;#sanity? #puts "idxstart:$idxstart idxend:$idxend outcols[llength $outcols] undercols:[llength $undercols]" incr idx $moveend @@ -3151,7 +3150,7 @@ tcl::namespace::eval overtype { set gxstackinfo [list] } #pad outcols - set movemore [expr {$num - $moveend}] + set movemore [expr {$num - $moveend}] #assert movemore always at least 1 or we wouldn't be in this branch for {set m 1} {$m <= $movemore} {incr m} { incr idx @@ -3159,7 +3158,7 @@ tcl::namespace::eval overtype { priv::render_addchar $idx " " $stackinfo $gxstackinfo $insert_mode } } else { - #normal - insert + #normal - insert incr idx $num incr cursor_column $num if {$idx > [llength $outcols]} { @@ -3169,13 +3168,13 @@ tcl::namespace::eval overtype { } } } - } + } D { #Col move #puts stdout "<-back" #cursor back #left-arrow/move-back when ltr mode - lassign [split $param {;}] num modifierkey + lassign [split $param {;}] num modifierkey if {$modifierkey ne ""} { puts stderr "modifierkey:$modifierkey" } @@ -3189,7 +3188,7 @@ tcl::namespace::eval overtype { incr cursor_column -$num } else { if {!$autowrap_mode} { - set cursor_column 1 + set cursor_column 1 set idx 0 } else { set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] @@ -3239,7 +3238,7 @@ tcl::namespace::eval overtype { set cursor_row [expr {$cursor_row -$upmove}] if {$cursor_row < 1} { set cursor_row 1 - } + } set idx [expr {$cursor_column - 1}] set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] incr idx_over @@ -3269,9 +3268,8 @@ tcl::namespace::eval overtype { } #adjust to colstart - as column 1 is within overlay #??? REVIEW - set idx [expr {($targetcol -1) + $opt_colstart -1}] - - + set idx [expr {($targetcol -1) + $opt_colstart -1}] + set cursor_column $targetcol #puts stderr "renderline absolute col move ESC G (TEST)" } @@ -3280,7 +3278,7 @@ tcl::namespace::eval overtype { #CSI n;m f - HVP - Horizontal Vertical Position REVIEW - same as CUP with differences (what?) in some terminal modes # - 'counts as effector format function (like CR or LF) rather than an editor function (like CUD or CNL)' - # - REVIEW + # - REVIEW #see Annex A at: https://www.ecma-international.org/wp-content/uploads/ECMA-48_5th_edition_june_1991.pdf #test e.g ansicat face_2.ans @@ -3288,7 +3286,7 @@ tcl::namespace::eval overtype { lassign [split $param {;}] paramrow paramcol #missing defaults to 1 #CSI ;5H = CSI 1;5H -> row 1 col 5 - #CSI 17;H = CSI 17H = CSI 17;1H -> row 17 col 1 + #CSI 17;H = CSI 17H = CSI 17;1H -> row 17 col 1 if {$paramcol eq ""} {set paramcol 1} if {$paramrow eq ""} {set paramrow 1} @@ -3298,7 +3296,7 @@ tcl::namespace::eval overtype { } else { set max [llength $outcols] if {$overflow_idx == -1} { - incr max + incr max } if {$paramcol > $max} { set target_column $max @@ -3331,7 +3329,7 @@ tcl::namespace::eval overtype { } } J { - set modegroup [tcl::string::index $codenorm 4] ;#e.g ? + set modegroup [tcl::string::index $codenorm 4] ;#e.g ? switch -exact -- $modegroup { ? { #CSI ? Pn J - selective erase @@ -3339,7 +3337,7 @@ tcl::namespace::eval overtype { } default { puts stderr "overtype::renderline ED - ERASE IN DISPLAY (TESTING) [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" - if {$param eq ""} {set param 0} + if {$param eq ""} {set param 0} switch -exact -- $param { 0 { #clear from cursor to end of screen @@ -3375,12 +3373,12 @@ tcl::namespace::eval overtype { } K { #see DECECM regarding background colour - set modegroup [tcl::string::index $codenorm 4] ;#e.g ? + set modegroup [tcl::string::index $codenorm 4] ;#e.g ? switch -exact -- $modegroup { ? { puts stderr "overtype::renderline DECSEL - SELECTIVE ERASE IN LINE (UNIMPLEMENTED) [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" set param [string range $param 1 end] ;#chop qmark - if {$param eq ""} {set param 0} + if {$param eq ""} {set param 0} switch -exact -- $param { 0 { #clear from cursor to end of line - depending on DECSCA @@ -3400,7 +3398,7 @@ tcl::namespace::eval overtype { } default { puts stderr "overtype::renderline EL - ERASE IN LINE (TESTING) [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" - if {$param eq ""} {set param 0} + if {$param eq ""} {set param 0} switch -exact -- $param { 0 { #clear from cursor to end of line @@ -3431,7 +3429,7 @@ tcl::namespace::eval overtype { #CSI Pn T - SD Pan Up (empty lines introduced at top) #CSI Pn+T - kitty extension (lines at top come from scrollback buffer) #Pn new lines appear at top of the display, Pn old lines disappear at the bottom of the display - if {$param eq "" || $param eq "0"} {set param 1} + if {$param eq "" || $param eq "0"} {set param 1} if {[string index $param end] eq "+"} { puts stderr "overtype::renderline CSI Pn + T - kitty Pan Up - not implemented [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" } else { @@ -3442,7 +3440,7 @@ tcl::namespace::eval overtype { puts stderr "overtype::renderline X ECH ERASE CHARACTER - $param" #ECH - erase character if {$param eq "" || $param eq "0"} {set param 1}; #param=count of chars to erase - priv::render_erasechar $idx $param + priv::render_erasechar $idx $param #cursor position doesn't change. } q { @@ -3499,14 +3497,14 @@ tcl::namespace::eval overtype { if {$param ne ""} { #DECSLRM - should only be recognised if DECLRMM is set (vertical split screen mode) - lassign [split $param {;} margin_left margin_right + lassign [split $param {;}] margin_left margin_right puts stderr "overtype DECSLRM not yet supported - got [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" if {$margin_left eq ""} { set margin_left 1 } set columns_per_page 80 ;#todo - set to 'page width (DECSCPP set columns per page)' - could be 132 or?? if {$margin_right eq ""} { - set margin_right $columns_per_page + set margin_right $columns_per_page } puts stderr "DECSLRM margin left: $margin_left margin right: $margin_right" if {![string is integer -strict $margin_left] || $margin_left < 0} { @@ -3519,7 +3517,7 @@ tcl::namespace::eval overtype { if {$scrolling_region_size < 2 || $scrolling_region_size > $columns_per_page} { puts stderr "DECSLRM region size '$scrolling_regsion_size' must be between 1 and $columns_per_page" } - #todo + #todo } else { @@ -3535,7 +3533,7 @@ tcl::namespace::eval overtype { #any single shift 2 (SS2) or single shift 3(SSD) functions sent #$re_cursor_save - #cursor save could come after last column + #cursor save could come after last column if {$overflow_idx != -1 && $idx == $overflow_idx} { #bartman2.ans test file - fixes misalignment at bottom of dialog bubble #incr cursor_row @@ -3546,12 +3544,12 @@ tcl::namespace::eval overtype { set cursor_saved_position [list row $cursor_row column $cursor_column] } #there may be overlay stackable codes emitted that aren't in the understacks because they come between the last emmited character and the cursor_save control. - #we need the SGR and gx overlay codes prior to the cursor_save + #we need the SGR and gx overlay codes prior to the cursor_save #a real terminal would not be able to know the state of the underlay.. so we should probably ignore it. #set sgr_stack [lindex $understacks $idx] #set gx_stack [lindex $understacks_gx $idx] ;#not actually a stack - just a boolean state (for now?) - + set sgr_stack [list] set gx_stack [list] @@ -3559,12 +3557,12 @@ tcl::namespace::eval overtype { #The overlay_grapheme_control_list had leading resets from previous lines - so we go back to the beginning not just the first grapheme. foreach gc [lrange $overlay_grapheme_control_list 0 $gci-1] { - lassign $gc type code + lassign $gc type code #types g other sgr gx0 switch -- $type { gx0 { #code is actually a stand-in for the graphics on/off code - not the raw code - #It is either gx0_on or gx0_off + #It is either gx0_on or gx0_off set gx_stack [list $code] } sgr { @@ -3600,7 +3598,7 @@ tcl::namespace::eval overtype { #as there is apparently only one cursor storage element we don't need to throw back to the calling loop for a save. #don't incr index - or the save will cause cursor to move to the right - #carry on + #carry on } } u { @@ -3613,7 +3611,7 @@ tcl::namespace::eval overtype { #we only want to jump and render the unapplied at the new location. #lset overstacks $idx_over [list] - #set replay_codes_overlay "" + #set replay_codes_overlay "" #if {$cursor_saved_attributes ne ""} { # set replay_codes_overlay $cursor_saved_attributes ;#empty - or last save if it happend in this input chunk @@ -3622,8 +3620,8 @@ tcl::namespace::eval overtype { #set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] set replay_codes_overlay "" #} - - #like priv::render_unapplied - but without the overlay's ansi reset or gx stacks from before the restore code + + #like priv::render_unapplied - but without the overlay's ansi reset or gx stacks from before the restore code incr idx_over set unapplied "" @@ -3642,8 +3640,8 @@ tcl::namespace::eval overtype { #incr idx_over } set unapplied [join $unapplied_list ""] - #if the save occured within this line - that's ok - it's in the return value list and caller can prepend for the next loop. - set instruction restore_cursor + #if the save occured within this line - that's ok - it's in the return value list and caller can prepend for the next loop. + set instruction restore_cursor break } "{" { @@ -3662,10 +3660,10 @@ tcl::namespace::eval overtype { } } ~ { - set code_secondlast [tcl::string::index $codenorm end-1] ;#used for e.g CSI x '~ + set code_secondlast [tcl::string::index $codenorm end-1] ;#used for e.g CSI x '~ switch -exact -- $code_secondlast { ' { - #DECDC - editing sequence - Delete Column + #DECDC - editing sequence - Delete Column puts stderr "renderline warning - DECDC - unimplemented" } default { @@ -3677,7 +3675,7 @@ tcl::namespace::eval overtype { #e.g esc \[2~ insert esc \[2;2~ shift-insert #mod - subtract 1, and then use bitmask #shift = 1, (left)Alt = 2, control=4, meta=8 (meta seems to do nothing on many terminals on windows? Intercepted by windows?) - #puts stderr "vt key:$key mod:$mod code:[ansistring VIEW $code]" + #puts stderr "vt key:$key mod:$mod code:[ansistring VIEW $code]" if {$key eq "1"} { #home } elseif {$key eq "2"} { @@ -3744,7 +3742,7 @@ tcl::namespace::eval overtype { #set mode unset mode #we are matching only last char to get to this arm - but are there other sequences ending in h|l we need to handle? - #$re_mode if first after CSI is "?" + #$re_mode if first after CSI is "?" #some docs mention ESC=h|l - not seen on windows terminals.. review #e.g https://www2.math.upenn.edu/~kazdan/210/computer/ansi.html set modegroup [tcl::string::index $codenorm 4] ;#e.g ? = @@ -3774,15 +3772,15 @@ tcl::namespace::eval overtype { } 7 { - #DECAWM autowrap + #DECAWM autowrap if {$code_end eq "h"} { #set (enable) set autowrap_mode 1 if {$opt_width ne "\uFFEF"} { set overflow_idx $opt_width } else { - #review - this is also the cursor position when adding a char at end of line? - set overflow_idx [expr {[llength $undercols]}] ;#index at which we would be *in* overflow a row move may still override it + #review - this is also the cursor position when adding a char at end of line? + set overflow_idx [expr {[llength $undercols]}] ;#index at which we would be *in* overflow a row move may still override it } #review - can idx ever be beyond overflow_idx limit when we change e.g with a width setting and cursor movements? # presume not usually - but sanity check with warning for now. @@ -3832,7 +3830,7 @@ tcl::namespace::eval overtype { puts stderr "CRM MODE $code_end" #CRM - Show control character mode # 'No control functions are executed except LF,FF and VT which are represented in the CRM FONT before a CRLF(new line) is executed' - # + # #use ansistring VIEW -nul 1 -lf 2 -ff 2 -vt 2 #https://vt100.net/docs/vt510-rm/CRM.html #NOTE - vt100 CRM always does auto-wrap at right margin. @@ -3847,8 +3845,8 @@ tcl::namespace::eval overtype { if {$opt_width ne "\uFFEF"} { set overflow_idx $opt_width } else { - #review - this is also the cursor position when adding a char at end of line? - set overflow_idx [expr {[llength $undercols]}] ;#index at which we would be *in* overflow a row move may still override it + #review - this is also the cursor position when adding a char at end of line? + set overflow_idx [expr {[llength $undercols]}] ;#index at which we would be *in* overflow a row move may still override it } } else { set crm_mode 0 @@ -3884,10 +3882,10 @@ tcl::namespace::eval overtype { set page_width -1 ;#flag as unset if {$param eq ""} { set page_width 80 - } elseif {[string is integer -strict $param] && $param >=2 0} { + } elseif {[string is integer -strict $param] && $param >=2} { set page_width [expr {$param}] ;#we should allow leading zeros in the number - but lets normalize using expr } else { - puts stderr "overtype::renderline unacceptable DECSPP value '$param'" + puts stderr "overtype::renderline unacceptable DECSPP value '$param'" } if {$page_width > 2} { @@ -3905,19 +3903,19 @@ tcl::namespace::eval overtype { default { puts stderr "overtype::renderline CSI code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code] not implemented" } - } - } + } + } 7ESC { # #re_other_single {\x1b(D|M|E)$} - #also vt52 Y.. + #also vt52 Y.. #also PM \x1b^...(ST) switch -- [tcl::string::index $codenorm 4] { c { #RIS - reset terminal to initial state - where 'terminal' in this case is the renderspace - not the underlying terminal! puts stderr "renderline reset" priv::render_unapplied $overlay_grapheme_control_list $gci - set instruction reset + set instruction reset break } D { @@ -3925,11 +3923,11 @@ tcl::namespace::eval overtype { #index (IND) #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 + incr cursor_row priv::render_unapplied $overlay_grapheme_control_list $gci set instruction down #retain cursor_column - break + break } E { #\x85 @@ -3937,7 +3935,7 @@ tcl::namespace::eval overtype { #todo - possibly(?) same logic as handling above. i.e return instruction depends on where column_cursor is at the time we get NEL #leave implementation until logic for is set in stone... still under review #It's arguable NEL is a pure cursor movement as opposed to the semantic meaning of crlf or lf in a file. - # + # #Next Line (NEL) "Move the cursor to the left margin on the next line. If the cursor is at the bottom margin, scroll the page up" puts stderr "overtype::renderline ESC E unimplemented" @@ -3963,7 +3961,7 @@ tcl::namespace::eval overtype { priv::render_unapplied $overlay_grapheme_control_list $gci set instruction up ;#need instruction for scroll-down? #retain cursor_column - break + break } N { #\x8e - affects next character only @@ -3976,7 +3974,7 @@ tcl::namespace::eval overtype { P { #\x90 #DCS - shouldn't get here - handled in 7DCS branch - #similarly \] OSC (\x9d) and \\ (\x9c) ST + #similarly \] OSC (\x9d) and \\ (\x9c) ST } V { #\x96 @@ -4008,11 +4006,11 @@ tcl::namespace::eval overtype { } #We don't want to render it - but we need to make it available to the application #see the textblock library in punk, for the exception we make here for single backspace. - #It is unlikely to be encountered as a useful PM - so we hack to pass it through as a fix + #It is unlikely to be encountered as a useful PM - so we hack to pass it through as a fix #for spacing issues on old terminals which miscalculate the single-width 'Symbols for Legacy Computing' if {$pm_content eq "\b"} { #puts stderr "renderline PM sole backspace special handling for \U1FB00 - \U1FBFF" - #esc^\b\007 or esc^\besc\\ + #esc^\b\007 or esc^\besc\\ #HACKY pass-through - targeting terminals that both mis-space legacy symbols *and* don't support PMs #The result is repair of the extra space. If the terminal is a modern one and does support PM - the \b should be hidden anyway. #If the terminal has the space problem AND does support PMs - then this just won't fix it. @@ -4038,9 +4036,9 @@ tcl::namespace::eval overtype { } 7DCS - 8DCS { puts stderr "overtype::renderline DCS - DEVICE CONTROL STRING command UNIMPLEMENTED. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" - #ST (string terminator) \x9c or \x1b\\ + #ST (string terminator) \x9c or \x1b\\ if {[tcl::string::index $codenorm end] eq "\x9c"} { - set code_content [tcl::string::range $codenorm 4 end-1] ;#ST is 8-bit 0x9c + set code_content [tcl::string::range $codenorm 4 end-1] ;#ST is 8-bit 0x9c } else { set code_content [tcl::string::range $codenorm 4 end-2] ;#ST is \x1b\\ } @@ -4070,11 +4068,11 @@ tcl::namespace::eval overtype { 4 { #OSC 4 - set colour palette #can take multiple params - #e.g \x1b\]4\;1\;red\;2\;green\x1b\\ + #e.g \x1b\]4\;1\;red\;2\;green\x1b\\ set params [tcl::string::range $code_content 2 end] ;#strip 4 and first semicolon set cmap [dict create] foreach {cnum spec} [split $params {;}] { - if {$cnum >= 0 and $cnum <= 255} { + if {$cnum >= 0 && $cnum <= 255} { #todo - parse spec from names like 'red' to RGB #todo - accept rgb:ab/cd/ef as well as rgb:/a/b/c (as alias for aa/bb/cc) #also - what about rgb:abcd/defg/hijk and 12-bit abc/def/ghi ? @@ -4087,12 +4085,12 @@ tcl::namespace::eval overtype { puts stderr "overtype::renderline OSC 4 set colour palette unimplemented. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" - + } 10 - 11 - 12 - 13 - 14 - 15 - 16 - 17 { #OSC 10 through 17 - so called 'dynamic colours' #can take multiple params - each successive parameter changes the next colour in the list - #- e.g if code started at 11 - next param is for 12. 17 takes only one param because there are no more + #- e.g if code started at 11 - next param is for 12. 17 takes only one param because there are no more #10 change text foreground colour #11 change text background colour #12 change text cursor colour @@ -4102,7 +4100,7 @@ tcl::namespace::eval overtype { #16 change tektronix background colour #17 change highlight colour set params [tcl::string::range $code_content 2 end] - + puts stderr "overtype::renderline OSC $osc_code set dynamic colours unimplemented. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" @@ -4128,7 +4126,7 @@ tcl::namespace::eval overtype { break } 1337 { - #iterm2 graphics and file transfer + #iterm2 graphics and file transfer puts stderr "overtype::renderline OSC 1337 iterm2 graphics/file_transfer unimplemented. 1st 100 chars of code [ansistring VIEW -lf 1 -vt 1 -nul 1 [string range $code 0 99]]" } 5113 { @@ -4147,7 +4145,7 @@ tcl::namespace::eval overtype { } default { - #don't need to handle sgr or gx0 types + #don't need to handle sgr or gx0 types #we have our sgr gx0 codes already in stacks for each overlay grapheme } } @@ -4180,7 +4178,7 @@ tcl::namespace::eval overtype { #how does caller avoid an infinite loop if they have autowrap on and keep throwing graphemes to the next line? REVIEW set in_overflow 1 } - set trailing_nulls 0 + set trailing_nulls 0 foreach ch [lreverse $outcols] { if {$ch eq "\u0000"} { incr trailing_nulls @@ -4279,7 +4277,7 @@ tcl::namespace::eval overtype { if {$trailing_nulls && $i < $first_tail_null_posn} { append outstring " " ;#map inner nulls to space } else { - append outstring \u0000 + append outstring \u0000 } } } else { @@ -4296,13 +4294,13 @@ tcl::namespace::eval overtype { # # set outstring [tcl::string::trimright $outstring "\u0000"] # #} # set outstring [tcl::string::trimright $outstring "\u0000"] - # set outstring [tcl::string::map {\u0000 " "} $outstring] + # set outstring [tcl::string::map {\u0000 " "} $outstring] #} #REVIEW #set overflow_right [tcl::string::trimright $overflow_right "\u0000"] - #set overflow_right [tcl::string::map {\u0000 " "} $overflow_right] + #set overflow_right [tcl::string::map {\u0000 " "} $overflow_right] set replay_codes "" if {[llength $understacks] > 0} { @@ -4330,12 +4328,12 @@ tcl::namespace::eval overtype { #pdict $understacks if {[punk::ansi::ta::detect_sgr $outstring]} { - append outstring [punk::ansi::a] ;#without this - we would get for example, trailing backgrounds after rightmost column + append outstring [punk::ansi::a] ;#without this - we would get for example, trailing backgrounds after rightmost column #close off any open gx? - #probably should - and overflow_right reopen? + #probably should - and overflow_right reopen? } - + if {$opt_returnextra} { #replay_codes is the codestack at the boundary - used for ellipsis colouring to match elided text - review #replay_codes_underlay is the set of codes in effect at the very end of the original underlay @@ -4383,11 +4381,11 @@ tcl::namespace::eval overtype { set viewop VIEW switch -- $opt_returnextra { 2 { - #codes and character data + #codes and character data set viewop VIEWCODES ;#ansi colorisation of codes - green for SGR, blue/blue reverse for cursor_save/cursor_restore, cyan for movements, orange for others } 3 { - set viewop VIEWSTYLE ;#ansi colorise the characters within the output with preceding codes, stacking codes only within each dict value - may not be same SGR effect as the effect in-situ. + set viewop VIEWSTYLE ;#ansi colorise the characters within the output with preceding codes, stacking codes only within each dict value - may not be same SGR effect as the effect in-situ. } } tcl::dict::set result result [ansistring $viewop -lf 1 -vt 1 [tcl::dict::get $result result]] @@ -4397,7 +4395,7 @@ tcl::namespace::eval overtype { tcl::dict::set result replay_codes [ansistring $viewop -lf 1 -vt 1 [tcl::dict::get $result replay_codes]] tcl::dict::set result replay_codes_underlay [ansistring $viewop -lf 1 -vt 1 [tcl::dict::get $result replay_codes_underlay]] tcl::dict::set result replay_codes_overlay [ansistring $viewop -lf 1 -vt 1 [tcl::dict::get $result replay_codes_overlay]] - tcl::dict::set result cursor_saved_attributes [ansistring $viewop -lf 1 -vt 1 [tcl::dict::get $result cursor_saved_attributes]] + tcl::dict::set result cursor_saved_attributes [ansistring $viewop -lf 1 -vt 1 [tcl::dict::get $result cursor_saved_attributes]] return $result } } else { @@ -4409,7 +4407,7 @@ tcl::namespace::eval overtype { #*** !doctools #[list_end] [comment {--- end definitions namespace overtype ---}] -} +} tcl::namespace::eval overtype::piper { proc overcentre {args} { @@ -4457,7 +4455,7 @@ tcl::namespace::eval overtype::piper { tailcall overtype::renderline {*}$argsflags $under $over } } -interp alias "" piper_renderline "" overtype::piper::renderline +interp alias "" piper_renderline "" overtype::piper::renderline #intended primarily for single grapheme - but will work for multiple #WARNING: query CAN contain ansi or newlines - but if cache was not already set manually,the answer will be incorrect! @@ -4506,7 +4504,7 @@ proc overtype::blocksize {textblock} { set width [tcl::mathfunc::max {*}[lmap v [split $textblock \n] {::punk::char::ansifreestring_width $v}]] } else { set num_le 0 - set width [punk::char::ansifreestring_width $textblock] + set width [punk::char::ansifreestring_width $textblock] } #our concept of block-height is likely to be different to other line-counting mechanisms set height [expr {$num_le + 1}] ;# one line if no le - 2 if there is one trailing le even if no data follows le @@ -4524,7 +4522,7 @@ tcl::namespace::eval overtype::priv { variable cache_is_sgr if {[tcl::dict::exists $cache_is_sgr $code]} { return [tcl::dict::get $cache_is_sgr $code] - } + } set answer [punk::ansi::codetype::is_sgr $code] tcl::dict::set cache_is_sgr $code $answer return $answer @@ -4572,7 +4570,7 @@ tcl::namespace::eval overtype::priv { set unapplied [join $unapplied_list ""] } - #clearer - renders the specific gci forward as unapplied - prefixed with it's merged sgr stack + #clearer - renders the specific gci forward as unapplied - prefixed with it's merged sgr stack proc render_this_unapplied {overlay_grapheme_control_list gci} { upvar idx_over idx_over upvar unapplied unapplied @@ -4671,9 +4669,9 @@ tcl::namespace::eval overtype::priv { if {$existing eq "\0"} { lset o $i $c } else { - lset o $i $existing$c + lset o $i $existing$c } - } + } #is actually addgrapheme? proc render_addchar {i c sgrstack gx0stack {insert_mode 0}} { upvar outcols o @@ -4695,7 +4693,7 @@ tcl::namespace::eval overtype::priv { #note we can't just look for \x1b\[7m or \x1b\[27m # it may be a more complex sequence like \x1b\[0\;\;7\;31m etc - set existing_reverse_state 0 + set existing_reverse_state 0 set codeinfo [punk::ansi::codetype::sgr_merge $sgrstack -info 1] set codestate_reverse [dict get $codeinfo codestate reverse] switch -- $codestate_reverse { @@ -4718,13 +4716,13 @@ tcl::namespace::eval overtype::priv { set sgrstack [list [dict get $codeinfo mergeresult] $rflip] #set sgrstack [punk::ansi::codetype::sgr_merge [list [dict get $codeinfo mergeresult] $rflip]] } - + # -- --- --- - set nxt [llength $o] + set nxt [llength $o] if {!$insert_mode} { if {$i < $nxt} { - #These lists must always be in sync + #These lists must always be in sync lset o $i $c } else { lappend o $c @@ -4759,14 +4757,14 @@ tcl::namespace::eval overtype::priv { # -- --- --- --- --- --- --- --- --- --- --- tcl::namespace::eval overtype { - interp alias {} ::overtype::center {} ::overtype::centre + interp alias {} ::overtype::center {} ::overtype::centre } # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready +## Ready package provide overtype [tcl::namespace::eval overtype { variable version - set version 1.6.6 + set version 1.7.1 }] return 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 6a2a3376..c20e3b51 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 @@ -4950,7 +4950,7 @@ tcl::namespace::eval punk::args { set argd [punk::args::parse $args withid ::myns::myfunc] lassign [dict values $argd] leaders opts values received solos if {[dict exists $received] -configfile} { - puts "have option for existing file [dict get $opts -configfile]" + puts "have option for existing file [dict get $opts -configfile]" } } }]} @@ -6515,7 +6515,7 @@ tcl::namespace::eval punk::args { set range [lindex $ranges $clausecolumn] #todo - small-value double comparisons with error-margin? review lassign $range low high - if {$low$high ne ""} { + if {"$low$high" ne ""} { if {$low eq ""} { #lowside unspecified - check only high if {$e_check > $high} { diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/templates-0.1.3.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/templates-0.1.3.tm new file mode 100644 index 0000000000000000000000000000000000000000..e679d01307bca6d437e4c564d9e02e4bee17a1a0 GIT binary patch literal 70519 zcmce;1z1#F*Eddzl1eut-Ju}e(%sz*-7|Dbhk&9;BMkx)0@5G?5&{y^(%oH3d}mPa zc=W#C=X<~Z^`Gk+2F}@g?bYkI7iSMD=r1oSFKZ`|g|!_RS}EVwRQjjb1fjuAV(LFn+1fA4@L^=2(ou{ zb%280tzblfOHKd<)W56;~WMXD(VhLt(1G_-19UVXxj&?BitRWzP1Bi(|_~#W92#6JGe=W>^ENBUK z0K1sLh`K_o9W40(7Gb3M`0T7r`S|QjY{5nV4@Tdwf><0aEFfSg)YAzJGI24p0@wrz z0QX^95&{W8?XQ3Nn@H9cAa6Z06R4RL$opEE4vsGNCU(|dV33}*gM}jqV&-D)1U2wA z@CAAQZ6-`HU>6rag_J**zt#rS)%5#iR*;5+i7B8-K(XdvKyUWe4qzDnuD~@X6Q~s{ zh~CK&0-E$aKXzf7E*05f=d14LoG|BgeL zeAGYggTT%pN=lHA59qGmwX9$dYX}qq`g#AiBK|*%NeTKJ&oFv_mjZSLuo_G?=GHEt z@2mm8Ilw&R58i$u0-FN%0RKAWJAwbSBaE7(1u((P6$&$pfq}tqNdjCLnK+mm0Z#ja z6&FWG=ru3j2}4b+?fzuzS0Z*MfK4qOKza}-J8S6m$Ug|O82oU6Ya&15;gwVE^7j2z+rLf|`(IBJ z0_pu_@qc0xwj#`6uvA1X`isP{+prgGh$x6!>|Y0nfv5p8za8>>QGYJ%{rlS%jxJym zApSi7&OqLi(`LkKf7& z8~S@eet-3cAN*Elzwr&KUvd@9_aQ(o2eOnS$Q=waGjRaC7*;6&W?dYeT&#fvZRhz5 zvoKBCnVCSqM&A>!5d>^$4|V_&jvg$*IamUj(azERk2w1?UVxbXhv@uH4~S79iNbOy zG3_kW5)SoZk~|8_1W4wgW@`>Pz^ zld-{Hg8M(#00C}l0OF@|g#gtI@B*+4P>NvIHV47T|5kjM3QU1uv;FPeU)}fDD}PfU z_21<9$Jm0I%)-^q?gtzJ>Df2}_(RXk(E+IYpuZEjPS=2M!6+Mm`1oKF!sddm3xJ~q zP`Ix#4G4fNfaK;dB=hr<%Xh5xTiLGN1{O0$z>+`k5!-i#UvuNl==*m@4A_8Cz<97Z z3t$Qunu1lrpM~U?HGDx}JHQbC?6ZGW0F2TP8Gj)JGtqCE{l8-e^%ug|mb=b}W{&pu zK!t^XuA>wN&j18^Evx|uKuDC7|Kz?@CN7q)unYp=Rv3^pvx508;BSr~Qy?t?a0!TZ z*zIdT{1e#n@hMy9ksmX^XU%J3zb9hu=s*XB`4x!nFZhfOK;&Qt5EOugu%!7XM-Tu( zLL32*^pkfG;9PcK69^P!34^}&FeCzenuG03JRu+efxBBfm^->dKu&fhP#^~akQ;!n z4vr2i*EPxn5P{+MoT*#EP&+UYsJyQB0DkfWN)$lkyY|`G00Y2y`;K6NiUV8+BE$r+ zC)C~1#r7KS{)z+t=4{t`0cwLe0DVEWV1Qx0UmfJ1(<&t!+jm!D1Kj(2pizPxtYHBS z{PmsqKRMR58<+z{&Ke2^i7Lzd@T|W$=pRA;L)9R6SONg{2QE-oU_S)g4LLXhrgJjC z)(OjxQu*DWwhoT&z<%U!z6*0vM^`8a>f(8=IOy-S1LN#Ea(--4erp}rAlQrQ7k&MK zQ$c@d=ilNONOrJY9M~Qv4+N;qu(hE-Om6~mcX0%4Z0QPyKtS{+E>LR=V7~_flA;N$ zp27kX*s=hY|BLSeJ_B(DgM@$YR^QnM7Yq`|5XG34TXPJG>}AHTonGX zj{LzbU^5V~l?C9B^}lihGu+*uo6BEW`@;RyOeyua^he~R0)AjjU0h)hYJwb)3NL=L@XvR?+w`v<{;L^brTdqX4b#IP^&9AR{Eu$- zHx+y*2>NN=YjeP|{r__DABG1kcWt!qH3cYrdVl%T;NO+^w`Ak$@SUUI@bj+`@}qz9 zXQRXdC{WjK@)PO6`a%H4f+_D>>9B$Y{0{4(Q2zzf{4=k=H>L0Ivj7#4i@vM+Z*U6) zaWw_@B*0eO5eR(~J9k()g_S}W*Z{Z#T5Eswn}9tMuFbqhje>TVf z^aJzW?^6LQ0z%pUR!^=@c3_~@2I2s4IDl<{s^aPbz>NQ;)qgFX{|XzaEKKa|OaZ(L zi!fL<03z@wsQN9pRElD(AT0oIT*DYM0O$kd6sDVNSYQvdYG4-tMM6Lyf$K>;uL9&a${VB!Yk;_H6l_g3wHH2!{Ork|fb`ULg> z8$c9O%2)tU>wAm$JITLxc1>IW_xyuA%MZ0*#}Ldc@yVOt+Npe?}q&%p=d_CGjP2k2Zkj)Cqn2tZ2!tbmywSnWr^09!8@ zhybXY{Ok|IVE3PG<-aDSO?CnV1p@L%n;8ITKUw{E2EQjEYCx60^=g<5{~9N- z0kGHgKGPhe_cKO*ZXteh0s7Tp|8YSWz5l}F|G%j;u*LplTH{A9r?vnx@qdQczcLJ? z^Z!Fehb{B_tp3k;en0*n((5l$|95KsMK^z6)Ytb%hvh#z(?9;hVDKM_5BC3^KVk&% zX&?dr+4LkpXXRkM z&-NdG1I0C0Ytm)%!EN7BExXq}JOokQORsG56;qDyVkNCr`hD~exLq4(90VsGkf#xQ z)o2MH7e~rhr53|ReRFeZa~v(7)0;Q@3CWpo(jZ-~y>XFU-{HVlWp2;@KGx2%Itx^i zJc@<*sV`s5xpM@pmAdgid*m$?e&$v$WD=s)dRBT+D_~A3%wtn1hMcFdCHu9uPWS4b z-h&C;QGM^#&i4w5@+Pe>`;kp*D+~$r#oxTORXv=XX^#4=MDeLJ?6t`~KFg>yrs5LY zP&*2z;$roFIeX}sYEdh#uI~*T9(TVD!~~*BA17q@tfFKs{ZaikgEV!e+BcQvrrD!j z)^Wu4kfHFZnrBmzY)Y$}s8^IXvtHS3;%P88tJ>xzGp)Ef9cevmV6m-k zZB*}2((cR*(P6#|7@e3u8!Ze>lQqS`W5pNoD-UptzeBp}dQ9t02OqEY=EjCx99qlj zs5jgKvd0PTg-O&c@=vqMElk6SaEV`B(Zk{Hrjti4+x2^*w=u>Cyc8IiWEe0y&mG`O zunX!yu-p*DU0^cl+ke@0F}x@YRif35-`pctsn@h1P5LAmL_1nIBAcaKm&MUASaVUl z)&2C7twG4a0bSiL;czt$yq9t`F5#4W4O)!BVLwF^0}pqaaG9ndk%k63`F3MwE9fXn zcHdO{c}Ll6FHS3lTc^B%s;j#C*_QkneQU(BA_#YUFFl5Ypz=46`CEAKT&lO)GeR4p zu+K*t)l3)BOG~+`(>Ti-g$^zHH@h75%~av#3DchFdRZn1)Hl3p@9)dkraljiUL){A z7l`Om5?5VkdSDO@@+vrf*W5TZl_sn(huD2g_BFJSm6PQeI9Nob=q>im=NUJwA0NFR zH&d~fA7%2f!ABjSH;`V!jpvSgSEIjQ+{$669uD6p9t3hUd$ce1#jnGfV2~n?XdpCR z#g`;nxEvP?RY zMwIlLH?G=N?Y+K|+_eEev&T6MJi|1e+gPUrT`?G>yNddaT1379f!fMzo=ox7ElgI< z3}o_;$$W-dDs&_`%g~V}v2*?PD78tF;F;fu*3p8*9kzXhsO7O*q88l)$*pPh*rrt3 zg9!bVG2-^L8|-{~4!iG;7}(hem5oRph9EwQ!r_oTK8u7j24;reb#si}5HfFHyXtxE zNqNvr?KlBBG>Ry`7<^5#XK%c$?T?L}JIfk9(S|_kSv5LlcHqd(7pqcgR#S|4-_8Vt z&mnR$-`Gr8uxe@d87tU4{< zeumj#!c*HgwUoZQZfdVAXfz#d!Yg5Y!kHTV@`0K4<)-qYmJ4%sivY<0zbD~U-}c;- zWfTO~_Y^p_480boNv^&StIl|GPy4iZFNjFBN&0$NXJ-8C)CifF9X;GN&%yzS^$Yr^ zU3dKX9+7#Ey8HAMnDYA+9ah<#M=kO z*bm^P0=)mnV!#Hp2Z3Ickqg)Y!Upv6ZGerA2(WK4cXVNLa&@p}`f=^Lhya5S;r?9E zJBm}gh$KGnIj~S0@D_$c`L7rJV=*>}iy0g2(FAi=pp$TQg$M@+kDw9#5%oR$ZHbe! zNLxL6dYL0Eqy*L}w*di35@NL;MCSQsl0p)0ND{=N<|t2X#NFAP>+}Vcb+v`ju_k!q zF?~Tuf_vcOn}?kbo;=cJSCNhBo|EyS7waU?lTQ1BfEkaI6LsIE@-npLNxGAvKPZ?m zfcJdhqjaB%t6(;rb@=uqyr0DIX3;&vFawB>)+Sv~@i@w#a*L+==_+{+&hr7~Hm4pA zP6+PC|59$)Lk!==28;&386;EGG`uNOkvOq5*gQNuaD5~w;wr4qj0w?4=c;f` z>e^>Y7v2QCq$=;rVtg7BuBNgm_tolIupC1-Q*EA6YgXqAXYFq3hbBak8t7Y}BEjU2 zvg;@;?X*2$-AIiW5AP9-qdrmy%1kvhjoOn)jkz_Z9nGz&03V@>JEt4@aJm!e29DWk zVRQNo(Ytcac=%c}sj?h|k#{ez1}-rJ6_6_k*Y2E-J_-;{VQgeAF^{`RNvcHHWOI1R zg`xVcc?>kLsE`;wj$W^tUk`V8D%g|MkeWD@a*&QXN4mm?jCOA(=c`~O1c^?leT`9# zZ26!TE$prn|GGw~Go|E%Q_0xgqb14&|JU>SB_^4udkhg#E|<}hrep*XsfO!pX*+Su zkB!lGwODsKN=jtLOv;FrE&q9aY1Y@|<-q2-QC6bUWUsIw4=J83^6*49 zS28)s4@rDsYoS0%h_D8)%@{CU&9NC##=JzFr)yE>y@>ijDXA4t^}fjJ;T-By*|<%7 zXQnrdVUoi)64P3@6Z%Za}r7ts7F&Yao2mU?zK3M5vtz!?f*dE$MSTU{>0 z*$6CP5LE$(P~+=#3(o?s^8@}{Jye5_OtXm_PH6Ibl96Z;L+0c?lTdw-e;8R~dhcq( zJ7p6Mizo$c!-xV(>3fY42h0+h#)^8P#c%0b8<5tclu{RS}(0R$w z^yPh}@qNcX%jj5R?-F1P5J zOIzh$wIlW(JJv8BQhdeJ=GxsmfJmS&ehzq0{h0gR{*#aXHR(}~p*JR2I_H_m5K(Ta z&67G=h%WY@R>sIs4#`m~nYlHDew`H0i}YCM9kE2YLa)Gmh!Oj^SSD4I0c~C_lN~R| zH<7$wGxQySsCnz1w<$d=HD1_McA@oeC3+3Axh_QwN%G^NO=DF7ei}-KR8EM=hNWQHTCOyw{yeQbi#8GxX?#IP!Y$^_EK zWfR54rM7yH;2x#=j20y9gvQdU&SoS(;X*B39bn6;F5Z@9Mth{RtQ@BDnU4p)8e_e8 zz07HGQ};1ng=+v`FXux;hLBQKdQqqM=?kLqt9VS$gKNJ~*QsRc-aYH;gu^?t9UOz> zdZKp@G0gS&{Gw*KTmzTD$?9#52uTv%Bm;)(l_kB%`cOF*PH+<#bqFB``;w@>l59vc zhNXUmk~xEjId4RO^hS4(56BrEAJb0hNpb>Z97+E@QRa>U2agv|^0-r8FMR5&PBy-D zoN5wjkUu>9u)|-^R=T)fSI_NBR&c=)+zziGXDf!F!#5eq6(*HN8##~dE~tE4Yixj7 ztx7zcqvD}X!1gwtRH!)ovmTms8XgY?PxJds7U~6WW0}W#)z-*AH=PR75YU(qPlb`NAJVq;rDQUwtxtR}E*;pcgB^UNoV8d0Aux@vCb3 z)#5I47+0x?;@s1&kOu^rL&Ysg&zyp!9&+vt7)bB#c8{&=7-_ZZV7Py|vo(vw9+um0 zPvCT;GqC~f;N$xdah+ZV;@*-ph3Mf^Ez{j{xcQzN^P}pVO)Z~@DQ?*Z4BfUHpo~vd zI$QXVZ~1BOS+jZ#!A5MOxcr!`D81TyTP)%UZ9kz}ziIfghXKx_VSEvf@Pfu&QkI^s z@!z$8yXS_tvLR+y(Y^Yxt+aIAgtd?-g0JH#Y z+NcLsTgD%v-4_MVq9bYEKv~{wK1Crts;^)b;UH=6#pY8I<1DvW)x;My z1Xh($EqbG-d-zd&*V@aB?}4Z@vMT&QmSRomZIX|URy(v~#sqO%6Nr62i#7{nq#bjX zTu;=Ty%?v{{XIgi($mw4GZa3D%(1UVBVlA9p@Z9&Yjj(v>uKBy6vDxpG@G~Up2%{f z9-*_}emNGrX_}0veZ!9Xq?Jbl((msbY8w3k6j>OJ4S%O-f?bH8PT8n%kcM2(n`Dz> zd~(;fs_h_pVotNcB($WwhQRu{vXx5clA!ITDHJ&?3m=}Iu(P0-&2e>sp6VpmgSck- zV}Zkt2PgEKWr?FG+WZIF%JcLR#e-XQp=X0cC{AfnJ56{>DeKYvB^SNOkG-Z;-96q< zwALEO=D1ATJQTNF)a7S)8%(YY?s`QS(swpMSqJZj`;~@|!Rao8(*qOz>OB*jlKho) zFM?;ar|Wuq@`ta9-05sH$Mpo#s-0W~2Mm?=I-V0-XZ1Yf_7EULq_E*EdiwPpcXxhX z`h9{b$1?_-hs6sciMGv9?gtrSwUbX{Z+Pvdy$*k3vcbH>g}P;F-=TX!V`_@-_2iLh zhOx~oB6N_vkV?-|>lUh|{idTb1!-WqY6eZZ0nUB2Xpt^axF|Y_w=Y(An$-O)mqtQf zto9>6qo&;;Peb*55l-M}v@Z%LDdVFeu2%C-=hcgMmWvTC&Oss~WVLY4QhaG4o!TcX zCGRozbdfmlISOv8BGh&|>c0-jt`5?Ec=5j^ZbI?oD{tq!*{2amFKuv4 zABaOdGWT4}q^sB#(~T3#2252Y>fowlp5Cco6i~^{IeJ7YmJ}69xsE|kv2XXRBNwX0 zZ60=l%*V&eek(C1ZJRd>>3WFh3hS@sT8kAnc*2y8EfVHFpx9G-7Yv)>E#Id8;U)sgb<* zulvre7Z+^yOHKP#1ydeBBkV^y#dwqI>yJWapf@LJC*-l{yg3x?Z-L2jqpEI_&pI-q zwgbJ(46zK0O!dOz*0O*rDbGtpEIU#Qn@aYE0UVo>ZzcR+ODgaw%HC%A>vlekeTj28 zasRHBbMv^9RI==ez5sou_&vE?OpNLQk{nBu12xjTvZnE~WBG-|x%65cFZYC`vag6N zbJ;O@0uuRaUqvSyGxHD0tzB-6u8b|b-#mFtYk%~3oG|yMa(KG@6GA&T>^F-XF(O%Z ziM1w`T(R?xdlqzf3yxo(E7N8wXGGo?z{LxrN?bnQy5eSvS7V_Tta?Dc3QsSgtjPKZCg ztM2toPz56PrjHm$&^gGH<#??)%0;)j$?kNiaYm1XMsaTQ{bD?qM9Y(Ld0*Y-cWOwC zDjv{$r{rUn_0Mog-csaMp~(994V!4w{C&5*KWwC?1yW=cS=@D0p8K{)L^A&3>sJS{ z7v?J6(OJC?ew@yNbAf$n2Lr478YU81R`mtFZ9Nu@ZAAi~T*g>$`a1RGplprQkI+pZ zyCei*MAIUuxsM9iyQfhVStY%Vm~FP@P^IWw_O4@zTo0sD{xJ0Bj(bHC&t!y>E8m<^ z5&I*Y$JTMEhYck6HgVh1OrdUKkrh>kP$^b&vX9$0F@{FvE8vk1Gl@gCX(siJY#?<^ zyzkRdS0uC_&gn}@#B^DstjjzyJl5-;&7i1Cey+KJMqPl(fYzfz({#)1*-ISo<B1rCBfTe@yNo>7>fMzS%? zGYBfNE=Ilqf^S!(m(6{jMl^VbY%bUVHJa;uM8V~O1#};+^$B|Bwh+OLA5;2~ecS_4 zDPMYTO^3>DyG9%-hnr(|4J4a(+#5L)AIERyG%)Ll*dZ5osUEjb8%$Cmv+MZuOHKNs zB1Sl18B5|zc%;7H_PRK}2qSQuHa6p`@)kqOmL~IeC@#1Foj>JiK6W7JYa787G!Ix^ zg=^0w(8_IKE`5K9jq~v|%t~m7qNgkBAR2BqUQ(S|`YQcXyFb~q<;>}~7-IXbBQ9_= zU)QOZHHWD38K%ZG2UxFSG}6UOC(Ud!)4f;_Ns>iDvhj8(*$a0^Itv?rzoX-&GyYuL z-X24oXFEOWD2>L)g$pciSSxxp<>|$gW2>)vNHa{x6*bUxe6Qw@Qnc7kqF1=ZVkoxG zJ1(D+yFbDbOLcpPFOO zxABfM&U@akM7|#K6ix(@ZoS^uuh{!qC~#0trYS@`{ptSFBWSRHcY@>aT+X_axG#|~ z?);Gx+w(?kZ(rr;yRk-ZZec*Wz>zoS%H_ZqR z{L`sp2B<}~V%xWk#QRNN=e#&g#`^jL_T(Zwi&${Hb@e$%$Ze%O>}l=VLBt4HZ#SsC z6IvgshTCqw$k=+#sOW--P$Y4?R$tRN;!9`6l3UW)t#;%jO4+V_X2XVA^T-O$?qYN8 zrrZ*?itodZx=Q$no!3JD-#Pt1e zNR)>R{it(o{8mIm3U;@aacA&WDCVR)1amSrWPAx$a~`|584J{qn@i@P_9vr36Cd26$A zw2Sa@ZYi>OW4W@l-x_!7-x$A(^5}KMYSh*MN97TVwp zpwt5|dGX4RRfZ+s6pYxii(k=J1?Xs35Dg1|!Xn`2uTOuNkTRYAh*2Y>anLe+dYtdl zXQa-JslXi70JWrabiD|*b9~+fJ$f~3#KN{DmC+-)LZKb&UVBl$_8Qt*ifP%6Q_WG) zf{$%$qNd8ual@Pi3Z@V39))$*j(mEM=(;y2FRHyt()O{CzTzmUDXn#iSOYhe6>ZtL zFWg;_15wG*u|MOHc0NjP7zV*!g#4qFcXT&5iUt)xLbcrH_#wGOwCgYA5B#d?ymQ}T zYky)ts~JkQQTaee<-;lYSTDaw4IRWFZal4Tnq7{U>_6S;wYQ(IHRQVJIJodMmj$dE z9E-6JMT#O9d2&BLK$ES5dx5O$^eCddERm>BNw>R`22Cc&%dG<~#4l!=w2%Db{Ora2 zLwTo)SrxtA7^0-!gV_1m>3(O5C}Bp)zNq$f32m>F;dgqS?a`r=E0+a?r?;&S!~F9Z z6{Niu5j|eTh*QbVs;)IR$aXB2bli~vJ#N*AaKA;Robgr-8`1w1tKoHxt_nEdmGQTn zdD|9d%+Sv==a*|kn&?e*sIm7|bBH`j$**L%4o^Z^R;D2XV1|4$s44YJ2I>uOmSdT! zTGU~-Zx-Rm39H6;urLr<4e?Rc=ekA|qnI-%GoIF#7RJvMD#Pnce--WZsXQyFc`R76 zY-o=;4}H(nvJZ(sR>LW7TfuKy`uJXd0V!&sF#4fS&}WXv-r*b?4<2E4fX z;gu3k*vuYIc&U^Bpg2wESw!<~23m8BJ6p=lpcn8dx*8NVPQlnO>YSc?q|zlp3q?lO zh`h@4msV8E?npj4vuHk(^utV`@p&8;hPIc*#l;1h^&irB!2!1&RY{owpZAJ2SQW0D%rfu)x1l@W$LzlKGNlaX+J} z?eYiRO}?i1?c+=sL?&AabAne$;%00v&ih#JWGHJ<;nmEV8D1lKj1e=F6gIDoz=3og zE!`L$?7X?CXl0P4Cbv4jdgtC7bTq-wcrkZqJu|~qre)RSipKIj8cWZZi)rJLdp$O= z=h$cQ+}EIfs`+y4c&@HYZ0zv>OU{-<>$d2Mn`Mb?|Ei5fi)!?W7!nJ~n8dOWExQPY z{!sbQZq*mpbCQ*5@wUk^ z@*K>kGLPC^WV$A(JMy!J)s8IEqxCb=&F@!#5yvPAN$#Vw6{#HTl4Klp-jVMT-uc*9 z+2qt!)Gf~U?b)G7R-kz3i=(2H-jg6s=vGL9Uhmehef&kcZ_L4?*Af*jTWo1*_wMyV zd*q}V0v7_uTJEkPWP9C>{b;r8CO{pLiH76*4ea>AGvn00&4K9*C>`dCuv@Hur@=}PejN^% zlpYhbp;C5ud2~XRO)*XFUv~mw9%m}^ExseE~2#%->L|~C>2sydXX42q>1PM zV9998{pr|EkuV9bS7OnmxGT&(6;2hmY;qlN7WnxLRi926%L^?gNkY1xBNoe$mnKOw zGBzfFnutaWDW1`b&gjLY#Hn$GJqWDITEstJJHNlnON&=rr%2_;-tlHj5feWB=~Kf{ z)*x>u(g!Vq3)QWX6#dGy6ow7o=7z&g$kE537nkR~AGLNS_AI?$5ofNl&8lc0#`sgj z29lX>ACe2Crv%t*2Vw6OKKg*Bc^IDc^tG3%b9sMmXR^C~>Uv3|W&+qbDdiz*Fgrfz-iNtYN#&T z%6y}^XBkBg`-0Rn5#PsOOJ8}o(v8K)hkqBxtG6r)%^@k{0|EvAOVi$y51%8wY^ab3 zHwSj4zPWm>sIcXBRpWY;x(Q4?tF7m^1Ak+3_Tt=*5of>Yb*DmOE6vxqQb^EdV<7wO zWwACV1LN1b;-!p1aiPOR^2ZgNylEHhGH>un(IIu|cW%tadVbZ7qZuTcH`alF>cY7E`)J=#T! zVs>uPfP7^76r6mc>8N<&Q5Ad8-NyZDOm2~$R~lroGZoU+bT!z?oHo41j2?PJw7FHd zL&gOo(ofpzUg-HPh>Dk6gn6~AE0?c757_V5akz@K9??5eG_g8fjqvIa7pEDT7hC^g z=MoTH_1fAV|KeS-*Qkc_AjiEJ24l%NtTMP&_f_$laT1JvE2W3R@DZbvi`AnBQV(4*!BA2j;Bm3!h!IJbj?Dd2H6S(#M0M$KBdPmmA7%Q()E z6vtBP@folMTmkB5Pu|>v*DCB%8$CLnDJaad3&^Y$uYLPoA^T%P-x9pO; zeS>|u*DJ?*Aru z&dd8X5OnJ0=@sO9a@p7Ma3se*{tRfYYGB$!4SOnF{m}V$cuK3X80ee3M28>q(}N{1 z62m-`KT2uL-~@ktNSRHZbm31x>ZJ3&wqv6W0lx1M)cKZ~OtRms7#@Ymoq;DUFH#50 zc>;{-%e@#k?qrXoCENKt{A?TdMUbFpoy*KIGE#A5&TGDJ#_#GY%AR0>#Qbo*`^rw9 zS6;NpylP;=7nv%~G_ z2&t-1#EX=x)r^t6kG!|odiD{*;fz#A)AmU^P;aH35jkV-xId*Q|LC1KZhjJRG%K$H ziYs(pSz)l?M&4ItEqkI?%0!fVo3BzxD`J<5K)Sbbfc*KntEzc6WmA}?Iy$jNi&~g zRN8$h-$JJq*;*lXUuF?c1TL+*@XKZa;%!3JVTJRqY<&ucK7kK2##ZIGs<*?+J<>-w zDD%NnVoS&qM)T=NdstCNVgAkGGBlJ^p&B_~NzR`mTI&kae@>&S#84WYJARIy#+*lO zqaoE<9zyM(^BR1P8Q{twC^ z3#O1~hRnXN`aVOmkL?>nM$57ATgQi+Z0k5k>-$o@Pj|WXdVQOoTp7-J=Ik_$5c&>z zm(3W`O;^e^l_i*$8co$d@uTDKz#k8(El5jxz#_`uvwu@T2%VVDt>I>~70;Iq1mO=- zN}dXZRW+SiTcjA68V&0oJ^2rx0zP8*?VY?XtW-cIPy z5Du&rG=|V+xj864N2g&yUNR&jq}xKSdu7DZ+ddeP#bE6A(ebU;xn$L=Qz?l%Jn%2g zK1rHy2sp+Ct{XC}wrG}%e92pH)FP|ooYpxCuVWU6%HBnAm2w%$IByS4jCuAEi2^^% ze;0Ui#g(XpJH+F?qC)&#_1u2yypHG)I4`xY807x4-Cw>)9=zlIGE?L(KfXCif7YiPjw2a5($Zd2VU+kovy)?$xs|Wt}{R z@2AbZWL*?IHS||Z5DA%KA#>fZRdHmv zCuiEb(L4>z9Tf>{*bhjcgQXyGlzr4UpG4BIl8Kl`&QGf;m9UNEnjT_7Y9iT6XA@G` zV|g#*_RaI=G4it4I60H~N|1z$eI$-wB8ZkIsI|N;wSJMKH99GYa$|0k{%K^r@)?>z z#vP+`)eZ_GwEFEibLIl1#X!x{J--q+A1=m9q!&tKUJgwq2+|{NlZLpO$Hb4^D8XYN zEy3i^@2Jt;eoBgffj(ftD1h9Aw zbVOO2f#(*yrPF18ZPR`SXLs#sujB3vW^7XshK?W$cfD|~PQ70bu4MH4HU)oIIbM>9 zQRAmtvk{2o0d9_%AIrPw`LQQvlcI@fy;z4QlHQp~z56^a&Z#?Hh-zb*7Wa)r4$&0) z{64m{jZ%}XhPG+lNqy*WIE%rViD;Z#S-IxwaCppFv;R@C;WtKf=+Y~9ge_*}44xy! zsU9{|>m9cj{&j;|R6d3`A%!v$OQ5N4Hx`A*JFE-lTNC9Dt{kE^OytFzU=4W|kXtEO0bX&R9und^`$vNOp;nUUkxJmc=t!1 zpPId2bE*-QSr`oZ9Dg+4=o+8ta+8|Hu7WPlsp(!x0q4WMdasF_9s2=D{uM720YcZm8&s4R1Mu?9TG3sr@EbC8$DRu-ir&Oj8Ta8O}S6M==P(J0v ze|)B=w>LY^@>z8gqsxYNtY6ReP_G1iMnMLbB6f3&S}O$2eW$8FPt_{ha=IES`Zk@& zsvx}n#)B|^DM9K(v9i=`mZK@}y7S}#p)nz?q+;^@X!k6N$WPbd-+PV{BDwb=>3@=c)SZ}ba zJsA7krVhXOOQ$|`j*M9X(XlcKM`5#om|mR}Pn3ODyii-vxYwx<;v zit@WD%l7_@h?on3$v98lMy@ zPF9cu(s-%8x8xLrcr%3-LX=)KkxPubbb;>$W$_@ zz7n-ndbf)~NHXv#qs${j1X|oOBkyTEO1e`78QLngs-lVN_`1#632EbPi9|Qs!Gn3l z9XYa-8IRYmaiv@%G3ARFE=Vn%A}=X(F+Bs}QCi;CT{G2G7Cf&HD?I=&Z z`pvCdhgr`39s;U7F-pe`)zDQE+P2|sMR(%eY0T73W&Lg6w{4B2`PL~P-*l@*c&6Q? z|7aN$l=;|Wv2k*vXyG^^XcgyBF($2Aw0+U5*et}uKT1{d_G#Db-Po*PZXMF6voW>( zOe-rbUfD5P46#jq8i7>j?Oe?vPi9#XSX`%1vM^uDC~qhZ$wy&PX)3M_hR8N?@`fi5 z$hXbnZp>)tkB~_0ti9XL{B-yB@;Ci%;U@pCzIQyYg~WFxzs?_Apsh&S-!OcR;zgm% zoIji!y}SAj!}hRX##g3k!kPK~XOF@)?M=@-dV}Sd4FBh0z2RK^>#gqdYb|Wj=gF6y zY5KQq$jSmQ*i4F3+uHG7NYdKMH!`li5nRG4xLBQ9WUqSklKd-QU(1cjvm+>DF$>R# z&3H{Z-ikTa_FkDnwT!8NHe+r8u0fJiN#rtYvy7 zCAib3*g9{M-$IBX;5QR$|3 z=N&!x#5!MDL^xZ3-0k@7tL(1Igj6ayu~9)(vxnrC&#}j1%xnZF&l23k(4L81`U5u; z_h3>@XJXoS&wGpX`LQA|=E9DB>fb&=#WT|+!Lnm{AcauQY(*+_@#WU!_Uiik%AOSu ze3Hi9PU#D6H9Wg{WitMe#k&_!_buQRjOb z%=0`R9z-A3WLlk-+D*}Xv`7)3ofnrSXuC1-VjZhhQ~3;vsMcxWx7d8%c8Vok%M!q+Kw5}VoRvN!uu=fwNGfV@`xYmW2^{FaA61(s%h z-~?}go=EsGuKeX}2*qh*d-KjX_lR^;0tpGF6!+Svid{Nyp^c_;-R2N!7T2t!&M)}I zJ4^+u7>pZ=1P?8^2M4j1Z3QjkuP_$nRzeQ=`*Ju8V% z$~LVBE7wjh9QRc5Xw+%gkx!S=gX9UHXlEaqqaaz_#(cjd1|P&rO5`~|%Y9DEX*w@W?3Y?fT*)i&+xbEs<)|D7#$h8Eht(5k z1`JY@9ANuTTnB!h`Zq@-&(&}RRVWxqZ~8ZLu*@;qG}k{`;+?BOBZwvm@OpUPS>Lis ziwKV}@0f=)0ByOIKqNkQ*A_HMJ+?Z$rAZ~ zS^mz3Jvx&-*mzfBX!UFev3f&~*t(C=rE47_jlN&Z30vT~;n*D)O)A{^=*>$E3KPMk zvKMa@>K-4JsJ#`uXt42acdz@AD3eET2+&-dQ51{$u^L zGs`ULbU&|Pw}uZgZ_Q6P>=GBm@7cDeqpl?r=9$JzR!>-G;4xLM^B08+epbTiA)4!B zOb}!Zp^nhSpYF#ZnI<1m>pEr1mPNmOg)~KI@;PNXH{?n#t}LB8sjMyg+<=R?hmcfm z?ad3x(LmNqnpgTUIp1(h7|`KuX~hGsB=wEB+D0neDgD|WaU|L|? z%idEju4Wr!leU#tN=h%`{|rQxT$THm(xYz$fCu9Rfw$&=^>F9-@?(5Ax~Wm^QE!~cc^2PgIa&Nl4JOIU#eZ9n)#+qJN`V*&>sLRLyi_#}Ym zHq**-KJH@vD#EM5RQ0JhpR?wB&IK;u3TQDy6DAEM%%_bF1ztuxGT|pd3}SUqV4q7p zZ+kw!nAH=A-59r+I`JgPvl_$WII_8nZFlM&uCI6RanOW@`@N)(eWTO`g(247rD`hv zlZPwSp(ll-_4f`_^^bk8=I*#=A0|-G+%3&(W#bi2#j@ysdC>jJ*JMGfT0U=aY`dVj z`_4oPw=Szb-Dcc3ZY1DExl%NUdq9NOf|2&c|jD~>IW#KhzVE}GR>^I3FLIJsMezST*Kv zO?F2O>#4=NJG}lp;_Yi`pLG~(HZk6zC>wHiWy=MQJ10M^TvAi}S4Yf0LXkV|V)biD#xj+Kuvj{%=@Qm0!pNtdH+#2p$bCtYG2GaWr9Q zPwy{$_~Lo*siS@o-TqZ#{e{(HYe?kwJjvH_{%sv%n!-b#gWWgwPu>nO`&Y}(?sVlU zRgmIuZq9N+lMaKA8hqe7@;w<*mnWx(R9ZEgp8W1DvC+cR_ZKS(F6k#`N_kawXXmcY z!=ID$aQC0S>^QQ2Ad=2<_aS13oJ0r>L`j=OPD?U)^m1^r3r+|G zK?vH(PelVWJ&j(ib;(r|wh{&_3L+1_*3UbMMYIl<7~ALQp?t!dm$PhRz7hXA>YftZ zYX}yP8;ZH0ck`hZbb|wtVBE{oLO?Xy4o`euvFj=!=KbryGl6$0@fbOwL^p$ohzMyp zf;|3`Pv~{0D4th0nzFnK#r)0``NbjL;IFai3nt%LV#Z}FG{crs~f2Q#bgaJ*sTy4K_ zfcLk+`yufDpAS|2hJWBIhOWO&6!@AP82b{@EtrAq=%G7u$C&!Z*lmdg`tkzsUToQ7 zuIPiV0?h_I9yZOT7n9$@RaO-`U6&s08YTAY9Ed4aO1gdgVZV;42P1VfMPlj`x5=#@BXwt*+t- zoHX|1p1pD^GpJOsU|UNsL=t`LfaQBrxzh9gp@^3c@P>)b)|6UR-4K}YAqMn1k}v`a zJ_lCE!nUZAzW&azO73pUpPq=Fke3()b5q31xzpA9!!0TTkC?%nr6{5XrsY|tW{dV1&^945P;bDuy3`}g7oxnKONqNU*}tvt`1MfDSV7CFSovfVZFb_Uy;z1h0STA#r;!k0;Tx- zqz3B`E&pOJX_&|s;yh=UNSb`Oz^SL1VRG{hGaFjd z&S{3*s?PzTLv{oyHe^AicbA9Mzs*Ln*`lU2$^kS+dB9OGu_wDoaM*T4F$jLp8lI;AoHQWwza)kyvhv@tt-zcdx;25? zt|JRB=u0g76P|oa>yk;-gt3EU3w&q5!)0p$&v46|<+E}c$xekq8Wn6nf<$(PmS9>U zTqHB!MD{~88-r^9ZU}XY_+!zgT!?j08xe6{xm4s(w!6fyGa@0DDFj=_exp)Kv?8>i z7&vx6N_LvuQA3PoQeV*uF~ky(CX*n1a)m9V&bPzsmbmPx>h%Mk+0FK?#iderz$$IR z10`W?yMN34-_VrnrlhVm-bQo$dtim3{v&?*zY|0Jzo6-V9atkP^Zz1x|9M#dBZpX| zY8`XHg7BTK$EaPSxw?^f1nuuT+lPlQXV`{(*-~DPW4fNs)m)dQ>!I?)%`7*srcQzG zv=L>>^DxOw{|s=yfs?=ZnE|`2K!H35L5#Saj^IUHP+trXWf+8j4zW{g+NfJ2ZixW+ zYdcVx0rf{!EMZyH4Pw{g`KRdJPlR5HLq}DJh@`q{4ZQs0{2`>rE~-F%7vK}K!)*XG zaQ)Lgn%YQK3dO6TY61u3{r&~3<>mPSLimrxUlj?~eA>+EI?gIYV#9(wpDIb!4j5lq zn`H412w)Lx20|TPTnf0Bf$6$iX5NcBY1Om^03}Q!MCp=tQoB<@A)LN~20_sa_REJQ>i5qQe#P(4J!p)7@~;MlM^BcngAz2m+L-P? zbDTm{9NY{fOd(!|*F$Or9&)6X+_Xe{)qeO=!adtcDcJ@uY&`Z44Q2I~h-#{0mQKE) zP*R&o8#XpJdkxznY#1y39Qn4I_Pr?iEk3!C17(X;HP%aJnay@PIU;;{RrBppY7e4; z=(GX!uB_#yb^QbeANm*R4^I(H+9!x#GV(+GWDOmV0BNO`EQrl+a6REzg!<=!Y*YRh zebcRCWm<*+Y!^w=SZ>`$E`fDU$qju4Cxg!!1yMvm@lN#2 z`L|f=WZppS=4|_S1rKn0jT7J9B_UDl`9O4naf_Rg~?+9~6x{R6ekZ0!u8+UV>}xpBbnY9)r&?)J<^o z6mxDlaej$!k$ukK86L)VU9*w#*BSov-d)c89X*`CYjlw*&BcT6)fr+n-~x=8yh!}} z_)|HJ@?z^QEmVl^K8@&^aom_@@59&?w_b!A{!3aDJc*T^af>HkUK2`oB~^r_X6|=d zpGHSpHT54p>U?UA+in99?w_u-1bsIbg~sppM90C07b({y6Q3aFxl^yIUOqunQql|r zYu+R38J6FBL?{V%i&G|38|W1ura3@K8T+`0-fRD#s9I_C%pEh$4e$k>k%nIL*2fs4 z^evf&RyN23{eJ_Ar~Z&Sp_Cj2*l&vnB@zID(Em3e`7dPoe_%5~s^^_4z1raK?07IM+qk9@{M< zKuXpp%La3QnNzq1usT>cM2r|77A(}E%j6jZdbOhu3E-Uzr5?f|7xZ|zQvz~!orP?+ z;jPLm7eS=rEmt}{z*kO3Q90tn!M9UL z=TLD-%@UM07zIxD^F6MO#vdlMISlmx_)%h((C31_%~x{PWtDu&E)P+A;7D`M7R|G? zFbZ-R@L+76oxyfQ5#BfH1F6P}T!6QEu9i=K7@V#;giKYUT?{@>u;C8&;tJ{l zRBcTr;JMH2CufUmTc06rzaN&E0CPb_{l@$97ySO@3)G%I5QwPPqCCbvNw)3NFa*aH z<;~H=>`gCZA6(e=L-R)T$_Sa$IZwp>$ygFNmPB?%HM51()8=Gxkk#;bkrI6y5 z_UIKBRD}jCA%gb{&y7e>%k42 zlS=+SHiT;oSeI)t!?wBv*?~XOmLux5Xhe9Z=$g9ZnuMQ6%;%$iD*M1Wa50($`TbZs zQ&QGu8(wp664S{&9xn>W8S%`YVXfJ{Kod{A>4_3cM+Q`pk0F6;pM+eWyXg%&R&-5w z;3ycXRIq)=2WGkWC46zl)I^R}QU*z1N1)K#)%KT<3iVNu=g8pdsI)n(q(6Dm_p4gC z)69pPP#s&>8-FK@7lysl$?>_EMEIh@z;yniG(HxhhNRdL|9N|)ykk=mwSMOwf5m*~ z)$U_=L{>;+aKN7*ClBkiO!murxU}J+M+2F3`xgyq~5prOW4`j zOV~+hD5Zr;lr<$q%W5u*CYi8`>_w&RNW~Me(<#4TckTe=Cdz0O_eiE>y9@CnDu!m} zDwQ?b$~x?5CYkr(hbpTKC_gY;a2}VVb3j z%#=1VKJNq4kPe$=Ng!cvl5eQoFK~=cszm)ZJe8U1E^bkKy)`jXwZftju_r}~kEF4$ z(EhiaeWs?j_o2%V^L2QngjHR{&}6RLnae)khhm?{f}e>BI*59yjMaZXu%0tB_^@Eg z2ZE7(1$~w>2)|#@Rw{d%WAJLTYVssi5`(Xz2anS8=P|`okBT@&k^4j5^Lt%$ZsG3w z?fP+}G#R3NuntYy9FX!ry;=nA()QyO@uCq)4AOb~ZO7-^`+3C%9d-XWfh8Y0Fjg)| zV`1&h(gK4&an`QxAeESMv>V)6>2P@NN?in>j2t^3pCkMUYWYbL_Zk$5ZK9?~GFB{v zl2Dk=ywk@*z+%7Z!B!9Ogs!W6(rD>D>dxmKawq5cpo>tRgCuH@hJGvbxafJQO3Hn@ zp99UrfO0A!UU;@-%=F>Qb<&Ho2RC#(U_>d7l0buv8rV3Wf@EC5>(7Bq9vj%(`ALw} zmucY4c0#P>pDwB{+)*w>%yiZQT~IN^cj3Eg=q+ye*{uV;BH2hP^%JzWsY0~&It;gj zekWUPt>bSre`z~K&5&SVj+-qV_7(LYz$Aj7#R>0@wWh$hYL-0zW|0lT{R6A>dm++i zfVl4Yhs=)|q^w^5Vp`^qe-_5MG2i~he#JzSGMoc{N!T~{vW=m#lre~x9Z6T7%~NWV zqIp&*g*N9~Crmq=q!h7o`s_Mm1!vF3jC0h*5%ICO1sG~j#z?2kXAL_GY>3n4HMF39 ze)Rd)LaGPqC-99R*$s$UgiPcWpiR>jp%3p>Gavzd>XFqmaQQQfeu!9RBN!)GL;(Q< zC{5^g6MEf5ETZd(R2*1*;Bv^k!DUlQ;4^{|PK>FkPk(3B z6Z)uy=1zF5g|wjA&;*T(DTA2;$;CJn+Ij8=V2g>O6_=y^XMX}Dw%N4G)>T($DpeU@ zV40$EfeOQrKE;gkzFaFRR8_L>E&~c_ho?=GczCxU>D^0iY;RS=`1={08oM9UAuC+) z-G7uH9&jJQ>~PjCQ=4u?(YwIOGWrgV<#8WS^Bq&ZoiV<#{yqD}vt{Yt*g_(XCZ?}; zzX=PT%40!bd``oNZ*MP8t8pc2Hsqs~|^w@`HQYaoiU4(n5F%^fk=lzSy|(8JK|E+)AY2s5m|ZK?^Efy*p0HGVNC- zsFhm(NpUDjnvv_#X}&VZ+STC6Qf&%fslhSVuVsnQs26F;T%JaoE`*v0={Pm8sHd53_CQP}cleh#yV`aY7E+3(fX{A!Sio|GQ;fj|{U) zfe6dO#l_}1amR9xKwJrd(JbmryS%(Y(3ipc9#j`=6nNK=mNyywI|2rO&?gu;KGIf6dKv0n?$9v!?;en{Y9-dxt3X6sews zhK&c#wSkBm)0*ZbRXne;5XkrER)I*v_J5UkgM3F2t%onMP9#2E9W!hh)uOdyhv7PR zKM=0^3)eozOWSK|9g>?AIP=vrRZ#<8vNzJPsnjH)Q*YL2Xlmw9qllV1Quko4IG+{e zWOlrOPs<&}&afPlEYUwa9uMdHpO;4!5nSg&AYKL=UhC3=an)Z8x+{bz6{snL<_LmSWVw$r($ec}b50XDGX9{X0js7$o-MwT1 z%hMIcA$oclD%9hjzoX|JX=4{i!%g9$zP-j*Kz2n$UkjAscWT zh^`rnq-3$`{vSpHY#f}L`?eoH`)|!E^4Dx<_ubG3*%Fh4DxUxuxHIvlN zlH7kTIwBSx67D)&%3+YXM_^dzUg@<(sCxQBcsdwCmr2LGb&d15!iWnh+YdruD;yaI z7QVi^BO{-o6V5@4^?g1J^@=m>ce>?0!Ua5GpWP64#b9jotS`%eom$s0%i1Vq5`#R- zYmOW3HI1R+{nw!qCjEDBG{X8Sp4xNdI*_$X3FB-9{>?1nrefp@Ur2*$Ad$ulK_y7- zEEpFWfrQ-%#2_6gYooPmUnB&h$CSEFoAKe`<* zBUAZ}M`g*zQ+s6%#W9H*sAQJUuOfMX=Xxa;y{en{SN6BjCDJ8H5+}*3aK=>i&bcb2 z2DOJtLo`vv|MgKcyDX%#BvLUM-y}oz)dr~7&%t(LoHZ3F_jo`16zbysVo)`;SsEHUYvba7cYMDyl&{D*=R;-y5GALbyitMS zWNyvCFdPy_^>>K{#uX>GYr`2eIj{^k_!|)<88ndW#>_~yB1#$JRa?L33md@^Qd}mA zHndP=005s#un>}*tsYR#h(%SyOoaB2Y7jVL=g`NTBls7#G` z3DmgRGMHdIQOHWr z0@gzfEX1S(ruIl1SK-jhucI;nh`isg+Via0~IQza;}ygoyqFt}&0 z6)Pb=Pd2YX&!0l{b||yue8>1#u<%y8Ar!Ow{Su;&DjgoH5jTClxC^{cJkm)WeKUyY zWPP&zob{!3RGkI$3{Av%+W4o+S&%4Xf>&jL1CQr7he^x&`YlWxV8|DCn^%HM zb!}~Z(REXSf|Jc;F&bkx)LCIdY~z|m*u>G;wF{3JM3{VENx#wCmFvLuR*P^;BWT8* zW5cyaj=>D18#ay^Vo{-?h?}U7S%mCUkfvJ?pXiCW7A2=Eh)wgRh7uE;&w*S4xgZNtcj13W&wr2Pw1fEv27Kf?e+G@@!+;yD>#KwGb(wonH^; z3i-zp74JHKM^gyHwaX&~b_PTcHZE--*B2Qx+!Z*}&q* z#)~fTwq@aKZL(0h3`xN*EqTJ_keA&3bxHA(t~W^CF+sa&@=bjZnyURAq+3MLa`jOG z@ha4B>8#=8Iqyz6drx6hehMwcYQFSeF94f$bzNqM?cXrLH!j9__WWSG4(NBkSuWHW zr6R@L-#%jvmb;{KGA{XyyL_}e%-oF6nJ!6e zL#RsL7V4`_Nu6^!akKedkrWDQv}x#vP!0n_a?%ITdD_pL)JtDz#&jWH7D_Ko8|kOt z05&+8B@P0#gib4~FN&5BvRz{q9b$!se;U*CgZrhEtiQhAQVe~oOMgwxqRz%l+fE6A z{R^jDiE`fv8V+7xYE27Ub#u>lMF&+8>r{nD(~int9NLObVlS+E4RgWGuJi4QlBoeW zYfFbH!_8jS0Dw9}mV23#=r0I`KL{f9q6u^nFj4_IGnpWwc73l$Vf*BppZH?dn|FJ zRuRp}{P5p2JUe<#8_FRJ&|q2iQU(3 zxJhkTERM#;o*!KPo?P{8A$7WJcB8K>{M`8y>1vF{J0#4b7d0`MU#6 zQi-U5Y+4wx(szpQITB)I|tx{?ezV5LB+A%5xrdbJQgpz_17!aoPmx? zBs{z(u@WF>cQ?1(>wQQlrsfp{tQU^KStXOEBCNik;A4cme;$=#9USq}3@odKw4Bd> z)Hd5d-5)llvGcC3DT1XwG>an7DCWIV#FK(>W!lvf3?Sp0GnWW0&90r!EL)RY!b8O_ z%T6o3wrHmTqZ^)qIzJ{Qw!NKETxmR?UpJ2{l3i))6m&L>#W+u_pgfnwfPAqB!td{CTBBhkEY>?FT|k8>#VdX7e4DDG0|j0 z+KVo16J1Axo{UtYwo>keEn09@McwzzaL%9{;G)i34Au;i1H!Z);vm$mML%7E6)^U; zlj2hfZ>X1e_mK$DomNlshoK-IKnW`VArS)^#fVH9UCm1rudfKGpG6FTHMfUrOCc?@ z0L6-@<&Gg- zIGMSyEYv@^wrylzKYf0=-jjdle>zZuQTiQtq&1+NIV1h8F)VOwKuH!%Ie(S8_T%IW z@=gx`{sxY?5O;yLX8UVMtTi9`rDvJtwUbW=9E`K2zS`@k?+9ih3-Ss zxbFNDfNLa8W6Q~l>!bX-av@x7SPy|Ed&PN%}&Wax%O%U0C|!I zW%l#=V^I_rNupt*mzcQS6sLIvs-5QC~a*Xa&ZCNrIiABpr^1e zA+x2%mj6ttgz;hGBn%(iqIKU|V^N-XQlDL0?_CN*mg(Qp{gIOwIM|b3b6pqQ;cOlm zsr;rAZ5iv+f`Q;<44_8~P(^BxG-m8fC*OJ`rI?d{hyF}wf)5<7H9i5wykbi>y7Mm1%XR;( zZv}o@V6T;CZEvF9|TEr9Hxpyf4Du3~o zPpwyZZkT$xm6vQqmSn`dtt0w4g>LEQ1H%5Bdg~?waXy^S?Q-6&2v0VcQN8xg9uqN) z#QLshTRr+Z-uws5U!YR+?yqBdg8J6Wfu%4v9J%Usid-aeVqA1AQS#yLwTG9jC#mz& z{$TUSP??izn1m))uv>uT(!Y{n%_rPfRt4cCu_kVHQQld+?)fW+K{tsy5v!$De^XNo zwbf)w6pYG+j6=Oh#(fz%rn1a z@$1Z@6R9g$DWYBfTvr8DuiKggc) zDN*U=Z#*7hCRXf~l;-L%3dn+Uz4>F)-&&XiK_M0P#FNg6$ubP>i-oZ|F3Dd-vu!)_W!XZ#{PHM@4q>^k+t!E za`dGxOJQuzd5X_1{=F}fmaDp~JJ5s+4m%(~radblD}sbAT0a;hXL9fPUk?I72myREtFy^SoF8xf_zlj+{)X)-yC z@HBpnY}rqV$S(mLSn~Z|NHTe$PsHpNa5hg&IdQ{gUwUSrJrH>prnQB2@=adC)sdrh*K1hf zl@}2;?H&q3prRCZCwFdOl$ku1@7H<`S^}`C;@WZS`d2jMwHWcEn8 z$`c{9YsI^hqv+GHD2qJm>8xJNw*k0WaDxcD-9J%u5pJjMriQ|++Y*6#$KHn!9=m#6 zw2YargpCiN_=Kn@*&aj65P-inD%fe2A8wPD#CRAiE;l$!sS7Nl-6f(B-aGOs4I8fg zhI}hwey=n6D_7>O`mN}H1Pyqko(Gxxp)AQZ#;M&;Hvx2(uVQBLs(Ydp; z?e$=DXYw+z7w6j2(L(&Z6I#&H5wdT4F>u|7D8Jo?#l?I)REHfHhw=8%H;5>56Gx;8 zogT+CX>999He1sB#^hpv0*Vk12G~oZZF5L3gw-4beE@NDBAlCPOz*KTChfTq+&>!s z+&d(`Iy_x;(AO$c5FAQYk z%hoH`!}lpo25@`*@LCgfn1Km`VTu?OE(9756C9A=9z+|#Jeh0hyrjIdrn zD7VS{-lN{+XOK`<7*C9+JpPa(vcj=9eA8amXj`P!1V|+9<=~Z+XXEIFO>(M)-7HRF zbl*Lk`Vd4It`?+ea6kSSc`An92a5EdEoW?#-CH2EV11ZcEdsuEy<-Y-FM2C}ZJ+w? z?@MzJ3q20m4NI==BJ5W@sMO;k+}2V2DO)^kpa)hJ{`Hw$!FVb6t>L0Hh2+SbSmCDxcYuD(ZHcnUNE71E--s~w9PIk+T)w; zM>%NFcXtb1kFJG9Ml2=L_uduVMJ=Toj4fKBmQV|oIEG=YDv6Bk}3MtoGJe z_+*Ax=wr|&cC!PB_Ly0Hr~5Bx?E+ubsbgs%T#h|YBq#R;(rWA3!8+3;z8ipvLHcD6 zVeiiFb94WG-yt}nsUiJ0V#j>Y$SCN6#a+@IN90R_Z>;q^Vo?Yv7z{CeRyqi%2>43z zNXW~S^YdAFpjk6lO0pwkUy<-#%moO+#o~XV<)*lYSQhE4AZ5Y^>9jPxg7LX4l-(Xm zjWW|_J;2Aep`6PCxN?j@cHzfnDo0VZW|RHdMVu3gto*>O3Hd7GPt%oUwQ(TVsCg!l z;R?M1Ef_xZ^SNZ$XQ(0PfAjS|{U|x@hg->@G-UP)$Z*HpV+R|;97vteTz5SZNS~N( zf92-Tz$&zg$)zQw*JKlz*Ur4S7-|TGrt+y2m5F!%ql%K(gU3b-7}?DOCD8;vhJb6O zm2<%>ZKxyE5&SJBgs^fjg60$YKx~z{bYQT)GBBA?MLSDmnC^ir;<8i1WjN<}2Ip`M zmJo_GCTlgSu;B>bS_i0u^nT7T$x_BSSm7orJ^&_Gb?BfU?gPg1rxXSZ3GdV^nNJ?5 z>S74r>nyYfME^FNx7x{F$8ou=j$v{CpZSLQ-3!B$-<}z?x*C0F_ZI&(MAhWIi*pZN z#!tl{Ms&2Y(!naoMX69IV0CTnS3D&`)9xR#lMYVysWmv-n*)?^QX)tumbk)ikO<&$ z>Ro@i_+5s-v}V2MPnFSsdp|%b@&9PKW{giU=yowo+a<_WO#pC#AEh+gI;p~ZY6z3&Vhy|iSmjCKh8 z7#@rArU1L_#C~~Ti+E<1dq6Ao88SnzH3fu=%us#GCd$SBy?GWam(;O5fm%gMs^Hi*j2WEFY#GJzph`iTYAHJ`3y&5A6DEC%9x*1vFN0 zY*b#~-vt|k-5^?Vf`D6A&yjJ|zTvUL%IPQb0|Duvj>DJ=F1b6s45gF8K7zJFHyMWp z4#XJhR{zB0Fp`xw*$LRImm(Y<*$^qlNIHz_9#06g^1wVHC2~RG7)ScWex^0Bhl&=t z;v}yMjVdL&@Z=vSei?9Br?O)<&AS1z(74-ylL}!-8)gChszROC=AewpbZ_M&Cp$ z!X~-_Vo^yvW@FP^iTi^Fg=04Pybg?7!wv%uJzQ%c$XE403GSfrdtoG034gNRdV%Bq z^3|rA8O0-U2*@tmpjW@x;))a4l1-B`L>-FbuPE?_b5J}2ps=Pk_5I59z3j}`snM>a zXepKaz&&|INHTF#qp>UfiM*Tk2r8_ZpDZ}KPscghI8Una3~~X->Y= z2|?Wc8j+jEi2i8$9O7utO;ba~NL&=C_lC}PVn(uAHUJZoHCP9|c3^v@fa`wvx|Ecc zz7zl|5U5KuU`8+Fn5=+7r#vJ$07cLvX=81H%Gs;H>Xd%!*O)~094_PxQKMCX4T|jv z^7gY9XR`J{p&&dSb2#1Z+O7sxfu%S&)EdIL15JE$35^B^MY%Wk)`Tkwyjae_FnKgT z8%1-)Q*h_#^~TK;b^~Tu=)fMbA0-Z7emwB0qsZ+|`LbJ93cjO&J|mx7mIID6R%4o3uIKRrT>&|vYa*Y-@q@D3QAorQ z(#9m}QUFV<=!<*LB8BMt_Ns|r7n#?bBP^O|Pg~>#P+e^nL|v~&@MeMox=R?YDuE~e z_2nu0;#YXxz@n8=o#z6@6=LF(HML zB$7v*eH+8wTv5JKxmGWvQbgZeU32fCuLlqz{isx2CD1cKr+}PzSJ;({F+S}RuR;%M zV|CCx1&%#i#N3Jwp-KW*>8d!42PF3s4ED?d8neye(@3JZ4JWOKKhQOADRYWDjY~|MDoTv4{6(U&ju#ZJ4j2u(xC)w8Q*5UQkA|0y0B`s~GC=lA-b~Qf z?2iD(uG~CKE3F8#3()i1Cf~trL|F`d001!r(CoDq_Te+!3Z2?u(iffl)vBV1!}N zHUkcqc6Tk0I`u{|-wJMMb0utbYd&ke_GzMf)9YGR?wqc0_nF_(*-93VPZ+*3LK7T_ zQX;I$k_Kj&4vP)ozxGBqLX-)>YuI`2$Zy`4a)PNCeZk#OCP@yD?r!~faD5gaA3pUY zhH{W$!Xt#j#U3?L@8Xs{Jnr`s^j8i(b2x8us~||Me?7&Jh5hwU(}Pn=AS34-t7m@; zZQCfXEI=MwA8rjKzrQ*HM+tZfFJ!L!cS~99tVLYDki?IX0`O)@F{x(ErZY?Y0*9{q zZ^=<}qx-X+jfppWXM<$CD zycVO{kL*-B9gM#QLOP?c^9`(Tw_H}%f{l3iJO0*xZ3)F=+_K(|(Pqkkt$*cv229o= zOQ_qtD++Iv?fDOWM6oRZ6Naf-Eo$~Bck^J8*oOx$i-Lt@F1k{BP=W8Cy@-;2DO?fM zkYluN++ioqIz`beZ8(ZW-bPT1EyZ{k8`Ktu>vSB5sq+Pw+P_71?J33NDJ$nc8;oCV z6*%=2Iy)7d073eL1p|oQ#8=KmLxw;J>%=vO#*!a$trDY4R)^BnVs}tim=Y5zfWs=F z4v+={uujHhhmM#!7|rM>biV0(Y?RaELFr1Zv_+Z4@gC`c&~jZ6?!4&*z$44T6OUzi z(Y@<^X2v`t>KK^sAw0_D2IbC%c3%NOl(mA@b-@4jz|kp^#ug66aOBLG#87)wib7WK z4ore0Qx@NuxsxuHb1jj*{tC}4NIVL!04MW~;v7qiLP^*iW6wD1B3m}>!fWX0zqCg| zr%P0uvF7tYGlZ87j>!fHdb^wwAQ+dTpeZ6H`jW>qOo_-$+79k?+QfJvGe z1{T(d1p+*6b~~nSPx6IcS^W0?QK01s_MV|eL?+e?_^v&hk>DoQ;jxL_WRvT}`!UDy zz;!W@Rr05`+P6r%g-d1zhQEj6*+fb1O$o{b;>m}b(8jk!bl}$8RiOwD7<*F!@7>f9 z)SHx^RH0cgo>7DaS*NaYx`>m>C3u~@aKX~V@6MV`oWmv)XM#ARwh&8ZM*R^dB zXXvl;E<^9%^*%-K1yynn-}$9)FQqdrr5yn6#2j+_LV*I@Q`z=y4iHeJiaY3w-k(XThkvo^DlHSMzk7HyfNosFn>tFA;_W%dvq$g7K#na8 zwTi#$Dz|D60la{b!TXg~h7mSrfED70hkvIx&wj-;y2uDa?OUR;r}-A@5-ha?Ow*`S zqOeVSrrzKP!TI}y+n2*DLXa?8V~#@j(uT8mwweS^k01S#N=O?%Tn<2+3%^ixj>3)H zYho9&nYixS+XXQoN&4-^Jg+gIR3Tuj zgKZwc{&D#;LXo=GqeIG6?6m}P3dS2sRMCr=QQCZz0y>1U=BLPoK1eC~9qG^29)hN@K%6{tF*$+=js>R<<|kH8onkvQx8 z>joix{Ra2*)AUuucDDexYY4=NyponkXDmf!Xd1cifx*Rvn$Y&8lJ;laj0+ck@c6G| z3BjoTEPz5&!({l5W}=js9I{`L&6R|GS@3&5P7F-H7sP)~T=|Cj=jFo<_YI?@vDs6C zERf0CmiH$p1Q^LihK=Mkso_A%)Wu`7LS?PZ<|P?E2?Qz<`~* z8c}~$1J7^|D~V85ixJf;8bb^@GGZBOR8oiEYcbLdMFRi*z{w#*A$gr=9G^QyjL=O3#1kucHU@$iOqhBi@)tbh}=)o}YZbt44D`BVi+3KICaGpdeV^20PyNzf7 z3p200#3)z+G>7cx3IZPbI-QF*CVif~3|+fN;+EzL3=;s>NZxs4{hVoYNhF9co+Her>|_d+k# zcUi5SQpPD=hQ^VgNZpYwU&-~>7wbjaxibq`p&-q!xHV@?w1PeK>02+&#$thiu{E8G zq=iOMU>uukMWMzS)`Y$&a#$M|jWokuRDxk6%J`NcitNN09NHz9qO{d5zJdxrbdCsW zNZM{Sdepj+-o=4uhVXqZ0>1vSS&@4as%EVoQNVXY!Rb}j+MMgZ*eeKQ7%N(HFVO$) zzbH(OJfywPkE&5@c!X9);_Y08mn_WGW^lfw7lV}*BErPZ^V<3nb3EOVwZj(U+>AQ( zx=UylV5df+hW>Xaf|mdf9n6CH!cq6y%aeThP7hCkLXS3{9lQNXCVWY^rd<`aiRYDS zT)D>)iGG1Obw=zyG1N|G`8{}h;ZTMLg}=_7cpdju3d$bq4u~23JOH1)MdXjw-1q+X zE`P2}=5nPl7e*^*LN(@2gPa{^6P3AhA0V+jvpkl;8OWNpWV%QaihZ(c8wP zbs0+tf`!3W2Oqu76?8k%DFQ4^zlm+|!#OgxT$OB5%N8IIKN9}C!+XLi7rX^L{?b_` z(ts>q<6J)N7)wpuD zL^lF0<69&ot=t8%{i%*Ay$^8w=N4x;c)P-0N6;(ul#`{b-rfY}e-N-z{X%hQ$%BjBsmjj!~Xr8evNCP3Ari3qj=$Dql zm8^r<*rFR(UK~QeAcrUtQd{sV0}x`)Z|f|pe#~GINK=Sv;E?lnz(zP|N-x)tLGw`1 z&%gY7Nm{@2Y>fq~W91qpnJ-eaw|OV;@p>pGGh<=@&h7$ZOLRoo#l7v{7OT)tCb!?_ zZ}uGIFaFXu-W#G@DAT|~C}qHq>#+)Jl5-0po+{84L`j;v0&=4;A$vZDV?crO(x5Ua z@*{A?qi+tovR`m2-4V0dmF{3v9zc}ed{q{;sf2N9*!R}G9K;1e;L~y(N3PsZ)k5+L zIh3tDEJDi`bZIT0!8({9d8GT2=W~@eYUfm!bu2rJ`i(7B*T&aKbg3$pI~c;G6ev~) z`e5+WSsB6)W;e=A!PP!BJk0!K^ADV5ZSyv)V_~e3{@K;cM$GR_T{N2fA*0q0q z0D#{@=V^Gqun!mj%d3z*&ikPfhj0*i5e_dxytu=JsjTiv#UncBg@VQlTrojf$;jZb z-=%zH7cYLCs``KQ5abZKE_)olnW`-wpH^~gFsnWKNVG$cE(^F7x>oGNz%Pb`G!>1@ zH3eYTrQ#lB=T9#5)2j!vU2mc-j&B)8bGV;s{3SoOdo}q*hKYC@iM$Ipqeu8SrAa{_ zhJSQj_Zu;PICy%{ws}v;q!HhW*4}heZ_I?xMyjihVTi&UW7fQL814OYQCI0|7mj?R zdT^n*zA%FuP?DJfVTu|8`?HnS$P)liN`l@RWi{W9&nu8+XKG7$6u}4}QLg?*4CmTcN z$7!ryECWsuhFp}2X`AKicjp9mIia13g}H8#$@wD#urrfF&9&VCrqq*!*Oy**KNOBq zd-%2aRRe_hTC|5ya34fMY=Y%wuH{klW`5Rrk*-!igLzV8M&x2&v+w&BsI&I=$r&?3 zPKf8ItZ+PeJUgQFf{Eww()#FkngIp4wc4^yJ0Fjc>!N>#u?5{9guKtbm)w-&YId%> zIjI(*Eq=yNVU|VERejK$-I<`kX%u-Tr-#i}_X-2dBDpXqXy7+S5Nqi~2Zyjz8_Oc+ z2(`z`Ne z|KTLfr*O)=!j9OlcItfzSSvYrX0Lm9UkXA}Kh(OeRXvw4<=>HQ$jyDKRHD&Gs1Q;w zsu8I%`Z)b)TC#9UQf5-fQ=(jp^D#I3KhHC0{~xTKLzgaH)MZmQZR1JXwr$(CZQHhO z=bN@|+jiznqwY7VYSbU75uG!l5v|jSz2{o}8i zrbd49U@i@9EgB1SMgE@itZPQFtVE=KxR_AxBVgB&Lw;5xP2<9!-dT}E_ARW=o6bgHN$icdVW z5X%X6Ozo;c6>LS%2ccBoW@guK4480FzI>;8FL@ocx1Q&J5_J~;&#k`}E)7#SOp)F_ z@Sk7k7o>+_!T~P>1XJt@bW^GtQm9Qu#}};8!@r1NO2o~>5vGeIO>hKO{B!H`(x95> zD{5e$+4bJd!X!T+-{S==A5qdHSHQdl1ucfaG`JE{D;eQvA5S5~+n(?&ZmF48Pm_}_ z_afFQ(pl%8LZoF6jzVuzG%R_3nj*fD(aCDwh{O)RbM4hE+2{1l@TSHr@e{Ug)#-V< z$9sc;sb}qn57YvzEOYo<5aq<*?3$^lgfia$Z9ufh+5b$=2OqSobjp`Qp-h5lBVI)V zP3V_02S8%uQ>ZEB>KdicqY+SfWB3dUk60ALs3CTe$5LjiL9YsIAJi zpy*-qbOBOBM1I&*!#`L)F&^i|12aQjaAFA9gJ3XZwyXoATx#g!D)!(JR*EH{r2|vx zPYCq(75qg?Y+K2&2&g!?NQ(vk4uIbVKjU1)^CPc>3j)C-dLf<>6sy6uvE}6^en# z(TU0)6N2KTta$&hrov&fZdzx&CF^D&nfx8J00E_{VOXRddcvM7Y=MJ|*AW7EReen? zWb#h{r^JpRA=gV?; zlIKHJRI5$W+wvzDJ)7DaU4Fbh=MG2YkPJ7N$T*|Pa&ZBrch%&up&DAa6WhjPR2=p@ zT8&UtD&+&-G$dYr0}4rG*WOKGK2I=wa8n$xdV5~*K|-@#PvO9IsOJcVOaIa#p5~ zeCd9Ak8bzmA79-BY}QVS1X|fK(ZQx;nI9?T?e-&paA5-1{NmIn>Y+0_0k$_s)(%8z zo(_5p#v8q7@#+cpN!%>zc}8kuI9tQy&~h^{kGF{=K+`55lYhX6HQmDluNO@zim&f( z@B_?W!?9?1@)?CSmsPpZaM$6>kq~_lwSR9HHSb)Kf`F6jt7_C89gMfQg7ssundXSS zOnGGcP%M@3Bi5_D-1UfOT1174?rhE81zWT}gAaI!6>X-#p;$Ra9rki1q4U{XOZ^D; z=q%%Tr^W`Y$+G}0W>X6DKN;5Ii;qdGzgtz`E!ao-cGcfD3Ait=ODb`ZF)mIEYurA-c+t_NsN3j;qr>{ zjG6&F)`W$Lrlbo6PfK|+c0z4V^Jzf3lo1o)EJ4Sn@d$RoMPVJxCMvjop?9hJmlMU|2>E=4#xsd~u;wW2R!!?x zk9DHSj~)lL0|zkpXEb)^f&BTQwak0`*&HET znp=4ywU!)@L+F9Fg)4hM{PNuPT=M$*Tzy|S>J6FknL*$NlC)QxJUL3@xg5N|5%Ruf zsLRKZb8_*h(moOEgCsdd@HpGMrC&H1tI}~W_D8u|PKT=_mVx!=gM*iRnBY=y{W&YP zHAe`g(#I+CRY+EPeplT`UjKg0_V59baLHDAx0a>EQmKEH2=nf{GYzr5!$jS*k(pgq ziGz8sUGUl-I+;t2CjfK?Y!V$I;KO2Y%&3uF^^Huk0pN=JBcP#HGyf8y0=!C=ETdKr z_+J4hEV+`E=G$wa2(hXWZ$Jz;nGpM)IS3XR__g1UU@|S@b0X%p-$92-_eEhEk?Wx*>MSj!? zlzmd8xCwf0NFXonv@hrqGD$q**YWrKY zok3O^(f=LydKD@#Y}Y*W;DBR1n=)l-jz!ouxa4IHFDU{&q9%8d(o^omk|(ZLLnVSlr#%+&1I3DNpqh;)H(;|4$p-k*Yd0e#@vycA90P zqF5I_F2gfqU*aSLQD>M)J}2T6KB83KY=|4h4Dz3=7{Mf)4^ZE^nsyi(^tZsDy9yI) z=69j7FIZchtTUG$Ak#FZLc(Dlrb3t<(&3E@0bF-t0df+T7;Tkj(Sdth=0*h~ztmMd zJ8sHS1_a1zVn}f^)+9fxvC?66TbFKpV!q3dPJ-ht4JUKasPgw|ABQkMl;9Z@Sk-}y zxZ7a2`lhB~{nPHmHsZrOy7vlB-2G06vSy1)r3?e)EXp0uOHo=LX@yvh%A(|xFWTNZ zO0Wyaih`%Nbs_RKYYlC9a;v34V!31E&iD)(_-+JB!XynN>Da8g`bo4=`xkx#vQVj$ z|7aprI7VA2va7 zYg$cA19T@8F0MirM%5*XW4VVFd&j=4^XevhQ~6()Z3=13GdVXV(5AXu-G0I;ABH3g zML6^Hx#u%w0$q6>FE&kFo&ES+#o={*B|-G}#v%iG+li$-;~P7kN4ROC7-0xg8HX*- z$3c72Ge+YFSVlN;mC3e{zE@T_2(?&w4LX?7aKYY-%v~SQlC#EEP}Ne+Na@Dq9sJ@S z3fz)^X5fDW>zM$mEpMy}9j*)lDFJj86x>r@&?P2|M13lC$jqrxLitM*49;a_zF9lm zW%lHMsLbSNnS8lVbCARsMbdSUBqgR7ijt9-J)`$0pH=g-|8DABd-EVGI+P&+Pem#Ofugkld#RDz=iv!Eivw-z+*K=;)?uLn=c z2g zWAJZbFjxKvt<zX+P04j6?)`@2Th0&+QOHmIGQqS$HkKyCim7FR6?C=L62yC8#YzsE_y(9i}S zK?`m~(cg_|>_|2nO8rAjH!LC(O5Q(>s1J4@0n{v}6BXKyEd3z<6EOTg-}Hu!p!@7& zCs-uw{SENx6Zi)1T&z|1^C3?*(2zNW8|fW_Va#8calMj{g*iEv?XJLFxQQ3@bBilZ z;y?ZqhN|39H1OtKszRmdo_6VXH^VnCh454T6;Rd-y3DTfJxQgn`ehC6FRDqS)#!BU zt8?madsyEMeEyTP0rz^UOzsfgfdZc*6R-bTlV6fr(|Wwhb%lV>>-YG)L7%p(+D3)j zn$CG)p@RcGJQ?>$Gj=!P+mhY#(IeIMZio9Cj-5(nRzn?k7lpc|KxpTZFQk`{xBV=k z*H#d`q!cfG2>xTuXQ328^+lV~%i7@?S+|FIIRwUJ%Ehl+Qpv&>iGw`Ol;>v~YxzgQT(3?UQc$U(`sUL_LR3{Xly40q>muc~_ok1>NX% z3v)UXbDZ5&B2-l&`HzVw+XH8)k@VlC1qw$$9Yq|Pe+jdV+6kFjHZx`S#>p!mM{5=R zDgnwv2kJCC($Lul)3%Q+$WSnLd~^Asz>2!=^NuPMU_})i^fE_9nZ(P;&NFgvW7lku zoB#{|@#A-JTnlv%SQK|7`UQ*|uc3*Yy0`-8kn6o;Q0*36>bnlezoyvhzx2-APjHT( ziEhOgei$w!Z7fR?*T)sr+ST{qw61>wdSTP&dcih%XFX33x$`*nt3EH*=Y8wwpKPF<^^Sm|0`8$#3q=}rwrRPIAl2K2->AOcnd@L0o zbMo~1D0c4KF2xF;jp?GxyYJ8mX+>eUrulIYr3X@u1VZa5+`HbUd`8yZs?^gX z)vd3?)9Y7h@Ul+7f2mW9-bIiO&7EP1*OGIL=&|;CabHNg$T}4>Hilrj6=ZZ5t2xpy z599f6?0nSbx^$5tZtq3X5k0m}$2*YoDKQ08j;v--8r_sACL+9H2M7!2(x*ZX0Q9kg z*5c!TjCI(<3&sMf;@g}^5zz-C7itr6Hx8LW5KkV?OBhOW9`9L|#V#k5y~EB2Yxv>g zcpa~EBb;<%1iSR|FKZU+k9n8VQhg){Pwo@MSYrgXph8^l?Vc*8OacxWo*tBJ5i>yn z`d&13ma?t)sKI}p8xjzsA<}&6+&sP$9=-We%0^@Z@5&Cn&zMD_nrJ+f`w=l=Co?^~ zbYQ&<#_Cl8L;n@QXA+)3brYX}o|bcA`xQ^2PbKlOgM*VLP||v;-R92D3xnCKsp2ZA z#PPa!rAVO!QLieHqIBp@l25$u%Uxk;Nxay(3YMbK^vdPCwGhwOJsk z&rpHeZg#c^G|+vm%{I}!R^rs$5N<{0|0bD~)GI!_xZMv2$wiU3HNx zHciopVHgnSa5s~6DulCi*DOm(c-q$R`8y_Rg`O4Bj$4ar9Gbiqvr{fQ?RA>>(Rk-QYT$yT*ap_6O#+9sm1*#M+ zf*Pw0Hu%i>Y^a@S&ZtyyZoj@krtu+FlxHUYQUW?7}QarF=Q79&3{( z-61V^b;*KCs%nnr6vd&>7#8hG%8+)cpf_q@lIqEL*liiN^{@y7x9)ein)m)qP4 zVr;gZ>^hw)k383urY3Noblw4N?y*;lRR9~93z&Nw|{!t3qiBIzp0+Vz&vFyfev zQ&f`A8Famb)ihHfGFiYLN0QZfQhFV@1cWf;<1pD7evWCiuu^FqX8T2u*UANYAM@Yt z&Q_rk8hwZ-lf<3WtCN_t#o}n0kB;X;WoAOgpu!X6MvTDlfiXFePS`D=IOo<2;?kXD z<^-W!Hg9ODVemxROGgxFaERA;h4>1)@suzhMf;+h87k%9s9+q|jv58>k;~M^o?}@` zo)TQStio?&33X}tmH_3j&*bxl+h&mTME+{5%q#mm(%ZPJ%f zIj8e66Yt5pN1(gx7UVhIHCU<|b!Gd=?3sXaDNvxeE>|*?JWP^vUV<TA|3#HN2eF9ze}jkJNtTFXA@|yTbu~V_(Ls3Qk7YE92kuhMd5EsL&b=&I`cE zua_3x<3%aev?$Kt8#8#WVMjo_n|vn1IZg^KQXK;5zLut_VQFS{X%qD=Q^j^qqc3_I zw4h%QpN|n9WeAp=+tFcbdWR#PpK1R|M zQna$|A*r*M_NXdlA#6bI&^`CmyQx}TO6TgJJK-!aHJXeaxqbpy6|ql*A)^2@iikqg z`^P-8H0bnf7*>|8ko*#@hzx3~pB`GJ6Aa`6sBLC0XbAMtE@HvXY)iydQkkG&J=2+Y>#8+O$vRCEbG1rdcuAooIJ;bB84>&Or4dfZU&} z+?M!scBI&MsHQ18<}}n^q7$P#X=>4^qe0z}pfQJPZ}LS*FVu;@)5jBP1L9LPpN&AV zfmAO}!fY&Zdk4lr8p{bWkA7&NjqQGToWc`dk{6{HNcj3kNTzaIh8;*_)W=sPyuwm3 zkGy!oYirxO?phJz+2Z-|%rp@Zh|8*K^S5Uip?sq}GgPSH+j^rs-WH8F|5F2@Bra{T z*y-pKEnR))8$j4xq}wM*HX{K{XDr?ry@|G2504Dvz<5yf+Iu`baCT*g+Zoufo-1P) z`OvyI+HZdM=I~QWWWlxxOI^PpGax-_GQ|a8^8gc8TB@^cfznZydmG&gB#}2ipS$fe z#D|H@geXBEJ#>d83N-|b2+4w*^>c-37D?#B?+8c=RCaGZ)aG60(eS8(u38ReCs60# z#qVM7V+0k2(Lu(->yJ~=pRKGhRmB)tcu0}pyrC^vM$!tv%4;%Z(GE!l85`~dC6e-} z!S*qE9An3h#=j95{+DS(*|&YLgmRiW=LVd>e_>PbkHVuj%blbZ8N+zToPI7W#LgVrqsW`S^F1bbXjV(%t~ z^unSBO?2~#A>{EmZ^_d~1IQ>LdQ}>Ofx&j9SQkRG$_feLTp;oGZVVpkPLy0;Uq}#( zf>S0W1fp1gRmSt`>y@w=Vo~LEXwVOg{y(7JM&81%n^Y-8sLaBJ{_sl?UN4#et%(SS zXA8hMrL57YK#_d3KQt{^` z9Gppap_8*}W4w>3vFo*3>1!yD&Lo`ZE-Mz?MU0jh#mzdNliE)tbKG-;gtOuw2#4NK z=kRaA#i?=?J>{c48?A0 z!Dk{dupJK`xR{Ko2H9W~r)uQXO5UQkRmK&6is-FdntwC5r_2#gM33j`c@IFqhO9&X)s!aXDndI8Xjcuu$?*#+eY0i}0%kmYOI=pg%SS1SFJrKPIR` z!1x*1Wh4ZKT1Q~=yeJMfg9*zCFcDJL-U_0tZN9DK>sq>gytTl*F=4D{gWAy zPMTko4c;qG5bSfc!8^9nI&(mh3}RN^_LuCc6iC4S12UB>4-l;z+ej-7zMEbS+doe& z8+Pjc)NJSgmlh)Ic=O%m*C8^A!hF6l+U+oE{5CV?ka3y;?Et-9mKkyV)fyocg<37wR zDzf`&igKHcIDo?sVt%ulUk&j8jE_AjGWZ296=P^ZQ6(*7;H~3z)Le+!mWMP+SMaks z{R+ep(l{t)$3~9G*_LJi6oXp>;U0}GtndUD>84Cy6q^~;%D`{HnWf`YL^voIhH<|2ZLE= z@%!1XTtf+sNt>)BKV0Xc)6b^e1xULHh;UF#B!L8-jMeD``JJK&Rod=6ZNs-!v?o=<|vWedZuqhtEXy~p6_ zDRh}{)<%*^2+>BMI9-|J6_+1-{N+*{2OA8~TB0Gm;i!3|)6Nc(r0=7(uJWC5LYwj3IDqlFx}I!YJg7b5IRr; ze9A2R=@S=4GYVBVDWI_z$>9T67pvdJKQQ>|dz~?O1dTTp=}1Cx zpT>=)9gxNtAETV|n8uVAtitTTzyR{yN$uujC{t~btlq(ibvlqb`57+$%ePJ_fs6~? zvA^}lxIP|t9*t=|GL(5=!3(#ZGz0ED2wMtkAeeR|##>+%i`(LD6H*;tpY<+RFg0f1 zi68?E_;^_JKX~hr`tREBp1lul?K`g(h!so-%_MY-T!G|P>^Cxr)HhBw6XM>4u|5Jk z!}`#FEEoKtam}-%me-DLHj36M5POIaQ$-+;7PEoe#bm_v8^*t(j#415F#j%V|2Y9v z)#b7CQxlcdZr03RvBGWHGpA4`$^0AgGqOWyp+Dk*8qudhJAhbsT6WeSLKDMAVPUqB7nEbcUFS|G+GFgH)5xxhJp1}oR|%_`f}`l0lNkq zaN*gKj{QMOJXWUDU&$el zO0`66ppYx4(Bvq~cQMDSWz_A7b)<9GqW}D;Ty{AivMCb#LIc+lT3!tW5dP!`wpQOD zMTgbgV_-(9KSkAqQT>^K5ji{(NIv1LGS8k~YuFIEOPkbbH*VX!AW0R~SO`P#poYwa zEHfeUm6?V;K?Vl_u|CmZ|2}$KqENW|l_+xY8C)wNbO}lQ;&3k{wR3&&Iou*;7)=yK zKmPMHhh`t^t-ze4z~lz`-|`7m8VAT!7HaNp<-|--S>im;=>zhp^OIe@9FLH>j|0}S zRi5<3&@_^>Fg&=TcBmIjCi!x|;>bl1Op1I8x|ZIY?bBa&FM0{{a>j2f+9zb)0{%;O z-Ye%TFwhfP=Gkb-nHf;H-=cLZO+slQWIjXj`1Ba4%I=^!xLhPTabr~AK&;O2ST%=> ziwb;B+IxdaBC2}#9B9ZH>U5%(=9QS?C)rGJi6E>G<`xEuKh}taB=f1H!~~h5b`L^Tg`bXeLEUj~N8Ehae(W}YE(7PjO6cp7A(Wv6L#Eq0><_Dz z6NoGOB07U;zJtILm~ze0Eve|VnFlrHzhS)#$Lq4KG!BeDfB{?T~tF znE6W{q_3sGNj&<3*Fm1a4$?`^tT2+z>U&OH5+^N5nN7&zA!_-EMiP-POxO~Kf?c$6 zTlwMI3Am0!&vaaAR&kQBqBH7Y@s4~d4V}OpsHw_%=`uP1f>RewOb1kM*9k+rgX0> zF+CW$#CVEk$J)O|29$ayAg2H|WU5>}$MulqS1rnIQVALRpzJr;mawVYQV-HpPo=|H zH0=cGz}p$V7lj=CtJX>jpMUnrQ6M87NIB{U(T`_*@T$klAAI~~ymWQ}h3 zGd=&9B_ZEFM)$fTaW}yw(RAs61Ln)vO|_I&998efkQk|ViCligPZC+mF_jQ|fQz^u zJ*wwr3eGL;shgmf7-N<0uE1v=rVxv@YfOR>vlAY{SyewjO{i}x!)yX5n9CbJaXa}d zWFOz?e0xyNTKQtMTUDe`Ocohf7BPs~kh`b^sn>6;cig!bQCcL{1-JVhyoEUvxh$y| zZ<8v`o>LCK*ismr(uU;Ce)fW~Dj$mtA=+BSJH;;Y_7VouG%T3TW7zn2*npBbYVk}Q zqOPelD&XI>s8-Nkyn%HZauB()qpBs@tFtXhO$m%e2Dv4Bqq`F)5`$i`C$Y8Xh=(pE z($x_w3OA5T|JNL?UU?q*-`SsM78_cz!>J-O1ffos%AXwQ(G8@+5-)Y?`T=V*g@%&^ z7cs$og}SS7g)yr9+aY_*N^HJ|)zhRvC%0s6mq)7}C zqKu;%gv$53WW;4+UdaRwZuNz+@!XJ|+q%v30I`PThf#6*dX*>AbJG8~Fm^LOiaGVl zH<&M3^(V_&gUjyT71OzkN7N7^9nGi(KBykhm(B`t<| zkAqd?!l&VCFJVFEDyYFv z^xbYSgwHx)NGoRPDrR)*=sQZvb?E0-L`EjaHN7LLgm(ae5q!0~Z>#TJLe-=iu^|JwAl{eqfi2b>;t%CY_h$Ma3f`|DxFHmxAuVIEPgb%=ae z`OL8R=;<&{bsjh?jplW0QErqFY>9JHh!bk-{WZ0pu753F96p!x z-$DBkj~|N<3ua8-HxmFhZ+-6CJl@}v&4*+M0RmHuhx9;hjm~+0&WG(uxQrzh+bP6I zw8LP6Z(dKvYdy6Z=6w)-rCk7xeVQZU2<=mGGR}R2H4;duCCzvI^`C>x8P?@Jq`9es z{|%wjre3szUZDZSS`8mCR*TDD5tZF(Q8WcrT@+P&r}c+yS1)MUEgZtb^rclg{sDlD zaDP^NVR0x@ud9S(^%z5{TaUYE|B!iU#36sf-okNl%I1E$@3l>R^dAn~1D*!P95C&B zpreLz*)j)`X@|^p<$OAqcb-N)v+~Nfl;vj!``x7t(dAOD?1C^^tlhe?1@T%`wgX9AG5!O5F~#RR zK%~$Q@1X8laDTXG+^63KbU1-$c%o4rnJzqE(nz`xLV!$Skw_0Gn0CtoF(@nR()e-H zCPDJ;`x~MfI~mixZq}KX(VQkljU8zmAjq~?L3oKQ%=E*wO@)d}{|#1~E2;-+gbR$$ zHlI0{lzSv%HK8+!6@^D?zzl_m;8Z9IqGC6Qird8&uE~d%S?{7Ud&-_8JN(kG+o|s_ zf;kk`TRxOPzcaUifwe+r>|_&X*F{wHU0Gwr$*GzVEKc=qqJf1a!FaxV%1(>`9qef$ zirM6f^JnH^+3Kl~aaGEH(hXy+k~lUXdn+ zPSM>WT#_5h`4)>OAY-SSc~^=l49n&RJ*XWf0#p1w>Z7XW831+d2{tf191k=p?axu9 zv4Dad9{OV`fU-W+^P41Xcd2yK+U{6wQF;i13k@ojO%>G&w@Mj48#$itBZVcdfK<5% z$}3YhUJ84K%QszkG^C?9bic#5&(K3_zcMbx1%9oNClc0c(K-e^uDpj3a>fgfe8HIa z@Sop9>amL0;bNJWT#wY8KBl#IeNEY%?cchcVOhbnZdwaHd^NN=hS&8`IX1iunnbeu zXobM)r)<+E$wJsR2%M%opSF6t4Ozf0Y34vdO_^g}vIhvZ?o_C(yMfP3B-O*tRg|+{ z`owPsxvizGwtm08S#Xxvx+RhjKfiFr@7qK*{m_0gSCe{4G<4diKZ}#296jJUB88!f zdjse^ZvuAq^&_E8abz!8va17)cS#l_+~Lg*7IUVCy9Vzj0qL|0^?urO zn$iE5dJImstRSoXFsdwH?FwT)P`O_3n{)sNc?Pi|{wMP#?*n?MlPzN&Ciw@qe?}#? z3VE|S^PqKFp$+t7oOYG3nYvXAIqo}OsA_(1EhF;f{a@wqzHV2v5cCe5!$4IzPMgU& zcuCIt?j8hbcY?!$bm>z}tJ@iePss-?aAzeCE!9!cicmRt38TNT-<~wzI-LJy2WiR& zMpU&f(+;vo^T?6!UPUz^@LzuxwmsXPwoVsjTUF)H-oZb` z@{S#a!ka_SWzQ1}07NWX^Zn(qsx2d~A_`2%F~E zTDAP$4(4WI&D|o_mK2+aA#Yd*6A$W3$Zxtr#EpGes+lNT` zyk#k)V)x-eZ|7j&;0A_A$PUVV`cfu+qq_?jLo{x;NN!0dE;nS4kD9M(Sf<#V>QJYvtR+cB5-N+O}Wh)@1Z$d&5G^&U$e#b9Ryho2!+ z>Roc$5$X*}_EbIbV%MN?9CYdF;f?tFc#JJov(q`yJSz zlKu$a+I0|yQbNWI5SiFvi0MjG6@IlUBJpv17qc7;6w5aYk)K`V@Cm%@B~6 zXri*EdnT2f*s3s28>ldlj9!6-(}D#CxwU7zXg?9P=p;Rf?7<&h-<#R?{>f`LKpKF3 zbxp_n2BPbO0M8^JKXWGu0H5Kk_BV}-%f!wY?-{=Kmxk#QeJIk#1mZub-j0-406q4t zCBd)Aref7rl+7B(=Y6GObXPPNT~o>@x_0KNKK^_*pG>aGGo~91=uw_;_mZGqT6Yb4 zbBJ$>N4aSk_lCdfQ-yd>N+ads7s!iQ7+Y+TW(tS6I0mWq6er^z*Iva6lL>Qx0gDls z6h+Wusn6pf;)U(q96=uB`bUbCUe~5QNJ7ub%p>M(7`ReD?w{8(lk)bUG-{T? zWOXcIJz$M)*#>wZFKiU&C0wRH7>#PvJcd3Of%M&T0uWS(M1q};M!4YhaJ|)p%qiua z%dl6iG-{7^(o=;|Je0$gTWJJlBZJ%yY|+tLF~v>BRHScIK>+& zZ8R_K7-O2FB59Vk!f45?Ofq^~;k+p0>oWhgv9tS$TXj{>r@AJ8#xVB=fy{VCS$(z3 zrbuZVlQC*6d3}R_lYkBq!U2kmg>>8KR(#7KFy#bXJ(+ob+7dm&_>Ii9?6@r*cRZg6 zD-}s}S3$KovQ-UkWRW>0F;!(DzpPdXi?!R?H)@a+qGGV32jg#R7}7=epj=i6xRXsv z0+hVkJ>6TJ>34~1e{OMWjlJzQEM;880NTWkbK+u5qOHR1k=LccFn!cfPw(eCi`cDHef2&PE`2v1RcqjlW7!LLV~c31ngKv+haH=GMAT-1{4&uis^r&gnfphs#etT^P1Oq*ehlLCJdgdmg& ze(r+qDw*OWZy>nwjw&y*>ZSw z@gYY>Z;=@_L+FB3?b*f49zwqM;$i4W+JbbJS8(Bn%men(XMoZ}AN_~_YeB8g1e4se z&cYa?#9XAY4gexnSnT+y=N-{Sh>9qNULI7n~n#!z?0w5)Pg+sK)eqDn&H>9ev? zGZln>P8q^>E|5s-zztJGAv9sf-%ySpIMfA=Tt3V4j9v#iEfcm+Kh!j3ntmBy zO%agDB9Q<)GyijurqC4IlOb-Q4;R=p<)afQf3C4529;J0knEJ;aMhYnV#uKlZs>C`4y2b{u!APM>P7y;~C@a3i397{0 zE6;vy0WAsd2ns!fnIkADU_{&M2C5d8FdDbOeDa8jb$8`T2d5Yn-snQ0`SLdvFFtr~ zw?LF213Im7vtmjg9YOFAqzY>QIOjMZ7>nb`<91zn3uqQPVl;5|9@brM#Uii7Y5IPA z7OOcXtAP5@5)=92;)C~KLYfsBejZCcc=@a@@AJSUEAC4`Zu|Kw)S<{S3ZbY!_?`Ex zPp3o;%xpX+#$|e0CK)+KqCh!0AP`Zp`)pB3@t&=QltzCa#CYh#l5?x7HeuW%8UYLV z$p$5@`b?lTL^ES)Jk-;Gz7F$GL#d4ME%g2AquJ4WI#U@{2|vZAy3mq%4MgCx1s8)o z0j9wc>M4%&8yt0bc3S@6;GqLbk~N{bpfjjTFc7Ff zLrq@QMtDULVog7ib8T^d3mwo}ze)o#1Lw9B+SK44a0L)c2nd8H#sVM62$;J~ffGWy zLYeTJ7nv{?3Y(>FDh=3A;WwBn^zkC0jT`}W%}jCbQBSbCwzmLdfgO&U;7D3dY@Oczkpzg9brSQi6e=x856T#ldxEDCJM zX)PTAC$Sh5%fexp#D+;~8Ik&G%qvY-W)yT5z|G_l{2J(UW4wK=aDrtdLlkMVU=sPP z0e{Vz=Wz}B!9JRy1aJs)h!%=>VE~-5hUUn@oR(179*i9v#FqsV^&p9|^=jgcDZ#_q zxLrdO9g9xdLH7~H`0f*;kYYcn&j27oUU^7xpbMeN$V0wir+s*nfbqvU#Dt9we4ry> zG%@C5NR94jRT9G1TR=5dm!PQhY17ntzr`|E-VXkK$GH3YI zgbZ(EP54FJn^?=3H12g2v!jP*JMa*7E6UY%7fMCIZsG$% zPiT>6uKYO-&G$LC8@%P_s03Yz4lnnySYT>4Et1hzH%50V)$+6qKj#IdaU;caGK=!O zq<`NWSKT2$HcjOxL@wCzH^VMv1Y>!QmmaYpcB^)*1g4cXH37d+nX@_ycv^WcuiMQ# zEgdVzS!r3>!=#v$S#-(N_1n!tz00V-3pzxwy%g*%6g}{P56#rO;uY4n&I*V#r zO584AKmbY|6p|P=Q}Rq7l*K$zhcVr64$C4ct5CRCgXJNGptoejLb<>$au~bKIPU|y zS-MGv>vVzfxGvS_(LO*u%=n>dvkhv3BoR0_Kr*@D3v}a`JXK78PA-?Jr2zKWT87ve z9P}Wol@TIegsHt0?i_H7)^->$83}QSlw>28BsJ3) zAWl0qGIR*pP8suYLv$3P zuLM?6OAk=jwl z*F@+B?`fOdBrSwzib$x)`Z)1rsPhxy_#xRQ$cy#yRphILeDGl|2!HPd2s}7O2{4O8 z^_J|1*8}9Zu!^$R+%<$m*Cm-5?}aym3`G{~fU<0?dJFL;vOS9uIuE_$Ee59{3L_rT z!tUX8Va$EBpCHJ>cz4*f_F3Ks$l;=VEhBQK(AzQ&ydL`{C874Jk_{1KZyM}F{PHPr zUCA|WoCtYXG9E5Z$-`s6q8oL=dl!h>wgaE3Q7G(Ct@v+=MHeXz40*sTn&^AmPYOYZ zqVpj8=MH*GkPy1yg7g9poJWYb&1xni#*&e2S!3pi3$olz)~OC5-gN;`w{ z!jiV1CyIe9RrsLz8=*L}3=$I495q}SjMiXM)VwJv1_$o;2l{>sNSfHZ-q3zI1r2&0 zQ)br)a8F)0da~Wj5vY7!xv!i-M(A4LCN(-HSlqbfaC3~Ad=;YaTGbHSv&4}XzDiJBgd79?V3G9(^xUBpoxg8y5)Z4<;*!yK5Z9Mcf!B=lE>P*yADv>HWf zwa88NQZ8A}OJsB1>XH(lxUvc}VsYl|NAzNub%WA4PFwG#=9QmFmhqhl$A)J2_c*0> ztbB!H?y!NE$?Fm~DvSb9*p#uKcbV_TA93PT_4SdwN>>b7lnMM;RkFunlq+W`z0a3@ zD#I*pl9Xl$HfyT+$&#N(w!>ciIJmvIdu;G7ZLFg|4-ada$Uq!IXIGWB)!c!2=zOf5 z_}cJh^bXA56xib-n(ylrQYn$v46l~)>g!ZRrKS1`Co9mdfB{QeR8g@T(X);TnlWJJ zn2b(w?f(s+ONJ5>wu2n*;+GtG!Q~AOF9zq{n6?mSpvh;`h2nD^>74}?@xFjT@1Hq37j-ABtH`6Pza%PQbG@^m)_Qx{dXy}&TlED0@q|Qr1JOG> z(bq#9)5_rI?JCJSvUmL@t`EUFQ;RytnKSf9Zgocvh?wzWTKHhbUtvDhDUf>TY~J;| zmPh1QhOe=5kHgF&+b+~Mgy4wjmOTxL>=2jE7dp*s=iiZG)*ls<+4yb`OXT^i2Ll-G z)nn-t?9P5oUDO?QH&&vYqLc;h2^H}I>eFSCoaFrzU7xm(&e?piJPV?5$YtL1nT(yh z%xkb4?=iPo0BwMt+b)tMw-e#Zxcf_--hH*2aZwdKUFnh}6W|(;*YvMTux#^*E{HS( zOVAOaosqA@=gPTv^E%S?Y%>IyMdga!S9nLCG8GNCT$XlRA7Wiqwk@F}V|$a-=r8T+Xy_WMn0}c-k&d~f6OHTR z;l6o34k}DqM~rW0+bqsD=XQwCz^ebG40C)My%$)33Ncl(z`br+nCakWhN%AZ*j+>T z(I_uik1Ffv=ENtMWVMiUdV#x$7d1W@F-dGdl+TtGzhx$JV^7brrsqsJ-_}>Z?Tqzh z;vg~`LHEq*+pp$Xoi-gy*bdL9(C4bhp_TH69GFBQ&0SxPz6h(V>4#vu__4ugPCmB? zbVw}r(!eIjL|&p^<(x}H%hIzmLzeWUHt5`lvFUi}*Sc{rLjIt7Iwo_Nr4#}GJ(pYy z3PHqvKOb=iMNIHKR58?F=+Nfj5@M-j!^RdI5e9LfUU$%dgdK+1=>R&u;JlrIMr7nl zJDYG#c(r<`SUYQ+=p*Nh=$S=d$P=d6?dWMX)6t192yjSm%8jrypH4DIrPxHZVnW)D zOt%#`NV$Isbndr8r3<5e=b!-Sp4OrB-oIFf-u#@Oo8n=Z*d5kZr^i{OjF!zQA=Lgx*93MT(v05)J{qIERayOzu2Q6+JRRgG&U{=soL zs547m=Vb4oP+g_+Z?n8@iRLl~3fnmG!!#$*M4+aXU=t zK3XszNmz6w%%G;UoMv>g9?lkfOkNQO-Iiu}KgYdnFeWrZ=v@W3iqJkL7LQH^LS;u3 z>SdHCT=bW2io7e1sme)0qSKFS?r-k37q!;y`yIOs=R1(+#U}NP?vr!?XFqYVz#zg1n;hH(4rwe_k4THn zmU%y-=FnULp~7M36aaxCrkmB*U>@Zzt~9)My;4lSXhhcOe4(7xq53P?gEm@tw3lFzBeHv^ zu(Ba!CS{U-ri8QhlQ8iC(PSvag-V+N#c3$Ap}E{rzw!qg8t*goobQ&n{R0%Pc6l}s z!vp4rfm;41634B*25yK70%26`C-bZ@DrB0ihvQT=e@R&b`$MtjNrk%XROBe$45J@JQ#Z*NoRj-J??!@g*|M;mp;{*fRVGU312h4tkBa zjkEr9w;Lsace=QSPa>-{aNG#Ly>v~U>Lyc8wsAs~G>||=qn^tHB4Ix$=YV3AGeI|E zgifj7T%H`4q>3c=xe{_$%EVi9J%U?g_rr@I+4MIC8>S&}9~dkz?MA2OMeZUxtoD8>esfUqm;(8ZECBA5n<}ce5*^ zyocf6((KGbEX8fa!);>=wZ7VS${hA%z!%^O2qwHOi`6}$jE5EqScBNymkl}VCpnj} zk)Kft}iOw7L`Y6Ji%jJ5NNkUd~Cypib-|V{F>si z6)WjtsZ{GSwYD^NsG63ksm0j^|Iks=>YcIvBHKVZRN>lSWPH?7=U-HV%9*K8^|04C{W(IxC% z`7KdhcRHyuZ94t>Qpu5iynfc9a=#)XaUoAg>q|roIGmkja)boK+zqQJoE#GFjiTnlr(R&Xv!ujZtSQ7UE zN4O?oL?0|!8}p;d2$2LX7r2koiBiG^EM~O@HM86&)+Yf)@u5f)X&rqtP_XWhYR7_o z!qHWt!yt883*N!cWfa9ub=`#K<*t22Hcv4pi1J4dWh@I2ZnGUJx=|wE=D1DW@Ty$W zPgLfxG6Dm-2_P#Yvz#-fuI7@J*TgN2TiT?BeGE1s=FeGM8)r&vC3zu;S8Y^Lv6Syn z&eG8>!?e3quN-+_mA{&$`#pOJAGNI;cXf;HB_qD(4ybFCV(xe}ThL!r4XV~)eP>IC zli4?r?nJ8@Y+gdH`G#|?b{6?g^G5VA$X!Q|IGF!rf31fbVSFw4i;rYN> zuIRyZ4$SVS)K;VbtSANle8TQ<4gUnn;vJ>&!IZQpKXrNuU~Y_uYkauG`PV7h@Os_L z9>NcXbth3Io2_X_7+RG1N%)iiR07)$bNLwQCdr&Z;eF7NK=0+C((Y30&Ali+CcU>d z#fteeZtMGtb|1*DyKTQ+5MAE9V|BLY@)LdKXPOhE`B2?HW{>Q5tRJ7cpj`aQ4k%uJ z)J4A1X>o^5fFa{Xw7q%_L~;X4%fBvY|=hA!i1gdT%t4 zLOe}WbZ>u$Z$(h^QKuNsyCLxLa7A;JU>P;{5;kUKu3G&jO^q{-)3fYMVZHL9VPO#A zmm5B}vmU5l)r#bCUjQe^$x zQ7{!cl^FvOMmu*I4#{@-ul^AeXEivN=zYcd?EFgyecYRDIbpt>@RI!W zvf#o&C;B^TGvZ<7EwlXopE-bH>fV9n3!w*W{K-oRm(>y0*;c_Ryckic#0cDTJ}?fU*+O95_3<%xJA$4>;Z%5mNV+})I^LP?mEqM9QF9&RrhTxSEy6v;}Hu4ytEaavCKU*U1Ebq zGV=7ljN;1;i4pUxZXlhUA{UhumSFC1O&Pj11n|Y2%KLIC)hR_Bf$-}$pJ1LR;e6&r zsFQs-60?~TIq`B@y5%fUPYe`j<|xsN;N_&>xWCO9ZChMxq`b+Yiyf9`_xD8>?8@m= zSkwfrAtOJg`mtz<3qsX5MbT}wm6TA@ZOVtL*mH63e@eG#*IrUWL7~cPdT@Kr%P7=3 z0^{->>Kc8x07QPUP&~c2GIKXzuPW6%alTXW$Gkt?P9fClB9$JaZF*PZH?B|MH_Q%@ z;=Fl&|?6#-_vOBtj3f;Emf@TDrm2Tr8+{Mm{Ky@tF+c56@vUJBbo z+Vrze)k4zn;m?EbHdXl*nJyM^bc?g$tTes|rd+Yax6uU{{u)#>r?fN{0yBJNpiQAn zW9WGFTSviXR-`kdEQ5n;!hV4xs2D49#Z>J!0%1`huQM?X@TL$C>UC!BGv}WMpRs>T zBzJ-8;l<+1Fy^GoRfq|p<_K443mlV^6~_3L7_P{0?T`($5fp6LnJyN-F50Uy!b zYwDNM{5EM_ZM zxAJ(A!XT0iA}tJ|_{?7r$38*XEW?OrbPZdnry-Ca+AU0Rhs*7gF@+=e7WL5Alse3cax4)=b^J9 zPO$9>dT}m@H7v6TV z#+=P7XZ|Go(deXu%bHX$ua_TM^(`2CA0oVvL3$-)vVi9!P9!;=+*eOZ|AHUZ1{UD^ zK_iD5I8gA|)(5g##z_V?vA>GbX3qIXw~7i~X567uZlYU4oxIHU5IH$o;x7Z;!NHh& z^9UJ8n6SfzDdUfAup4gTb-4x^?27DvtgCg>XevL>!3iS7whP3t#SrY|Oyz4>;&Qwn z?A7rMS&qgll7if0-SC>WhmM_D>8YJNh6>`V1~9quDtU1%il-6_E<+2yJ*>^0YkZwt z7pEYE)o*~6N+@`@k8eK0rWw|9{Iai^KLI|K3w$>tv366c`zsOoZTx_kkhr&Y2ix!8KaitnC?JA0l&}D154F zA~rvJ&&ag*aIV|k=2C8l3G`FF&3=vM(nE8HVTrind%XfBorE}4meYs;rvvW`Y=r*` zAVpRT#uE!MA#ti#*8b&`2yIS$;(~>9xL#Qkh2B}&*kNld<&aiY+VY^^VxOTv0?`ik zq;*~lI=@V0!5zo%=4YN(l@Xez9J$kFiIqyce$Hj5lZ&6b!~*H#ekai=LL`qdp|rSW z5NV~&N^Yh@Q(im$oXdx5H6hpxFo6iSR+Iha{AMm-paPJ!PInW2)A-e^~Ik z&uH*9*8bAAWK~7dPCsi-NFzSqYwf>i@1U9u^_r%apD>yr3B#ePCGH;XU6riq)1#xU zl{|rG`r-NQ=NV{l*FZci<)W&A;yI3w78$)ji1iz0BV0c#FFZ%+lIV8HiB3IN-x~A_emP7H+eS+Um&j46P#k9M zM<4k~6{xiIbHIa14yQ;?zCDT(FxFpIe->CS!k8`8Ag#OC) zK$i>K2t%Nf?_KoqHb%wuK2@}?9N;XHaYS|P>xazKfr4-3J#$I9Qk>mBPO8rCXi1rp z`ACwb_^i{$;9#l7n1piVbcRwfV8oQ|_pnOnZ?!yb!q|LCVdne<+%!D=lZ$lV`I$S^^OXYhh}d_*OchcXCub}!-Vduu2~kSG4GWtz$eSwLAExbx{|Do5*LEet$>B! ziMg=vn%sq@(!?zp&b-d<)>I~xS-uXefjhc2imAeXeZ(9-n zt==Bz1LZOWkH9ITfE&()R0 z?3m{^)A z)wgDw#dopuwIQPt9P;jSuzS8{By{0#F zMfEl}S=99@*TpQb`)^H`Ukf`ZoAgDC$Pq8{I&q)n9fKLjXbo;6zV9WSxXRDTNGt!? zD>|V(DOY6(TM>xd12;l`Br1GknKL)N+lVzKHBHOqySUJucYAMb||9K^G4E7Yz$`MUe_)6K+do+ZI_ zC5H0A%CedT!Qsrt{a4J**xEo9NPad4;T6^7TFH z%R8rGa(_yIt!$>%K$4;~ccm~ops~w8m36iq0kf*;t|3F#9Dz)e9%;1P>P(mv z7exnm(Ha(Wx03Is*&tMW5m@tCDuFh5mRveV{}l8ze|IEHlMBqbqw`Ge#yedT&h|mF z5Vvac=xuk=obLYhvh0d}o@_FE(Qp#0pS`{XJ#1Y00vQ?p?{k~{0| zV5;UA9;q{2TbCeuOl6=?{+QN1E2Y`Z-eX(_dVoNitw{RfNe^DHn?@N1U++_*n>fKp zza0&GefhB2BP4--`aSOh>6daEdg8ejG{VZa=__D<`2bbog#v1#+lP|D|QU{ zz@+hYt=Dp`$tZ;&czo(g)p4byeoswS!)?R{t5Rl5u_+Obuj%8r%%*eS=6$i$97Re8BK zHay;QT($a_7B3sA{h-S{a41ot226J8)=lhbnlGBhls>3tAM(ta52=q8R}Jg2M);^Q zAWEOrI+KiYu^znizJ?rjdwaDtt^F+K{n|^|W+a8WS}P~-_Ru0PPkZ}S!`2WynJbcb z9u&Nxh{u#`f;G1p3VFRZ@3H12xUZM-mIquQ_c5q+m>3G2OiPk+>t~<2*(WgQ6P~aA zRQ;9urf!!>ENK4Ly%xM;l5ej2JDTmt1J}z|c9HgLYPT2d$u;G*O?I~kMlwe794a+% zvs73P+WluzIv;<`SNI#1evu*e3<}N@W^@)ly>ow(B9ZF)K2b~**03cuYCqeB!CqOy zcaZgAnI12gnVnuJDd>`VawLE--#^HTI{=Jl_bORp1mPYRCF4y)}iw5 zd^i_5{``Iz37<5>wOFw?txs+sy`b}y+kkY6cegRxy2dx#=IPq$%?I4_rvYKi;G^cL zOHIh@(VLea6?K@ycSZ8jKa`N&o-Rs1`^xU1HhtTTTc9tEnm$+eBmO-33al3m^h*Ol zMkB+?57EWPmBzY0T#8Zx&HOWiw>`7-xO{Z&IvZma&zSAeQdtj+~qX)1Di?P>C-IhLoPyf#KM({WCQ7}IB`m#?Ts-#jyGUg znIPLDZ5O%KlVdp{t6G+u0F~>~1A8t{CHZ(%E#u@0_Z?47>U1VppmS*r)uKH2d%P2pQx7H=@E@9FV5TUzgcg^ij$^qY_T5(ERP-1T zq-r`ElD_E?F2SFjg%@hDj)n}fru7Onx|~xetS-$wHAQ(^gTftXQ8w{oUMb1Yl9}3! zvcsR4laRsG8EcUvI}33E-l?1A>%{h-YZSSna3UGoC$5u!$a>$IiV!X{o8Kgd*oPH>0g--1{7pK8eeT|@7mu4N_UZhn z*z&?vj@~L_Onu{`tp&d9Z18H+$jY!m7OD5SKP={Bp%x@H_wjrpqfxcJp!@!seQS@* z)^WsK{i%vDy0j)gk7vXXJ?AP;;Is{!cTezaTA+_PxhalA!EE^HV^rBM!Ehp!bT zR~r>#nDp|eK7anKWY=Okfh7W=eyK@qgHaXPGT)WvZ?wC%H0qCEQ0cMgke=45@7XH<5E(*>aYEx0s9$L6^(;8)msYn|RG_@r*TX zsq0Mo+8fB{@bO=kd@U>Pa%N5o#|NNS*tkz6?)Io8@KqT;@T(w8(z}vu3HWdAdfK}B zrxV*l9*>jPJl7Al_BF}BpT{#A}zY!PI3P04D#~uUG;iWTH~?>f=iOG zD)&n41NuCU&5Kctk7v1KSoORKU3;h2hKo3bqvc0?BFj^Ws4sRu*i=ZoW7|_Ke7Kb8 zi_dZU@k3i$0%JW%^d7eMzDRXoWqly4JnAvh#!TyK$UFz9t6-m#kY9rFee z>d>9tvvQXOPEGjgN47|PmUgcH9sxSHCNE6l zFB~#g6qNR0{UJ(h1@^o23hp^sK`ny{@9MHaKAU!P13`dc0BPVjVAHjCx;U;#W&A0+ zfpPWRl-GAixBFm2z^;dRV$;p3DBF$UQR$^wFI;jA6H+@0C19g8>{2jEU*r~j_}vW0 zZ91f}JX~Jfe3kr(0}9hq;)xbLcER;w+J-f6JLR*%RsbNys{(qV-*m1cY+Pin1wrR2 zG>Y8nR~Qf5XkF0E3*Z!Jt=`$D718kpIg}#sH+4@}aVMipMDKLd_@eW0E9ApHqs5jHX!gAhR;}(`lD%XrEbo~voetu3 zFJ4}MRpFl&^INGsS9%?+3(;pFUb$Ov zIiKY^o)^<^yT{Gm=w2Kc^KLY-6hV1sX1U1j3gZFSJ%_r@!24-tgw zFnc`u=r`E{s;}`5)#H56zW+jw8vLoLFDqCXLoML#;TK;%x6Cu^EOoTjV@4N78vSlK zhS*$^pI&-7*3f|46hkXKSSp`>m3`BEx@WK!{ziqc*;9*r8$AP)cQ7w%sPKGA8qmKtJ=!^ZGEw2p+r% zs&#YGpeIyAx$rCnP3Z!bya|woE7miexb_7r({uJ38$DTjDE(yV1CzfHQLx<2l32j7 z)>H`=%SawZd3YE{T)jp;!5$W`PdzwwD z$n=%|pHIt+w!*7Z6~=EHLIMC@NB{umzxTAfg{h5=k)gA`DszJ@DaUpSQE~)8mFQ z%pWZ^^7SKw*y=|(k!?QCB5D==t(^NCo|vUfA;tCAaM*$y@kWKw`>zJ7r6%0*KiCs$ zSF(c%+edQ_Mz!7uh9HM>BY*BZC3P53fpK+v~>!q(2yBIGzcYMH;ZPKojJQ_GQZM-{0KWrGhfPc zLauEmU*hk#2VJ0ei3sUt7UGdaScm#T_MnsxTOEu?|>m<-{SCY1is=b$pVDv&P3=G4lFMk~nO5*8{#kbJL zwZ|h*$fb|Q@|OPn8PkR@`&efiw~Aw8@_D%BsEq0(e8ALUZCD-D61hbODz1`SM&J&&knj>kfAPQ$bU6{4>Upx@<;%Ri1^wX z(0C2P=_Z|9QcK5j(gCe+ULM-q)mneQWHc8ILde*3w*cBrl1MveIp?v)7R|Qo-x^%4%R!_E~nK_q)VMSe)Ze z^f@|jl3)#OXYNTO!diBgmjw)^E7I|k1V+YMdw4_C;nY-mi~J1hc!Z8|UANJM%=&X> zQZMZCinAyLK4JS1ZaQN@{pTbQU$1RI*Uci7Q~^axLQFf!19A|QR!Sl{oDUO^3Uv;+ z6$`dj&_N(xg;uIMuGb`TP&G}1AiV|26$&&ea+su?%AyOuq3)eEMJ0{094Oh5%U65X z^i-<4=^`uJHA=;Am$pZtxlpJD>t*IF*a_2BhbK~3kODsv?D%=ZUA(bJWNB7tUr79G z8-uV}!89sL*;gV+nlAAwBneLs;_+VkP77Zd?oCk&tcV-LHzPaBWfdpbV7+vy5PCVy z1t`CBI7CrvKyp3F+<&XYTE15UZ6OL~HNTyG$4kj}oL&DJ4ZFt`S2{h2AaU!ehQjFR zvleQ`!)!O6a8f+ZjS1$>a~{3%)k6Eh`OTxZ`RW9;SPI|9vnwlx&cd(a20H4;#4pdo zj>gj4(H{nGa9ukC7q>%TQLiY4^dB}dw~m0X_MCw+G4gwIIF!r%E=}KtnYffYmr$-W zo1uf5pVdOc-YR?j1rl#}*OnBz=lrHEk377?nSLS{NBx0I*b}U6lx@T5hp04j-}u>= z<;VTH9>21ix1P!yUnMH8o=a_qH8V8<{Bk0FTylla4SHzDp$-8u0J$yqcG(@x(E@lF zfu`=Vsu2WCxws=DkBfJjATH@U>O#FkF8Nbi+=!eX)fgCNdY_%7WvwCLg>Xkz>bzdL z1!^SWaYnvoS7svh3>LveT=1^&(OUXbS^A@IvRNdC4Lqh}5&24;X)R7baZTjE&}Y*G zUd-QB{zJj1osxqWlwv#)Mk$oO> z)S%2UHUX8xkNGBffxTFa;VBVAJ=i4sNpM}dJB=-*iGo;CZlpWUlfdN@+UM`BC{MsB z(CkD!jgNp_M>3-&tDGvq!mFI#z~3dJNGGGIG@;F*&E87ipjRs0{%~(g zMt62`k^ClEcAV}3OEkjSsRQ_@u-333>RE=`esMrS-+_e#0QqkV3slFM4k+~dJ19`p zl;}Fxeg>@IM}duPi7JTvonIYKNOmXj#g+(zUs?R5OZYlycM9kbq1?O)#P@Vd&%xQ= z(sYYBKAyj}&*D+%o?gUHZP(VY(Cl&B%!tJj;^0s*C7V9mQ?IuBH(V<@gHe!H@AfLV z)(1zy$%;(J?Y|fEMVtI=sZ&|JPR)N=Kw=ZIeg+X2x-KxTGoZ@(r>ayv?`nQe-#{0E zYAygn0?z+XRi=OHnyn~kHNb$>NqP5y4 zlYd;q`{@&RVfJ#u!U!yyoXi-Tlt^MRW-$~c1S1|>jK5^=khHZc@(gG34PE-i<$h5P zbBw_2;2z%D422+X{=Jjt=dtc|X49C)4#(TjN;d2|!_1JYhxWkRY}21w@P6#N?9bQsSYCs|3_;#0~XOgK?}J4mr$Uwo&K;gaBpX5YpVaZ zhV~EZ|1nPdjywgOQ3Did_=W>f&A=k^C!`Vge~2_O{d?5{>-(?7YrvGo=ZDdEX`p3O zfUQpWPed7DrT@>p`R~d({j=E_+Ijq;DzN)9&@uhRedKv4Yp9R5eL4UFg<=2Ne_w&! z`9A;}+gSb$2E1+jldtkN_@+T5B}WMf^np|;0D#b+v=alG_dkIBqXYe|Q~ia96C
Yf_`{OrK7rIYH90Oa@WROx@i{;$}{*2Tuz(&>-8e>w*z#@~CyPdEi_ zW$M-^BNYI^9R&m+^*aRMWAyJ({@w`;9UR;ofnPxXNB!M_Fm^L)zhn179Rf5)(&|2vq!M!vsu{xwYfowN5JaQ-W3{hji! l5#sNZsf&MKn?ERjix(B7A%HOj0DunsD8m2%U{`+}{ePlXsp0?t literal 0 HcmV?d00001 diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/repl-0.1.2.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/repl-0.1.2.tm index f2977c09..f976ae57 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/repl-0.1.2.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/repl-0.1.2.tm @@ -3,9 +3,7 @@ #todo - make repls configurable/pluggable packages -#list/string-rep bug -global run_commandstr "" - +# ----------------------------------- set stdin_info [chan configure stdin] if {[dict exists $stdin_info -inputmode]} { #this is the only way I currently know to detect console on windows.. doesn't work on Alma linux. @@ -19,37 +17,46 @@ if {[dict exists $stdin_info -mode]} { } #give up for now set tcl_interactive 1 +unset stdin_info +# ----------------------------------- + #------------------------------------------------------------------------------------- if {[package provide punk::libunknown] eq ""} { #maintenance - also in src/vfs/_config/punk_main.tcl - set libunks [list] - foreach tm_path [tcl::tm::list] { - set punkdir [file join $tm_path punk] - if {![file exists $punkdir]} {continue} - lappend libunks {*}[glob -nocomplain -dir $punkdir -type f libunknown-*.tm] - } - set libunknown "" - set libunknown_version_sofar "" - foreach lib $libunks { - #expecting to be of form libunknown-.tm - set vtail [lindex [split [file tail $lib] -] 1] - set thisver [file rootname $vtail] ;#file rootname x.y.z.tm - if {$libunknown_version_sofar eq ""} { - set libunknown_version_sofar $thisver - set libunknown $lib - } else { - if {[package vcompare $thisver $libunknown_version_sofar] == 1} { - set libunknown_version_sofar $thisver - set libunknown $lib + namespace eval ::punk::libunknown::boot { + variable libunknown_boot + set libunknown_boot {{} { + set libunks [list] + foreach tm_path [tcl::tm::list] { + set punkdir [file join $tm_path punk] + if {![file exists $punkdir]} {continue} + lappend libunks {*}[glob -nocomplain -dir $punkdir -type f libunknown-*.tm] } - } - } - if {$libunknown ne ""} { - source $libunknown - if {[catch {punk::libunknown::init -caller triggered_by_repl_package_require} errM]} { - puts "error initialising punk::libunknown\n$errM" - } + set libunknown "" + set libunknown_version_sofar "" + foreach lib $libunks { + #expecting to be of form libunknown-.tm + set vtail [lindex [split [file tail $lib] -] 1] + set thisver [file rootname $vtail] ;#file rootname x.y.z.tm + if {$libunknown_version_sofar eq ""} { + set libunknown_version_sofar $thisver + set libunknown $lib + } else { + if {[package vcompare $thisver $libunknown_version_sofar] == 1} { + set libunknown_version_sofar $thisver + set libunknown $lib + } + } + } + if {$libunknown ne ""} { + uplevel 1 [list source $libunknown] + if {[catch {punk::libunknown::init -caller triggered_by_repl_package_require} errM]} { + puts "error initialising punk::libunknown\n$errM" + } + } + }} + apply $libunknown_boot } } else { #This should be reasonably common - a punk shell will generally have libunknown loaded @@ -2817,38 +2824,41 @@ namespace eval repl { namespace eval ::punk::libunknown {} set ::punk::libunknown::epoch %lib_epoch% - set libunks [list] - foreach tm_path [tcl::tm::list] { - set punkdir [file join $tm_path punk] - if {![file exists $punkdir]} {continue} - lappend libunks {*}[glob -nocomplain -dir $punkdir -type f libunknown-*.tm] - } - set libunknown "" - set libunknown_version_sofar "" - foreach lib $libunks { - #expecting to be of form libunknown-.tm - set vtail [lindex [split [file tail $lib] -] 1] - set thisver [file rootname $vtail] ;#file rootname x.y.z.tm - if {$libunknown_version_sofar eq ""} { - set libunknown_version_sofar $thisver - set libunknown $lib - } else { - if {[package vcompare $thisver $libunknown_version_sofar] == 1} { + apply {{} { + set libunks [list] + foreach tm_path [tcl::tm::list] { + set punkdir [file join $tm_path punk] + if {![file exists $punkdir]} {continue} + lappend libunks {*}[glob -nocomplain -dir $punkdir -type f libunknown-*.tm] + } + set libunknown "" + set libunknown_version_sofar "" + foreach lib $libunks { + #expecting to be of form libunknown-.tm + set vtail [lindex [split [file tail $lib] -] 1] + set thisver [file rootname $vtail] ;#file rootname x.y.z.tm + if {$libunknown_version_sofar eq ""} { set libunknown_version_sofar $thisver set libunknown $lib + } else { + if {[package vcompare $thisver $libunknown_version_sofar] == 1} { + set libunknown_version_sofar $thisver + set libunknown $lib + } } } - } - if {$libunknown ne ""} { - source $libunknown - if {[catch {punk::libunknown::init -caller "repl::init init_script parent interp"} errM]} { - puts "repl::init problem - error initialising punk::libunknown\n$errM" + if {$libunknown ne ""} { + uplevel 1 [list source $libunknown] + if {[catch {punk::libunknown::init -caller "repl::init init_script parent interp"} errM]} { + puts "repl::init problem - error initialising punk::libunknown\n$errM" + } + #package require punk::lib + #puts [punk::libunknown::package_query snit] + } else { + puts "repl::init problem - can't load punk::libunknown" } - #package require punk::lib - #puts [punk::libunknown::package_query snit] - } else { - puts "repl::init problem - can't load punk::libunknown" - } + }} + #----------------------------------------------------------------------------- package require punk::packagepreference @@ -3543,34 +3553,38 @@ namespace eval repl { if {[package provide punk::libunknown] eq ""} { namespace eval ::punk::libunknown {} set ::punk::libunknown::epoch %lib_epoch% - set libunks [list] - foreach tm_path [tcl::tm::list] { - set punkdir [file join $tm_path punk] - if {![file exists $punkdir]} {continue} - lappend libunks {*}[glob -nocomplain -dir $punkdir -type f libunknown-*.tm] - } - set libunknown "" - set libunknown_version_sofar "" - foreach lib $libunks { - #expecting to be of form libunknown-.tm - set vtail [lindex [split [file tail $lib] -] 1] - set thisver [file rootname $vtail] ;#file rootname x.y.z.tm - if {$libunknown_version_sofar eq ""} { - set libunknown_version_sofar $thisver - set libunknown $lib - } else { - if {[package vcompare $thisver $libunknown_version_sofar] == 1} { + + apply {{} { + set libunks [list] + foreach tm_path [tcl::tm::list] { + set punkdir [file join $tm_path punk] + if {![file exists $punkdir]} {continue} + lappend libunks {*}[glob -nocomplain -dir $punkdir -type f libunknown-*.tm] + } + set libunknown "" + set libunknown_version_sofar "" + foreach lib $libunks { + #expecting to be of form libunknown-.tm + set vtail [lindex [split [file tail $lib] -] 1] + set thisver [file rootname $vtail] ;#file rootname x.y.z.tm + if {$libunknown_version_sofar eq ""} { set libunknown_version_sofar $thisver set libunknown $lib + } else { + if {[package vcompare $thisver $libunknown_version_sofar] == 1} { + set libunknown_version_sofar $thisver + set libunknown $lib + } } } - } - if {$libunknown ne ""} { - source $libunknown - if {[catch {punk::libunknown::init -caller "repl::init init_script code interp for punk"} errM]} { - puts "error initialising punk::libunknown\n$errM" + if {$libunknown ne ""} { + uplevel 1 [list source $libunknown] + if {[catch {punk::libunknown::init -caller "repl::init init_script code interp for punk"} errM]} { + puts "error initialising punk::libunknown\n$errM" + } } - } + }} + } else { puts stderr "punk::libunknown [package provide punk::libunknown] already loaded" } @@ -3594,6 +3608,9 @@ namespace eval repl { } else { puts stderr "repl code interp loaded vfs,vfs::zip lag:[expr {[clock millis] - $tsstart}]" } + unset errM + unset tsstart + #puts stderr "package unknown: [package unknown]" #puts stderr ----- @@ -3634,6 +3651,8 @@ namespace eval repl { puts stderr "========================" lappend ::codethread_initstatus "error $errM" error "$errM" + } else { + unset errM } } } @@ -3682,7 +3701,8 @@ namespace eval repl { thread::id } set init_script [string map $scriptmap $init_script] - + #REVIEW - the same initscript sent for all values of $safe and it switches on values of $safe provided in %args% + #we already know $safe in this thread when generating the script - so why send the large script to the thread to then switch on that? #thread::send $codethread $init_script if {![catch { 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 new file mode 100644 index 0000000000000000000000000000000000000000..fcb76636a0670797560a57e80a0d00bf7c4fb42d GIT binary patch literal 9910 zcmch6dpwkB|Np4Aw#4daD|CfI>sYJJ6gH(zDU?u5+-B}!n3K6@oDWZIN@q$3gi4f< z5{lCHXp;(U(!r^sT9VEbI()C|o*9Q`c=q@FzOV1}$Bg^FuFv&3zCZ8l(-_e2qZQ2J z115`&g8-J$8#vP0fX%}gxB&14I3MRSaE2jRjr)mM0-OLiTmxTuidbwRiwodhCZP{_ z0^rXis8l3M$O9anh${pE-bg5X#D@~b^g9t~En*9C0T&ap{Bd>=5OL8yf(L}&m=NHB zLIFk>;tZh0;W79;h5;X=`(j?Wfj=%FSUfIZ^4Lf{76G6J1jfOoPcQ-)3OS@P-yGj++7@HN016LN8$pZvkz~T#OVYDz1GGHfi3@#8r z7ivn5C%qvQd5Rw!g0)=C6M7OlmVraRaadd&=`VuM_?Xb!5a{xG1i?aU2#kqCufSD& z0K+8|u;@bQGQv_%bHJft1OCGJd>Dq15GWMsE>A;bpSI*Z!2N)xCI}4$Gh9hq@jw*5|o{-c&OgdvvIB$L;>wZG+=HHjNxJdE))s4 zAS6uI+p^oN{_AZPz_s7ugDHtlL;*ukq`gSSV)Pn)(2_+!+iJ)KRzMqyk-J2`snUZ( zGda1TC4*Hc_X&vQ5T$q^00(r83$qw?3aG4r#}}|5K(m8nltrFo z(=h^f7Xz<5fqQXqE(9D`1aMq0h>UDrKyRJ()eEfYL8??CUAcS&6Nn^;SyK|5jpe-v{7VXhl$S874KWj)Vm1r-ONRx2~+C89FUB&RNJ)qPj zihS!a?SW^~$a3u~yl>wArz%9~(@%f40ONYWe%Id)F&NYO756u10GOsUus};hz-|V! z02jbkgrdy=NW5J0kqbOwvH8kE2;X(f4O6PH5 z-vk4)2(E(bafSg51!7aE6G|J2%o$+-XTv}Yp0oWOfFwz5lo5nNBv;x0 zH+9Cy2qq&(;vt>K;lK_{0J2IEJ%bFCG?oS+L(Pix-^d6C0O=-Xu(0F6=deOB7*AmUPvA@PU0EJD zAlXR2z}~=s)ED^TP+?cu1Q{GwHI0nKsbmDxTU=6u24E%cZPpy&>r}t~XrrZ<|sD zq~E012qA>RzB?!Z@1GVH7X4CJf~{a73Jbgi_tk?1V8S*BFZpg5Dz&owfoc`YfOk0eQ9Ra?G?y~NR$Pc~!8%{g^W10S zX(DAhXf6af7IGfxbkwlmZ!|;E?#F2c*HwNf!{noY7Q`a4s|V06K!`lyodjORd9d^` zb^vOps1+iz0kwmpwcdFXyd%L|Ke{7{If*~cWx-_-Q2PdCko}o)6ghp}X`borR z<8aglOdt=3+y-_PkpR++|1#>b&2vcFsKvzCY){B{QH7yy04q>Rs^n^`waUs6I77Zc z(il1<`mmiM-;lI`14lLJ0dyn*4B#XZHb3}IoH&r$K$4B90s&;XBPvVT!qXN{fBFDs z$dW?)rC9t8WAC-6TN4#Q@{U^Ja0H$ZJcms*s$r?g=D)v3h zR&spI0G>gRIdVlX_>vJXpF~_3E3yK6OA%dt*l;XhIC$|PZNJgf5y~M4$8fp~AX|d8 z0)-x)CMg(r^+F^9O2?%0VMM$8#>)MHR9b!HG?@<#g#{@YGed$VRdr|u#UP{&T`4!K zkqtxE30ir;BI1k1IV5Q)Dnu^|;k za{dnx9UUVd)dzngfBhivDr5CObF++Z1|Av~CYi8&JDHaJ4+HHR;6wkv(_14jry&6M z4LzsYuNXdJB85Wvo|3?JcP;8!^Xcel3WcRkp=iRV(k4cV5EvL6n*5AzM{r0({)SEU z;<_H9?&`QNw1__wA~mnmuczq;v7I|@={hTCy}7gI#vwmFr{TkXd#kD9!KdgQeEPMK z_d(exlKrCA;Of5D=jzG|t6bG@TZV`KHbGr)Ox%42OM_t(%+Gxt9KZ4zR4iqbzXi&*_+^Wm*|?~{2}hax%p z)0GPX=F}Y1x_0ljUA|@X_C2|uxi6;GgeT72c%j~+jEPis|~S+i_1z2lo!E}Usu zQpF72GxL#^`SQ1p%l6FMTe0`g<4;6eCapIqKXE1XH%IL*U!w8p=L4Y^FP;v?)7 z?q(O&54+Rq*qPM${N|Xpg09Cr zvn2hqMhA~}JX`i~eR1a(+mi>CnUrRybsmaY$Az?ISElDSwkq<*WPhrQQ{{d%`*(HJ z#ispp9x)F$shmAkSGs(Xvt}pUzx}j>MQoq3fJ6||{MX9azxCnJl#L~ti z9qFMVKi*V1zN}(`d4)n&*?GMcpYJaTzZ$tCc5$pj$n59^d9ymLZ60m=;JasGi2s`l zzZ}o7b8xA^^7Bvl7G1;AHY8o~nbi8@lS8%X`DV7Z=~zm>gFT;Gb^OwUt8A-MusqUr z=i&1y8^_-5tS{|u(NeEy)lEB^($Zp}e(|CGuGYYh4wnyPo+vN7^KRp-gzkp6*NoxW zei7#PZ>71F+1&eWewO8J*Wkrl6z81bZ~suJbo$Z1bAP-&!^f?#E$oF-vSnL}+Xf5E z!x0YmLPCOqE(bIwuB=Wt!aH4+NZX)1(!Z>}y(Rcr&B@E<>4stZGE9`TlrlPgKV8OH zYOwIe`l5Y|(Tb&OvF##_w&L@-FNGB2_e-ofo=R04LTacT#kAR0&ZiC;ctmL{S8VZF zHKprni{2CcEFWw2?fOn{pWAJop0nZT6@Faw75d)Dkji~Tj(>FN*3w4iGQNvdaA#St z=XVj7<2{Wu_TQ|#@KbD$sX{{Xq^>p3f5|2;{V{S&40U8|f*;jH?e60Di{qB8U1**2 zcFgWXrZOX2$2DPzC!0MEBX%e!6yz=q{?4zYXJ>tN)c&3>-l)p(arL9p@8A70#n))Z zUncA`9v)^2{E`D&rBf^8lP*nr{$%HK3m*7-6ueS)zFy!^pyaB(bj5D4kUgWb_3()D#dS6}Zv~_(wWe=*@bm98 zqjdMD8MCZtYnMOLvdKQ*&>&Eut`;4<%?}|N8+Ww{B~5BLZhO&f4*Bh@Mw=$z`S*R}hnxAgAQ(MH2Z1#TdQEu9;AbbHg9YV!y0COl{7_cR#Y zi)x!Y%;|ISmvs?*i;|Xm6IvsSlaIU(h|W9+eFrC<}z@nyRV;JzT>@1OApt@MNRLS;?$pyeB4+_)c79{U!%LN&G(jm z&aBkN@Ra)Kd(2YxDWg5oEPVW%OR>_P6~w$#mwFs>u4jDEFD!1ZCVvZ#*<1Hpm&x6XG*nGf@SIO}nI z&GdVxM!#J*1N4l$txr8Twq0dsqV>!6BY5zq{e{jt5#A3pXfXn#R`X5C`c!9YX12x0lsi{X#iUhv8 zh>Nv5HB#2kHh*qzylT8&dBTy!jh=}`+r8E~pZ&?v=c4Hmuy#eZ)1;{BU%I=M{I+-1 zTM+)m=fZvR>Z-q3A7wQ*t9sov%5rwQRlOrHL1#;GN>*XvOy5hWvx1KTjw2fiBKd}Vac8j&Atyp2bS-aawiF5cAyd<}p#uokgvT#J zcw@KG@ZKl$N0UugZhv8lH6$OKZE`08Ia`z+0UxV}` zT-NRTNnd?|uS4wh>ld#nd>z?G@nY1hT%)>ziYpZ;6yM<#$_&cLAt;{VYU@QyR$71k zI*dY52-~xgS7$snx~lpVh*Yo6YTznFdwlPI?Zo2KYqn`jjM*7;EpGO8zdi1jw^tQ0 z?>|fAJpUYMdrGl(x!ci3meidfvIIAB-^LLl1(Tq1-L(0wYJcCFX{Tg%I9ao0ejuAY z{rQ2%<(r;#{-GO}oN{XAw5{}KHqKGYKY8kTH~JKgpJ&R$o<-(&&V1`ws#R=tKHc-? z2j`PlDpL(p6-(YbzGi~v=`hkWX`0fW?t~udUurwz&&Ed_ z+oih3#$wf^SaGKfx literal 0 HcmV?d00001 diff --git a/src/vendormodules/modpod-0.1.3.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/modpod-0.1.5.tm similarity index 92% rename from src/vendormodules/modpod-0.1.3.tm rename to src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/modpod-0.1.5.tm index 540a1696..63875951 100644 --- a/src/vendormodules/modpod-0.1.3.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/modpod-0.1.5.tm @@ -7,7 +7,7 @@ # (C) 2024 # # @@ Meta Begin -# Application modpod 0.1.3 +# Application modpod 0.1.5 # Meta platform tcl # Meta license # @@ Meta End @@ -17,7 +17,7 @@ # doctools header # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #*** !doctools -#[manpage_begin modpod_module_modpod 0 0.1.3] +#[manpage_begin modpod_module_modpod 0 0.1.5] #[copyright "2024"] #[titledesc {Module API}] [comment {-- Name section and table of contents description --}] #[moddesc {-}] [comment {-- Description at end of page heading --}] @@ -63,38 +63,11 @@ package require punk::args #*** !doctools #[section API] -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# oo::class namespace -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -namespace eval modpod::class { - #*** !doctools - #[subsection {Namespace modpod::class}] - #[para] class definitions - if {[info commands [namespace current]::interface_sample1] eq ""} { - #*** !doctools - #[list_begin enumerated] - - # oo::class create interface_sample1 { - # #*** !doctools - # #[enum] CLASS [class interface_sample1] - # #[list_begin definitions] - - # method test {arg1} { - # #*** !doctools - # #[call class::interface_sample1 [method test] [arg arg1]] - # #[para] test method - # puts "test: $arg1" - # } - - # #*** !doctools - # #[list_end] [comment {-- end definitions interface_sample1}] - # } - - #*** !doctools - #[list_end] [comment {--- end class enumeration ---}] - } -} -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#changes +#0.1.5 - Reduce pollution of global namespace with procs,variables +#0.1.4 - when mounting with vfs::zip (because zipfs not available) - mount relative to executable folder instead of module dir +# (given just a module name it's easier to find exepath than look at package ifneeded script to get module path) # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ # Base namespace @@ -124,13 +97,6 @@ namespace eval modpod { - #proc sample1 {p1 args} { - # #*** !doctools - # #[call [fun sample1] [arg p1] [opt {?option value...?}]] - # #[para]Description of sample1 - # return "ok" - #} - #old tar connect mechanism - review - not needed? proc connect {args} { puts stderr "modpod::connect--->>$args" @@ -351,24 +317,23 @@ namespace eval modpod::lib { set opt_offsettype [dict get $argd opts -offsettype] + #mount_stub should not pollute global namespace. set mount_stub [string map [list %offsettype% $opt_offsettype] { #zip file with Tcl loader prepended. Requires either builtin zipfs, or vfs::zip to mount while zipped. #Alternatively unzip so that extracted #modpod-package-version folder is in same folder as .tm file. #generated using: modpod::lib::make_zip_modpod -offsettype %offsettype% - if {[catch {file normalize [info script]} modfile]} { + if {[catch {file normalize [info script]}]} { error "modpod zip stub error. Unable to determine module path. (possible safe interp restrictions?)" } - if {$modfile eq "" || ![file exists $modfile]} { - error "modpod zip stub error. Unable to determine module path" - } - set moddir [file dirname $modfile] - set mod_and_ver [file rootname [file tail $modfile]] - lassign [split $mod_and_ver -] moduletail version - if {[file exists $moddir/#modpod-$mod_and_ver]} { - source $moddir/#modpod-$mod_and_ver/$mod_and_ver.tm - } else { - #determine module namespace so we can mount appropriately - proc intersect {A B} { + apply {{modfile} { + if {$modfile eq "" || ![file exists $modfile]} { + error "modpod zip stub error. Unable to determine module path" + } + set moddir [file dirname $modfile] + set exedir [file dirname [file normalize [info nameofexecutable]]] + set mod_and_ver [file rootname [file tail $modfile]] + lassign [split $mod_and_ver -] moduletail version + set do_intersect {{A B} { if {[llength $A] == 0} {return {}} if {[llength $B] == 0} {return {}} if {[llength $B] > [llength $A]} { @@ -384,12 +349,13 @@ namespace eval modpod::lib { } } return $res - } + }} + #determine module namespace so we can mount appropriately set lcase_tmfile_segments [string tolower [file split $moddir]] set lcase_modulepaths [string tolower [tcl::tm::list]] foreach lc_mpath $lcase_modulepaths { set mpath_segments [file split $lc_mpath] - if {[llength [intersect $lcase_tmfile_segments $mpath_segments]] == [llength $mpath_segments]} { + if {[llength [apply $do_intersect $lcase_tmfile_segments $mpath_segments]] == [llength $mpath_segments]} { set tail_segments [lrange [file split $moddir] [llength $mpath_segments] end] ;#use properly cased tail break } @@ -429,27 +395,29 @@ namespace eval modpod::lib { } } # #modpod-$mod_and_ver subdirectory always present in the archive so it can be conveniently extracted and run in that form - source //zipfs:/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm + uplevel 1 [list source //zipfs:/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm] } else { #fallback to slower vfs::zip #NB. We don't create the intermediate dirs - but the mount still works - if {![file exists $moddir/$mount_at]} { + + if {![file exists $exedir/$mount_at]} { if {[catch {package require vfs::zip} errM]} { set msg "Unable to load vfs::zip package to mount module $mod_and_ver (and zipfs not available either)" append msg \n "If neither zipfs or vfs::zip are available - the module can still be loaded by manually unzipping the file $modfile in place." append msg \n "The unzipped data will all be contained in a folder named #modpod-$mod_and_ver in the same parent folder as $modfile" error $msg } else { - set fd [vfs::zip::Mount $modfile $moddir/$mount_at] - if {![file exists $moddir/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm]} { - vfs::zip::Unmount $fd $moddir/$mount_at + set fd [vfs::zip::Mount $modfile $exedir/$mount_at] + if {![file exists $exedir/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm]} { + vfs::zip::Unmount $fd $exedir/$mount_at error "Unable to find $mod_and_ver.tm in $modfile for module $fullpackage" } } } - source $moddir/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm + uplevel 1 [list source $exedir/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm] } - } + }} [file normalize [info script]] + #zipped data follows }] #todo - test if supplied zipfile has #modpod-loadcript.tcl or some other script/executable before even creating? @@ -700,7 +668,7 @@ namespace eval modpod::system { package provide modpod [namespace eval modpod { variable pkg modpod variable version - set version 0.1.3 + set version 0.1.5 }] return diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/overtype-1.7.1.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/overtype-1.7.1.tm new file mode 100644 index 00000000..18fa78ea --- /dev/null +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/overtype-1.7.1.tm @@ -0,0 +1,4772 @@ +# -*- tcl -*- +# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix 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) Julian Noble 2003-2023 +# +# @@ Meta Begin +# Application overtype 1.7.1 +# Meta platform tcl +# Meta license BSD +# @@ Meta End + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# doctools header +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[manpage_begin overtype_module_overtype 0 1.7.1] +#[copyright "2024"] +#[titledesc {overtype text layout - ansi aware}] [comment {-- Name section and table of contents description --}] +#[moddesc {overtype text layout}] [comment {-- Description at end of page heading --}] +#[require overtype] +#[keywords module text ansi] +#[description] +#[para] - + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section Overview] +#[para] overview of overtype +#[subsection Concepts] +#[para] - + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[subsection dependencies] +#[para] packages used by overtype +#[list_begin itemized] + +package require Tcl 8.6- +package require textutil +package require punk::lib ;#required for lines_as_list +package require punk::ansi ;#required to detect, split, strip and calculate lengths +package require punk::char ;#box drawing - and also unicode character width determination for proper layout of text with double-column-width chars +package require punk::assertion +#*** !doctools +#[item] [package {Tcl 8.6}] +#[item] [package textutil] +#[item] [package punk::ansi] +#[para] - required to detect, split, strip and calculate lengths of text possibly containing ansi codes +#[item] [package punk::char] +#[para] - box drawing - and also unicode character width determination for proper layout of text with double-column-width chars + +# #package require frobz +# #*** !doctools +# #[item] [package {frobz}] + +#*** !doctools +#[list_end] + +#PERFORMANCE notes +#overtype is very performance sensitive - used in ansi output all over the place ie needs to be optimised +#NOTE use of tcl::dict::for tcl::string::range etc instead of ensemble versions. This is for the many tcl 8.6/8.7 interps which don't compile ensemble commands when in safe interps +#similar for tcl::namespace::eval - but this is at least on some versions of Tcl - faster even in a normal interp. Review to see if that holds for Tcl 9. +#for string map: when there are exactly 2 elements - it is faster to use a literal which has a special case optimisation in the c code +#ie use tcl::string::map {\n ""} ... instead of tcl::string::map [list \n ""] ... +#note that we can use unicode (e.g \uFF31) and other escapes such as \t within these curly braces - we don't have to use double quotes +#generally using 'list' is preferred for the map as less error prone. +#can also use: tcl::string::map "token $var" .. but be careful regarding quoting and whitespace in var. This should be used sparingly if at all. + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[section API] + + +#Julian Noble - 2003 +#Released under standard 'BSD license' conditions. +# +#todo - ellipsis truncation indicator for center,right + +#v1.4 2023-07 - naive ansi color handling - todo - fix tcl::string::range +# - need to extract and replace ansi codes? + +tcl::namespace::eval overtype { + namespace import ::punk::assertion::assert + punk::assertion::active true + + namespace path ::punk::lib + + namespace export * + variable default_ellipsis_horizontal "..." ;#fallback + variable default_ellipsis_vertical "..." + tcl::namespace::eval priv { + proc _init {} { + upvar ::overtype::default_ellipsis_horizontal e_h + upvar ::overtype::default_ellipsis_vertical e_v + set e_h [format %c 0x2026] ;#Unicode Horizontal Ellipsis + set e_v [format %c 0x22EE] + #The unicode ellipsis looks more natural than triple-dash which is centred vertically whereas ellipsis is at floorline of text + #Also - unicode ellipsis has semantic meaning that other processors can interpret + #unicode does also provide a midline horizontal ellipsis 0x22EF + + #set e [format %c 0x2504] ;#punk::char::charshort boxd_ltdshhz - Box Drawings Light Triple Dash Horizontal + #if {![catch {package require punk::char}]} { + # set e [punk::char::charshort boxd_ltdshhz] + #} + } + } + priv::_init +} +proc overtype::about {} { + return "Simple text formatting. Author JMN. BSD-License" +} + +tcl::namespace::eval overtype { + variable grapheme_widths [tcl::dict::create] + + variable escape_terminals + #single "final byte" in the range 0x40–0x7E (ASCII @A–Z[\]^_`a–z{|}~). + tcl::dict::set escape_terminals CSI [list @ \\ ^ _ ` | ~ 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 "\{" "\}"] + #tcl::dict::set escape_terminals CSI [list J K m n A B C D E F G s u] ;#basic + tcl::dict::set escape_terminals OSC [list \007 \033\\] ;#note mix of 1 and 2-byte terminals + + #self-contained 2 byte ansi escape sequences - review more? + variable ansi_2byte_codes_dict + set ansi_2byte_codes_dict [tcl::dict::create\ + "reset_terminal" "\u001bc"\ + "save_cursor_posn" "\u001b7"\ + "restore_cursor_posn" "\u001b8"\ + "cursor_up_one" "\u001bM"\ + "NEL - Next Line" "\u001bE"\ + "IND - Down one line" "\u001bD"\ + "HTS - Set Tab Stop" "\u001bH"\ + ] + + #debatable whether strip should reveal the somethinghidden - some terminals don't hide it anyway. + # "PM - Privacy Message" "\u001b^somethinghidden\033\\"\ +} + + + + +proc overtype::string_columns {text} { + if {[punk::ansi::ta::detect $text]} { + #error "error string_columns is for calculating character length of string - ansi codes must be stripped/rendered first e.g with punk::ansi::ansistrip. Alternatively try punk::ansi::printing_length" + set text [punk::ansi::ansistrip $text] + } + return [punk::char::ansifreestring_width $text] +} + +#todo - consider a way to merge overtype::left/centre/right +#These have similar algorithms/requirements - and should be refactored to be argument-wrappers over a function called something like overtype::renderblock +#overtype::renderblock could render the input to a defined (possibly overflowing in x or y) rectangle overlapping the underlay. +#(i.e not even necessariy having it's top left within the underlay) +tcl::namespace::eval overtype::priv { +} + +#could return larger than renderwidth +proc _get_row_append_column {row} { + #obsolete? + upvar outputlines outputlines + set idx [expr {$row -1}] + if {$row <= 1 || $row > [llength $outputlines]} { + return 1 + } else { + upvar opt_expand_right expand_right + upvar renderwidth renderwidth + set existinglen [punk::ansi::printing_length [lindex $outputlines $idx]] + set endpos [expr {$existinglen +1}] + if {$expand_right} { + return $endpos + } else { + if {$endpos > $renderwidth} { + return [expr {$renderwidth + 1}] + } else { + return $endpos + } + } + } +} + +tcl::namespace::eval overtype { + #*** !doctools + #[subsection {Namespace overtype}] + #[para] Core API functions for overtype + #[list_begin definitions] + + + + #tcl::string::range should generally be avoided for both undertext and overtext which contain ansi escapes and other cursor affecting chars such as \b and \r + #render onto an already-rendered (ansi already processed) 'underlay' string, a possibly ansi-laden 'overlay' string. + #The underlay and overlay can be multiline blocks of text of varying line lengths. + #The overlay may just be an ansi-colourised block - or may contain ansi cursor movements and cursor save/restore calls - in which case the apparent length and width of the overlay can't be determined as if it was a block of text. + #This is a single-shot rendering of strings - ie there is no way to chain another call containing a cursor-restore to previously rendered output and have it know about any cursor-saves in the first call. + # a cursor start position other than top-left is a possible addition to consider. + #see editbuf in punk::repl for a more stateful ansi-processor. Both systems use loops over overtype::renderline + proc renderspace {args} { + #*** !doctools + #[call [fun overtype::renderspace] [arg args] ] + #[para] usage: ?-transparent [lb]0|1[rb]? ?-expand_right [lb]1|0[rb]? ?-ellipsis [lb]1|0[rb]? ?-ellipsistext ...? undertext overtext + + # @c overtype starting at left (overstrike) + # @c can/should we use something like this?: 'format "%-*s" $len $overtext + variable default_ellipsis_horizontal + + if {[llength $args] < 2} { + error {usage: ?-width ? ?-startcolumn ? ?-transparent [0|1|]? ?-expand_right [1|0]? ?-ellipsis [1|0]? ?-ellipsistext ...? undertext overtext} + } + set optargs [lrange $args 0 end-2] + if {[llength $optargs] % 2 == 0} { + set overblock [lindex $args end] + set underblock [lindex $args end-1] + #lassign [lrange $args end-1 end] underblock overblock + set argsflags [lrange $args 0 end-2] + } else { + set optargs [lrange $args 0 end-1] + if {[llength $optargs] %2 == 0} { + set overblock [lindex $args end] + set underblock "" + set argsflags [lrange $args 0 end-1] + } else { + error "renderspace expects opt-val pairs followed by: or just " + } + } + set opts [tcl::dict::create\ + -bias ignored\ + -width \uFFEF\ + -height \uFFEF\ + -startcolumn 1\ + -ellipsis 0\ + -ellipsistext $default_ellipsis_horizontal\ + -ellipsiswhitespace 0\ + -expand_right 0\ + -appendlines 1\ + -transparent 0\ + -exposed1 \uFFFD\ + -exposed2 \uFFFD\ + -experimental 0\ + -cp437 0\ + -looplimit \uFFEF\ + -crm_mode 0\ + -reverse_mode 0\ + -insert_mode 0\ + -wrap 0\ + -info 0\ + -console {stdin stdout stderr}\ + ] + #expand_right is perhaps consistent with the idea of the page_size being allowed to grow horizontally.. + # it does not necessarily mean the viewport grows. (which further implies need for horizontal scrolling) + # - it does need to be within some concept of terminal width - as columns must be addressable by ansi sequences. + # - This implies the -width option value must grow if it is tied to the concept of renderspace terminal width! REVIEW. + # - further implication is that if expand_right grows the virtual renderspace terminal width - + # then some sort of reflow/rerender needs to be done for preceeding lines? + # possibly not - as expand_right is distinct from a normal terminal-width change event, + # expand_right being primarily to support other operations such as textblock::table + + #todo - viewport width/height as separate concept to terminal width/height? + #-ellipsis args not used if -wrap is true + foreach {k v} $argsflags { + switch -- $k { + -looplimit - -width - -height - -startcolumn - -bias - -ellipsis - -ellipsistext - -ellipsiswhitespace + - -transparent - -exposed1 - -exposed2 - -experimental + - -expand_right - -appendlines + - -reverse_mode - -crm_mode - -insert_mode + - -cp437 + - -info - -console { + tcl::dict::set opts $k $v + } + -wrap - -autowrap_mode { + #temp alias -autowrap_mode for consistency with renderline + #todo - + tcl::dict::set opts -wrap $v + } + default { + error "overtype::renderspace unknown option '$k'. Known options: [tcl::dict::keys $opts]" + } + } + } + #set opts [tcl::dict::merge $defaults $argsflags] + # -- --- --- --- --- --- + #review - expand_left for RTL text? + set opt_expand_right [tcl::dict::get $opts -expand_right] + #for repl - standard output line indicator is a dash - todo, add a different indicator for a continued line. + set opt_width [tcl::dict::get $opts -width] + set opt_height [tcl::dict::get $opts -height] + set opt_startcolumn [tcl::dict::get $opts -startcolumn] + set opt_appendlines [tcl::dict::get $opts -appendlines] + set opt_transparent [tcl::dict::get $opts -transparent] + set opt_ellipsistext [tcl::dict::get $opts -ellipsistext] + set opt_ellipsiswhitespace [tcl::dict::get $opts -ellipsiswhitespace] + set opt_exposed1 [tcl::dict::get $opts -exposed1] ;#widechar_exposed_left - todo + set opt_exposed2 [tcl::dict::get $opts -exposed2] ;#widechar_exposed_right - todo + # -- --- --- --- --- --- + set opt_crm_mode [tcl::dict::get $opts -crm_mode] + set opt_reverse_mode [tcl::dict::get $opts -reverse_mode] + set opt_insert_mode [tcl::dict::get $opts -insert_mode] + ##### + # review -wrap should map onto DECAWM terminal mode - the wrap 2 idea may not fit in with this?. + set opt_autowrap_mode [tcl::dict::get $opts -wrap] + #??? wrap 1 is hard wrap cutting word at exact column, or 1 column early for 2w-glyph, wrap 2 is for language-based word-wrap algorithm (todo) + ##### + # -- --- --- --- --- --- + set opt_cp437 [tcl::dict::get $opts -cp437] + set opt_info [tcl::dict::get $opts -info] + + + + # ---------------------------- + # -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 + } + } + } + # ---------------------------- + + set underblock [tcl::string::map {\r\n \n} $underblock] + set overblock [tcl::string::map {\r\n \n} $overblock] + + + #set underlines [split $underblock \n] + + #underblock is a 'rendered' block - so width height make sense + #only non-cursor affecting and non-width occupying ANSI codes should be present. + #ie SGR codes and perhaps things such as PM - although generally those should have been pushed to the application already + #renderwidth & renderheight were originally used with reference to rendering into a 'column' of output e.g a table column - before cursor row/col was implemented. + + if {$opt_width eq "\uFFEF" || $opt_height eq "\uFFEF"} { + lassign [blocksize $underblock] _w renderwidth _h renderheight + if {$opt_width ne "\uFFEF"} { + set renderwidth $opt_width + } + if {$opt_height ne "\uFFEF"} { + set renderheight $opt_height + } + } else { + set renderwidth $opt_width + set renderheight $opt_height + } + #initial state for renderspace 'terminal' reset + set initial_state [dict create\ + renderwidth $renderwidth\ + renderheight $renderheight\ + crm_mode $opt_crm_mode\ + reverse_mode $opt_reverse_mode\ + insert_mode $opt_insert_mode\ + autowrap_mode $opt_autowrap_mode\ + cp437 $opt_cp437\ + ] + #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 + + # -- --- --- --- + #REVIEW - do we need ansi resets in the underblock? + if {$underblock eq ""} { + set underlines [lrepeat $renderheight ""] + } else { + set underblock [textblock::join_basic -- $underblock] ;#ensure properly rendered - ansi per-line resets & replays + 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] + #} + # -- --- --- --- + + #todo - reconsider the 'line' as the natural chunking mechanism for the overlay. + #In practice an overlay ANSI stream can be a single line with ansi moves/restores etc - or even have no moves or newlines, just relying on wrapping at the output renderwidth + #In such cases - we process the whole shebazzle for the first output line - only reducing by the applied amount at the head each time, reprocessing the long tail each time. + #(in cases where there are interline moves or cursor jumps anyway) + #This works - but doesn't seem efficient. + #On the other hand.. maybe it depends on the data. For simpler files it's more efficient than splitting first + + #a hack until we work out how to avoid infinite loops... + # + set looplimit [tcl::dict::get $opts -looplimit] + if {$looplimit eq "\uFFEF"} { + #looping for each char is worst case (all newlines?) - anything over that is an indication of something broken? + #do we need any margin above the length? (telnet mapscii.me test) + set looplimit [expr {[tcl::string::length $overblock] + 10}] + } + + #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 $overblock] + } + 1 { + set inputchunks [punk::ansi::ta::split_codes $overblock] + } + 2 { + + #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 { + #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 + } + if {[llength $lflines]} { + lset lflines end [tcl::string::range [lindex $lflines end] 0 end-1] + } + #set inputchunks $lflines[unset lflines] + set inputchunks [lindex [list $lflines [unset lflines]] 0] + + } + 4 { + set inputchunks [list] + foreach ln [split $overblock \n] { + lappend inputchunks $ln\n + } + if {[llength $inputchunks]} { + lset inputchunks end [tcl::string::range [lindex $inputchunks end] 0 end-1] + } + } + } + + + + + set replay_codes_underlay [tcl::dict::create 1 ""] + #lappend replay_codes_overlay "" + set replay_codes_overlay "[punk::ansi::a]" + set unapplied "" + set cursor_saved_position [tcl::dict::create] + set cursor_saved_attributes "" + + + 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] + + set loop 0 + #while {$overidx < [llength $inputchunks]} { } + + while {[llength $inputchunks]} { + #set overtext [lindex $inputchunks $overidx]; lset inputchunks $overidx "" + set overtext [lpop inputchunks 0] + if {![tcl::string::length $overtext]} { + incr loop + continue + } + #puts "----->[ansistring VIEW -lf 1 -vt 1 -nul 1 $overtext]<----" + set undertext [lindex $outputlines [expr {$row -1}]] + set renderedrow $row + + #renderline pads each underaly line to width with spaces and should track where end of data is + + + #set overtext [tcl::string::cat [lindex $replay_codes_overlay $overidx] $overtext] + set overtext $replay_codes_overlay$overtext + 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\ + -cp437 $opt_cp437\ + -info 1\ + -crm_mode [tcl::dict::get $vtstate crm_mode]\ + -insert_mode [tcl::dict::get $vtstate insert_mode]\ + -autowrap_mode [tcl::dict::get $vtstate autowrap_mode]\ + -reverse_mode [tcl::dict::get $vtstate reverse_mode]\ + -cursor_restore_attributes $cursor_saved_attributes\ + -transparent $opt_transparent\ + -width [tcl::dict::get $vtstate renderwidth]\ + -exposed1 $opt_exposed1\ + -exposed2 $opt_exposed2\ + -expand_right $opt_expand_right\ + -cursor_column $col\ + -cursor_row $row\ + ] + set rinfo [renderline {*}$renderopts $undertext $overtext] + + set instruction [tcl::dict::get $rinfo instruction] + tcl::dict::set vtstate crm_mode [tcl::dict::get $rinfo crm_mode] + tcl::dict::set vtstate insert_mode [tcl::dict::get $rinfo insert_mode] + tcl::dict::set vtstate autowrap_mode [tcl::dict::get $rinfo autowrap_mode] ;# + tcl::dict::set vtstate reverse_mode [tcl::dict::get $rinfo reverse_mode] + #how to support reverse_mode in rendered linelist? we need to examine all pt/code blocks and flip each SGR stack? + # - review - the answer is probably that we don't need to - it is set/reset only during application of overtext + + #Note carefully the difference betw overflow_right and unapplied. + #overflow_right may need to be included in next run before the unapplied data + #overflow_right most commonly has data when in insert_mode + set rendered [tcl::dict::get $rinfo result] + set overflow_right [tcl::dict::get $rinfo overflow_right] + set overflow_right_column [tcl::dict::get $rinfo overflow_right_column] + set unapplied [tcl::dict::get $rinfo unapplied] + set unapplied_list [tcl::dict::get $rinfo unapplied_list] + set post_render_col [tcl::dict::get $rinfo cursor_column] + set post_render_row [tcl::dict::get $rinfo cursor_row] + set c_saved_pos [tcl::dict::get $rinfo cursor_saved_position] + set c_saved_attributes [tcl::dict::get $rinfo cursor_saved_attributes] + 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] + 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] + set replay_codes_overlay [tcl::dict::get $rinfo replay_codes_overlay] + if {0 && [tcl::dict::get $vtstate reverse_mode]} { + #test branch - todo - prune + puts stderr "---->[ansistring VIEW $replay_codes_overlay] rendered: $rendered" + #review + #JMN3 + set existing_reverse_state 0 + #split_codes_single is single esc sequence - but could have multiple sgr codes within one esc sequence + #e.g \x1b\[0;31;7m has a reset,colour red and reverse + set codeinfo [punk::ansi::codetype::sgr_merge [list $replay_codes_overlay] -info 1] + set codestate_reverse [dict get $codeinfo codestate reverse] + switch -- $codestate_reverse { + 7 { + set existing_reverse_state 1 + } + 27 { + set existing_reverse_state 0 + } + "" { + } + } + if {$existing_reverse_state == 0} { + set rflip [a+ reverse] + } else { + #reverse of reverse + set rflip [a+ noreverse] + } + #note that mergeresult can have multiple esc (due to unmergeables or non sgr codes) + set replay_codes_overlay [punk::ansi::codetype::sgr_merge [list [dict get $codeinfo mergeresult] $rflip]] + puts stderr "---->[ansistring VIEW $replay_codes_overlay] rendered: $rendered" + } + + + + #-- todo - detect looping properly + if {$row > 1 && $overtext ne "" && $unapplied eq $overtext && $post_render_row == $row && $instruction eq ""} { + puts stderr "overtype::renderspace loop?" + puts [ansistring VIEW $rinfo] + break + } + #-- + + if {[tcl::dict::size $c_saved_pos] >= 1} { + set cursor_saved_position $c_saved_pos + set cursor_saved_attributes $c_saved_attributes + } + + + set overflow_handled 0 + + + + set nextprefix "" + + + #todo - handle potential insertion mode as above for cursor restore? + #keeping separate branches for debugging - review and merge as appropriate when stable + set instruction_type [lindex $instruction 0] ;#some instructions have params + tcl::dict::incr instruction_stats $instruction_type + switch -- $instruction_type { + reset { + #reset the 'renderspace terminal' (not underlying terminal) + set row 1 + set col 1 + 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 + if {![llength $unapplied_list]} { + if {$overflow_right ne ""} { + incr row + } + } else { + puts stderr "renderspace end of input line - has unapplied: [ansistring VIEW $unapplied] (review)" + } + set col $opt_startcolumn + } + up { + + #renderline knows it's own line number, and knows not to go above row l + #it knows that a move whilst 1-beyond the width conflicts with the linefeed and reduces the move by one accordingly. + #row returned should be correct. + #column may be the overflow column - as it likes to report that to the caller. + + #Note that an ansi up sequence after last column going up to a previous line and also beyond the last column, will result in the next grapheme going onto the following line. + #this seems correct - as the column remains beyond the right margin so subsequent chars wrap (?) review + #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 + } + down { + if {$data_mode == 0} { + #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]}] + if {$diff > 0} { + lappend outputlines {*}[lrepeat $diff ""] + } + lappend outputlines "" + } + } + set row $post_render_row + set col $post_render_col + } else { + if {$post_render_row > [llength $outputlines]} { + if {$opt_appendlines} { + set diff [expr {$post_render_row - [llength $outputlines]}] + if {$diff > 0} { + lappend outputlines {*}[lrepeat $diff ""] + } + lappend outputlines "" + } + } + 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 + } + + } + } + 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] + #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 + set replay_codes_overlay [tcl::dict::get $rinfo replay_codes_overlay]$cursor_saved_attributes + #set replay_codes_overlay $cursor_saved_attributes + set cursor_saved_position [tcl::dict::create] + set cursor_saved_attributes "" + } else { + #TODO + #?restore without save? + #should move to home position and reset ansi SGR? + #puts stderr "overtype::renderspace cursor_restore without save data available" + } + #If we were inserting prior to hitting the cursor_restore - there could be overflow_right data - generally the overtype functions aren't for inserting - but ansi can enable it + #if we were already in overflow when cursor_restore was hit - it shouldn't have been processed as an action - just stored. + if {!$overflow_handled && $overflow_right ne ""} { + #wrap before restore? - possible effect on saved cursor position + #this overflow data has previously been rendered so has no cursor movements or further save/restore operations etc + #we can just insert another call to renderline to solve this.. ? + #It would perhaps be more properly handled as a queue of instructions from our initial renderline call + #we don't need to worry about overflow next call (?)- but we should carry forward our gx and ansi stacks + + puts stdout ">>>[a+ red bold]overflow_right during restore_cursor[a]" + + set sub_info [overtype::renderline\ + -info 1\ + -width [tcl::dict::get $vtstate renderwidth]\ + -insert_mode [tcl::dict::get $vtstate insert_mode]\ + -autowrap_mode [tcl::dict::get $vtstate autowrap_mode]\ + -expand_right [tcl::dict::get $opts -expand_right]\ + ""\ + $overflow_right\ + ] + set foldline [tcl::dict::get $sub_info result] + tcl::dict::set vtstate insert_mode [tcl::dict::get $sub_info insert_mode] ;#probably not needed..? + tcl::dict::set vtstate autowrap_mode [tcl::dict::get $sub_info autowrap_mode] ;#nor this.. + linsert outputlines $renderedrow $foldline + #review - row & col set by restore - but not if there was no save.. + } + set overflow_handled 1 + + } + move { + ######## + if {$post_render_row > [llength $outputlines]} { + #Ansi moves need to create new lines ? + #if {$opt_appendlines} { + # set diff [expr {$post_render_row - [llength $outputlines]}] + # if {$diff > 0} { + # lappend outputlines {*}[lrepeat $diff ""] + # } + # set row $post_render_row + #} else { + set row [llength $outputlines] + #} + } else { + set row $post_render_row + } + ####### + set col $post_render_col + #overflow + unapplied? + } + clear_and_move { + #e.g 2J + if {$post_render_row > [llength $outputlines]} { + set row [llength $outputlines] + } else { + set row $post_render_row + } + set 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 \000 $renderwidth]\x1b\[0m + if 0 { + + 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"} { + incr numcells 1 + } else { + incr numcells [grapheme_width_cached $grapheme] + } + } + } + + } + } + } + #replays/resets each line + lappend clearedlines \x1b\[0m$replay_codes_overlay[string repeat \000 $numcells]\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] + + } + lf_start { + #raw newlines + # ---------------------- + #test with fruit.ans + #test - treating as newline below... + #append rendered $overflow_right + #set overflow_right "" + set row $renderedrow + incr row + if {$row > [llength $outputlines]} { + lappend outputlines "" + } + set col $opt_startcolumn + # ---------------------- + } + lf_mid { + + set edit_mode 0 + if {$edit_mode} { + set inputchunks [linsert $inputchunks 0 $overflow_right$unapplied] + set overflow_right "" + set unapplied "" + set row $post_render_row + #set col $post_render_col + set col $opt_startcolumn + if {$row > [llength $outputlines]} { + lappend outputlines {*}[lrepeat 1 ""] + } + } 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] + set overflow_right "" + set 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 + } + } + set overflow_right [join $remaining_overflow ""] + } + } + } + } + set row $post_render_row + set col $opt_startcolumn + if {$row > [llength $outputlines]} { + lappend outputlines {*}[lrepeat 1 ""] + } + } 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 ""] + } + } + } + } + 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 + } + + 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 ""] + } + set col $opt_startcolumn + + } + newlines_above { + #we get a newlines_above instruction when received at column 1 + #In some cases we want to treat that as request to insert a new blank line above, and move our row 1 down (staying with the data) + #in other cases - we want to treat at column 1 the same as any other + + 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 + if {$insert_lines_above > 0} { + set row $renderedrow + set outputlines [linsert $outputlines $renderedrow-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 + #? set row $post_render_row #can renderline tell us? + } + } + 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 + # + + + set overflow_right "" + set row $renderedrow + #only add newline if we're at the bottom + if {$row > [llength $outputlines]} { + 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]}] + if {$diff > 0} { + lappend outputlines {*}[lrepeat $diff ""] + } + 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 + } + } + } + } + wrapmoveforward { + #doesn't seem to be used by fruit.ans testfile + #used by dzds.ans + #note that cursor_forward may move deep into the next line - or even span multiple lines !TODO + set c $renderwidth + set r $post_render_row + if {$post_render_col > $renderwidth} { + set i $c + while {$i <= $post_render_col} { + if {$c == $renderwidth+1} { + incr r + if {$opt_appendlines} { + if {$r < [llength $outputlines]} { + lappend outputlines "" + } + } + set c $opt_startcolumn + } else { + incr c + } + incr i + } + set col $c + } else { + #why are we getting this instruction then? + puts stderr "wrapmoveforward - test" + set r [expr {$post_render_row +1}] + set c $post_render_col + } + set row $r + set col $c + } + wrapmovebackward { + set c $renderwidth + set r $post_render_row + if {$post_render_col < 1} { + set c 1 + set i $c + while {$i >= $post_render_col} { + if {$c == 0} { + if {$r > 1} { + incr r -1 + set c $renderwidth + } else { + #leave r at 1 set c 1 + #testfile besthpav.ans first line top left border alignment + set c 1 + break + } + } else { + incr c -1 + } + incr i -1 + } + set col $c + } else { + puts stderr "Wrapmovebackward - but postrendercol >= 1???" + } + set row $r + set col $c + } + overflow { + #normal single-width grapheme overflow + #puts "----normal overflow --- [ansistring VIEWSTYLE -lf 1 -nul 1 -vt 1 $rendered]" + set row $post_render_row ;#renderline will not advance row when reporting overflow char + if {[tcl::dict::get $vtstate autowrap_mode]} { + incr row + set col $opt_startcolumn ;#whether wrap or not - next data is at column 1 ?? + } else { + set col $post_render_col + #set unapplied "" ;#this seems wrong? + #set unapplied [tcl::string::range $unapplied 1 end] + #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' + set idx 0 + set next_grapheme_index -1 + foreach u $unapplied_list { + if {![punk::ansi::ta::detect $u]} { + set next_grapheme_index $idx + break + } + incr idx + } + assert {$next_grapheme_index >= 0} + #drop the overflow grapheme - keeping all codes in place. + set unapplied [join [lreplace $unapplied_list $next_grapheme_index $next_grapheme_index] ""] + #we need to run the reduced unapplied on the same line - further graphemes will just overflow again, but codes or control chars could trigger jumps to other lines + + set overflow_handled 1 + #handled by dropping overflow if any + } + } + overflow_splitchar { + set row $post_render_row ;#renderline will not advance row when reporting overflow char + + #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 + if {[tcl::dict::get $vtstate autowrap_mode]} { + if {$renderwidth < 2} { + #edge case of rendering to a single column output - any 2w char will just cause a loop if we don't substitute with something, or drop the character + set idx 0 + set triggering_grapheme_index -1 + foreach u $unapplied_list { + if {![punk::ansi::ta::detect $u]} { + set triggering_grapheme_index $idx + break + } + incr idx + } + set unapplied [join [lreplace $unapplied_list $triggering_grapheme_index $triggering_grapheme_index $opt_exposed1] ""] + } else { + set col $opt_startcolumn + incr row + } + } else { + set overflow_handled 1 + #handled by dropping entire overflow if any + if {$renderwidth < 2} { + set idx 0 + set triggering_grapheme_index -1 + foreach u $unapplied_list { + if {![punk::ansi::ta::detect $u]} { + set triggering_grapheme_index $idx + break + } + incr idx + } + set unapplied [join [lreplace $unapplied_list $triggering_grapheme_index $triggering_grapheme_index $opt_exposed1] ""] + } + } + + } + vt { + + #can vt add a line like a linefeed can? + set row $post_render_row + set col $post_render_col + } + set_window_title { + set newtitle [lindex $instruction 1] + puts stderr "overtype::renderspace set_window_title [ansistring VIEW $newtitle] instruction '$instruction'" + # + } + reset_colour_palette { + puts stderr "overtype::renderspace instruction '$instruction' unimplemented" + } + default { + puts stderr "overtype::renderspace unhandled renderline instruction '$instruction'" + } + + } + + + if {!$opt_expand_right && ![tcl::dict::get $vtstate autowrap_mode]} { + #not allowed to overflow column or wrap therefore we get overflow data to truncate + if {[tcl::dict::get $opts -ellipsis]} { + set show_ellipsis 1 + if {!$opt_ellipsiswhitespace} { + #we don't want ellipsis if only whitespace was lost + set lostdata "" + if {$overflow_right ne ""} { + append lostdata $overflow_right + } + if {$unapplied ne ""} { + append lostdata $unapplied + } + if {[tcl::string::trim $lostdata] eq ""} { + set show_ellipsis 0 + } + #set lostdata [tcl::string::range $overtext end-[expr {$overflowlength-1}] end] + if {[tcl::string::trim [punk::ansi::ansistrip $lostdata]] eq ""} { + set show_ellipsis 0 + } + } + if {$show_ellipsis} { + set rendered [overtype::right $rendered $opt_ellipsistext] + } + set overflow_handled 1 + } else { + #no wrap - no ellipsis - silently truncate + set overflow_handled 1 + } + } + + + + if {$renderedrow <= [llength $outputlines]} { + lset outputlines [expr {$renderedrow-1}] $rendered + } else { + if {$opt_appendlines} { + lappend outputlines $rendered + } else { + #? + lset outputlines [expr {$renderedrow-1}] $rendered + } + } + + if {!$overflow_handled} { + append nextprefix $overflow_right + } + + append nextprefix $unapplied + + 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] + } + } + } + + if {$nextprefix ne ""} { + set inputchunks [linsert $inputchunks 0 $nextprefix] + } + + + incr overidx + incr loop + if {$loop >= $looplimit} { + puts stderr "overtype::renderspace looplimit reached ($looplimit)" + lappend outputlines "[a+ red bold] - looplimit $looplimit reached[a]" + set Y [a+ yellow bold] + set RST [a] + set sep_header ----DEBUG----- + 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" + tcl::dict::for {k v} $rinfo { + append debugmsg "${Y}$k [ansistring VIEW -lf 1 -vt 1 $v]$RST" \n + } + append debugmsg "${Y}[string repeat - [string length $sep_header]]$RST" \n + + puts stdout $debugmsg + #todo - config regarding error dumps rather than just dumping in working dir + set fd [open [pwd]/error_overtype.txt w] + puts $fd $debugmsg + close $fd + error $debugmsg + break + } + } + + set result [join $outputlines \n] + if {!$opt_info} { + return $result + } else { + #emit to debug window like basictelnet does? make debug configurable as syslog or even a telnet server to allow on 2nd window? + #append result \n$instruction_stats\n + set inforesult [dict create\ + result $result\ + last_instruction $instruction\ + instruction_stats $instruction_stats\ + ] + if {$opt_info == 2} { + return [pdict -channel none inforesult] + } else { + return $inforesult + } + } + } + + #todo - left-right ellipsis ? + proc centre {args} { + variable default_ellipsis_horizontal + if {[llength $args] < 2} { + error {usage: ?-transparent [0|1]? ?-bias [left|right]? ?-overflow [1|0]? undertext overtext} + } + + foreach {underblock overblock} [lrange $args end-1 end] break + + #todo - vertical vs horizontal overflow for blocks + set opts [tcl::dict::create\ + -bias left\ + -ellipsis 0\ + -ellipsistext $default_ellipsis_horizontal\ + -ellipsiswhitespace 0\ + -overflow 0\ + -transparent 0\ + -exposed1 \uFFFD\ + -exposed2 \uFFFD\ + ] + set argsflags [lrange $args 0 end-2] + foreach {k v} $argsflags { + switch -- $k { + -bias - -ellipsis - -ellipsistext - -ellipsiswhitespace - -overflow - -transparent - -exposed1 - -exposed2 { + tcl::dict::set opts $k $v + } + default { + set known_opts [tcl::dict::keys $opts] + error "overtype::centre unknown option '$k'. Known options: $known_opts" + } + } + } + #set opts [tcl::dict::merge $defaults $argsflags] + # -- --- --- --- --- --- + set opt_transparent [tcl::dict::get $opts -transparent] + set opt_ellipsis [tcl::dict::get $opts -ellipsis] + set opt_ellipsistext [tcl::dict::get $opts -ellipsistext] + set opt_ellipsiswhitespace [tcl::dict::get $opts -ellipsiswhitespace] + set opt_exposed1 [tcl::dict::get $opts -exposed1] + set opt_exposed2 [tcl::dict::get $opts -exposed2] + # -- --- --- --- --- --- + + + set underblock [tcl::string::map {\r\n \n} $underblock] + set overblock [tcl::string::map {\r\n \n} $overblock] + + set underlines [split $underblock \n] + #set renderwidth [tcl::mathfunc::max {*}[lmap v $underlines {punk::ansi::printing_length $v}]] + lassign [blocksize $underblock] _w renderwidth _h renderheight + set overlines [split $overblock \n] + lassign [blocksize $overblock] _w overblock_width _h overblock_height + set under_exposed_max [expr {$renderwidth - $overblock_width}] + if {$under_exposed_max > 0} { + #background block is wider + if {$under_exposed_max % 2 == 0} { + #even left/right exposure + set left_exposed [expr {$under_exposed_max / 2}] + } else { + set beforehalf [expr {$under_exposed_max / 2}] ;#1 less than half due to integer division + if {[tcl::string::tolower [tcl::dict::get $opts -bias]] eq "left"} { + set left_exposed $beforehalf + } else { + #bias to the right + set left_exposed [expr {$beforehalf + 1}] + } + } + } else { + set left_exposed 0 + } + + set outputlines [list] + if {[punk::ansi::ta::detect_sgr [lindex $overlines 0]]} { + set replay_codes "[punk::ansi::a]" + } else { + set replay_codes "" + } + set replay_codes_underlay "" + set replay_codes_overlay "" + foreach undertext $underlines overtext $overlines { + set overtext_datalen [punk::ansi::printing_length $overtext] + set ulen [punk::ansi::printing_length $undertext] + if {$ulen < $renderwidth} { + set udiff [expr {$renderwidth - $ulen}] + set undertext "$undertext[string repeat { } $udiff]" + } + set undertext $replay_codes_underlay$undertext + set overtext $replay_codes_overlay$overtext + + set overflowlength [expr {$overtext_datalen - $renderwidth}] + #review - right-to-left langs should elide on left! - extra option required + + if {$overflowlength > 0} { + #overlay line wider or equal + #review - we still expand_right for centred for now.. possibly should do something like -expand_leftright with ellipsis each end? + set rinfo [renderline -info 1 -insert_mode 0 -transparent $opt_transparent -expand_right [tcl::dict::get $opts -overflow] -exposed1 $opt_exposed1 -exposed2 $opt_exposed2 $undertext $overtext] + set rendered [tcl::dict::get $rinfo result] + set overflow_right [tcl::dict::get $rinfo overflow_right] + set unapplied [tcl::dict::get $rinfo unapplied] + #todo - get replay_codes from overflow_right instead of wherever it was truncated? + + #overlay line data is wider - trim if overflow not specified in opts - and overtype an ellipsis at right if it was specified + if {![tcl::dict::get $opts -overflow]} { + #lappend outputlines [tcl::string::range $overtext 0 [expr {$renderwidth - 1}]] + #set overtext [tcl::string::range $overtext 0 $renderwidth-1 ] + if {$opt_ellipsis} { + set show_ellipsis 1 + if {!$opt_ellipsiswhitespace} { + #we don't want ellipsis if only whitespace was lost + #don't use tcl::string::range on ANSI data + #set lostdata [tcl::string::range $overtext end-[expr {$overflowlength-1}] end] + set lostdata "" + if {$overflow_right ne ""} { + append lostdata $overflow_right + } + if {$unapplied ne ""} { + append lostdata $unapplied + } + if {[tcl::string::trim $lostdata] eq ""} { + set show_ellipsis 0 + } + } + if {$show_ellipsis} { + set rendered [overtype::right $rendered $opt_ellipsistext] + } + } + } + lappend outputlines $rendered + #lappend outputlines [renderline -insert_mode 0 -transparent $opt_transparent $undertext $overtext] + } else { + #background block is wider than or equal to data for this line + #lappend outputlines [renderline -insert_mode 0 -startcolumn [expr {$left_exposed + 1}] -transparent $opt_transparent -exposed1 $opt_exposed1 -exposed2 $opt_exposed2 $undertext $overtext] + set rinfo [renderline -info 1 -insert_mode 0 -startcolumn [expr {$left_exposed + 1}] -transparent $opt_transparent -exposed1 $opt_exposed1 -exposed2 $opt_exposed2 $undertext $overtext] + lappend outputlines [tcl::dict::get $rinfo result] + } + set replay_codes_underlay [tcl::dict::get $rinfo replay_codes_underlay] + set replay_codes_overlay [tcl::dict::get $rinfo replay_codes_overlay] + } + return [join $outputlines \n] + } + + #overtype::right is for a rendered ragged underblock and a rendered ragged overblock + #ie we can determine the block width for bost by examining the lines and picking the longest. + # + proc right {args} { + #NOT the same as align-right - which should be done to the overblock first if required + variable default_ellipsis_horizontal + # @d !todo - implement overflow, length checks etc + + if {[llength $args] < 2} { + error {usage: ?-overflow [1|0]? ?-transparent 0|? undertext overtext} + } + foreach {underblock overblock} [lrange $args end-1 end] break + + set opts [tcl::dict::create\ + -bias ignored\ + -ellipsis 0\ + -ellipsistext $default_ellipsis_horizontal\ + -ellipsiswhitespace 0\ + -overflow 0\ + -transparent 0\ + -exposed1 \uFFFD\ + -exposed2 \uFFFD\ + -align "left"\ + ] + set argsflags [lrange $args 0 end-2] + tcl::dict::for {k v} $argsflags { + switch -- $k { + -bias - -ellipsis - -ellipsistext - -ellipsiswhitespace - -overflow - -transparent - -exposed1 - -exposed2 - -align { + tcl::dict::set opts $k $v + } + default { + set known_opts [tcl::dict::keys $opts] + error "overtype::centre unknown option '$k'. Known options: $known_opts" + } + } + } + #set opts [tcl::dict::merge $defaults $argsflags] + # -- --- --- --- --- --- + set opt_transparent [tcl::dict::get $opts -transparent] + set opt_ellipsis [tcl::dict::get $opts -ellipsis] + set opt_ellipsistext [tcl::dict::get $opts -ellipsistext] + set opt_ellipsiswhitespace [tcl::dict::get $opts -ellipsiswhitespace] + set opt_overflow [tcl::dict::get $opts -overflow] + set opt_exposed1 [tcl::dict::get $opts -exposed1] + set opt_exposed2 [tcl::dict::get $opts -exposed2] + set opt_align [tcl::dict::get $opts -align] + # -- --- --- --- --- --- + + set underblock [tcl::string::map {\r\n \n} $underblock] + set overblock [tcl::string::map {\r\n \n} $overblock] + + set underlines [split $underblock \n] + lassign [blocksize $underblock] _w renderwidth _h renderheight + set overlines [split $overblock \n] + #set overblock_width [tcl::mathfunc::max {*}[lmap v $overlines {punk::ansi::printing_length $v}]] + lassign [blocksize $overblock] _w overblock_width _h overblock_height + set under_exposed_max [expr {max(0,$renderwidth - $overblock_width)}] + set left_exposed $under_exposed_max + + + + set outputlines [list] + if {[punk::ansi::ta::detect_sgr [lindex $overlines 0]]} { + set replay_codes "[punk::ansi::a]" + } else { + set replay_codes "" + } + set replay_codes_underlay "" + set replay_codes_overlay "" + foreach undertext $underlines overtext $overlines { + set overtext_datalen [punk::ansi::printing_length $overtext] + set ulen [punk::ansi::printing_length $undertext] + if {$ulen < $renderwidth} { + set udiff [expr {$renderwidth - $ulen}] + #puts xxx + append undertext [string repeat { } $udiff] + } + if {$overtext_datalen < $overblock_width} { + set odiff [expr {$overblock_width - $overtext_datalen}] + switch -- $opt_align { + left { + set startoffset 0 + } + right { + set startoffset $odiff + } + default { + set half [expr {$odiff / 2}] + #set lhs [string repeat { } $half] + #set righthalf [expr {$odiff - $half}] ;#remainder - may be one more - so we are biased left + #set rhs [string repeat { } $righthalf] + set startoffset $half + } + } + } else { + set startoffset 0 ;#negative? + } + + set undertext $replay_codes_underlay$undertext + set overtext $replay_codes_overlay$overtext + + set overflowlength [expr {$overtext_datalen - $renderwidth}] + if {$overflowlength > 0} { + #raw overtext wider than undertext column + set rinfo [renderline\ + -info 1\ + -insert_mode 0\ + -transparent $opt_transparent\ + -exposed1 $opt_exposed1 -exposed2 $opt_exposed2\ + -overflow $opt_overflow\ + -startcolumn [expr {1 + $startoffset}]\ + $undertext $overtext] + set replay_codes [tcl::dict::get $rinfo replay_codes] + set rendered [tcl::dict::get $rinfo result] + if {!$opt_overflow} { + if {$opt_ellipsis} { + set show_ellipsis 1 + if {!$opt_ellipsiswhitespace} { + #we don't want ellipsis if only whitespace was lost + set lostdata [tcl::string::range $overtext end-[expr {$overflowlength-1}] end] + if {[tcl::string::trim $lostdata] eq ""} { + set show_ellipsis 0 + } + } + if {$show_ellipsis} { + set ellipsis $replay_codes$opt_ellipsistext + #todo - overflow on left if allign = right?? + set rendered [overtype::right $rendered $ellipsis] + } + } + } + lappend outputlines $rendered + } else { + #padded overtext + #lappend outputlines [renderline -insert_mode 0 -transparent $opt_transparent -startcolumn [expr {$left_exposed + 1}] $undertext $overtext] + #Note - we still need overflow(exapnd_right) here - as although the overtext is short - it may oveflow due to the startoffset + set rinfo [renderline -info 1 -insert_mode 0 -transparent $opt_transparent -expand_right $opt_overflow -startcolumn [expr {$left_exposed + 1 + $startoffset}] $undertext $overtext] + lappend outputlines [tcl::dict::get $rinfo result] + } + set replay_codes [tcl::dict::get $rinfo replay_codes] + set replay_codes_underlay [tcl::dict::get $rinfo replay_codes_underlay] + set replay_codes_overlay [tcl::dict::get $rinfo replay_codes_overlay] + } + + return [join $outputlines \n] + } + + proc left {args} { + overtype::block -blockalign left {*}$args + } + #overtype a (possibly ragged) underblock with a (possibly ragged) overblock + proc block {args} { + variable default_ellipsis_horizontal + # @d !todo - implement overflow, length checks etc + + if {[llength $args] < 2} { + error {usage: ?-blockalign left|centre|right? ?-textalign left|centre|right? ?-overflow [1|0]? ?-transparent 0|? undertext overtext} + } + #foreach {underblock overblock} [lrange $args end-1 end] break + lassign [lrange $args end-1 end] underblock overblock + + set opts [tcl::dict::create\ + -ellipsis 0\ + -ellipsistext $default_ellipsis_horizontal\ + -ellipsiswhitespace 0\ + -overflow 0\ + -transparent 0\ + -exposed1 \uFFFD\ + -exposed2 \uFFFD\ + -textalign "left"\ + -textvertical "top"\ + -blockalign "left"\ + -blockalignbias left\ + -blockvertical "top"\ + ] + set argsflags [lrange $args 0 end-2] + tcl::dict::for {k v} $argsflags { + switch -- $k { + -blockalignbias - -ellipsis - -ellipsistext - -ellipsiswhitespace - -overflow - -transparent - -exposed1 - -exposed2 - -textalign - -blockalign - -blockvertical { + tcl::dict::set opts $k $v + } + default { + error "overtype::block unknown option '$k'. Known options: [tcl::dict::keys $opts]" + } + } + } + # -- --- --- --- --- --- + set opt_transparent [tcl::dict::get $opts -transparent] + set opt_ellipsis [tcl::dict::get $opts -ellipsis] + set opt_ellipsistext [tcl::dict::get $opts -ellipsistext] + set opt_ellipsiswhitespace [tcl::dict::get $opts -ellipsiswhitespace] + set opt_overflow [tcl::dict::get $opts -overflow] + set opt_exposed1 [tcl::dict::get $opts -exposed1] + set opt_exposed2 [tcl::dict::get $opts -exposed2] + set opt_textalign [tcl::dict::get $opts -textalign] + set opt_blockalign [tcl::dict::get $opts -blockalign] + if {$opt_blockalign eq "center"} { + set opt_blockalign "centre" + } + # -- --- --- --- --- --- + + set underblock [tcl::string::map {\r\n \n} $underblock] + set overblock [tcl::string::map {\r\n \n} $overblock] + + set underlines [split $underblock \n] + lassign [blocksize $underblock] _w renderwidth _h renderheight + set overlines [split $overblock \n] + #set overblock_width [tcl::mathfunc::max {*}[lmap v $overlines {punk::ansi::printing_length $v}]] + lassign [blocksize $overblock] _w overblock_width _h overblock_height + set under_exposed_max [expr {max(0,$renderwidth - $overblock_width)}] + + switch -- $opt_blockalign { + left { + set left_exposed 0 + } + right { + set left_exposed $under_exposed_max + } + centre { + if {$under_exposed_max > 0} { + #background block is wider + if {$under_exposed_max % 2 == 0} { + #even left/right exposure + set left_exposed [expr {$under_exposed_max / 2}] + } else { + set beforehalf [expr {$under_exposed_max / 2}] ;#1 less than half due to integer division + if {[tcl::string::tolower [tcl::dict::get $opts -blockalignbias]] eq "left"} { + set left_exposed $beforehalf + } else { + #bias to the right + set left_exposed [expr {$beforehalf + 1}] + } + } + } else { + set left_exposed 0 + } + } + default { + set left_exposed 0 + } + } + + + + set outputlines [list] + if {[punk::ansi::ta::detect_sgr [lindex $overlines 0]]} { + set replay_codes "[punk::ansi::a]" + } else { + set replay_codes "" + } + set replay_codes_underlay "" + set replay_codes_overlay "" + foreach undertext $underlines overtext $overlines { + set overtext_datalen [punk::ansi::printing_length $overtext] + set ulen [punk::ansi::printing_length $undertext] + if {$ulen < $renderwidth} { + set udiff [expr {$renderwidth - $ulen}] + #puts xxx + append undertext [string repeat { } $udiff] + } + if {$overtext_datalen < $overblock_width} { + set odiff [expr {$overblock_width - $overtext_datalen}] + switch -- $opt_textalign { + left { + set startoffset 0 + } + right { + set startoffset $odiff + } + default { + set half [expr {$odiff / 2}] + #set lhs [string repeat { } $half] + #set righthalf [expr {$odiff - $half}] ;#remainder - may be one more - so we are biased left + #set rhs [string repeat { } $righthalf] + set startoffset $half + } + } + } else { + set startoffset 0 ;#negative? + } + + set undertext $replay_codes_underlay$undertext + set overtext $replay_codes_overlay$overtext + + set overflowlength [expr {$overtext_datalen - $renderwidth}] + if {$overflowlength > 0} { + #raw overtext wider than undertext column + set rinfo [renderline -info 1 -insert_mode 0 -transparent $opt_transparent -exposed1 $opt_exposed1 -exposed2 $opt_exposed2 -expand_right $opt_overflow -startcolumn [expr {1 + $startoffset}] $undertext $overtext] + set replay_codes [tcl::dict::get $rinfo replay_codes] + set rendered [tcl::dict::get $rinfo result] + set overflow_right [tcl::dict::get $rinfo overflow_right] + set unapplied [tcl::dict::get $rinfo unapplied] + if {!$opt_overflow} { + if {$opt_ellipsis} { + set show_ellipsis 1 + if {!$opt_ellipsiswhitespace} { + #we don't want ellipsis if only whitespace was lost + #don't use tcl::string::range on ANSI data + #set lostdata [tcl::string::range $overtext end-[expr {$overflowlength-1}] end] + set lostdata "" + if {$overflow_right ne ""} { + append lostdata $overflow_right + } + if {$unapplied ne ""} { + append lostdata $unapplied + } + if {[tcl::string::trim $lostdata] eq ""} { + set show_ellipsis 0 + } + } + if {$show_ellipsis} { + set rendered [overtype::block -blockalign right $rendered $opt_ellipsistext] + } + } + + #if {$opt_ellipsis} { + # set show_ellipsis 1 + # if {!$opt_ellipsiswhitespace} { + # #we don't want ellipsis if only whitespace was lost + # set lostdata [tcl::string::range $overtext end-[expr {$overflowlength-1}] end] + # if {[tcl::string::trim $lostdata] eq ""} { + # set show_ellipsis 0 + # } + # } + # if {$show_ellipsis} { + # set ellipsis [tcl::string::cat $replay_codes $opt_ellipsistext] + # #todo - overflow on left if allign = right?? + # set rendered [overtype::right $rendered $ellipsis] + # } + #} + } + lappend outputlines $rendered + } else { + #padded overtext + #lappend outputlines [renderline -insert_mode 0 -transparent $opt_transparent -startcolumn [expr {$left_exposed + 1}] $undertext $overtext] + #Note - we still need expand_right here - as although the overtext is short - it may oveflow due to the startoffset + set rinfo [renderline -info 1 -insert_mode 0 -transparent $opt_transparent -expand_right $opt_overflow -startcolumn [expr {$left_exposed + 1 + $startoffset}] $undertext $overtext] + #puts stderr "--> [ansistring VIEW -lf 1 -nul 1 $rinfo] <--" + set overflow_right [tcl::dict::get $rinfo overflow_right] + set unapplied [tcl::dict::get $rinfo unapplied] + lappend outputlines [tcl::dict::get $rinfo result] + } + set replay_codes [tcl::dict::get $rinfo replay_codes] + set replay_codes_underlay [tcl::dict::get $rinfo replay_codes_underlay] + set replay_codes_overlay [tcl::dict::get $rinfo replay_codes_overlay] + } + + return [join $outputlines \n] + } + + variable optimise_ptruns 10 ;# can be set to zero to disable the ptruns branches + + # ## ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### + # renderline written from a left-right line orientation perspective as a first-shot at getting something useful. + # ultimately right-to-left, top-to-bottom and bottom-to-top are probably needed. + # ## ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### + # + # + #-returnextra enables returning of overflow and length + #review - use punk::ansi::ta::detect to short-circuit processing and do simpler string calcs as an optimisation? + #review - DECSWL/DECDWL double width line codes - very difficult/impossible to align and compose with other elements + #(could render it by faking it with sixels and a lot of work - find/make a sixel font and ensure it's exactly 2 cols per char? + # This would probably be impractical to support for different fonts) + #todo - review transparency issues with single/double width characters + #bidi - need a base direction and concept of directional runs for RTL vs LTR - may be best handled at another layer? + proc renderline {args} { + #*** !doctools + #[call [fun overtype::renderline] [arg args] ] + #[para] renderline is the core engine for overtype string processing (frames & textblocks), and the raw mode commandline repl for the Tcl Punk Shell + #[para] It is also a central part of an ansi (micro) virtual terminal-emulator of sorts + #[para] This system does a half decent job at rendering 90's ANSI art to manipulable colour text blocks that can be joined & framed for layout display within a unix or windows terminal + #[para] Renderline helps maintain ANSI text styling reset/replay codes so that the styling of one block doesn't affect another. + #[para] Calling on the punk::ansi library - it can coalesce codes to keep the size down. + #[para] It is a giant mess of doing exactly what common wisdom says not to do... lots at once. + #[para] renderline is part of the Unicode and ANSI aware Overtype system which 'renders' a block of text onto a static underlay + #[para] The underlay is generally expected to be an ordered set of lines or a rectangular text block analogous to a terminal screen - but it can also be ragged in line length, or just blank. + #[para] The overlay couuld be similar - in which case it may often be used to overwrite a column or section of the underlay. + #[para] The overlay could however be a sequence of ANSI-laden text that jumps all over the place. + # + #[para] renderline itself only deals with a single line - or sometimes a single character. It is generally called from a loop that does further terminal-like or textblock processing. + #[para] By suppyling the -info 1 option - it can return various fields indicating the state of the render. + #[para] The main 3 are the result, overflow_right, and unapplied. + #[para] Renderline handles cursor movements from either keystrokes or ANSI sequences but for a full system the aforementioned loop will need to be in place to manage the set of lines under manipulation. + + #puts stderr "renderline '$args'" + variable optimise_ptruns + + if {[llength $args] < 2} { + error {usage: ?-info 0|1? ?-startcolumn ? ?-cursor_column ? ?-cursor_row |""? ?-transparent [0|1|]? ?-expand_right [1|0]? undertext overtext} + } + set under [lindex $args end-1] + set over [lindex $args end] + #lassign [lrange $args end-1 end] under over + if {[string last \n $under] >= 0} { + error "overtype::renderline not allowed to contain newlines in undertext" + } + #if {[string first \n $over] >=0 || [string first \n $under] >= 0} { + # error "overtype::renderline not allowed to contain newlines" + #} + + #generally faster to create a new dict in the proc than to use a namespace variable to create dict once and link to variable (2024 8.6/8.7) + set opts [tcl::dict::create\ + -etabs 0\ + -width \uFFEF\ + -expand_right 0\ + -transparent 0\ + -startcolumn 1\ + -cursor_column 1\ + -cursor_row ""\ + -insert_mode 1\ + -crm_mode 0\ + -autowrap_mode 1\ + -reverse_mode 0\ + -info 0\ + -exposed1 \uFFFD\ + -exposed2 \uFFFD\ + -cursor_restore_attributes ""\ + -cp437 0\ + -experimental {}\ + ] + #-cursor_restore_attributes only - for replay stack - position and actual setting/restoring handled by throwback to caller + + #cursor_row, when numeric will allow detection of certain row moves that are still within our row - allowing us to avoid an early return + #An empty string for cursor_row tells us we have no info about our own row context, and to return with an unapplied string if any row move occurs + + #exposed1 and exposed2 for first and second col of underying 2wide char which is truncated by transparency, currsor movements to 2nd charcol, or overflow/expand_right + #todo - return info about such grapheme 'cuts' in -info structure and/or create option to raise an error + + 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 + - -crm_mode - -insert_mode - -autowrap_mode - -reverse_mode + - -info - -exposed1 - -exposed2 - -cursor_restore_attributes { + tcl::dict::set opts $k $v + } + default { + error "overtype::renderline unknown option '$k'. Known options: [tcl::dict::keys $opts]" + } + } + } + # -- --- --- --- --- --- --- --- --- --- --- --- + set opt_width [tcl::dict::get $opts -width] + set opt_etabs [tcl::dict::get $opts -etabs] + set opt_expand_right [tcl::dict::get $opts -expand_right] + set opt_colstart [tcl::dict::get $opts -startcolumn] ;#lhs limit for overlay - an offset to cursor_column - first visible column is 1. 0 or < 0 are before the start of the underlay + set opt_colcursor [tcl::dict::get $opts -cursor_column];#start cursor column relative to overlay + set opt_row_context [tcl::dict::get $opts -cursor_row] + if {[string length $opt_row_context]} { + if {![tcl::string::is integer -strict $opt_row_context] || $opt_row_context <1 } { + error "overtype::renderline -cursor_row must be empty for unspecified/unknown or a non-zero positive integer. received: '$opt_row_context'" + } + } + # -- --- --- --- --- --- --- --- --- --- --- --- + #The _mode flags correspond to terminal modes that can be set/reset via escape sequences (e.g DECAWM wraparound mode) + set opt_insert_mode [tcl::dict::get $opts -insert_mode];#should usually be 1 for each new line in editor mode but must be initialised to 1 externally (review) + #default is for overtype + # -- --- --- --- --- --- --- --- --- --- --- --- + set opt_autowrap_mode [tcl::dict::get $opts -autowrap_mode] ;#DECAWM - char or movement can go beyond leftmost/rightmost col to prev/next line + set opt_reverse_mode [tcl::dict::get $opts -reverse_mode] ;#DECSNM + set opt_crm_mode [tcl::dict::get $opts -crm_mode];# CRM - show control character mode + # -- --- --- --- --- --- --- --- --- --- --- --- + set temp_cursor_saved [tcl::dict::get $opts -cursor_restore_attributes] + + set cp437_glyphs [tcl::dict::get $opts -cp437] + set cp437_map [tcl::dict::create] + if {$cp437_glyphs} { + set cp437_map [set ::punk::ansi::cp437_map] + #for cp437 images we need to map these *after* splitting ansi + #some old files might use newline for its glyph.. but we can't easily support that. + #Not sure how old files did it.. maybe cr lf in sequence was newline and any lone cr or lf were displayed as glyphs? + tcl::dict::unset cp437_map \n + } + + set opt_transparent [tcl::dict::get $opts -transparent] + if {$opt_transparent eq "0"} { + set do_transparency 0 + } else { + set do_transparency 1 + if {$opt_transparent eq "1"} { + set opt_transparent {[\s]} + } + } + # -- --- --- --- --- --- --- --- --- --- --- --- + set opt_returnextra [tcl::dict::get $opts -info] + # -- --- --- --- --- --- --- --- --- --- --- --- + set opt_exposed1 [tcl::dict::get $opts -exposed1] + set opt_exposed2 [tcl::dict::get $opts -exposed2] + # -- --- --- --- --- --- --- --- --- --- --- --- + + if {$opt_row_context eq ""} { + set cursor_row 1 + } else { + set cursor_row $opt_row_context + } + + set insert_mode $opt_insert_mode ;#default 1 + set autowrap_mode $opt_autowrap_mode ;#default 1 + set crm_mode $opt_crm_mode ;#default 0 (Show Control Character mode) + set reverse_mode $opt_reverse_mode + + #----- + # + if {[info exists punk::console::tabwidth]} { + #punk console is updated if punk::console::set_tabstop_width is used or rep is started/restarted + #It is way too slow to test the current width by querying the terminal here - so it could conceivably get out of sync + #todo - we also need to handle the new threaded repl where console config is in a different thread. + # - also - concept of sub-regions being mini-consoles with their own settings - 'id' for console, or use in/out channels as id? + set tw $::punk::console::tabwidth + } else { + set tw 8 + } + + set overdata $over + if {!$cp437_glyphs} { + #REVIEW! tabify will give different answers for an ANSI colourised string vs plain text + if {!$opt_etabs} { + if {[string first \t $under] >= 0} { + #set under [textutil::tabify::untabify2 $under] + set under [textutil::tabify::untabifyLine $under $tw] + } + if {[string first \t $over] >= 0} { + #set overdata [textutil::tabify::untabify2 $over] + set overdata [textutil::tabify::untabifyLine $over $tw] + } + } + } + #------- + + #ta_detect ansi and do simpler processing? + + #we repeat tests for grapheme width in different loops - rather than create another datastructure to store widths based on column, + #we'll use the grapheme_width_cached function as a lookup table of all graphemes encountered - as there will often be repeats in different positions anyway. + + # -- --- --- --- --- --- --- --- + if {$under ne ""} { + if {[punk::ansi::ta::detect $under]} { + set undermap [punk::ansi::ta::split_codes_single $under] + } else { + #single plaintext part + set undermap [list $under] + } + } else { + set undermap [list] + } + set understacks [list] + set understacks_gx [list] + set pm_list [list] + + set i_u -1 ;#underlay may legitimately be empty + set undercols [list] + set u_codestack [list] + #u_gx_stack probably isn't really a stack - I don't know if g0 g1 can stack or not - for now we support only g0 anyway + set u_gx_stack [list] ;#separate stack for g0 (g1 g2 g3?) graphics on and off (DEC special graphics) + #set pt_underchars "" ;#for string_columns length calculation for expand_right 0 truncation + set remainder [list] ;#for returnextra + foreach {pt code} $undermap { + #pt = plain text + #append pt_underchars $pt + if {$pt ne ""} { + if {$cp437_glyphs} { + set pt [tcl::string::map $cp437_map $pt] + } + set is_ptrun 0 + if {$optimise_ptruns && [tcl::string::length $pt] >= $optimise_ptruns} { + set p1 [tcl::string::index $pt 0] + set hex [format %x [scan $p1 %c]] ;#punk::char::char_hex + set re [tcl::string::cat {^[} \\U$hex {]+$}] + set is_ptrun [regexp $re $pt] + } + if {$is_ptrun} { + #switch -- $p1 { + # " " - - - _ - ! - @ - # - $ - % - ^ - & - * - = - + - : - . - , - / - | - ? - + # 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 { + # set width 1 + # } + # default { + # if {$p1 eq "\u0000"} { + # #use null as empty cell representation - review + # #use of this will probably collide with some application at some point + # #consider an option to set the empty cell character + # set width 1 + # } else { + # set width [grapheme_width_cached $p1] ;# when zero??? + # } + # } + #} + set width [grapheme_width_cached $p1] ;# when zero??? + set ptlen [string length $pt] + if {$width <= 1} { + #review - 0 and 1? + incr i_u $ptlen + lappend understacks {*}[lrepeat $ptlen $u_codestack] + lappend understacks_gx {*}[lrepeat $ptlen $u_gx_stack] + lappend undercols {*}[lrepeat $ptlen $p1] + } else { + incr i_u $ptlen ;#2nd col empty str - so same as above + set 2ptlen [expr {$ptlen * 2}] + lappend understacks {*}[lrepeat $2ptlen $u_codestack] + lappend understacks_gx {*}[lrepeat $2ptlen $u_gx_stack] + set l [concat {*}[lrepeat $ptlen [list $p1 ""]]] + lappend undercols {*}$l + unset l + } + + } else { + foreach grapheme [punk::char::grapheme_split $pt] { + #an ugly but easy hack to serve *some* common case ascii quickly with byte-compiled literal switch - feels dirty. + #.. but even 0.5uS per char (grapheme_width_cached) adds up quickly when stitching lots of lines together. + #todo - test decimal value instead, compare performance + 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 { + set width 1 + } + default { + if {$grapheme eq "\u0000"} { + #use null as empty cell representation - review + #use of this will probably collide with some application at some point + #consider an option to set the empty cell character + set width 1 + } else { + #zero width still acts as 1 below??? review what should happen + set width [grapheme_width_cached $grapheme] + #we still want most controls and other zero-length codepoints such as \u200d (zero width joiner) to stay zero-length + #we substitute lone ESC that weren't captured within ANSI context as a debugging aid to see malformed ANSI + #todo - default to off and add a flag (?) to enable this substitution + set sub_stray_escapes 0 + if {$sub_stray_escapes && $width == 0} { + if {$grapheme eq "\x1b"} { + set gvis [ansistring VIEW $grapheme] ;#can only use with graphemes that have a single replacement char.. + set grapheme $gvis + set width 1 + } + } + } + } + } + + #set width [grapheme_width_cached $grapheme] + incr i_u + lappend understacks $u_codestack + lappend understacks_gx $u_gx_stack + + lappend undercols $grapheme + if {$width > 1} { + #presumably there are no triple-column or wider unicode chars.. until the aliens arrive.(?) + #but what about emoji combinations etc - can they be wider than 2? + #todo - if -etabs enabled - then we treat \t as the width determined by our elastic tabstop + incr i_u + lappend understacks $u_codestack + lappend understacks_gx $u_gx_stack + lappend undercols "" + } + } + + } + } + #underlay should already have been rendered and not have non-sgr codes - but let's retain the check for them and not stack them if other codes are here + + #only stack SGR (graphics rendition) codes - not title sets, cursor moves etc + #keep any remaining PMs in place + if {$code ne ""} { + set c1c2 [tcl::string::range $code 0 1] + + set leadernorm [tcl::string::range [tcl::string::map [list\ + \x1b\[ 7CSI\ + \x9b 8CSI\ + \x1b\( 7GFX\ + \x1b^ 7PMX\ + \x1bX 7SOS\ + ] $c1c2] 0 3];# leadernorm is 1st 2 chars mapped to normalised indicator - or is original 2 chars + + switch -- $leadernorm { + 7CSI - 8CSI { + #need to exclude certain leaders after the lb e.g < for SGR 1006 mouse + #REVIEW - what else could end in m but be mistaken as a normal SGR code here? + set maybemouse "" + if {[tcl::string::index $c1c2 0] eq "\x1b"} { + set maybemouse [tcl::string::index $code 2] + } + + if {$maybemouse ne "<" && [tcl::string::index $code end] eq "m"} { + if {[punk::ansi::codetype::is_sgr_reset $code]} { + set u_codestack [list "\x1b\[m"] + } elseif {[punk::ansi::codetype::has_sgr_leadingreset $code]} { + set u_codestack [list $code] + } else { + #basic simplification first.. straight dups + set dup_posns [lsearch -all -exact $u_codestack $code] ;#-exact because of square-bracket glob chars + set u_codestack [lremove $u_codestack {*}$dup_posns] + lappend u_codestack $code + } + } + } + 7GFX { + switch -- [tcl::string::index $code 2] { + "0" { + set u_gx_stack [list gx0_on] ;#we'd better use a placeholder - or debugging will probably get into a big mess + } + B { + set u_gx_stack [list] + } + } + } + 7PMX - 7SOS { + #we can have PMs or SOS (start of string) in the underlay - though mostly the PMs should have been processed.. + #attach the PM/SOS (entire ANSI sequence) to the previous grapheme! + #It should not affect the size - but terminal display may get thrown out if terminal doesn't support them. + + #note that there may in theory already be ANSI stored - we don't assume it was a pure grapheme string + set graphemeplus [lindex $undercols end] + if {$graphemeplus ne "\0"} { + append graphemeplus $code + } else { + set graphemeplus $code + } + lset undercols end $graphemeplus + #The grapheme_width_cached function will be called on this later - and doesn't account for ansi. + #we need to manually cache the item with it's proper width + variable grapheme_widths + #stripped and plus version keys pointing to same length + dict set grapheme_widths $graphemeplus [grapheme_width_cached [::punk::ansi::ansistrip $graphemeplus]] + + } + default { + + } + + } + + #if {[punk::ansi::codetype::is_sgr_reset $code]} { + # #set u_codestack [list] + #} elseif {[punk::ansi::codetype::has_sgr_leadingreset $code]} { + #} elseif {[punk::ansi::codetype::is_sgr $code]} { + #} else { + # #leave SGR stack as is + # if {[punk::ansi::codetype::is_gx_open $code]} { + # } elseif {[punk::ansi::codetype::is_gx_close $code]} { + # } + #} + } + #consider also if there are other codes that should be stacked..? + } + + #NULL empty cell indicator + if {$opt_width ne "\uFFEF"} { + if {[llength $understacks]} { + set cs $u_codestack + set gs $u_gx_stack + } else { + set cs [list] + set gs [list] + } + if {[llength $undercols]< $opt_width} { + set diff [expr {$opt_width- [llength $undercols]}] + if {$diff > 0} { + #set undercols [list {*}$undercols {*}[lrepeat $diff "\u0000"]] ;#2024 - much slower + lappend undercols {*}[lrepeat $diff "\u0000"] + lappend understacks {*}[lrepeat $diff $cs] + lappend understacks_gx {*}[lrepeat $diff $gs] + } + } + } + + if {$opt_width ne "\uFFEF"} { + set renderwidth $opt_width + } else { + set renderwidth [llength $undercols] + } + + + if 0 { + # ----------------- + # if we aren't extending understacks & understacks_gx each time we incr idx above the undercols length.. this doesn't really serve a purpose + # Review. + # ----------------- + #replay code for last overlay position in input line + # whether or not we get that far - we need to return it for possible replay on next line + if {[llength $understacks]} { + lappend understacks $u_codestack + lappend understacks_gx $u_gx_stack + } else { + #in case overlay onto emptystring as underlay + lappend understacks [list] + lappend understacks_gx [list] + } + # ----------------- + } + + #trailing codes in effect for underlay + if {[llength $u_codestack]} { + #set replay_codes_underlay [join $u_codestack ""] + set replay_codes_underlay [punk::ansi::codetype::sgr_merge_list {*}$u_codestack] + } else { + set replay_codes_underlay "" + } + + + # -- --- --- --- --- --- --- --- + #### + #if opt_colstart - we need to build a space (or any singlewidth char ?) padding on the left containing the right number of columns. + #this will be processed as transparent - and handle doublewidth underlay characters appropriately + set startpadding [string repeat " " [expr {$opt_colstart -1}]] + #overdata with left padding spaces based on col-start under will show through for left-padding portion regardless of -transparency + if {$startpadding ne "" || $overdata ne ""} { + if {[punk::ansi::ta::detect $overdata]} { + set overmap [punk::ansi::ta::split_codes_single $startpadding$overdata] + } else { + #single plaintext part + set overmap [list $startpadding$overdata] + } + } else { + set overmap [list] + } + #### + + + #todo - detect plain ascii no-ansi input line (aside from leading ansi reset) + #will that allow some optimisations? + + #todo - detect repeated transparent char in overlay + #regexp {^(.)\1+$} ;#backtracking regexp - relatively slow. + # - try set c [string index $data 0]; regexp [string map [list %c% $c] {^[%c%]+$}] $data + #we should be able to optimize to pass through the underlay?? + + #??? + set colcursor $opt_colstart + #TODO - make a little virtual column object + #we need to refer to column1 or columnmin? or columnmax without calculating offsets due to to startcolumn + #need to lock-down what start column means from perspective of ANSI codes moving around - the offset perspective is unclear and a mess. + + + #set re_diacritics {[\u0300-\u036f]+|[\u1ab0-\u1aff]+|[\u1dc0-\u1dff]+|[\u20d0-\u20ff]+|[\ufe20-\ufe2f]+} + #as at 2024-02 punk::char::grapheme_split uses these - not aware of more complex graphemes + + set overstacks [list] + set overstacks_gx [list] + + set o_codestack [list]; #SGR codestack (not other codes such as movement,insert key etc) + set o_gxstack [list] + set pt_overchars "" + set i_o 0 + set overlay_grapheme_control_list [list] ;#tag each with g, sgr or other. 'other' are things like cursor-movement or insert-mode or codes we don't recognise/use + #experiment + set overlay_grapheme_control_stacks [list] + foreach {pt code} $overmap { + if {$pt ne ""} { + #todo - wrap in test for empty pt (we used split_codes_single - and it may be common for sgr sequences to be unmerged and so have empty pts between) + if {$cp437_glyphs} { + set pt [tcl::string::map $cp437_map $pt] + } + append pt_overchars $pt + #will get empty pt between adjacent codes + if {!$crm_mode} { + + set is_ptrun 0 + if {$optimise_ptruns && [tcl::string::length $pt] >= $optimise_ptruns} { + set p1 [tcl::string::index $pt 0] + set re [tcl::string::cat {^[} \\U[format %x [scan $p1 %c]] {]+$}] + set is_ptrun [regexp $re $pt] + + #leading only? we would have to check for graphemes at the trailing boundary? + #set re [tcl::string::cat {^[} \\U[format %x [scan $p1 %c]] {]+}] + #set is_ptrun [regexp -indices $re $pt runrange] + #if {$is_ptrun && 1} { + #} + } + if {$is_ptrun} { + #review - in theory a run over a certain length won't be part of some grapheme combo (graphemes can be long e.g 44?, but not as runs(?)) + #could be edge cases for runs at line end? (should be ok as we include trailing \n in our data) + set len [string length $pt] + set g_element [list g $p1] + + #lappend overstacks {*}[lrepeat $len $o_codestack] + #lappend overstacks_gx {*}[lrepeat $len $o_gxstack] + #incr i_o $len + #lappend overlay_grapheme_control_list {*}[lrepeat $len [list g $p1]] + #lappend overlay_grapheme_control_stacks {*}[lrepeat $len $o_codestack] + + set pi 0 + incr i_o $len + while {$pi < $len} { + lappend overstacks $o_codestack + lappend overstacks_gx $o_gxstack + lappend overlay_grapheme_control_list $g_element + lappend overlay_grapheme_control_stacks $o_codestack + incr pi + } + } else { + foreach grapheme [punk::char::grapheme_split $pt] { + lappend overstacks $o_codestack + lappend overstacks_gx $o_gxstack + incr i_o + lappend overlay_grapheme_control_list [list g $grapheme] + lappend overlay_grapheme_control_stacks $o_codestack + } + } + } else { + set tsbegin [clock micros] + foreach grapheme_original [punk::char::grapheme_split $pt] { + set pt_crm [ansistring VIEW -nul 1 -lf 2 -vt 2 -ff 2 $grapheme_original] + #puts stderr "ptlen [string length $pt] graphemelen[string length $grapheme_original] pt_crmlen[string length $pt_crm] $pt_crm" + foreach grapheme [punk::char::grapheme_split $pt_crm] { + if {$grapheme eq "\n"} { + lappend overlay_grapheme_control_stacks $o_codestack + lappend overlay_grapheme_control_list [list crmcontrol "\x1b\[00001E"] + } else { + lappend overstacks $o_codestack + lappend overstacks_gx $o_gxstack + incr i_o + lappend overlay_grapheme_control_list [list g $grapheme] + lappend overlay_grapheme_control_stacks $o_codestack + } + } + } + set elapsed [expr {[clock micros] - $tsbegin}] + puts stderr "ptlen [string length $pt] elapsedus:$elapsed" + } + } + + #only stack SGR (graphics rendition) codes - not title sets, cursor moves etc + #order of if-else based on assumptions: + # that pure resets are fairly common - more so than leading resets with other info + # that non-sgr codes are not that common, so ok to check for resets before verifying it is actually SGR at all. + if {$code ne ""} { + #we need to immediately set crm_mode here if \x1b\[3h received + if {$code eq "\x1b\[3h"} { + set crm_mode 1 + } elseif {$code eq "\x1b\[3l"} { + set crm_mode 0 + } + #else crm_mode could be set either way from options + if {$crm_mode && $code ne "\x1b\[00001E"} { + #treat the code as type 'g' like above - only allow through codes to reset mode REVIEW for now just \x1b\[3l ? + #we need to somehow convert further \n in the graphical rep to an instruction for newline that will bypass further crm_mode processing or we would loop. + set code_as_pt [ansistring VIEW -nul 1 -lf 1 -vt 1 -ff 1 $code] + #split using standard split for first foreach loop - grapheme based split when processing 2nd foreach loop + set chars [split $code_as_pt ""] + set codeparts [list] ;#list of 2-el lists each element {crmcontrol } or {g } + foreach c $chars { + if {$c eq "\n"} { + #use CNL (cursor next line) \x1b\[00001E ;#leading zeroes ok for this processor - used as debugging aid to distinguish + lappend codeparts [list crmcontrol "\x1b\[00001E"] + } else { + if {[llength $codeparts] > 0 && [lindex $codeparts end 0] eq "g"} { + set existing [lindex $codeparts end 1] + lset codeparts end [list g [string cat $existing $c]] + } else { + lappend codeparts [list g $c] + } + } + } + + set partidx 0 + foreach record $codeparts { + lassign $record rtype rval + switch -exact -- $rtype { + g { + append pt_overchars $rval + foreach grapheme [punk::char::grapheme_split $rval] { + lappend overstacks $o_codestack + lappend overstacks_gx $o_gxstack + incr i_o + lappend overlay_grapheme_control_list [list g $grapheme] + lappend overlay_grapheme_control_stacks $o_codestack + } + } + crmcontrol { + #leave o_codestack + lappend overlay_grapheme_control_stacks $o_codestack + lappend overlay_grapheme_control_list [list crmcontrol $rval] + } + } + } + } else { + lappend overlay_grapheme_control_stacks $o_codestack + #there will always be an empty code at end due to foreach on 2 vars with odd-sized list ending with pt (overmap coming from perlish split) + if {[punk::ansi::codetype::is_sgr_reset $code]} { + set o_codestack [list "\x1b\[m"] ;#reset better than empty list - fixes some ansi art issues + lappend overlay_grapheme_control_list [list sgr $code] + } elseif {[punk::ansi::codetype::has_sgr_leadingreset $code]} { + set o_codestack [list $code] + lappend overlay_grapheme_control_list [list sgr $code] + } elseif {[priv::is_sgr $code]} { + #basic simplification first - remove straight dupes + set dup_posns [lsearch -all -exact $o_codestack $code] ;#must be -exact because of square-bracket glob chars + set o_codestack [lremove $o_codestack {*}$dup_posns] + lappend o_codestack $code + lappend overlay_grapheme_control_list [list sgr $code] + } elseif {[regexp {\x1b7|\x1b\[s} $code]} { + #experiment + #cursor_save - for the replays review. + #jmn + #set temp_cursor_saved [punk::ansi::codetype::sgr_merge_list {*}$o_codestack] + lappend overlay_grapheme_control_list [list other $code] + } elseif {[regexp {\x1b8|\x1b\[u} $code]} { + #experiment + #cursor_restore - for the replays + set o_codestack [list $temp_cursor_saved] + lappend overlay_grapheme_control_list [list other $code] + } else { + #review + if {[punk::ansi::codetype::is_gx_open $code]} { + set o_gxstack [list "gx0_on"] + lappend overlay_grapheme_control_list [list gx0 gx0_on] ;#don't store code - will complicate debugging if we spit it out and jump character sets + } elseif {[punk::ansi::codetype::is_gx_close $code]} { + set o_gxstack [list] + lappend overlay_grapheme_control_list [list gx0 gx0_off] ;#don't store code - will complicate debugging if we spit it out and jump character sets + } else { + lappend overlay_grapheme_control_list [list other $code] + } + } + } + } + + } + #replay code for last overlay position in input line - should take account of possible trailing sgr code after last grapheme + set max_overlay_grapheme_index [expr {$i_o -1}] + lappend overstacks $o_codestack + lappend overstacks_gx $o_gxstack + + #set replay_codes_overlay [join $o_codestack ""] + set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}$o_codestack] + + #if {[tcl::dict::exists $overstacks $max_overlay_grapheme_index]} { + # set replay_codes_overlay [join [tcl::dict::get $overstacks $max_overlay_grapheme_index] ""] + #} else { + # set replay_codes_overlay "" + #} + # -- --- --- --- --- --- --- --- + + + #potential problem - combinining diacritics directly following control chars like \r \b + + # -- --- --- + #we need to initialise overflow_idx before any potential row-movements - as they need to perform a loop break and force in_excess to 1 + if {$opt_expand_right} { + #expand_right true means we can have lines as long as we want, but either way there can be excess data that needs to be thrown back to the calling loop. + #we currently only support horizontal expansion to the right (review regarding RTL text!) + set overflow_idx -1 + } else { + #expand_right zero - we can't grow beyond our column width - so we get ellipsis or truncation + if {$opt_width ne "\uFFEF"} { + set overflow_idx [expr {$opt_width}] + } else { + #review - this is also the cursor position when adding a char at end of line? + set overflow_idx [expr {[llength $undercols]}] ;#index at which we would be *in* overflow a row move may still override it + } + } + # -- --- --- + + set outcols $undercols ;#leave undercols as is, outcols can potentially be appended to. + + set unapplied "" ;#if we break for move row (but not for /v ?) + set unapplied_list [list] + + set insert_lines_above 0 ;#return key + set insert_lines_below 0 + set instruction "" + + # -- --- --- + #cursor_save_dec, cursor_restore_dec etc + set cursor_restore_required 0 + set cursor_saved_attributes "" + set cursor_saved_position "" + # -- --- --- + + #set idx 0 ;# line index (cursor - 1) + #set idx [expr {$opt_colstart + $opt_colcursor} -1] + + #idx is the per column output index + set idx [expr {$opt_colcursor -1}] ;#don't use opt_colstart here - we have padded and won't start emitting until idx reaches opt_colstart-1 + #cursor_column is usually one above idx - but we have opt_colstart which is like a margin - todo: remove cursor_column from the following loop and calculate it's offset when breaking or at end. + #(for now we are incrementing/decrementing both in sync - which is a bit silly) + set cursor_column $opt_colcursor + + #idx_over is the per grapheme overlay index + set idx_over -1 + + + #movements only occur within the overlay range. + #an underlay is however not necessary.. e.g + #renderline -expand_right 1 "" data + + #set re_mode {\x1b\[\?([0-9]*)(h|l)} ;#e.g DECAWM + #set re_col_move {\x1b\[([0-9]*)(C|D|G)$} + #set re_row_move {\x1b\[([0-9]*)(A|B)$} + #set re_both_move {\x1b\[([0-9]*)(?:;){0,1}([0-9]*)H$} ;# or "f" ? + #set re_vt_sequence {\x1b\[([0-9]*)(?:;){0,1}([0-9]*)~$} + #set re_cursor_save {\x1b\[s$} ;#note probable incompatibility with DECSLRM (set left right margin)! + #set re_cursor_restore {\x1b\[u$} + #set re_cursor_save_dec {\x1b7$} + #set re_cursor_restore_dec {\x1b8$} + #set re_other_single {\x1b(D|M|E)$} + #set re_decstbm {\x1b\[([0-9]*)(?:;){0,1}([0-9]*)r$} ;#DECSTBM set top and bottom margins + + #puts "-->$overlay_grapheme_control_list<--" + #puts "-->overflow_idx: $overflow_idx" + for {set gci 0} {$gci < [llength $overlay_grapheme_control_list]} {incr gci} { + set gc [lindex $overlay_grapheme_control_list $gci] + lassign $gc type item + + #emit plaintext chars first using existing SGR codes from under/over stack as appropriate + #then check if the following code is a cursor movement within the line and adjust index if so + #foreach ch $overlay_graphemes {} + switch -- $type { + g { + set ch $item + #crm_mode affects both graphic and control + if {0 && $crm_mode} { + set chars [ansistring VIEW -nul 1 -lf 2 -vt 2 -ff 2 $ch] + set chars [string map [list \n "\x1b\[00001E"] $chars] + if {[llength [split $chars ""]] > 1} { + priv::render_unapplied $overlay_grapheme_control_list $gci + #prefix the unapplied controls with the string version of this control + set unapplied_list [linsert $unapplied_list 0 {*}[split $chars ""]] + set unapplied [join $unapplied_list ""] + #incr idx_over + break + } else { + set ch $chars + } + } + incr idx_over; #idx_over (until unapplied reached anyway) is per *grapheme* in the overlay - not per col. + if {($idx < ($opt_colstart -1))} { + incr idx [grapheme_width_cached $ch] + continue + } + #set within_undercols [expr {$idx <= [llength $undercols]-1}] ;#within our active data width + set within_undercols [expr {$idx <= $renderwidth-1}] + + #https://www.enigma.com/resources/blog/the-secret-world-of-newline-characters + #\x85 NEL in the c1 control set is treated by some terminal emulators (e.g Hyper) as a newline, + #on some it's invisble but doesn't change the line, on some it's a visible glyph of width 1. + #This is hard to process in any standard manner - but I think the Hyper behaviour of doing what it was intended is perhaps most reasonable + #We will map it to the same behaviour as lf here for now... but we need also to consider the equivalent ANSI sequence: \x1bE + + set chtest [tcl::string::map [list \n \x85 \b \r \v \x7f ] $ch] + #puts --->chtest:$chtest + #specials - each shoud have it's own test of what to do if it happens after overflow_idx reached + switch -- $chtest { + "" { + set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] + if {$idx == 0} { + #puts "---a at col 1" + #linefeed at column 1 + #leave the overflow_idx ;#? review + set instruction lf_start ;#specific instruction for newline at column 1 + priv::render_unapplied $overlay_grapheme_control_list $gci + break + } elseif {$overflow_idx != -1 && $idx == $overflow_idx} { + #linefeed after final column + #puts "---c at overflow_idx=$overflow_idx" + incr cursor_row + set overflow_idx $idx ;#override overflow_idx even if it was set to -1 due to expand_right = 1 + set instruction lf_overflow ;#only special treatment is to give it it's own instruction in case caller needs to handle differently + priv::render_unapplied $overlay_grapheme_control_list $gci + break + } else { + #linefeed occurred in middle or at end of text + #puts "---mid-or-end-text-linefeed idx:$idx overflow_idx:$overflow_idx" + if {$insert_mode == 0} { + incr cursor_row + if {$idx == -1 || $overflow_idx > $idx} { + #don't set overflow_idx higher if it's already set lower and we're adding graphemes to overflow + set overflow_idx $idx ;#override overflow_idx even if it was set to -1 due to expand_right = 1 + } + set instruction lf_mid + priv::render_unapplied $overlay_grapheme_control_list $gci + break + } else { + incr cursor_row + #don't adjust the overflow_idx + priv::render_unapplied $overlay_grapheme_control_list $gci + set instruction lf_mid + break ;# could have overdata following the \n - don't keep processing + } + } + + } + "" { + #will we want/need to use raw for keypresses in terminal? (terminal with LNM in standard reset mode means enter= this is the usual config for terminals) + #So far we are assuming the caller has translated to and handle above.. REVIEW. + + #consider also the old space-carriagereturn softwrap convention used in some terminals. + #In the context of rendering to a block of text - this works similarly in that the space gets eaten so programs emitting space-cr at the terminal width col will pretty much get what they expect. + set idx [expr {$opt_colstart -1}] + set cursor_column $opt_colstart ;#? + } + "" { + #literal backspace char - not necessarily from keyboard + #review - backspace effect on double-width chars - we are taking a column-editing perspective in overtype + #(important for -transparent option - hence replacement chars for half-exposed etc) + #review - overstrike support as per nroff/less (generally considered an old technology replaced by unicode mechanisms and/or ansi SGR) + if {$idx > ($opt_colstart -1)} { + incr idx -1 + incr cursor_column -1 + } else { + set flag 0 + if $flag { + #review - conflicting requirements? Need a different sequence for destructive interactive backspace? + priv::render_unapplied $overlay_grapheme_control_list $gci + set instruction backspace_at_start + break + } + } + } + "" { + #literal del character - some terminals send just this for what is generally expected to be a destructive backspace + #We instead treat this as a pure delete at current cursor position - it is up to the repl or terminal to remap backspace key to a sequence that has the desired effect. + priv::render_delchar $idx + } + "" { + #end processing this overline. rest of line is remainder. cursor for column as is. + #REVIEW - this theoretically depends on terminal's vertical tabulation setting (name?) + #e.g it could be configured to jump down 6 rows. + #On the other hand I've seen indications that some modern terminal emulators treat it pretty much as a linefeed. + #todo? + incr cursor_row + set overflow_idx $idx + #idx_over has already been incremented as this is both a movement-control and in some sense a grapheme + priv::render_unapplied $overlay_grapheme_control_list $gci + set instruction vt + break + } + default { + if {$overflow_idx != -1} { + #review - how to check arbitrary length item such as tab is going to overflow .. before we get to overflow_idx? + #call grapheme_width_cached on each ch, or look for tab specifically as it's currently the only known reason to have a grapheme width > 2? + #we need to decide what a tab spanning the overflow_idx means and how it affects wrap etc etc + if {$idx == $overflow_idx-1} { + set owidth [grapheme_width_cached $ch] + if {$owidth == 2} { + #review split 2w overflow? + #we don't want to make the decision here to split a 2w into replacement characters at end of line and beginning of next line + #better to consider the overlay char as unable to be applied to the line + #render empty column(?) - and reduce overlay grapheme index by one so that the current ch goes into unapplied + #throwing back to caller with instruction complicates its job - but is necessary to avoid making decsions for it here. + priv::render_addchar $idx "" [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode + #change the overflow_idx + set overflow_idx $idx + incr idx + incr idx_over -1 ;#set overlay grapheme index back one so that sgr stack from previous overlay grapheme used + priv::render_unapplied $overlay_grapheme_control_list [expr {$gci-1}] ;#note $gci-1 instead of just gci + #throw back to caller's loop - add instruction to caller as this is not the usual case + #caller may for example choose to render a single replacement char to this line and omit the grapheme, or wrap it to the next line + set instruction overflow_splitchar + break + } elseif {$owidth > 2} { + #? tab? + #TODO! + puts stderr "overtype::renderline long overtext grapheme '[ansistring VIEW -lf 1 -vt 1 $ch]' not handled" + #tab of some length dependent on tabstops/elastic tabstop settings? + } + } elseif {$idx >= $overflow_idx} { + #REVIEW + set next_gc [lindex $overlay_grapheme_control_list $gci+1] ;#next grapheme or control + lassign $next_gc next_type next_item + if {$autowrap_mode || $next_type ne "g"} { + set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci-1]] + #set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] + #don't incr idx beyond the overflow_idx + #idx_over already incremented - decrement so current overlay grapheme stacks go to unapplied + incr idx_over -1 + #priv::render_unapplied $overlay_grapheme_control_list [expr {$gci-1}] ;#back one index here too + priv::render_this_unapplied $overlay_grapheme_control_list $gci ;# + set instruction overflow + break + } else { + #no point throwing back to caller for each grapheme that is overflowing + #without this branch - renderline would be called with overtext reducing only by one grapheme per call + #processing a potentially long overtext each time (ie - very slow) + set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] + #JMN4 + + } + } + } else { + #review. + #overflow_idx = -1 + #This corresponds to expand_right being true (at least until overflow_idx is in some cases forced to a value when throwing back to calling loop) + } + + if {($do_transparency && [regexp $opt_transparent $ch])} { + #pre opt_colstart is effectively transparent (we have applied padding of required number of columns to left of overlay) + if {$idx > [llength $outcols]-1} { + lappend outcols " " + #tcl::dict::set understacks $idx [list] ;#review - use idx-1 codestack? + #lset understacks $idx [list] ;#will get index $i out of range error + lappend understacks [list] ;#REVIEW + incr idx + incr cursor_column + } else { + #todo - punk::char::char_width + set g [lindex $outcols $idx] + #JMN + set uwidth [grapheme_width_cached $g] + if {[lindex $outcols $idx] eq ""} { + #2nd col of 2-wide char in underlay + incr idx + incr cursor_column + } elseif {$uwidth == 0} { + #e.g control char ? combining diacritic ? + incr idx + incr cursor_column + } elseif {$uwidth == 1} { + set owidth [grapheme_width_cached $ch] + incr idx + incr cursor_column + if {$owidth > 1} { + incr idx + incr cursor_column + } + } elseif {$uwidth > 1} { + if {[grapheme_width_cached $ch] == 1} { + if {!$insert_mode} { + #normal singlewide transparent overlay onto double-wide underlay + set next_pt_overchar [tcl::string::index $pt_overchars $idx_over+1] ;#lookahead of next plain-text char in overlay + if {$next_pt_overchar eq ""} { + #special-case trailing transparent - no next_pt_overchar + incr idx + incr cursor_column + } else { + if {[regexp $opt_transparent $next_pt_overchar]} { + incr idx + incr cursor_column + } else { + #next overlay char is not transparent.. first-half of underlying 2wide char is exposed + #priv::render_addchar $idx $opt_exposed1 [tcl::dict::get $overstacks $idx_over] [tcl::dict::get $overstacks_gx $idx_over] $insert_mode + priv::render_addchar $idx $opt_exposed1 [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode + incr idx + incr cursor_column + } + } + } else { + #? todo - decide what transparency even means for insert mode + incr idx + incr cursor_column + } + } else { + #2wide transparency over 2wide in underlay - review + incr idx + incr cursor_column + } + } + } + } else { + + set idxchar [lindex $outcols $idx] + #non-transparent char in overlay or empty cell + if {$idxchar eq "\u0000"} { + #empty/erased cell indicator + set uwidth 1 + } else { + set uwidth [grapheme_width_cached $idxchar] + } + if {$within_undercols} { + if {$idxchar eq ""} { + #2nd col of 2wide char in underlay + if {!$insert_mode} { + priv::render_addchar $idx $ch [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] 0 + #JMN - this has to expose if our startposn chopped an underlay - but not if we already overwrote the first half of the widechar underlay grapheme + #e.g renderline \uFF21\uFF21--- a\uFF23\uFF23 + #vs + # renderline -startcolumn 2 \uFF21---- \uFF23 + if {[lindex $outcols $idx-1] != ""} { + #verified it's an empty following a filled - so it's a legit underlay remnant (REVIEW - when would it not be??) + #reset previous to an exposed 1st-half - but leave understacks code as is + priv::render_addchar [expr {$idx-1}] $opt_exposed1 [lindex $understacks $idx-1] [lindex $understacks_gx $idx-1] 0 + } + incr idx + } else { + set prevcolinfo [lindex $outcols $idx-1] + #for insert mode - first replace the empty 2ndhalf char with exposed2 before shifting it right + #REVIEW - this leaves a replacement character permanently in our columns.. but it is consistent regarding length (?) + #The alternative is to disallow insertion at a column cursor that is at 2nd half of 2wide char + #perhaps by inserting after the char - this may be worthwhile - but may cause other surprises + #It is perhaps best avoided at another level and try to make renderline do exactly as it's told + #the advantage of this 2w splitting method is that the inserted character ends up in exactly the column we expect. + priv::render_addchar $idx $opt_exposed2 [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] 0 ;#replace not insert + priv::render_addchar $idx $ch [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] 1 ;#insert - same index + if {$prevcolinfo ne ""} { + #we've split the 2wide - it may already have been rendered as an exposed1 - but not for example if our startcolumn was current idx + priv::render_addchar [expr {$idx-1}] $opt_exposed1 [lindex $understacks $idx-1] [lindex $understacks_gx $idx-1] 0 ;#replace not insert + } ;# else?? + incr idx + } + if {$cursor_column < [llength $outcols] || $overflow_idx == -1} { + incr cursor_column + } + } elseif {$uwidth == 0} { + #what if this is some other c0/c1 control we haven't handled specifically? + + #by emitting a preceding empty-string column - we associate whatever this char is with the preceeding non-zero-length character and any existing zero-lengths that follow it + #e.g combining diacritic - increment before over char REVIEW + #arguably the previous overchar should have done this - ie lookahead for combiners? + #if we can get a proper grapheme_split function - this should be easier to tidy up. + priv::render_addchar $idx "" [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode + incr idx + priv::render_addchar $idx $ch [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode + incr idx + incr cursor_column 2 + + if {$cursor_column > [llength $outcols] && $overflow_idx != -1} { + set cursor_column [llength $outcols] + } + } elseif {$uwidth == 1} { + #includes null empty cells + set owidth [grapheme_width_cached $ch] + if {$owidth == 1} { + priv::render_addchar $idx $ch [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode + incr idx + } else { + priv::render_addchar $idx $ch [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode + incr idx + priv::render_addchar $idx "" [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode + #if next column in underlay empty - we've overwritten first half of underlying 2wide grapheme + #replace with rhs exposure in case there are no more overlay graphemes coming - use underlay's stack + if {([llength $outcols] >= $idx +2) && [lindex $outcols $idx+1] eq ""} { + priv::render_addchar [expr {$idx+1}] $opt_exposed2 [lindex $understacks $idx+1] [lindex $understacks_gx $idx+1] $insert_mode + } + incr idx + } + if {($cursor_column < [llength $outcols]) || $overflow_idx == -1} { + incr cursor_column + } + } elseif {$uwidth > 1} { + set owidth [grapheme_width_cached $ch] + if {$owidth == 1} { + #1wide over 2wide in underlay + if {!$insert_mode} { + priv::render_addchar $idx $ch [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode + incr idx + incr cursor_column + priv::render_addchar $idx $opt_exposed2 [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode + #don't incr idx - we are just putting a broken-indication in the underlay - which may get overwritten by next overlay char + } else { + #insert mode just pushes all to right - no exposition char here + priv::render_addchar $idx $ch [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode + incr idx + incr cursor_column + } + } else { + #2wide over 2wide + priv::render_addchar $idx $ch [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode + incr idx 2 + incr cursor_column 2 + } + + if {$cursor_column > [llength $outcols] && $overflow_idx != -1} { + set cursor_column [llength $outcols] + } + } + } else { + priv::render_addchar $idx $ch [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode + incr idx + incr cursor_column + } + } + } + } ;# end switch + + + } + other - crmcontrol { + if {$crm_mode && $type ne "crmcontrol" && $item ne "\x1b\[00001E"} { + if {$item eq "\x1b\[3l"} { + set crm_mode 0 + } else { + #When our initial overlay split was done - we weren't in crm_mode - so there are codes that weren't mapped to unicode control character representations + #set within_undercols [expr {$idx <= $renderwidth-1}] + #set chars [ansistring VIEW -nul 1 -lf 2 -vt 2 -ff 2 $item] + set chars [ansistring VIEW -nul 1 -lf 1 -vt 1 -ff 1 $item] + priv::render_unapplied $overlay_grapheme_control_list $gci + #prefix the unapplied controls with the string version of this control + set unapplied_list [linsert $unapplied_list 0 {*}[split $chars ""]] + set unapplied [join $unapplied_list ""] + + break + } + } + + #todo - consider CSI s DECSLRM vs ansi.sys \x1b\[s - we need \x1b\[s for oldschool ansi art - but may have to enable only for that. + #we should possibly therefore reverse this mapping so that x1b7 x1b8 are the primary codes for save/restore? + set code [tcl::string::map [list \x1b7 \x1b\[s \x1b8 \x1b\[u ] $item] + #since this element isn't a grapheme - advance idx_over to next grapheme overlay when about to fill 'unapplied' + + + #remap of DEC cursor_save/cursor_restore from ESC sequence to equivalent CSI + #probably not ideal - consider putting cursor_save/cursor_restore in functions so they can be called from the appropriate switch branch instead of using this mapping + #review - cost/benefit of function calls within these switch-arms instead of inline code? + + set c1 [tcl::string::index $code 0] + set c1c2c3 [tcl::string::range $code 0 2] + #set re_ST_open {(?:\033P|\u0090|\033X|\u0098|\033\^|\u009e|\033_|\u009f)} + #tcl 8.7 - faster to use inline list than to store it in a local var outside of loop. + #(somewhat surprising) + set leadernorm [tcl::string::range [tcl::string::map [list\ + \x1b\[< 1006\ + \x1b\[ 7CSI\ + \x1bY 7MAP\ + \x1bP 7DCS\ + \x90 8DCS\ + \x9b 8CSI\ + \x1b\] 7OSC\ + \x9d 8OSC\ + \x1b 7ESC\ + ] $c1c2c3] 0 3] ;#leadernorm is 1st 1,2 or 3 chars mapped to 4char normalised indicator - or is original first chars (1,2 or 3 len) + + #we leave the tail of the code unmapped for now + switch -- $leadernorm { + 1006 { + #https://invisible-island.net/xterm/ctlseqs/ctlseqs.html + #SGR (1006) CSI < followed by colon separated encoded-button-value,px,py ordinates and final M for button press m for button release + set codenorm [tcl::string::cat $leadernorm [tcl::string::range $code 3 end]] + } + 7CSI - 7OSC { + #set codenorm [tcl::string::cat $leadernorm [tcl::string::range $code 2 end]] + set codenorm $leadernorm[tcl::string::range $code 2 end] + } + 7DCS { + #ESC P + #Device Control String https://invisible-island.net/xterm/ctlseqs/ctlseqs.html#h4-Controls-beginning-with-ESC:ESC-F.C74 + set codenorm [tcl::string::cat $leadernorm [tcl::string::range $code 2 end]] + } + 8DCS { + #8-bit Device Control String + set codenorm [tcl::string::cat $leadernorm [tcl::string::range $code 1 end]] + } + 7MAP { + #map to another type of code to share implementation branch + set codenorm $leadernorm[tcl::string::range $code 1 end] + } + 7ESC { + #set codenorm [tcl::string::cat $leadernorm [tcl::string::range $code 1 end]] + set codenorm $leadernorm[tcl::string::range $code 1 end] + } + 8CSI - 8OSC { + set codenorm [tcl::string::cat $leadernorm [tcl::string::range $code 1 end]] + } + default { + puts stderr "Sequence detected as ANSI, but not handled in leadernorm switch. code: [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + #we haven't made a mapping for this + #could in theory be 1,2 or 3 in len + #although we shouldn't be getting here if the regexp for ansi codes is kept in sync with our switch branches + set codenorm $code + } + } + + switch -- $leadernorm { + 7MAP { + switch -- [lindex $codenorm 4] { + Y { + #vt52 movement. we expect 2 chars representing position (limited range) + set params [tcl::string::range $codenorm 5 end] + if {[tcl::string::length $params] != 2} { + #shouldn't really get here or need this branch if ansi splitting was done correctly + puts stderr "overtype::renderline ESC Y recognised as vt52 move, but incorrect parameters length ([string length $params] vs expected 2) [ansistring VIEW -lf 1 -vt 1 -nul 1 $code] not implemented codenorm:[ansistring VIEW -lf 1 -vt 1 -nul 1 $codenorm]" + } + set line [tcl::string::index $params 5] + set column [tcl::string::index $params 1] + set r [expr {[scan $line %c] -31}] + set c [expr {[scan $column %c] -31}] + + #MAP to: + #CSI n;m H - CUP - Cursor Position + set leadernorm 7CSI + set codenorm "$leadernorm${r}\;${c}H" + } + } + } + } + + #we've mapped 7 and 8bit escapes to values we can handle as literals in switch statements to take advantange of jump tables. + switch -- $leadernorm { + 1006 { + #TODO + # + switch -- [tcl::string::index $codenorm end] { + M { + puts stderr "mousedown $codenorm" + } + m { + puts stderr "mouseup $codenorm" + } + } + + } + {7CSI} - {8CSI} { + set param [tcl::string::range $codenorm 4 end-1] + #puts stdout "--> CSI [tcl::string::index $leadernorm 0] bit param:$param" + set code_end [tcl::string::index $codenorm end] ;#used for e.g h|l set/unset mode + + switch -exact -- $code_end { + A { + #Row move - up + set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] + #todo + lassign [split $param {;}] num modifierkey + if {$modifierkey ne ""} { + puts stderr "modifierkey:$modifierkey" + } + + if {$num eq ""} {set num 1} + incr cursor_row -$num + + if {$cursor_row < 1} { + set cursor_row 1 + } + + #ensure rest of *overlay* is emitted to remainder + incr idx_over + priv::render_unapplied $overlay_grapheme_control_list $gci + set instruction up + #retain cursor_column + break + } + B { + #CUD - Cursor Down + #Row move - down + lassign [split $param {;}] num modifierkey + set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] + #move down + if {$modifierkey ne ""} { + puts stderr "modifierkey:$modifierkey" + } + if {$num eq ""} {set num 1} + incr cursor_row $num + + + incr idx_over ;#idx_over hasn't encountered a grapheme and hasn't advanced yet + priv::render_unapplied $overlay_grapheme_control_list $gci + set instruction down + #retain cursor_column + break + } + C { + #CUF - Cursor Forward + #Col move + #puts stdout "->forward" + #todo - consider right-to-left cursor mode (e.g Hebrew).. some day. + #cursor forward + #right-arrow/move forward + lassign [split $param {;}] num modifierkey + if {$modifierkey ne ""} { + puts stderr "modifierkey:$modifierkey" + } + if {$num eq ""} {set num 1} + + #todo - retrict to moving 1 position past datalen? restrict to column width? + #should ideally wrap to next line when interactive and not on last row + #(some ansi art seems to expect this behaviour) + #This presumably depends on the terminal's wrap mode + #e.g DECAWM autowrap mode + # CSI ? 7 h - set: autowrap (also tput smam) + # CSI ? 7 l - reset: no autowrap (also tput rmam) + set version 2 + if {$version eq "2"} { + set max [llength $outcols] + if {$overflow_idx == -1} { + incr max + } + if {$cursor_column == $max+1} { + #move_forward while in overflow + incr cursor_column -1 + } + + if {($cursor_column + $num) <= $max} { + incr idx $num + incr cursor_column $num + } else { + if {$autowrap_mode} { + set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] + #jmn + if {$idx == $overflow_idx} { + incr num + } + + #horizontal movement beyond line extent needs to wrap - throw back to caller + #we may have both overflow_right and unapplied data + #(can have overflow_right if we were in insert_mode and processed chars prior to this movement) + #leave row as is - caller will need to determine how many rows the column-movement has consumed + incr cursor_column $num ;#give our caller the necessary info as columns from start of row + #incr idx_over + #should be gci following last one applied + priv::render_unapplied $overlay_grapheme_control_list $gci + set instruction wrapmoveforward + break + } else { + set cursor_column $max + set idx [expr {$cursor_column -1}] + } + } + } else { + #review - dead branch + if {!$expand_right || ($cursor_column + $num) <= [llength $outcols+1]} { + incr idx $num + incr cursor_column $num + } else { + if {!$insert_mode} { + #block editing style with arrow keys + #overtype mode + set idxstart $idx + set idxend [llength $outcols] + set moveend [expr {$idxend - $idxstart}] + if {$moveend < 0} {set moveend 0} ;#sanity? + #puts "idxstart:$idxstart idxend:$idxend outcols[llength $outcols] undercols:[llength $undercols]" + incr idx $moveend + incr cursor_column $moveend + #if {[tcl::dict::exists $understacks $idx]} { + # set stackinfo [tcl::dict::get $understacks $idx] ;#use understack at end - which may or may not have already been replaced by stack from overtext + #} else { + # set stackinfo [list] + #} + if {$idx < [llength $understacks]} { + set stackinfo [lindex $understacks $idx] ;#use understack at end - which may or may not have already been replaced by stack from overtext + } else { + set stackinfo [list] + } + if {$idx < [llength $understacks_gx]} { + #set gxstackinfo [tcl::dict::get $understacks_gx $idx] + set gxstackinfo [lindex $understacks_gx $idx] + } else { + set gxstackinfo [list] + } + #pad outcols + set movemore [expr {$num - $moveend}] + #assert movemore always at least 1 or we wouldn't be in this branch + for {set m 1} {$m <= $movemore} {incr m} { + incr idx + incr cursor_column + priv::render_addchar $idx " " $stackinfo $gxstackinfo $insert_mode + } + } else { + #normal - insert + incr idx $num + incr cursor_column $num + if {$idx > [llength $outcols]} { + set idx [llength $outcols];#allow one beyond - for adding character at end of line + set cursor_column [expr {[llength $outcols]+1}] + } + } + } + } + } + D { + #Col move + #puts stdout "<-back" + #cursor back + #left-arrow/move-back when ltr mode + lassign [split $param {;}] num modifierkey + if {$modifierkey ne ""} { + puts stderr "modifierkey:$modifierkey" + } + if {$num eq ""} {set num 1} + + set version 2 + if {$version eq "2"} { + #todo - startcolumn offset! + if {$cursor_column - $num >= 1} { + incr idx -$num + incr cursor_column -$num + } else { + if {!$autowrap_mode} { + set cursor_column 1 + set idx 0 + } else { + set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] + incr cursor_column -$num + priv::render_unapplied $overlay_grapheme_control_list $gci + set instruction wrapmovebackward + break + } + } + } else { + incr idx -$num + incr cursor_column -$num + if {$idx < $opt_colstart-1} { + #wrap to previous line and position cursor at end of data + set idx [expr {$opt_colstart-1}] + set cursor_column $opt_colstart + } + } + } + E { + #CNL - Cursor Next Line + if {$param eq ""} { + set downmove 1 + } else { + set downmove [expr {$param}] + } + puts stderr "renderline CNL down-by-$downmove" + set cursor_column 1 + set cursor_row [expr {$cursor_row + $downmove}] + set idx [expr {$cursor_column -1}] + set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] + incr idx_over + priv::render_unapplied $overlay_grapheme_control_list $gci + set instruction move + break + + } + F { + #CPL - Cursor Previous Line + if {$param eq ""} { + set upmove 1 + } else { + set upmove [expr {$param}] + } + puts stderr "renderline CPL up-by-$upmove" + set cursor_column 1 + set cursor_row [expr {$cursor_row -$upmove}] + if {$cursor_row < 1} { + set cursor_row 1 + } + set idx [expr {$cursor_column - 1}] + set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] + incr idx_over + priv::render_unapplied $overlay_grapheme_control_list $gci + set instruction move + break + + } + G { + #CHA - Cursor Horizontal Absolute (move to absolute column no) + if {$param eq ""} { + set targetcol 1 + } else { + set targetcol $param + if {![string is integer -strict $targetcol]} { + puts stderr "renderline CHA (Cursor Horizontal Absolute) error. Unrecognised parameter '$param'" + } + set targetcol [expr {$param}] + set max [llength $outcols] + if {$overflow_idx == -1} { + incr max + } + if {$targetcol > $max} { + puts stderr "renderline CHA (Cursor Horizontal Absolute) error. Param '$param' > max: $max" + set targetcol $max + } + } + #adjust to colstart - as column 1 is within overlay + #??? REVIEW + set idx [expr {($targetcol -1) + $opt_colstart -1}] + + set cursor_column $targetcol + #puts stderr "renderline absolute col move ESC G (TEST)" + } + H - f { + #CSI n;m H - CUP - Cursor Position + + #CSI n;m f - HVP - Horizontal Vertical Position REVIEW - same as CUP with differences (what?) in some terminal modes + # - 'counts as effector format function (like CR or LF) rather than an editor function (like CUD or CNL)' + # - REVIEW + #see Annex A at: https://www.ecma-international.org/wp-content/uploads/ECMA-48_5th_edition_june_1991.pdf + + #test e.g ansicat face_2.ans + #$re_both_move + lassign [split $param {;}] paramrow paramcol + #missing defaults to 1 + #CSI ;5H = CSI 1;5H -> row 1 col 5 + #CSI 17;H = CSI 17H = CSI 17;1H -> row 17 col 1 + + if {$paramcol eq ""} {set paramcol 1} + if {$paramrow eq ""} {set paramrow 1} + if {![string is integer -strict $paramcol] || ![string is integer -strict $paramrow]} { + puts stderr "renderline CUP (CSI H) unrecognised param $param" + #ignore? + } else { + set max [llength $outcols] + if {$overflow_idx == -1} { + incr max + } + if {$paramcol > $max} { + set target_column $max + } else { + set target_column [expr {$paramcol}] + } + + + if {$paramrow < 1} { + puts stderr "renderline CUP (CSI H) bad row target 0. Assuming 1" + set target_row 1 + } else { + set target_row [expr {$paramrow}] + } + if {$target_row == $cursor_row} { + #col move only - no need for break and move + #puts stderr "renderline CUP col move only to col $target_column param:$param" + set cursor_column $target_column + set idx [expr {$cursor_column -1}] + } else { + set cursor_row $target_row + set cursor_column $target_column + set idx [expr {$cursor_column -1}] + set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] + incr idx_over + priv::render_unapplied $overlay_grapheme_control_list $gci + set instruction move + break + } + } + } + J { + set modegroup [tcl::string::index $codenorm 4] ;#e.g ? + switch -exact -- $modegroup { + ? { + #CSI ? Pn J - selective erase + puts stderr "overtype::renderline ED - SELECTIVE ERASE IN DISPLAY (UNIMPLEMENTED) [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + } + default { + puts stderr "overtype::renderline ED - ERASE IN DISPLAY (TESTING) [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + if {$param eq ""} {set param 0} + switch -exact -- $param { + 0 { + #clear from cursor to end of screen + } + 1 { + #clear from cursor to beginning of screen + } + 2 { + #clear entire screen + #ansi.sys - move cursor to upper left REVIEW + set cursor_row 1 + set cursor_column 1 + set idx [expr {$cursor_column -1}] + set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] + incr idx_over + if {[llength $outcols]} { + priv::render_erasechar 0 [llength $outcols] + } + priv::render_unapplied $overlay_grapheme_control_list $gci + set instruction clear_and_move + break + } + 3 { + #clear entire screen. presumably cursor doesn't move - otherwise it would be same as 2J ? + + } + default { + } + } + + } + } + } + K { + #see DECECM regarding background colour + set modegroup [tcl::string::index $codenorm 4] ;#e.g ? + switch -exact -- $modegroup { + ? { + puts stderr "overtype::renderline DECSEL - SELECTIVE ERASE IN LINE (UNIMPLEMENTED) [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + set param [string range $param 1 end] ;#chop qmark + if {$param eq ""} {set param 0} + switch -exact -- $param { + 0 { + #clear from cursor to end of line - depending on DECSCA + } + 1 { + #clear from cursor to beginning of line - depending on DECSCA + + } + 2 { + #clear entire line - depending on DECSCA + } + default { + puts stderr "overtype::renderline DECSEL - SELECTIVE ERASE IN LINE PARAM '$param' unrecognised [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + } + } + + } + default { + puts stderr "overtype::renderline EL - ERASE IN LINE (TESTING) [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + if {$param eq ""} {set param 0} + switch -exact -- $param { + 0 { + #clear from cursor to end of line + } + 1 { + #clear from cursor to beginning of line + + } + 2 { + #clear entire line + } + default { + puts stderr "overtype::renderline EL - ERASE IN LINE PARAM '$param' unrecognised [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + } + } + } + } + } + L { + puts stderr "overtype::renderline IL - Insert Line - not implemented [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + } + 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]" + + } + T { + #CSI Pn T - SD Pan Up (empty lines introduced at top) + #CSI Pn+T - kitty extension (lines at top come from scrollback buffer) + #Pn new lines appear at top of the display, Pn old lines disappear at the bottom of the display + if {$param eq "" || $param eq "0"} {set param 1} + if {[string index $param end] eq "+"} { + puts stderr "overtype::renderline CSI Pn + T - kitty Pan Up - not implemented [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + } else { + puts stderr "overtype::renderline CSI Pn T - SD Pan Up - not implemented [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + } + } + X { + puts stderr "overtype::renderline X ECH ERASE CHARACTER - $param" + #ECH - erase character + if {$param eq "" || $param eq "0"} {set param 1}; #param=count of chars to erase + priv::render_erasechar $idx $param + #cursor position doesn't change. + } + q { + set code_secondlast [tcl::string::index $codenorm end-1] + switch -exact -- $code_secondlast { + {"} { + #DECSCA - Select Character Protection Attribute + #(for use with selective erase: DECSED and DECSEL) + set param [tcl::string::range $codenorm 4 end-2] + if {$param eq ""} {set param 0} + #TODO - store like SGR in stacks - replays? + switch -exact -- $param { + 0 - 2 { + #canerase + puts stderr "overtype::renderline - DECSCA canerase not implemented - [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + } + 1 { + #cannoterase + puts stderr "overtype::renderline - DECSCA cannoterase not implemented - [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + } + default { + puts stderr "overtype::renderline DECSCA param '$param' not understood [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + } + } + + } + default { + puts stderr "overtype::renderline - CSI ... q not implemented - [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + } + } + + } + r { + #$re_decstbm + #https://www.vt100.net/docs/vt510-rm/DECSTBM.html + #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 + + incr idx_over + priv::render_unapplied $overlay_grapheme_control_list $gci + set instruction move ;#own instruction? decstbm? + break + } + s { + #code conflict between ansi emulation and DECSLRM - REVIEW + #ANSISYSSC (when no parameters) - like other terminals - essentially treat same as DECSC + # todo - when parameters - support DECSLRM instead + + if {$param ne ""} { + #DECSLRM - should only be recognised if DECLRMM is set (vertical split screen mode) + lassign [split $param {;}] margin_left margin_right + puts stderr "overtype DECSLRM not yet supported - got [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + if {$margin_left eq ""} { + set margin_left 1 + } + set columns_per_page 80 ;#todo - set to 'page width (DECSCPP set columns per page)' - could be 132 or?? + if {$margin_right eq ""} { + set margin_right $columns_per_page + } + puts stderr "DECSLRM margin left: $margin_left margin right: $margin_right" + if {![string is integer -strict $margin_left] || $margin_left < 0} { + puts stderr "DECSLRM invalid margin_left" + } + if {![string is integer -strict $margin_right] || $margin_right < 0} { + puts stderr "DECSLRM invalid margin_right" + } + set scrolling_region_size [expr {$margin_right - $margin_left}] + if {$scrolling_region_size < 2 || $scrolling_region_size > $columns_per_page} { + puts stderr "DECSLRM region size '$scrolling_regsion_size' must be between 1 and $columns_per_page" + } + #todo + + + } else { + #DECSC + #//notes on expected behaviour: + #DECSC - saves following items in terminal's memory + #cursor position + #character attributes set by the SGR command + #character sets (G0,G1,G2 or G3) currently in GL and GR + #Wrap flag (autowrap or no autowrap) + #State of origin mode (DECOM) + #selective erase attribute + #any single shift 2 (SS2) or single shift 3(SSD) functions sent + + #$re_cursor_save + #cursor save could come after last column + if {$overflow_idx != -1 && $idx == $overflow_idx} { + #bartman2.ans test file - fixes misalignment at bottom of dialog bubble + #incr cursor_row + #set cursor_column 1 + #bwings1.ans test file - breaks if we actually incr cursor (has repeated saves) + set cursor_saved_position [list row [expr {$cursor_row+1}] column 1] + } else { + set cursor_saved_position [list row $cursor_row column $cursor_column] + } + #there may be overlay stackable codes emitted that aren't in the understacks because they come between the last emmited character and the cursor_save control. + #we need the SGR and gx overlay codes prior to the cursor_save + + #a real terminal would not be able to know the state of the underlay.. so we should probably ignore it. + #set sgr_stack [lindex $understacks $idx] + #set gx_stack [lindex $understacks_gx $idx] ;#not actually a stack - just a boolean state (for now?) + + set sgr_stack [list] + set gx_stack [list] + + #we shouldn't need to scan for intermediate cursor save/restores - as restores would throw-back to the calling loop - so our overlay 'line' is since those. + #The overlay_grapheme_control_list had leading resets from previous lines - so we go back to the beginning not just the first grapheme. + + foreach gc [lrange $overlay_grapheme_control_list 0 $gci-1] { + lassign $gc type code + #types g other sgr gx0 + switch -- $type { + gx0 { + #code is actually a stand-in for the graphics on/off code - not the raw code + #It is either gx0_on or gx0_off + set gx_stack [list $code] + } + sgr { + #code is the raw code + if {[punk::ansi::codetype::is_sgr_reset $code]} { + #jmn + set sgr_stack [list "\x1b\[m"] + } elseif {[punk::ansi::codetype::has_sgr_leadingreset $code]} { + set sgr_stack [list $code] + lappend overlay_grapheme_control_list [list sgr $code] + } elseif {[priv::is_sgr $code]} { + #often we don't get resets - and codes just pile up. + #as a first step to simplifying - at least remove earlier straight up dupes + set dup_posns [lsearch -all -exact $sgr_stack $code] ;#needs -exact - codes have square-brackets (glob chars) + set sgr_stack [lremove $sgr_stack {*}$dup_posns] + lappend sgr_stack $code + } + } + } + } + set cursor_saved_attributes "" + switch -- [lindex $gx_stack 0] { + gx0_on { + append cursor_saved_attributes "\x1b(0" + } + gx0_off { + append cursor_saved_attributes "\x1b(B" + } + } + #append cursor_saved_attributes [join $sgr_stack ""] + append cursor_saved_attributes [punk::ansi::codetype::sgr_merge_list {*}$sgr_stack] + + #as there is apparently only one cursor storage element we don't need to throw back to the calling loop for a save. + + #don't incr index - or the save will cause cursor to move to the right + #carry on + } + } + u { + #ANSISYSRC save cursor (when no parameters) (DECSC) + + #$re_cursor_restore + #we are going to jump somewhere.. for now we will assume another line, and process accordingly. + #The caller has the cursor_saved_position/cursor_saved_attributes if any (?review - if we always pass it back it, we could save some calls for moves in same line) + #don't set overflow at this point. The existing underlay to the right must be preserved. + #we only want to jump and render the unapplied at the new location. + + #lset overstacks $idx_over [list] + #set replay_codes_overlay "" + + #if {$cursor_saved_attributes ne ""} { + # set replay_codes_overlay $cursor_saved_attributes ;#empty - or last save if it happend in this input chunk + #} else { + #jj + #set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] + set replay_codes_overlay "" + #} + + #like priv::render_unapplied - but without the overlay's ansi reset or gx stacks from before the restore code + incr idx_over + + set unapplied "" + set unapplied_list [list] + foreach gc [lrange $overlay_grapheme_control_list $gci+1 end] { + lassign $gc type item + if {$type eq "gx0"} { + if {$item eq "gx0_on"} { + lappend unapplied_list "\x1b(0" + } elseif {$item eq "gx0_off"} { + lappend unapplied_list "\x1b(B" + } + } else { + lappend unapplied_list $item + } + #incr idx_over + } + set unapplied [join $unapplied_list ""] + #if the save occured within this line - that's ok - it's in the return value list and caller can prepend for the next loop. + set instruction restore_cursor + break + } + "{" { + + puts stderr "renderline warning - CSI.. - unimplemented [ansistring VIEW -lf 1 -nul 1 $code]" + } + "}" { + set code_secondlast [tcl::string::index $codenorm end-1] + switch -exact -- $code_secondlast { + ' { + puts stderr "renderline warning - DECIC - Insert Column - CSI...' - unimplemented [ansistring VIEW -lf 1 -nul 1 $code]" + } + default { + puts stderr "renderline warning - CSI.. - unimplemented [ansistring VIEW -lf 1 -nul 1 $code]" + } + } + } + ~ { + set code_secondlast [tcl::string::index $codenorm end-1] ;#used for e.g CSI x '~ + switch -exact -- $code_secondlast { + ' { + #DECDC - editing sequence - Delete Column + puts stderr "renderline warning - DECDC - unimplemented" + } + default { + #$re_vt_sequence + lassign [split $param {;}] key mod + + #Note that f1 to f4 show as ESCOP|Q|R|S (VT220?) but f5+ show as ESC\[15~ + # + #e.g esc \[2~ insert esc \[2;2~ shift-insert + #mod - subtract 1, and then use bitmask + #shift = 1, (left)Alt = 2, control=4, meta=8 (meta seems to do nothing on many terminals on windows? Intercepted by windows?) + #puts stderr "vt key:$key mod:$mod code:[ansistring VIEW $code]" + if {$key eq "1"} { + #home + } elseif {$key eq "2"} { + #Insert + if {$mod eq ""} { + #no modifier key + set insert_mode [expr {!$insert_mode}] + #rather than set the cursor - we return the insert mode state so the caller can decide + } + } elseif {$key eq "3"} { + #Delete - presumably this shifts other chars in the line, with empty cells coming in from the end + switch -- $mod { + "" { + priv::render_delchar $idx + } + "5" { + #ctrl-del - delete to end of word (pwsh) - possibly word on next line if current line empty(?) + } + } + } elseif {$key eq "4"} { + #End + } elseif {$key eq "5"} { + #pgup + } elseif {$key eq "6"} { + #pgDn + } elseif {$key eq "7"} { + #Home + #?? + set idx [expr {$opt_colstart -1}] + set cursor_column 1 + } elseif {$key eq "8"} { + #End + } elseif {$key eq "11"} { + #F1 - or ESCOP or e.g shift F1 ESC\[1;2P + } elseif {$key eq "12"} { + #F2 - or ESCOQ + } elseif {$key eq "13"} { + #F3 - or ESCOR + } elseif {$key eq "14"} { + #F4 - or ESCOS + } elseif {$key eq "15"} { + #F5 or shift F5 ESC\[15;2~ + } elseif {$key eq "17"} { + #F6 + } elseif {$key eq "18"} { + #F7 + } elseif {$key eq "19"} { + #F8 + } elseif {$key eq "20"} { + #F9 + } elseif {$key eq "21"} { + #F10 + } elseif {$key eq "23"} { + #F11 + } elseif {$key eq "24"} { + #F12 + } + + } + } + + } + h - l { + #set mode unset mode + #we are matching only last char to get to this arm - but are there other sequences ending in h|l we need to handle? + + #$re_mode if first after CSI is "?" + #some docs mention ESC=h|l - not seen on windows terminals.. review + #e.g https://www2.math.upenn.edu/~kazdan/210/computer/ansi.html + set modegroup [tcl::string::index $codenorm 4] ;#e.g ? = + switch -exact -- $modegroup { + ? { + set smparams [tcl::string::range $codenorm 5 end-1] ;#params between ? and h|l + #one or more modes can be set + set smparam_list [split $smparams {;}] + foreach num $smparam_list { + switch -- $num { + "" { + #ignore empties e.g extra/trailing semicolon in params + } + 5 { + #DECSNM - reverse video + #How we simulate this to render within a block of text is an open question. + #track all SGR stacks and constantly flip based on the current SGR reverse state? + #It is the job of the calling loop to do this - so at this stage we'll just set the states + + if {$code_end eq "h"} { + #set (enable) + set reverse_mode 1 + } else { + #reset (disable) + set reverse_mode 0 + } + + } + 7 { + #DECAWM autowrap + if {$code_end eq "h"} { + #set (enable) + set autowrap_mode 1 + if {$opt_width ne "\uFFEF"} { + set overflow_idx $opt_width + } else { + #review - this is also the cursor position when adding a char at end of line? + set overflow_idx [expr {[llength $undercols]}] ;#index at which we would be *in* overflow a row move may still override it + } + #review - can idx ever be beyond overflow_idx limit when we change e.g with a width setting and cursor movements? + # presume not usually - but sanity check with warning for now. + if {$idx >= $overflow_idx} { + puts stderr "renderline warning - idx '$idx' >= overflow_idx '$overflow_idx' - unexpected" + } + } else { + #reset (disable) + set autowrap_mode 0 + #REVIEW! + set overflow_idx -1 + } + } + 25 { + if {$code_end eq "h"} { + #visible cursor + + } else { + #invisible cursor + + } + } + 117 { + #DECECM - Erase Color Mode + #https://invisible-island.net/ncurses/ncurses.faq.html + #The Erase color selection controls the background color used when text is erased or new + #text is scrolled on to the screen. Screen background causes newly erased areas or + #scrolled text to be written using color index zero, the screen background. This is VT + #and DECterm compatible. Text background causes erased areas or scrolled text to be + #written using the current text background color. This is PC console compatible and is + #the factory default. + + #see also: https://unix.stackexchange.com/questions/251726/clear-to-end-of-line-uses-the-wrong-background-color-in-screen + } + } + } + } + = { + set num [tcl::string::range $codenorm 5 end-1] ;#param between = and h|l + puts stderr "overtype::renderline CSI=...h|l code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code] not implemented" + } + default { + #e.g CSI 4 h + set num [tcl::string::range $codenorm 4 end-1] ;#param before h|l + switch -exact -- $num { + 3 { + puts stderr "CRM MODE $code_end" + #CRM - Show control character mode + # 'No control functions are executed except LF,FF and VT which are represented in the CRM FONT before a CRLF(new line) is executed' + # + #use ansistring VIEW -nul 1 -lf 2 -ff 2 -vt 2 + #https://vt100.net/docs/vt510-rm/CRM.html + #NOTE - vt100 CRM always does auto-wrap at right margin. + #disabling auto-wrap in set-up or by sequence is disabled. + #We should default to turning off auto-wrap when crm_mode enabled.. but + #displaying truncated (on rhs) crm can still be very useful - and we have optimisation in overflow to avoid excess renderline calls (per grapheme) + #we therefore could reasonably put in an exception to allow auto_wrap to be disabled after crm_mode is engaged, + #although this would be potentially an annoying difference to some.. REVIEW + if {$code_end eq "h"} { + set crm_mode 1 + set autowrap_mode 1 + if {$opt_width ne "\uFFEF"} { + set overflow_idx $opt_width + } else { + #review - this is also the cursor position when adding a char at end of line? + set overflow_idx [expr {[llength $undercols]}] ;#index at which we would be *in* overflow a row move may still override it + } + } else { + set crm_mode 0 + } + } + 4 { + #IRM - Insert/Replace Mode + if {$code_end eq "h"} { + #CSI 4 h + set insert_mode 1 + } else { + #CSI 4 l + #replace mode + set insert_mode 0 + } + } + default { + puts stderr "overtype::renderline CSI...h|l code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code] not implemented" + } + } + } + } + } + | { + switch -- [tcl::string::index $codenorm end-1] { + {$} { + #CSI ... $ | DECSCPP set columns per page- (recommended in vt510 docs as preferable to DECCOLM) + #real terminals generally only supported 80/132 + #some other virtuals support any where from 2 to 65,536? + #we will allow arbitrary widths >= 2 .. to some as yet undetermined limit. + #CSI $ | + #empty or 0 param is 80 for compatibility - other numbers > 2 accepted + set page_width -1 ;#flag as unset + if {$param eq ""} { + set page_width 80 + } elseif {[string is integer -strict $param] && $param >=2} { + set page_width [expr {$param}] ;#we should allow leading zeros in the number - but lets normalize using expr + } else { + puts stderr "overtype::renderline unacceptable DECSPP value '$param'" + } + + if {$page_width > 2} { + puts stderr "overtype::renderline DECSCPP - not implemented - but selected width '$page_width' looks ok" + #if cursor already beyond new page_width - will move to right colum - otherwise no cursor movement + + } + + } + default { + puts stderr "overtype::renderline unrecognised CSI code ending in pipe (|) [ansistring VIEW -lf 1 -vt 1 -nul 1 $code] not implemented" + } + } + } + default { + puts stderr "overtype::renderline CSI code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code] not implemented" + } + } + } + 7ESC { + # + #re_other_single {\x1b(D|M|E)$} + #also vt52 Y.. + #also PM \x1b^...(ST) + switch -- [tcl::string::index $codenorm 4] { + c { + #RIS - reset terminal to initial state - where 'terminal' in this case is the renderspace - not the underlying terminal! + puts stderr "renderline reset" + priv::render_unapplied $overlay_grapheme_control_list $gci + set instruction reset + break + } + D { + #\x84 + #index (IND) + #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_unapplied $overlay_grapheme_control_list $gci + set instruction down + #retain cursor_column + break + } + E { + #\x85 + #review - is behaviour different to lf? + #todo - possibly(?) same logic as handling above. i.e return instruction depends on where column_cursor is at the time we get NEL + #leave implementation until logic for is set in stone... still under review + #It's arguable NEL is a pure cursor movement as opposed to the semantic meaning of crlf or lf in a file. + # + #Next Line (NEL) "Move the cursor to the left margin on the next line. If the cursor is at the bottom margin, scroll the page up" + puts stderr "overtype::renderline ESC E unimplemented" + + } + H { + #\x88 + #Tab Set + puts stderr "overtype::renderline ESC H tab set unimplemented" + } + M { + #\x8D + #Reverse Index (RI) + #vt102-docs: "Moves cursor up one line in same column. If cursor is at top margin, screen performs a scroll-down" + puts stderr "overtype::renderline ESC M not fully implemented" + + set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] + #move up + incr cursor_row -1 + if {$cursor_row < 1} { + set cursor_row 1 + } + #ensure rest of *overlay* is emitted to remainder + priv::render_unapplied $overlay_grapheme_control_list $gci + set instruction up ;#need instruction for scroll-down? + #retain cursor_column + break + } + N { + #\x8e - affects next character only + puts stderr "overtype::renderline single shift select G2 command UNIMPLEMENTED. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + } + O { + #\x8f - affects next character only + puts stderr "overtype::renderline single shift select G3 command UNIMPLEMENTED. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + } + P { + #\x90 + #DCS - shouldn't get here - handled in 7DCS branch + #similarly \] OSC (\x9d) and \\ (\x9c) ST + } + V { + #\x96 + + } + W { + #\x97 + } + X { + #\x98 + #SOS + if {[string index $code end] eq "\007"} { + set sos_content [string range $code 2 end-1] ;#ST is \007 + } else { + set sos_content [string range $code 2 end-2] ;#ST is \x1b\\ + } + #return in some useful form to the caller + #TODO! + lappend sos_list [list string $sos_content row $cursor_row column $cursor_column] + puts stderr "overtype::renderline ESCX SOS UNIMPLEMENTED. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + } + ^ { + #puts stderr "renderline PM" + #Privacy Message. + if {[string index $code end] eq "\007"} { + set pm_content [string range $code 2 end-1] ;#ST is \007 + } else { + set pm_content [string range $code 2 end-2] ;#ST is \x1b\\ + } + #We don't want to render it - but we need to make it available to the application + #see the textblock library in punk, for the exception we make here for single backspace. + #It is unlikely to be encountered as a useful PM - so we hack to pass it through as a fix + #for spacing issues on old terminals which miscalculate the single-width 'Symbols for Legacy Computing' + if {$pm_content eq "\b"} { + #puts stderr "renderline PM sole backspace special handling for \U1FB00 - \U1FBFF" + #esc^\b\007 or esc^\besc\\ + #HACKY pass-through - targeting terminals that both mis-space legacy symbols *and* don't support PMs + #The result is repair of the extra space. If the terminal is a modern one and does support PM - the \b should be hidden anyway. + #If the terminal has the space problem AND does support PMs - then this just won't fix it. + #The fix relies on the symbol-supplier to cooperate by appending esc^\b\esc\\ to the problematic symbols. + + #priv::render_addchar $idx $code [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode + #idx has been incremented after last grapheme added + priv::render_append_to_char [expr {$idx -1}] $code + } + #lappend to a dict element in the result for application-specific processing + lappend pm_list $pm_content + } + _ { + #APC Application Program Command + #just warn for now.. + puts stderr "overtype::renderline ESC_ APC command UNIMPLEMENTED. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + } + default { + puts stderr "overtype::renderline ESC code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code] not implemented codenorm:[ansistring VIEW -lf 1 -vt 1 -nul 1 $codenorm]" + } + } + + } + 7DCS - 8DCS { + puts stderr "overtype::renderline DCS - DEVICE CONTROL STRING command UNIMPLEMENTED. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + #ST (string terminator) \x9c or \x1b\\ + if {[tcl::string::index $codenorm end] eq "\x9c"} { + set code_content [tcl::string::range $codenorm 4 end-1] ;#ST is 8-bit 0x9c + } else { + set code_content [tcl::string::range $codenorm 4 end-2] ;#ST is \x1b\\ + } + + } + 7OSC - 8OSC { + # OSCs are terminated with ST of either \007 or \x1b\\ - we allow either whether code was 7 or 8 bit + if {[tcl::string::index $codenorm end] eq "\007"} { + set code_content [tcl::string::range $codenorm 4 end-1] ;#ST is \007 + } else { + set code_content [tcl::string::range $codenorm 4 end-2] ;#ST is \x1b\\ + } + set first_colon [tcl::string::first {;} $code_content] + if {$first_colon == -1} { + #there probably should always be a colon - but we'll try to make sense of it without + set osc_code $code_content ;#e.g \x1b\]104\007 vs \x1b\]104\;\007 + } else { + set osc_code [tcl::string::range $code_content 0 $first_colon-1] + } + switch -exact -- $osc_code { + 2 { + set newtitle [tcl::string::range $code_content 2 end] + priv::render_unapplied $overlay_grapheme_control_list $gci + set instruction [list set_window_title $newtitle] + break + } + 4 { + #OSC 4 - set colour palette + #can take multiple params + #e.g \x1b\]4\;1\;red\;2\;green\x1b\\ + set params [tcl::string::range $code_content 2 end] ;#strip 4 and first semicolon + set cmap [dict create] + foreach {cnum spec} [split $params {;}] { + if {$cnum >= 0 && $cnum <= 255} { + #todo - parse spec from names like 'red' to RGB + #todo - accept rgb:ab/cd/ef as well as rgb:/a/b/c (as alias for aa/bb/cc) + #also - what about rgb:abcd/defg/hijk and 12-bit abc/def/ghi ? + dict set cmap $cnum $spec + } else { + #todo - log + puts stderr "overtype::renderline OSC 4 set colour palette - bad color number: $cnum must be from 0 to 255. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + } + } + + puts stderr "overtype::renderline OSC 4 set colour palette unimplemented. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + + + } + 10 - 11 - 12 - 13 - 14 - 15 - 16 - 17 { + #OSC 10 through 17 - so called 'dynamic colours' + #can take multiple params - each successive parameter changes the next colour in the list + #- e.g if code started at 11 - next param is for 12. 17 takes only one param because there are no more + #10 change text foreground colour + #11 change text background colour + #12 change text cursor colour + #13 change mouse foreground colour + #14 change mouse background colour + #15 change tektronix foreground colour + #16 change tektronix background colour + #17 change highlight colour + set params [tcl::string::range $code_content 2 end] + + puts stderr "overtype::renderline OSC $osc_code set dynamic colours unimplemented. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + + + } + 18 { + #why is this not considered one of the dynamic colours above? + #https://www.xfree86.org/current/ctlseqs.html + #tektronix cursor color + puts stderr "overtype::renderline OSC 18 - set tektronix cursor color unimplemented. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + } + 99 { + #kitty desktop notifications + #https://sw.kovidgoyal.net/kitty/desktop-notifications/ + # 99 ; metadata ; payload + puts stderr "overtype::renderline OSC 99 kitty desktop notification unimplemented. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + } + 104 { + #reset colour palette + #we want to do it for the current rendering context only (vvt) - not just pass through to underlying vt + puts stderr "overtype::renderline OSC 104 reset colour palette unimplemented. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + priv::render_unapplied $overlay_grapheme_control_list $gci + set instruction [list reset_colour_palette] + break + } + 1337 { + #iterm2 graphics and file transfer + puts stderr "overtype::renderline OSC 1337 iterm2 graphics/file_transfer unimplemented. 1st 100 chars of code [ansistring VIEW -lf 1 -vt 1 -nul 1 [string range $code 0 99]]" + } + 5113 { + puts stderr "overtype::renderline OSC 5113 kitty file transfer unimplemented. 1st 100 chars of code [ansistring VIEW -lf 1 -vt 1 -nul 1 [string range $code 0 99]]" + } + default { + puts stderr "overtype::renderline OSC - UNIMPLEMENTED. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + } + } + + } + default { + } + } + + + } + default { + #don't need to handle sgr or gx0 types + #we have our sgr gx0 codes already in stacks for each overlay grapheme + } + } + } + + #-------- + if {$opt_expand_right == 0} { + #need to truncate to the width of the original undertext + #review - string_width vs printing_length here. undertext requirement to be already rendered therefore punk::char::string_width ok? + #set num_under_columns [punk::char::string_width $pt_underchars] ;#plaintext underchars + } + if {$overflow_idx == -1} { + #overflow was initially unlimited and hasn't been overridden + } else { + + } + #-------- + + + #coalesce and replay codestacks for outcols grapheme list + set outstring "" ;#output prior to overflow + set overflow_right "" ;#remainder after overflow point reached + set i 0 + set cstack [list] + set prevstack [list] + set prev_g0 [list] + #note overflow_idx may already have been set lower if we had a row move above due to \v or ANSI moves + set in_overflow 0 ;#used to stop char-width scanning once in overflow + if {$overflow_idx == 0} { + #how does caller avoid an infinite loop if they have autowrap on and keep throwing graphemes to the next line? REVIEW + set in_overflow 1 + } + set trailing_nulls 0 + foreach ch [lreverse $outcols] { + if {$ch eq "\u0000"} { + incr trailing_nulls + } else { + break + } + } + if {$trailing_nulls} { + set first_tail_null_posn [expr {[llength $outcols] - $trailing_nulls}] + } else { + set first_tail_null_posn -1 + } + + #puts stderr "first_tail_null_posn: $first_tail_null_posn" + #puts stderr "colview: [ansistring VIEW $outcols]" + + foreach ch $outcols { + #puts "---- [ansistring VIEW $ch]" + + set gxleader "" + if {$i < [llength $understacks_gx]} { + #set g0 [tcl::dict::get $understacks_gx $i] + set g0 [lindex $understacks_gx $i] + if {$g0 ne $prev_g0} { + if {$g0 eq [list "gx0_on"]} { + set gxleader "\x1b(0" + } else { + set gxleader "\x1b(B" + } + } + set prev_g0 $g0 + } else { + set prev_g0 [list] + } + + set sgrleader "" + if {$i < [llength $understacks]} { + #set cstack [tcl::dict::get $understacks $i] + set cstack [lindex $understacks $i] + if {$cstack ne $prevstack} { + if {[llength $prevstack] && ![llength $cstack]} { + #This reset is important e.g testfile fruit.ans - we get overhang on rhs without it. But why is cstack empty? + append sgrleader \033\[m + } else { + append sgrleader [punk::ansi::codetype::sgr_merge_list {*}$cstack] + } + } + set prevstack $cstack + } else { + set prevstack [list] + } + + + + if {$in_overflow} { + if {$i == $overflow_idx} { + set 0 [lindex $understacks_gx $i] + set gxleader "" + if {$g0 eq [list "gx0_on"]} { + set gxleader "\x1b(0" + } elseif {$g0 eq [list "gx0_off"]} { + set gxleader "\x1b(B" + } + append overflow_right $gxleader + set cstack [lindex $understacks $i] + set sgrleader "" + #whether cstack is same or differs from previous char's stack - we must have an output at the start of the overflow_right + #if {[llength $prevstack] && ![llength $cstack]} { + # append sgrleader \033\[m + #} + append sgrleader [punk::ansi::codetype::sgr_merge_list {*}$cstack] + append overflow_right $sgrleader + append overflow_right $ch + } else { + append overflow_right $gxleader + append overflow_right $sgrleader + append overflow_right $ch + } + } else { + if {$overflow_idx != -1 && $i+1 == $overflow_idx} { + #one before overflow + #will be in overflow in next iteration + set in_overflow 1 + if {[grapheme_width_cached $ch]> 1} { + #we overflowed with second-half of a double-width char - replace first-half with user-supplied exposition char (should be 1 wide) + set ch $opt_exposed1 + } + } + append outstring $gxleader + append outstring $sgrleader + if {$ch eq "\u0000"} { + if {$cp437_glyphs} { + #map all nulls including at tail to space + append outstring " " + } else { + if {$trailing_nulls && $i < $first_tail_null_posn} { + append outstring " " ;#map inner nulls to space + } else { + append outstring \u0000 + } + } + } else { + append outstring $ch + } + } + incr i + } + #flower.ans good test for null handling - reverse line building + #review - presence of overflow_right doesn't indicate line's trailing nulls should remain. + #The cells could have been erased? + #if {!$cp437_glyphs} { + # #if {![ansistring length $overflow_right]} { + # # set outstring [tcl::string::trimright $outstring "\u0000"] + # #} + # set outstring [tcl::string::trimright $outstring "\u0000"] + # set outstring [tcl::string::map {\u0000 " "} $outstring] + #} + + + #REVIEW + #set overflow_right [tcl::string::trimright $overflow_right "\u0000"] + #set overflow_right [tcl::string::map {\u0000 " "} $overflow_right] + + set replay_codes "" + if {[llength $understacks] > 0} { + if {$overflow_idx == -1} { + #set tail_idx [tcl::dict::size $understacks] + set tail_idx [llength $understacks] + } else { + set tail_idx [llength $undercols] + } + if {$tail_idx-1 < [llength $understacks]} { + #set replay_codes [join [lindex $understacks $tail_idx-1] ""] ;#tail replay codes + set replay_codes [punk::ansi::codetype::sgr_merge_list {*}[lindex $understacks $tail_idx-1]] ;#tail replay codes + } + if {$tail_idx-1 < [llength $understacks_gx]} { + set gx0 [lindex $understacks_gx $tail_idx-1] + if {$gx0 eq [list "gx0_on"]} { + #if it was on, turn gx0 off at the point we stop processing overlay + append outstring "\x1b(B" + } + } + } + if {[string length $overflow_right]} { + #puts stderr "remainder:$overflow_right" + } + #pdict $understacks + + if {[punk::ansi::ta::detect_sgr $outstring]} { + append outstring [punk::ansi::a] ;#without this - we would get for example, trailing backgrounds after rightmost column + + #close off any open gx? + #probably should - and overflow_right reopen? + } + + if {$opt_returnextra} { + #replay_codes is the codestack at the boundary - used for ellipsis colouring to match elided text - review + #replay_codes_underlay is the set of codes in effect at the very end of the original underlay + + #review + #replay_codes_overlay is the set of codes in effect at the very end of the original overlay (even if not all overlay was applied) + #todo - replay_codes for gx0 mode + + #overflow_idx may change during ansi & character processing + if {$overflow_idx == -1} { + set overflow_right_column "" + } else { + set overflow_right_column [expr {$overflow_idx+1}] + } + set result [tcl::dict::create\ + result $outstring\ + visualwidth [punk::ansi::printing_length $outstring]\ + instruction $instruction\ + stringlen [string length $outstring]\ + overflow_right_column $overflow_right_column\ + overflow_right $overflow_right\ + unapplied $unapplied\ + unapplied_list $unapplied_list\ + insert_mode $insert_mode\ + autowrap_mode $autowrap_mode\ + crm_mode $crm_mode\ + reverse_mode $reverse_mode\ + insert_lines_above $insert_lines_above\ + insert_lines_below $insert_lines_below\ + cursor_saved_position $cursor_saved_position\ + cursor_saved_attributes $cursor_saved_attributes\ + cursor_column $cursor_column\ + cursor_row $cursor_row\ + expand_right $opt_expand_right\ + replay_codes $replay_codes\ + replay_codes_underlay $replay_codes_underlay\ + replay_codes_overlay $replay_codes_overlay\ + pm_list $pm_list\ + ] + if {$opt_returnextra == 1} { + #puts stderr "renderline: $result" + return $result + } else { + #human/debug - map special chars to visual glyphs + set viewop VIEW + switch -- $opt_returnextra { + 2 { + #codes and character data + set viewop VIEWCODES ;#ansi colorisation of codes - green for SGR, blue/blue reverse for cursor_save/cursor_restore, cyan for movements, orange for others + } + 3 { + set viewop VIEWSTYLE ;#ansi colorise the characters within the output with preceding codes, stacking codes only within each dict value - may not be same SGR effect as the effect in-situ. + } + } + tcl::dict::set result result [ansistring $viewop -lf 1 -vt 1 [tcl::dict::get $result result]] + tcl::dict::set result overflow_right [ansistring VIEW -lf 1 -vt 1 [tcl::dict::get $result overflow_right]] + tcl::dict::set result unapplied [ansistring VIEW -lf 1 -vt 1 [tcl::dict::get $result unapplied]] + tcl::dict::set result unapplied_list [ansistring VIEW -lf 1 -vt 1 [tcl::dict::get $result unapplied_list]] + tcl::dict::set result replay_codes [ansistring $viewop -lf 1 -vt 1 [tcl::dict::get $result replay_codes]] + tcl::dict::set result replay_codes_underlay [ansistring $viewop -lf 1 -vt 1 [tcl::dict::get $result replay_codes_underlay]] + tcl::dict::set result replay_codes_overlay [ansistring $viewop -lf 1 -vt 1 [tcl::dict::get $result replay_codes_overlay]] + tcl::dict::set result cursor_saved_attributes [ansistring $viewop -lf 1 -vt 1 [tcl::dict::get $result cursor_saved_attributes]] + return $result + } + } else { + #puts stderr "renderline returning: result $outstring instruction $instruction unapplied $unapplied overflow_right $overflow_right" + return $outstring + } + #return [join $out ""] + } + + #*** !doctools + #[list_end] [comment {--- end definitions namespace overtype ---}] +} + +tcl::namespace::eval overtype::piper { + proc overcentre {args} { + if {[llength $args] < 2} { + error {usage: ?-bias left|right? ?-transparent [0|1|]? ?-exposed1 ? ?-exposed2 ? ?-overflow [1|0]? overtext pipelinedata} + } + lassign [lrange $args end-1 end] over under + set argsflags [lrange $args 0 end-2] + tailcall overtype::centre {*}$argsflags $under $over + } + proc overleft {args} { + if {[llength $args] < 2} { + error {usage: ?-startcolumn ? ?-transparent [0|1|]? ?-exposed1 ? ?-exposed2 ? ?-overflow [1|0]? overtext pipelinedata} + } + lassign [lrange $args end-1 end] over under + set argsflags [lrange $args 0 end-2] + tailcall overtype::left {*}$argsflags $under $over + } +} + + +# -- --- --- --- --- --- --- --- --- --- --- +proc overtype::transparentline {args} { + foreach {under over} [lrange $args end-1 end] break + set argsflags [lrange $args 0 end-2] + set defaults [tcl::dict::create\ + -transparent 1\ + -exposed 1 " "\ + -exposed 2 " "\ + ] + set newargs [tcl::dict::merge $defaults $argsflags] + tailcall overtype::renderline {*}$newargs $under $over +} +#renderline may not make sense as it is in the long run for blocks of text - but is handy in the single-line-handling form anyway. +# We are trying to handle ansi codes in a block of text which is acting like a mini-terminal in some sense. +#We can process standard cursor moves such as \b \r - but no way to respond to other cursor movements e.g moving to other lines. +# +tcl::namespace::eval overtype::piper { + proc renderline {args} { + if {[llength $args] < 2} { + error {usage: ?-start ? ?-transparent [0|1|]? ?-overflow [1|0]? overtext pipelinedata} + } + foreach {over under} [lrange $args end-1 end] break + set argsflags [lrange $args 0 end-2] + tailcall overtype::renderline {*}$argsflags $under $over + } +} +interp alias "" piper_renderline "" overtype::piper::renderline + +#intended primarily for single grapheme - but will work for multiple +#WARNING: query CAN contain ansi or newlines - but if cache was not already set manually,the answer will be incorrect! +#We deliberately allow this for PM/SOS attached within a column +#(a cache of ansifreestring_width calls - as these are quite regex heavy) +proc overtype::grapheme_width_cached {ch} { + variable grapheme_widths + if {[tcl::dict::exists $grapheme_widths $ch]} { + return [tcl::dict::get $grapheme_widths $ch] + } + set width [punk::char::ansifreestring_width $ch] + tcl::dict::set grapheme_widths $ch $width + return $width +} + + + +proc overtype::test_renderline {} { + set t \uFF5E ;#2-wide tilde + set u \uFF3F ;#2-wide underscore + set missing \uFFFD + return [list $t $u A${t}B] +} + +#maintenance warning +#same as textblock::size - but we don't want that circular dependency +#block width and height can be tricky. e.g \v handled differently on different terminal emulators and can affect both +proc overtype::blocksize {textblock} { + if {$textblock eq ""} { + return [tcl::dict::create width 0 height 1] ;#no such thing as zero-height block - for consistency with non-empty strings having no line-endings + } + if {[tcl::string::first \t $textblock] >= 0} { + if {[info exists punk::console::tabwidth]} { + set tw $::punk::console::tabwidth + } else { + set tw 8 + } + set textblock [textutil::tabify::untabify2 $textblock $tw] + } + #ansistrip on entire block in one go rather than line by line - result should be the same - review - make tests + if {[punk::ansi::ta::detect $textblock]} { + set textblock [punk::ansi::ansistrip $textblock] + } + if {[tcl::string::last \n $textblock] >= 0} { + set num_le [expr {[tcl::string::length $textblock]-[tcl::string::length [tcl::string::map {\n {}} $textblock]]}] ;#faster than splitting into single-char list + set width [tcl::mathfunc::max {*}[lmap v [split $textblock \n] {::punk::char::ansifreestring_width $v}]] + } else { + set num_le 0 + set width [punk::char::ansifreestring_width $textblock] + } + #our concept of block-height is likely to be different to other line-counting mechanisms + set height [expr {$num_le + 1}] ;# one line if no le - 2 if there is one trailing le even if no data follows le + + return [tcl::dict::create width $width height $height] ;#maintain order in 'image processing' standard width then height - caller may use lassign [dict values [blocksize ]] width height +} + +tcl::namespace::eval overtype::priv { + variable cache_is_sgr [tcl::dict::create] + + #we are likely to be asking the same question of the same ansi codes repeatedly + #caching the answer saves some regex expense - possibly a few uS to lookup vs under 1uS + #todo - test if still worthwhile after a large cache is built up. (limit cache size?) + proc is_sgr {code} { + variable cache_is_sgr + if {[tcl::dict::exists $cache_is_sgr $code]} { + return [tcl::dict::get $cache_is_sgr $code] + } + set answer [punk::ansi::codetype::is_sgr $code] + tcl::dict::set cache_is_sgr $code $answer + return $answer + } + # better named render_to_unapplied? + proc render_unapplied {overlay_grapheme_control_list gci} { + upvar idx_over idx_over + upvar unapplied unapplied + upvar unapplied_list unapplied_list ;#maintaining as a list allows caller to utilize it without having to re-split + upvar overstacks overstacks + upvar overstacks_gx overstacks_gx + upvar overlay_grapheme_control_stacks og_stacks + + #set unapplied [join [lrange $overlay_grapheme_control_list $gci+1 end]] + set unapplied "" + set unapplied_list [list] + #append unapplied [join [lindex $overstacks $idx_over] ""] + #append unapplied [punk::ansi::codetype::sgr_merge_list {*}[lindex $overstacks $idx_over]] + set sgr_merged [punk::ansi::codetype::sgr_merge_list {*}[lindex $og_stacks $gci]] + if {$sgr_merged ne ""} { + lappend unapplied_list $sgr_merged + } + switch -- [lindex $overstacks_gx $idx_over] { + "gx0_on" { + lappend unapplied_list "\x1b(0" + } + "gx0_off" { + lappend unapplied_list "\x1b(B" + } + } + + foreach gc [lrange $overlay_grapheme_control_list $gci+1 end] { + lassign $gc type item + #types g other sgr gx0 + if {$type eq "gx0"} { + if {$item eq "gx0_on"} { + lappend unapplied_list "\x1b(0" + } elseif {$item eq "gx0_off"} { + lappend unapplied_list "\x1b(B" + } + } else { + lappend unapplied_list $item + } + } + set unapplied [join $unapplied_list ""] + } + + #clearer - renders the specific gci forward as unapplied - prefixed with it's merged sgr stack + proc render_this_unapplied {overlay_grapheme_control_list gci} { + upvar idx_over idx_over + upvar unapplied unapplied + upvar unapplied_list unapplied_list + upvar overstacks overstacks + upvar overstacks_gx overstacks_gx + upvar overlay_grapheme_control_stacks og_stacks + + #set unapplied [join [lrange $overlay_grapheme_control_list $gci+1 end]] + set unapplied "" + set unapplied_list [list] + + set sgr_merged [punk::ansi::codetype::sgr_merge_list {*}[lindex $og_stacks $gci]] + if {$sgr_merged ne ""} { + lappend unapplied_list $sgr_merged + } + switch -- [lindex $overstacks_gx $idx_over] { + "gx0_on" { + lappend unapplied_list "\x1b(0" + } + "gx0_off" { + lappend unapplied_list "\x1b(B" + } + } + + foreach gc [lrange $overlay_grapheme_control_list $gci end] { + lassign $gc type item + #types g other sgr gx0 + if {$type eq "gx0"} { + if {$item eq "gx0_on"} { + lappend unapplied_list "\x1b(0" + } elseif {$item eq "gx0_off"} { + lappend unapplied_list "\x1b(B" + } + } else { + lappend unapplied_list $item + } + } + set unapplied [join $unapplied_list ""] + } + proc render_delchar {i} { + upvar outcols o + upvar understacks ustacks + upvar understacks_gx gxstacks + set nxt [llength $o] + if {$i < $nxt} { + set o [lreplace $o $i $i] + set ustacks [lreplace $ustacks $i $i] + set gxstacks [lreplace $gxstacks $i $i] + } elseif {$i == 0 || $i == $nxt} { + #nothing to do + } else { + puts stderr "render_delchar - attempt to delchar at index $i >= number of outcols $nxt - shouldn't happen" + } + } + proc render_erasechar {i count} { + upvar outcols o + upvar understacks ustacks + upvar understacks_gx gxstacks + upvar replay_codes_overlay replay + #ECH clears character attributes from erased character positions + #ECH accepts 0 or empty parameter, which is equivalent to 1. Caller of render_erasechar should do that mapping and only supply 1 or greater. + if {![tcl::string::is integer -strict $count] || $count < 1} { + error "render_erasechar count must be integer >= 1" + } + set start $i + set end [expr {$i + $count -1}] + #we restrict ECH to current line - as some terminals do - review - is that the only way it's implemented? + if {$i > [llength $o]-1} { + return + } + if {$end > [llength $o]-1} { + set end [expr {[llength $o]-1}] + } + set num [expr {$end - $start + 1}] + set o [lreplace $o $start $end {*}[lrepeat $num \u0000]] ;#or space? + #DECECM ??? + set ustacks [lreplace $ustacks $start $end {*}[lrepeat $num [list $replay]]] + set gxstacks [lreplace $gxstacks $start $end {*}[lrepeat $num [list]]] ;# ??? review + return + } + proc render_setchar {i c } { + upvar outcols o + lset o $i $c + } + + #Initial usecase is for old-terminal hack to add PM-wrapped \b + #review - can be used for other multibyte sequences that occupy one column? + #combiners? diacritics? + proc render_append_to_char {i c} { + upvar outcols o + if {$i > [llength $o]-1} { + error "render_append_to_char cannot append [ansistring VIEW -lf 1 -nul 1 $c] to existing char at index $i while $i >= llength outcols [llength $o]" + } + set existing [lindex $o $i] + if {$existing eq "\0"} { + lset o $i $c + } else { + lset o $i $existing$c + } + } + #is actually addgrapheme? + proc render_addchar {i c sgrstack gx0stack {insert_mode 0}} { + upvar outcols o + upvar understacks ustacks + upvar understacks_gx gxstacks + + # -- --- --- + #this is somewhat of a hack.. probably not really the equivalent of proper reverse video? review + #we should ideally be able to reverse the video of a sequence that already includes SGR reverse/noreverse attributes + upvar reverse_mode do_reverse + #if {$do_reverse} { + # lappend sgrstack [a+ reverse] + #} else { + # lappend sgrstack [a+ noreverse] + #} + + #JMN3 + if {$do_reverse} { + #note we can't just look for \x1b\[7m or \x1b\[27m + # it may be a more complex sequence like \x1b\[0\;\;7\;31m etc + + set existing_reverse_state 0 + set codeinfo [punk::ansi::codetype::sgr_merge $sgrstack -info 1] + set codestate_reverse [dict get $codeinfo codestate reverse] + switch -- $codestate_reverse { + 7 { + set existing_reverse_state 1 + } + 27 { + set existing_reverse_state 0 + } + "" { + } + } + if {$existing_reverse_state == 0} { + set rflip [a+ reverse] + } else { + #reverse of reverse + set rflip [a+ noreverse] + } + #note that mergeresult can have multiple esc (due to unmergeables or non sgr codes) + set sgrstack [list [dict get $codeinfo mergeresult] $rflip] + #set sgrstack [punk::ansi::codetype::sgr_merge [list [dict get $codeinfo mergeresult] $rflip]] + } + + # -- --- --- + + set nxt [llength $o] + if {!$insert_mode} { + if {$i < $nxt} { + #These lists must always be in sync + lset o $i $c + } else { + lappend o $c + } + if {$i < [llength $ustacks]} { + lset ustacks $i $sgrstack + lset gxstacks $i $gx0stack + } else { + lappend ustacks $sgrstack + lappend gxstacks $gx0stack + } + } else { + #insert of single-width vs double-width when underlying is double-width? + if {$i < $nxt} { + set o [linsert $o $i $c] + } else { + lappend o $c + } + if {$i < [llength $ustacks]} { + set ustacks [linsert $ustacks $i $sgrstack] + set gxstacks [linsert $gxstacks $i $gx0stack] + } else { + lappend ustacks $sgrstack + lappend gxstacks $gx0stack + } + } + } + +} + + + +# -- --- --- --- --- --- --- --- --- --- --- +tcl::namespace::eval overtype { + interp alias {} ::overtype::center {} ::overtype::centre +} + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Ready +package provide overtype [tcl::namespace::eval overtype { + variable version + set version 1.7.1 +}] +return + +#*** !doctools +#[manpage_end] 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 6a2a3376..c20e3b51 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 @@ -4950,7 +4950,7 @@ tcl::namespace::eval punk::args { set argd [punk::args::parse $args withid ::myns::myfunc] lassign [dict values $argd] leaders opts values received solos if {[dict exists $received] -configfile} { - puts "have option for existing file [dict get $opts -configfile]" + puts "have option for existing file [dict get $opts -configfile]" } } }]} @@ -6515,7 +6515,7 @@ tcl::namespace::eval punk::args { set range [lindex $ranges $clausecolumn] #todo - small-value double comparisons with error-margin? review lassign $range low high - if {$low$high ne ""} { + if {"$low$high" ne ""} { if {$low eq ""} { #lowside unspecified - check only high if {$e_check > $high} { diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/templates-0.1.3.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/templates-0.1.3.tm new file mode 100644 index 0000000000000000000000000000000000000000..e679d01307bca6d437e4c564d9e02e4bee17a1a0 GIT binary patch literal 70519 zcmce;1z1#F*Eddzl1eut-Ju}e(%sz*-7|Dbhk&9;BMkx)0@5G?5&{y^(%oH3d}mPa zc=W#C=X<~Z^`Gk+2F}@g?bYkI7iSMD=r1oSFKZ`|g|!_RS}EVwRQjjb1fjuAV(LFn+1fA4@L^=2(ou{ zb%280tzblfOHKd<)W56;~WMXD(VhLt(1G_-19UVXxj&?BitRWzP1Bi(|_~#W92#6JGe=W>^ENBUK z0K1sLh`K_o9W40(7Gb3M`0T7r`S|QjY{5nV4@Tdwf><0aEFfSg)YAzJGI24p0@wrz z0QX^95&{W8?XQ3Nn@H9cAa6Z06R4RL$opEE4vsGNCU(|dV33}*gM}jqV&-D)1U2wA z@CAAQZ6-`HU>6rag_J**zt#rS)%5#iR*;5+i7B8-K(XdvKyUWe4qzDnuD~@X6Q~s{ zh~CK&0-E$aKXzf7E*05f=d14LoG|BgeL zeAGYggTT%pN=lHA59qGmwX9$dYX}qq`g#AiBK|*%NeTKJ&oFv_mjZSLuo_G?=GHEt z@2mm8Ilw&R58i$u0-FN%0RKAWJAwbSBaE7(1u((P6$&$pfq}tqNdjCLnK+mm0Z#ja z6&FWG=ru3j2}4b+?fzuzS0Z*MfK4qOKza}-J8S6m$Ug|O82oU6Ya&15;gwVE^7j2z+rLf|`(IBJ z0_pu_@qc0xwj#`6uvA1X`isP{+prgGh$x6!>|Y0nfv5p8za8>>QGYJ%{rlS%jxJym zApSi7&OqLi(`LkKf7& z8~S@eet-3cAN*Elzwr&KUvd@9_aQ(o2eOnS$Q=waGjRaC7*;6&W?dYeT&#fvZRhz5 zvoKBCnVCSqM&A>!5d>^$4|V_&jvg$*IamUj(azERk2w1?UVxbXhv@uH4~S79iNbOy zG3_kW5)SoZk~|8_1W4wgW@`>Pz^ zld-{Hg8M(#00C}l0OF@|g#gtI@B*+4P>NvIHV47T|5kjM3QU1uv;FPeU)}fDD}PfU z_21<9$Jm0I%)-^q?gtzJ>Df2}_(RXk(E+IYpuZEjPS=2M!6+Mm`1oKF!sddm3xJ~q zP`Ix#4G4fNfaK;dB=hr<%Xh5xTiLGN1{O0$z>+`k5!-i#UvuNl==*m@4A_8Cz<97Z z3t$Qunu1lrpM~U?HGDx}JHQbC?6ZGW0F2TP8Gj)JGtqCE{l8-e^%ug|mb=b}W{&pu zK!t^XuA>wN&j18^Evx|uKuDC7|Kz?@CN7q)unYp=Rv3^pvx508;BSr~Qy?t?a0!TZ z*zIdT{1e#n@hMy9ksmX^XU%J3zb9hu=s*XB`4x!nFZhfOK;&Qt5EOugu%!7XM-Tu( zLL32*^pkfG;9PcK69^P!34^}&FeCzenuG03JRu+efxBBfm^->dKu&fhP#^~akQ;!n z4vr2i*EPxn5P{+MoT*#EP&+UYsJyQB0DkfWN)$lkyY|`G00Y2y`;K6NiUV8+BE$r+ zC)C~1#r7KS{)z+t=4{t`0cwLe0DVEWV1Qx0UmfJ1(<&t!+jm!D1Kj(2pizPxtYHBS z{PmsqKRMR58<+z{&Ke2^i7Lzd@T|W$=pRA;L)9R6SONg{2QE-oU_S)g4LLXhrgJjC z)(OjxQu*DWwhoT&z<%U!z6*0vM^`8a>f(8=IOy-S1LN#Ea(--4erp}rAlQrQ7k&MK zQ$c@d=ilNONOrJY9M~Qv4+N;qu(hE-Om6~mcX0%4Z0QPyKtS{+E>LR=V7~_flA;N$ zp27kX*s=hY|BLSeJ_B(DgM@$YR^QnM7Yq`|5XG34TXPJG>}AHTonGX zj{LzbU^5V~l?C9B^}lihGu+*uo6BEW`@;RyOeyua^he~R0)AjjU0h)hYJwb)3NL=L@XvR?+w`v<{;L^brTdqX4b#IP^&9AR{Eu$- zHx+y*2>NN=YjeP|{r__DABG1kcWt!qH3cYrdVl%T;NO+^w`Ak$@SUUI@bj+`@}qz9 zXQRXdC{WjK@)PO6`a%H4f+_D>>9B$Y{0{4(Q2zzf{4=k=H>L0Ivj7#4i@vM+Z*U6) zaWw_@B*0eO5eR(~J9k()g_S}W*Z{Z#T5Eswn}9tMuFbqhje>TVf z^aJzW?^6LQ0z%pUR!^=@c3_~@2I2s4IDl<{s^aPbz>NQ;)qgFX{|XzaEKKa|OaZ(L zi!fL<03z@wsQN9pRElD(AT0oIT*DYM0O$kd6sDVNSYQvdYG4-tMM6Lyf$K>;uL9&a${VB!Yk;_H6l_g3wHH2!{Ork|fb`ULg> z8$c9O%2)tU>wAm$JITLxc1>IW_xyuA%MZ0*#}Ldc@yVOt+Npe?}q&%p=d_CGjP2k2Zkj)Cqn2tZ2!tbmywSnWr^09!8@ zhybXY{Ok|IVE3PG<-aDSO?CnV1p@L%n;8ITKUw{E2EQjEYCx60^=g<5{~9N- z0kGHgKGPhe_cKO*ZXteh0s7Tp|8YSWz5l}F|G%j;u*LplTH{A9r?vnx@qdQczcLJ? z^Z!Fehb{B_tp3k;en0*n((5l$|95KsMK^z6)Ytb%hvh#z(?9;hVDKM_5BC3^KVk&% zX&?dr+4LkpXXRkM z&-NdG1I0C0Ytm)%!EN7BExXq}JOokQORsG56;qDyVkNCr`hD~exLq4(90VsGkf#xQ z)o2MH7e~rhr53|ReRFeZa~v(7)0;Q@3CWpo(jZ-~y>XFU-{HVlWp2;@KGx2%Itx^i zJc@<*sV`s5xpM@pmAdgid*m$?e&$v$WD=s)dRBT+D_~A3%wtn1hMcFdCHu9uPWS4b z-h&C;QGM^#&i4w5@+Pe>`;kp*D+~$r#oxTORXv=XX^#4=MDeLJ?6t`~KFg>yrs5LY zP&*2z;$roFIeX}sYEdh#uI~*T9(TVD!~~*BA17q@tfFKs{ZaikgEV!e+BcQvrrD!j z)^Wu4kfHFZnrBmzY)Y$}s8^IXvtHS3;%P88tJ>xzGp)Ef9cevmV6m-k zZB*}2((cR*(P6#|7@e3u8!Ze>lQqS`W5pNoD-UptzeBp}dQ9t02OqEY=EjCx99qlj zs5jgKvd0PTg-O&c@=vqMElk6SaEV`B(Zk{Hrjti4+x2^*w=u>Cyc8IiWEe0y&mG`O zunX!yu-p*DU0^cl+ke@0F}x@YRif35-`pctsn@h1P5LAmL_1nIBAcaKm&MUASaVUl z)&2C7twG4a0bSiL;czt$yq9t`F5#4W4O)!BVLwF^0}pqaaG9ndk%k63`F3MwE9fXn zcHdO{c}Ll6FHS3lTc^B%s;j#C*_QkneQU(BA_#YUFFl5Ypz=46`CEAKT&lO)GeR4p zu+K*t)l3)BOG~+`(>Ti-g$^zHH@h75%~av#3DchFdRZn1)Hl3p@9)dkraljiUL){A z7l`Om5?5VkdSDO@@+vrf*W5TZl_sn(huD2g_BFJSm6PQeI9Nob=q>im=NUJwA0NFR zH&d~fA7%2f!ABjSH;`V!jpvSgSEIjQ+{$669uD6p9t3hUd$ce1#jnGfV2~n?XdpCR z#g`;nxEvP?RY zMwIlLH?G=N?Y+K|+_eEev&T6MJi|1e+gPUrT`?G>yNddaT1379f!fMzo=ox7ElgI< z3}o_;$$W-dDs&_`%g~V}v2*?PD78tF;F;fu*3p8*9kzXhsO7O*q88l)$*pPh*rrt3 zg9!bVG2-^L8|-{~4!iG;7}(hem5oRph9EwQ!r_oTK8u7j24;reb#si}5HfFHyXtxE zNqNvr?KlBBG>Ry`7<^5#XK%c$?T?L}JIfk9(S|_kSv5LlcHqd(7pqcgR#S|4-_8Vt z&mnR$-`Gr8uxe@d87tU4{< zeumj#!c*HgwUoZQZfdVAXfz#d!Yg5Y!kHTV@`0K4<)-qYmJ4%sivY<0zbD~U-}c;- zWfTO~_Y^p_480boNv^&StIl|GPy4iZFNjFBN&0$NXJ-8C)CifF9X;GN&%yzS^$Yr^ zU3dKX9+7#Ey8HAMnDYA+9ah<#M=kO z*bm^P0=)mnV!#Hp2Z3Ickqg)Y!Upv6ZGerA2(WK4cXVNLa&@p}`f=^Lhya5S;r?9E zJBm}gh$KGnIj~S0@D_$c`L7rJV=*>}iy0g2(FAi=pp$TQg$M@+kDw9#5%oR$ZHbe! zNLxL6dYL0Eqy*L}w*di35@NL;MCSQsl0p)0ND{=N<|t2X#NFAP>+}Vcb+v`ju_k!q zF?~Tuf_vcOn}?kbo;=cJSCNhBo|EyS7waU?lTQ1BfEkaI6LsIE@-npLNxGAvKPZ?m zfcJdhqjaB%t6(;rb@=uqyr0DIX3;&vFawB>)+Sv~@i@w#a*L+==_+{+&hr7~Hm4pA zP6+PC|59$)Lk!==28;&386;EGG`uNOkvOq5*gQNuaD5~w;wr4qj0w?4=c;f` z>e^>Y7v2QCq$=;rVtg7BuBNgm_tolIupC1-Q*EA6YgXqAXYFq3hbBak8t7Y}BEjU2 zvg;@;?X*2$-AIiW5AP9-qdrmy%1kvhjoOn)jkz_Z9nGz&03V@>JEt4@aJm!e29DWk zVRQNo(Ytcac=%c}sj?h|k#{ez1}-rJ6_6_k*Y2E-J_-;{VQgeAF^{`RNvcHHWOI1R zg`xVcc?>kLsE`;wj$W^tUk`V8D%g|MkeWD@a*&QXN4mm?jCOA(=c`~O1c^?leT`9# zZ26!TE$prn|GGw~Go|E%Q_0xgqb14&|JU>SB_^4udkhg#E|<}hrep*XsfO!pX*+Su zkB!lGwODsKN=jtLOv;FrE&q9aY1Y@|<-q2-QC6bUWUsIw4=J83^6*49 zS28)s4@rDsYoS0%h_D8)%@{CU&9NC##=JzFr)yE>y@>ijDXA4t^}fjJ;T-By*|<%7 zXQnrdVUoi)64P3@6Z%Za}r7ts7F&Yao2mU?zK3M5vtz!?f*dE$MSTU{>0 z*$6CP5LE$(P~+=#3(o?s^8@}{Jye5_OtXm_PH6Ibl96Z;L+0c?lTdw-e;8R~dhcq( zJ7p6Mizo$c!-xV(>3fY42h0+h#)^8P#c%0b8<5tclu{RS}(0R$w z^yPh}@qNcX%jj5R?-F1P5J zOIzh$wIlW(JJv8BQhdeJ=GxsmfJmS&ehzq0{h0gR{*#aXHR(}~p*JR2I_H_m5K(Ta z&67G=h%WY@R>sIs4#`m~nYlHDew`H0i}YCM9kE2YLa)Gmh!Oj^SSD4I0c~C_lN~R| zH<7$wGxQySsCnz1w<$d=HD1_McA@oeC3+3Axh_QwN%G^NO=DF7ei}-KR8EM=hNWQHTCOyw{yeQbi#8GxX?#IP!Y$^_EK zWfR54rM7yH;2x#=j20y9gvQdU&SoS(;X*B39bn6;F5Z@9Mth{RtQ@BDnU4p)8e_e8 zz07HGQ};1ng=+v`FXux;hLBQKdQqqM=?kLqt9VS$gKNJ~*QsRc-aYH;gu^?t9UOz> zdZKp@G0gS&{Gw*KTmzTD$?9#52uTv%Bm;)(l_kB%`cOF*PH+<#bqFB``;w@>l59vc zhNXUmk~xEjId4RO^hS4(56BrEAJb0hNpb>Z97+E@QRa>U2agv|^0-r8FMR5&PBy-D zoN5wjkUu>9u)|-^R=T)fSI_NBR&c=)+zziGXDf!F!#5eq6(*HN8##~dE~tE4Yixj7 ztx7zcqvD}X!1gwtRH!)ovmTms8XgY?PxJds7U~6WW0}W#)z-*AH=PR75YU(qPlb`NAJVq;rDQUwtxtR}E*;pcgB^UNoV8d0Aux@vCb3 z)#5I47+0x?;@s1&kOu^rL&Ysg&zyp!9&+vt7)bB#c8{&=7-_ZZV7Py|vo(vw9+um0 zPvCT;GqC~f;N$xdah+ZV;@*-ph3Mf^Ez{j{xcQzN^P}pVO)Z~@DQ?*Z4BfUHpo~vd zI$QXVZ~1BOS+jZ#!A5MOxcr!`D81TyTP)%UZ9kz}ziIfghXKx_VSEvf@Pfu&QkI^s z@!z$8yXS_tvLR+y(Y^Yxt+aIAgtd?-g0JH#Y z+NcLsTgD%v-4_MVq9bYEKv~{wK1Crts;^)b;UH=6#pY8I<1DvW)x;My z1Xh($EqbG-d-zd&*V@aB?}4Z@vMT&QmSRomZIX|URy(v~#sqO%6Nr62i#7{nq#bjX zTu;=Ty%?v{{XIgi($mw4GZa3D%(1UVBVlA9p@Z9&Yjj(v>uKBy6vDxpG@G~Up2%{f z9-*_}emNGrX_}0veZ!9Xq?Jbl((msbY8w3k6j>OJ4S%O-f?bH8PT8n%kcM2(n`Dz> zd~(;fs_h_pVotNcB($WwhQRu{vXx5clA!ITDHJ&?3m=}Iu(P0-&2e>sp6VpmgSck- zV}Zkt2PgEKWr?FG+WZIF%JcLR#e-XQp=X0cC{AfnJ56{>DeKYvB^SNOkG-Z;-96q< zwALEO=D1ATJQTNF)a7S)8%(YY?s`QS(swpMSqJZj`;~@|!Rao8(*qOz>OB*jlKho) zFM?;ar|Wuq@`ta9-05sH$Mpo#s-0W~2Mm?=I-V0-XZ1Yf_7EULq_E*EdiwPpcXxhX z`h9{b$1?_-hs6sciMGv9?gtrSwUbX{Z+Pvdy$*k3vcbH>g}P;F-=TX!V`_@-_2iLh zhOx~oB6N_vkV?-|>lUh|{idTb1!-WqY6eZZ0nUB2Xpt^axF|Y_w=Y(An$-O)mqtQf zto9>6qo&;;Peb*55l-M}v@Z%LDdVFeu2%C-=hcgMmWvTC&Oss~WVLY4QhaG4o!TcX zCGRozbdfmlISOv8BGh&|>c0-jt`5?Ec=5j^ZbI?oD{tq!*{2amFKuv4 zABaOdGWT4}q^sB#(~T3#2252Y>fowlp5Cco6i~^{IeJ7YmJ}69xsE|kv2XXRBNwX0 zZ60=l%*V&eek(C1ZJRd>>3WFh3hS@sT8kAnc*2y8EfVHFpx9G-7Yv)>E#Id8;U)sgb<* zulvre7Z+^yOHKP#1ydeBBkV^y#dwqI>yJWapf@LJC*-l{yg3x?Z-L2jqpEI_&pI-q zwgbJ(46zK0O!dOz*0O*rDbGtpEIU#Qn@aYE0UVo>ZzcR+ODgaw%HC%A>vlekeTj28 zasRHBbMv^9RI==ez5sou_&vE?OpNLQk{nBu12xjTvZnE~WBG-|x%65cFZYC`vag6N zbJ;O@0uuRaUqvSyGxHD0tzB-6u8b|b-#mFtYk%~3oG|yMa(KG@6GA&T>^F-XF(O%Z ziM1w`T(R?xdlqzf3yxo(E7N8wXGGo?z{LxrN?bnQy5eSvS7V_Tta?Dc3QsSgtjPKZCg ztM2toPz56PrjHm$&^gGH<#??)%0;)j$?kNiaYm1XMsaTQ{bD?qM9Y(Ld0*Y-cWOwC zDjv{$r{rUn_0Mog-csaMp~(994V!4w{C&5*KWwC?1yW=cS=@D0p8K{)L^A&3>sJS{ z7v?J6(OJC?ew@yNbAf$n2Lr478YU81R`mtFZ9Nu@ZAAi~T*g>$`a1RGplprQkI+pZ zyCei*MAIUuxsM9iyQfhVStY%Vm~FP@P^IWw_O4@zTo0sD{xJ0Bj(bHC&t!y>E8m<^ z5&I*Y$JTMEhYck6HgVh1OrdUKkrh>kP$^b&vX9$0F@{FvE8vk1Gl@gCX(siJY#?<^ zyzkRdS0uC_&gn}@#B^DstjjzyJl5-;&7i1Cey+KJMqPl(fYzfz({#)1*-ISo<B1rCBfTe@yNo>7>fMzS%? zGYBfNE=Ilqf^S!(m(6{jMl^VbY%bUVHJa;uM8V~O1#};+^$B|Bwh+OLA5;2~ecS_4 zDPMYTO^3>DyG9%-hnr(|4J4a(+#5L)AIERyG%)Ll*dZ5osUEjb8%$Cmv+MZuOHKNs zB1Sl18B5|zc%;7H_PRK}2qSQuHa6p`@)kqOmL~IeC@#1Foj>JiK6W7JYa787G!Ix^ zg=^0w(8_IKE`5K9jq~v|%t~m7qNgkBAR2BqUQ(S|`YQcXyFb~q<;>}~7-IXbBQ9_= zU)QOZHHWD38K%ZG2UxFSG}6UOC(Ud!)4f;_Ns>iDvhj8(*$a0^Itv?rzoX-&GyYuL z-X24oXFEOWD2>L)g$pciSSxxp<>|$gW2>)vNHa{x6*bUxe6Qw@Qnc7kqF1=ZVkoxG zJ1(D+yFbDbOLcpPFOO zxABfM&U@akM7|#K6ix(@ZoS^uuh{!qC~#0trYS@`{ptSFBWSRHcY@>aT+X_axG#|~ z?);Gx+w(?kZ(rr;yRk-ZZec*Wz>zoS%H_ZqR z{L`sp2B<}~V%xWk#QRNN=e#&g#`^jL_T(Zwi&${Hb@e$%$Ze%O>}l=VLBt4HZ#SsC z6IvgshTCqw$k=+#sOW--P$Y4?R$tRN;!9`6l3UW)t#;%jO4+V_X2XVA^T-O$?qYN8 zrrZ*?itodZx=Q$no!3JD-#Pt1e zNR)>R{it(o{8mIm3U;@aacA&WDCVR)1amSrWPAx$a~`|584J{qn@i@P_9vr36Cd26$A zw2Sa@ZYi>OW4W@l-x_!7-x$A(^5}KMYSh*MN97TVwp zpwt5|dGX4RRfZ+s6pYxii(k=J1?Xs35Dg1|!Xn`2uTOuNkTRYAh*2Y>anLe+dYtdl zXQa-JslXi70JWrabiD|*b9~+fJ$f~3#KN{DmC+-)LZKb&UVBl$_8Qt*ifP%6Q_WG) zf{$%$qNd8ual@Pi3Z@V39))$*j(mEM=(;y2FRHyt()O{CzTzmUDXn#iSOYhe6>ZtL zFWg;_15wG*u|MOHc0NjP7zV*!g#4qFcXT&5iUt)xLbcrH_#wGOwCgYA5B#d?ymQ}T zYky)ts~JkQQTaee<-;lYSTDaw4IRWFZal4Tnq7{U>_6S;wYQ(IHRQVJIJodMmj$dE z9E-6JMT#O9d2&BLK$ES5dx5O$^eCddERm>BNw>R`22Cc&%dG<~#4l!=w2%Db{Ora2 zLwTo)SrxtA7^0-!gV_1m>3(O5C}Bp)zNq$f32m>F;dgqS?a`r=E0+a?r?;&S!~F9Z z6{Niu5j|eTh*QbVs;)IR$aXB2bli~vJ#N*AaKA;Robgr-8`1w1tKoHxt_nEdmGQTn zdD|9d%+Sv==a*|kn&?e*sIm7|bBH`j$**L%4o^Z^R;D2XV1|4$s44YJ2I>uOmSdT! zTGU~-Zx-Rm39H6;urLr<4e?Rc=ekA|qnI-%GoIF#7RJvMD#Pnce--WZsXQyFc`R76 zY-o=;4}H(nvJZ(sR>LW7TfuKy`uJXd0V!&sF#4fS&}WXv-r*b?4<2E4fX z;gu3k*vuYIc&U^Bpg2wESw!<~23m8BJ6p=lpcn8dx*8NVPQlnO>YSc?q|zlp3q?lO zh`h@4msV8E?npj4vuHk(^utV`@p&8;hPIc*#l;1h^&irB!2!1&RY{owpZAJ2SQW0D%rfu)x1l@W$LzlKGNlaX+J} z?eYiRO}?i1?c+=sL?&AabAne$;%00v&ih#JWGHJ<;nmEV8D1lKj1e=F6gIDoz=3og zE!`L$?7X?CXl0P4Cbv4jdgtC7bTq-wcrkZqJu|~qre)RSipKIj8cWZZi)rJLdp$O= z=h$cQ+}EIfs`+y4c&@HYZ0zv>OU{-<>$d2Mn`Mb?|Ei5fi)!?W7!nJ~n8dOWExQPY z{!sbQZq*mpbCQ*5@wUk^ z@*K>kGLPC^WV$A(JMy!J)s8IEqxCb=&F@!#5yvPAN$#Vw6{#HTl4Klp-jVMT-uc*9 z+2qt!)Gf~U?b)G7R-kz3i=(2H-jg6s=vGL9Uhmehef&kcZ_L4?*Af*jTWo1*_wMyV zd*q}V0v7_uTJEkPWP9C>{b;r8CO{pLiH76*4ea>AGvn00&4K9*C>`dCuv@Hur@=}PejN^% zlpYhbp;C5ud2~XRO)*XFUv~mw9%m}^ExseE~2#%->L|~C>2sydXX42q>1PM zV9998{pr|EkuV9bS7OnmxGT&(6;2hmY;qlN7WnxLRi926%L^?gNkY1xBNoe$mnKOw zGBzfFnutaWDW1`b&gjLY#Hn$GJqWDITEstJJHNlnON&=rr%2_;-tlHj5feWB=~Kf{ z)*x>u(g!Vq3)QWX6#dGy6ow7o=7z&g$kE537nkR~AGLNS_AI?$5ofNl&8lc0#`sgj z29lX>ACe2Crv%t*2Vw6OKKg*Bc^IDc^tG3%b9sMmXR^C~>Uv3|W&+qbDdiz*Fgrfz-iNtYN#&T z%6y}^XBkBg`-0Rn5#PsOOJ8}o(v8K)hkqBxtG6r)%^@k{0|EvAOVi$y51%8wY^ab3 zHwSj4zPWm>sIcXBRpWY;x(Q4?tF7m^1Ak+3_Tt=*5of>Yb*DmOE6vxqQb^EdV<7wO zWwACV1LN1b;-!p1aiPOR^2ZgNylEHhGH>un(IIu|cW%tadVbZ7qZuTcH`alF>cY7E`)J=#T! zVs>uPfP7^76r6mc>8N<&Q5Ad8-NyZDOm2~$R~lroGZoU+bT!z?oHo41j2?PJw7FHd zL&gOo(ofpzUg-HPh>Dk6gn6~AE0?c757_V5akz@K9??5eG_g8fjqvIa7pEDT7hC^g z=MoTH_1fAV|KeS-*Qkc_AjiEJ24l%NtTMP&_f_$laT1JvE2W3R@DZbvi`AnBQV(4*!BA2j;Bm3!h!IJbj?Dd2H6S(#M0M$KBdPmmA7%Q()E z6vtBP@folMTmkB5Pu|>v*DCB%8$CLnDJaad3&^Y$uYLPoA^T%P-x9pO; zeS>|u*DJ?*Aru z&dd8X5OnJ0=@sO9a@p7Ma3se*{tRfYYGB$!4SOnF{m}V$cuK3X80ee3M28>q(}N{1 z62m-`KT2uL-~@ktNSRHZbm31x>ZJ3&wqv6W0lx1M)cKZ~OtRms7#@Ymoq;DUFH#50 zc>;{-%e@#k?qrXoCENKt{A?TdMUbFpoy*KIGE#A5&TGDJ#_#GY%AR0>#Qbo*`^rw9 zS6;NpylP;=7nv%~G_ z2&t-1#EX=x)r^t6kG!|odiD{*;fz#A)AmU^P;aH35jkV-xId*Q|LC1KZhjJRG%K$H ziYs(pSz)l?M&4ItEqkI?%0!fVo3BzxD`J<5K)Sbbfc*KntEzc6WmA}?Iy$jNi&~g zRN8$h-$JJq*;*lXUuF?c1TL+*@XKZa;%!3JVTJRqY<&ucK7kK2##ZIGs<*?+J<>-w zDD%NnVoS&qM)T=NdstCNVgAkGGBlJ^p&B_~NzR`mTI&kae@>&S#84WYJARIy#+*lO zqaoE<9zyM(^BR1P8Q{twC^ z3#O1~hRnXN`aVOmkL?>nM$57ATgQi+Z0k5k>-$o@Pj|WXdVQOoTp7-J=Ik_$5c&>z zm(3W`O;^e^l_i*$8co$d@uTDKz#k8(El5jxz#_`uvwu@T2%VVDt>I>~70;Iq1mO=- zN}dXZRW+SiTcjA68V&0oJ^2rx0zP8*?VY?XtW-cIPy z5Du&rG=|V+xj864N2g&yUNR&jq}xKSdu7DZ+ddeP#bE6A(ebU;xn$L=Qz?l%Jn%2g zK1rHy2sp+Ct{XC}wrG}%e92pH)FP|ooYpxCuVWU6%HBnAm2w%$IByS4jCuAEi2^^% ze;0Ui#g(XpJH+F?qC)&#_1u2yypHG)I4`xY807x4-Cw>)9=zlIGE?L(KfXCif7YiPjw2a5($Zd2VU+kovy)?$xs|Wt}{R z@2AbZWL*?IHS||Z5DA%KA#>fZRdHmv zCuiEb(L4>z9Tf>{*bhjcgQXyGlzr4UpG4BIl8Kl`&QGf;m9UNEnjT_7Y9iT6XA@G` zV|g#*_RaI=G4it4I60H~N|1z$eI$-wB8ZkIsI|N;wSJMKH99GYa$|0k{%K^r@)?>z z#vP+`)eZ_GwEFEibLIl1#X!x{J--q+A1=m9q!&tKUJgwq2+|{NlZLpO$Hb4^D8XYN zEy3i^@2Jt;eoBgffj(ftD1h9Aw zbVOO2f#(*yrPF18ZPR`SXLs#sujB3vW^7XshK?W$cfD|~PQ70bu4MH4HU)oIIbM>9 zQRAmtvk{2o0d9_%AIrPw`LQQvlcI@fy;z4QlHQp~z56^a&Z#?Hh-zb*7Wa)r4$&0) z{64m{jZ%}XhPG+lNqy*WIE%rViD;Z#S-IxwaCppFv;R@C;WtKf=+Y~9ge_*}44xy! zsU9{|>m9cj{&j;|R6d3`A%!v$OQ5N4Hx`A*JFE-lTNC9Dt{kE^OytFzU=4W|kXtEO0bX&R9und^`$vNOp;nUUkxJmc=t!1 zpPId2bE*-QSr`oZ9Dg+4=o+8ta+8|Hu7WPlsp(!x0q4WMdasF_9s2=D{uM720YcZm8&s4R1Mu?9TG3sr@EbC8$DRu-ir&Oj8Ta8O}S6M==P(J0v ze|)B=w>LY^@>z8gqsxYNtY6ReP_G1iMnMLbB6f3&S}O$2eW$8FPt_{ha=IES`Zk@& zsvx}n#)B|^DM9K(v9i=`mZK@}y7S}#p)nz?q+;^@X!k6N$WPbd-+PV{BDwb=>3@=c)SZ}ba zJsA7krVhXOOQ$|`j*M9X(XlcKM`5#om|mR}Pn3ODyii-vxYwx<;v zit@WD%l7_@h?on3$v98lMy@ zPF9cu(s-%8x8xLrcr%3-LX=)KkxPubbb;>$W$_@ zz7n-ndbf)~NHXv#qs${j1X|oOBkyTEO1e`78QLngs-lVN_`1#632EbPi9|Qs!Gn3l z9XYa-8IRYmaiv@%G3ARFE=Vn%A}=X(F+Bs}QCi;CT{G2G7Cf&HD?I=&Z z`pvCdhgr`39s;U7F-pe`)zDQE+P2|sMR(%eY0T73W&Lg6w{4B2`PL~P-*l@*c&6Q? z|7aN$l=;|Wv2k*vXyG^^XcgyBF($2Aw0+U5*et}uKT1{d_G#Db-Po*PZXMF6voW>( zOe-rbUfD5P46#jq8i7>j?Oe?vPi9#XSX`%1vM^uDC~qhZ$wy&PX)3M_hR8N?@`fi5 z$hXbnZp>)tkB~_0ti9XL{B-yB@;Ci%;U@pCzIQyYg~WFxzs?_Apsh&S-!OcR;zgm% zoIji!y}SAj!}hRX##g3k!kPK~XOF@)?M=@-dV}Sd4FBh0z2RK^>#gqdYb|Wj=gF6y zY5KQq$jSmQ*i4F3+uHG7NYdKMH!`li5nRG4xLBQ9WUqSklKd-QU(1cjvm+>DF$>R# z&3H{Z-ikTa_FkDnwT!8NHe+r8u0fJiN#rtYvy7 zCAib3*g9{M-$IBX;5QR$|3 z=N&!x#5!MDL^xZ3-0k@7tL(1Igj6ayu~9)(vxnrC&#}j1%xnZF&l23k(4L81`U5u; z_h3>@XJXoS&wGpX`LQA|=E9DB>fb&=#WT|+!Lnm{AcauQY(*+_@#WU!_Uiik%AOSu ze3Hi9PU#D6H9Wg{WitMe#k&_!_buQRjOb z%=0`R9z-A3WLlk-+D*}Xv`7)3ofnrSXuC1-VjZhhQ~3;vsMcxWx7d8%c8Vok%M!q+Kw5}VoRvN!uu=fwNGfV@`xYmW2^{FaA61(s%h z-~?}go=EsGuKeX}2*qh*d-KjX_lR^;0tpGF6!+Svid{Nyp^c_;-R2N!7T2t!&M)}I zJ4^+u7>pZ=1P?8^2M4j1Z3QjkuP_$nRzeQ=`*Ju8V% z$~LVBE7wjh9QRc5Xw+%gkx!S=gX9UHXlEaqqaaz_#(cjd1|P&rO5`~|%Y9DEX*w@W?3Y?fT*)i&+xbEs<)|D7#$h8Eht(5k z1`JY@9ANuTTnB!h`Zq@-&(&}RRVWxqZ~8ZLu*@;qG}k{`;+?BOBZwvm@OpUPS>Lis ziwKV}@0f=)0ByOIKqNkQ*A_HMJ+?Z$rAZ~ zS^mz3Jvx&-*mzfBX!UFev3f&~*t(C=rE47_jlN&Z30vT~;n*D)O)A{^=*>$E3KPMk zvKMa@>K-4JsJ#`uXt42acdz@AD3eET2+&-dQ51{$u^L zGs`ULbU&|Pw}uZgZ_Q6P>=GBm@7cDeqpl?r=9$JzR!>-G;4xLM^B08+epbTiA)4!B zOb}!Zp^nhSpYF#ZnI<1m>pEr1mPNmOg)~KI@;PNXH{?n#t}LB8sjMyg+<=R?hmcfm z?ad3x(LmNqnpgTUIp1(h7|`KuX~hGsB=wEB+D0neDgD|WaU|L|? z%idEju4Wr!leU#tN=h%`{|rQxT$THm(xYz$fCu9Rfw$&=^>F9-@?(5Ax~Wm^QE!~cc^2PgIa&Nl4JOIU#eZ9n)#+qJN`V*&>sLRLyi_#}Ym zHq**-KJH@vD#EM5RQ0JhpR?wB&IK;u3TQDy6DAEM%%_bF1ztuxGT|pd3}SUqV4q7p zZ+kw!nAH=A-59r+I`JgPvl_$WII_8nZFlM&uCI6RanOW@`@N)(eWTO`g(247rD`hv zlZPwSp(ll-_4f`_^^bk8=I*#=A0|-G+%3&(W#bi2#j@ysdC>jJ*JMGfT0U=aY`dVj z`_4oPw=Szb-Dcc3ZY1DExl%NUdq9NOf|2&c|jD~>IW#KhzVE}GR>^I3FLIJsMezST*Kv zO?F2O>#4=NJG}lp;_Yi`pLG~(HZk6zC>wHiWy=MQJ10M^TvAi}S4Yf0LXkV|V)biD#xj+Kuvj{%=@Qm0!pNtdH+#2p$bCtYG2GaWr9Q zPwy{$_~Lo*siS@o-TqZ#{e{(HYe?kwJjvH_{%sv%n!-b#gWWgwPu>nO`&Y}(?sVlU zRgmIuZq9N+lMaKA8hqe7@;w<*mnWx(R9ZEgp8W1DvC+cR_ZKS(F6k#`N_kawXXmcY z!=ID$aQC0S>^QQ2Ad=2<_aS13oJ0r>L`j=OPD?U)^m1^r3r+|G zK?vH(PelVWJ&j(ib;(r|wh{&_3L+1_*3UbMMYIl<7~ALQp?t!dm$PhRz7hXA>YftZ zYX}yP8;ZH0ck`hZbb|wtVBE{oLO?Xy4o`euvFj=!=KbryGl6$0@fbOwL^p$ohzMyp zf;|3`Pv~{0D4th0nzFnK#r)0``NbjL;IFai3nt%LV#Z}FG{crs~f2Q#bgaJ*sTy4K_ zfcLk+`yufDpAS|2hJWBIhOWO&6!@AP82b{@EtrAq=%G7u$C&!Z*lmdg`tkzsUToQ7 zuIPiV0?h_I9yZOT7n9$@RaO-`U6&s08YTAY9Ed4aO1gdgVZV;42P1VfMPlj`x5=#@BXwt*+t- zoHX|1p1pD^GpJOsU|UNsL=t`LfaQBrxzh9gp@^3c@P>)b)|6UR-4K}YAqMn1k}v`a zJ_lCE!nUZAzW&azO73pUpPq=Fke3()b5q31xzpA9!!0TTkC?%nr6{5XrsY|tW{dV1&^945P;bDuy3`}g7oxnKONqNU*}tvt`1MfDSV7CFSovfVZFb_Uy;z1h0STA#r;!k0;Tx- zqz3B`E&pOJX_&|s;yh=UNSb`Oz^SL1VRG{hGaFjd z&S{3*s?PzTLv{oyHe^AicbA9Mzs*Ln*`lU2$^kS+dB9OGu_wDoaM*T4F$jLp8lI;AoHQWwza)kyvhv@tt-zcdx;25? zt|JRB=u0g76P|oa>yk;-gt3EU3w&q5!)0p$&v46|<+E}c$xekq8Wn6nf<$(PmS9>U zTqHB!MD{~88-r^9ZU}XY_+!zgT!?j08xe6{xm4s(w!6fyGa@0DDFj=_exp)Kv?8>i z7&vx6N_LvuQA3PoQeV*uF~ky(CX*n1a)m9V&bPzsmbmPx>h%Mk+0FK?#iderz$$IR z10`W?yMN34-_VrnrlhVm-bQo$dtim3{v&?*zY|0Jzo6-V9atkP^Zz1x|9M#dBZpX| zY8`XHg7BTK$EaPSxw?^f1nuuT+lPlQXV`{(*-~DPW4fNs)m)dQ>!I?)%`7*srcQzG zv=L>>^DxOw{|s=yfs?=ZnE|`2K!H35L5#Saj^IUHP+trXWf+8j4zW{g+NfJ2ZixW+ zYdcVx0rf{!EMZyH4Pw{g`KRdJPlR5HLq}DJh@`q{4ZQs0{2`>rE~-F%7vK}K!)*XG zaQ)Lgn%YQK3dO6TY61u3{r&~3<>mPSLimrxUlj?~eA>+EI?gIYV#9(wpDIb!4j5lq zn`H412w)Lx20|TPTnf0Bf$6$iX5NcBY1Om^03}Q!MCp=tQoB<@A)LN~20_sa_REJQ>i5qQe#P(4J!p)7@~;MlM^BcngAz2m+L-P? zbDTm{9NY{fOd(!|*F$Or9&)6X+_Xe{)qeO=!adtcDcJ@uY&`Z44Q2I~h-#{0mQKE) zP*R&o8#XpJdkxznY#1y39Qn4I_Pr?iEk3!C17(X;HP%aJnay@PIU;;{RrBppY7e4; z=(GX!uB_#yb^QbeANm*R4^I(H+9!x#GV(+GWDOmV0BNO`EQrl+a6REzg!<=!Y*YRh zebcRCWm<*+Y!^w=SZ>`$E`fDU$qju4Cxg!!1yMvm@lN#2 z`L|f=WZppS=4|_S1rKn0jT7J9B_UDl`9O4naf_Rg~?+9~6x{R6ekZ0!u8+UV>}xpBbnY9)r&?)J<^o z6mxDlaej$!k$ukK86L)VU9*w#*BSov-d)c89X*`CYjlw*&BcT6)fr+n-~x=8yh!}} z_)|HJ@?z^QEmVl^K8@&^aom_@@59&?w_b!A{!3aDJc*T^af>HkUK2`oB~^r_X6|=d zpGHSpHT54p>U?UA+in99?w_u-1bsIbg~sppM90C07b({y6Q3aFxl^yIUOqunQql|r zYu+R38J6FBL?{V%i&G|38|W1ura3@K8T+`0-fRD#s9I_C%pEh$4e$k>k%nIL*2fs4 z^evf&RyN23{eJ_Ar~Z&Sp_Cj2*l&vnB@zID(Em3e`7dPoe_%5~s^^_4z1raK?07IM+qk9@{M< zKuXpp%La3QnNzq1usT>cM2r|77A(}E%j6jZdbOhu3E-Uzr5?f|7xZ|zQvz~!orP?+ z;jPLm7eS=rEmt}{z*kO3Q90tn!M9UL z=TLD-%@UM07zIxD^F6MO#vdlMISlmx_)%h((C31_%~x{PWtDu&E)P+A;7D`M7R|G? zFbZ-R@L+76oxyfQ5#BfH1F6P}T!6QEu9i=K7@V#;giKYUT?{@>u;C8&;tJ{l zRBcTr;JMH2CufUmTc06rzaN&E0CPb_{l@$97ySO@3)G%I5QwPPqCCbvNw)3NFa*aH z<;~H=>`gCZA6(e=L-R)T$_Sa$IZwp>$ygFNmPB?%HM51()8=Gxkk#;bkrI6y5 z_UIKBRD}jCA%gb{&y7e>%k42 zlS=+SHiT;oSeI)t!?wBv*?~XOmLux5Xhe9Z=$g9ZnuMQ6%;%$iD*M1Wa50($`TbZs zQ&QGu8(wp664S{&9xn>W8S%`YVXfJ{Kod{A>4_3cM+Q`pk0F6;pM+eWyXg%&R&-5w z;3ycXRIq)=2WGkWC46zl)I^R}QU*z1N1)K#)%KT<3iVNu=g8pdsI)n(q(6Dm_p4gC z)69pPP#s&>8-FK@7lysl$?>_EMEIh@z;yniG(HxhhNRdL|9N|)ykk=mwSMOwf5m*~ z)$U_=L{>;+aKN7*ClBkiO!murxU}J+M+2F3`xgyq~5prOW4`j zOV~+hD5Zr;lr<$q%W5u*CYi8`>_w&RNW~Me(<#4TckTe=Cdz0O_eiE>y9@CnDu!m} zDwQ?b$~x?5CYkr(hbpTKC_gY;a2}VVb3j z%#=1VKJNq4kPe$=Ng!cvl5eQoFK~=cszm)ZJe8U1E^bkKy)`jXwZftju_r}~kEF4$ z(EhiaeWs?j_o2%V^L2QngjHR{&}6RLnae)khhm?{f}e>BI*59yjMaZXu%0tB_^@Eg z2ZE7(1$~w>2)|#@Rw{d%WAJLTYVssi5`(Xz2anS8=P|`okBT@&k^4j5^Lt%$ZsG3w z?fP+}G#R3NuntYy9FX!ry;=nA()QyO@uCq)4AOb~ZO7-^`+3C%9d-XWfh8Y0Fjg)| zV`1&h(gK4&an`QxAeESMv>V)6>2P@NN?in>j2t^3pCkMUYWYbL_Zk$5ZK9?~GFB{v zl2Dk=ywk@*z+%7Z!B!9Ogs!W6(rD>D>dxmKawq5cpo>tRgCuH@hJGvbxafJQO3Hn@ zp99UrfO0A!UU;@-%=F>Qb<&Ho2RC#(U_>d7l0buv8rV3Wf@EC5>(7Bq9vj%(`ALw} zmucY4c0#P>pDwB{+)*w>%yiZQT~IN^cj3Eg=q+ye*{uV;BH2hP^%JzWsY0~&It;gj zekWUPt>bSre`z~K&5&SVj+-qV_7(LYz$Aj7#R>0@wWh$hYL-0zW|0lT{R6A>dm++i zfVl4Yhs=)|q^w^5Vp`^qe-_5MG2i~he#JzSGMoc{N!T~{vW=m#lre~x9Z6T7%~NWV zqIp&*g*N9~Crmq=q!h7o`s_Mm1!vF3jC0h*5%ICO1sG~j#z?2kXAL_GY>3n4HMF39 ze)Rd)LaGPqC-99R*$s$UgiPcWpiR>jp%3p>Gavzd>XFqmaQQQfeu!9RBN!)GL;(Q< zC{5^g6MEf5ETZd(R2*1*;Bv^k!DUlQ;4^{|PK>FkPk(3B z6Z)uy=1zF5g|wjA&;*T(DTA2;$;CJn+Ij8=V2g>O6_=y^XMX}Dw%N4G)>T($DpeU@ zV40$EfeOQrKE;gkzFaFRR8_L>E&~c_ho?=GczCxU>D^0iY;RS=`1={08oM9UAuC+) z-G7uH9&jJQ>~PjCQ=4u?(YwIOGWrgV<#8WS^Bq&ZoiV<#{yqD}vt{Yt*g_(XCZ?}; zzX=PT%40!bd``oNZ*MP8t8pc2Hsqs~|^w@`HQYaoiU4(n5F%^fk=lzSy|(8JK|E+)AY2s5m|ZK?^Efy*p0HGVNC- zsFhm(NpUDjnvv_#X}&VZ+STC6Qf&%fslhSVuVsnQs26F;T%JaoE`*v0={Pm8sHd53_CQP}cleh#yV`aY7E+3(fX{A!Sio|GQ;fj|{U) zfe6dO#l_}1amR9xKwJrd(JbmryS%(Y(3ipc9#j`=6nNK=mNyywI|2rO&?gu;KGIf6dKv0n?$9v!?;en{Y9-dxt3X6sews zhK&c#wSkBm)0*ZbRXne;5XkrER)I*v_J5UkgM3F2t%onMP9#2E9W!hh)uOdyhv7PR zKM=0^3)eozOWSK|9g>?AIP=vrRZ#<8vNzJPsnjH)Q*YL2Xlmw9qllV1Quko4IG+{e zWOlrOPs<&}&afPlEYUwa9uMdHpO;4!5nSg&AYKL=UhC3=an)Z8x+{bz6{snL<_LmSWVw$r($ec}b50XDGX9{X0js7$o-MwT1 z%hMIcA$oclD%9hjzoX|JX=4{i!%g9$zP-j*Kz2n$UkjAscWT zh^`rnq-3$`{vSpHY#f}L`?eoH`)|!E^4Dx<_ubG3*%Fh4DxUxuxHIvlN zlH7kTIwBSx67D)&%3+YXM_^dzUg@<(sCxQBcsdwCmr2LGb&d15!iWnh+YdruD;yaI z7QVi^BO{-o6V5@4^?g1J^@=m>ce>?0!Ua5GpWP64#b9jotS`%eom$s0%i1Vq5`#R- zYmOW3HI1R+{nw!qCjEDBG{X8Sp4xNdI*_$X3FB-9{>?1nrefp@Ur2*$Ad$ulK_y7- zEEpFWfrQ-%#2_6gYooPmUnB&h$CSEFoAKe`<* zBUAZ}M`g*zQ+s6%#W9H*sAQJUuOfMX=Xxa;y{en{SN6BjCDJ8H5+}*3aK=>i&bcb2 z2DOJtLo`vv|MgKcyDX%#BvLUM-y}oz)dr~7&%t(LoHZ3F_jo`16zbysVo)`;SsEHUYvba7cYMDyl&{D*=R;-y5GALbyitMS zWNyvCFdPy_^>>K{#uX>GYr`2eIj{^k_!|)<88ndW#>_~yB1#$JRa?L33md@^Qd}mA zHndP=005s#un>}*tsYR#h(%SyOoaB2Y7jVL=g`NTBls7#G` z3DmgRGMHdIQOHWr z0@gzfEX1S(ruIl1SK-jhucI;nh`isg+Via0~IQza;}ygoyqFt}&0 z6)Pb=Pd2YX&!0l{b||yue8>1#u<%y8Ar!Ow{Su;&DjgoH5jTClxC^{cJkm)WeKUyY zWPP&zob{!3RGkI$3{Av%+W4o+S&%4Xf>&jL1CQr7he^x&`YlWxV8|DCn^%HM zb!}~Z(REXSf|Jc;F&bkx)LCIdY~z|m*u>G;wF{3JM3{VENx#wCmFvLuR*P^;BWT8* zW5cyaj=>D18#ay^Vo{-?h?}U7S%mCUkfvJ?pXiCW7A2=Eh)wgRh7uE;&w*S4xgZNtcj13W&wr2Pw1fEv27Kf?e+G@@!+;yD>#KwGb(wonH^; z3i-zp74JHKM^gyHwaX&~b_PTcHZE--*B2Qx+!Z*}&q* z#)~fTwq@aKZL(0h3`xN*EqTJ_keA&3bxHA(t~W^CF+sa&@=bjZnyURAq+3MLa`jOG z@ha4B>8#=8Iqyz6drx6hehMwcYQFSeF94f$bzNqM?cXrLH!j9__WWSG4(NBkSuWHW zr6R@L-#%jvmb;{KGA{XyyL_}e%-oF6nJ!6e zL#RsL7V4`_Nu6^!akKedkrWDQv}x#vP!0n_a?%ITdD_pL)JtDz#&jWH7D_Ko8|kOt z05&+8B@P0#gib4~FN&5BvRz{q9b$!se;U*CgZrhEtiQhAQVe~oOMgwxqRz%l+fE6A z{R^jDiE`fv8V+7xYE27Ub#u>lMF&+8>r{nD(~int9NLObVlS+E4RgWGuJi4QlBoeW zYfFbH!_8jS0Dw9}mV23#=r0I`KL{f9q6u^nFj4_IGnpWwc73l$Vf*BppZH?dn|FJ zRuRp}{P5p2JUe<#8_FRJ&|q2iQU(3 zxJhkTERM#;o*!KPo?P{8A$7WJcB8K>{M`8y>1vF{J0#4b7d0`MU#6 zQi-U5Y+4wx(szpQITB)I|tx{?ezV5LB+A%5xrdbJQgpz_17!aoPmx? zBs{z(u@WF>cQ?1(>wQQlrsfp{tQU^KStXOEBCNik;A4cme;$=#9USq}3@odKw4Bd> z)Hd5d-5)llvGcC3DT1XwG>an7DCWIV#FK(>W!lvf3?Sp0GnWW0&90r!EL)RY!b8O_ z%T6o3wrHmTqZ^)qIzJ{Qw!NKETxmR?UpJ2{l3i))6m&L>#W+u_pgfnwfPAqB!td{CTBBhkEY>?FT|k8>#VdX7e4DDG0|j0 z+KVo16J1Axo{UtYwo>keEn09@McwzzaL%9{;G)i34Au;i1H!Z);vm$mML%7E6)^U; zlj2hfZ>X1e_mK$DomNlshoK-IKnW`VArS)^#fVH9UCm1rudfKGpG6FTHMfUrOCc?@ z0L6-@<&Gg- zIGMSyEYv@^wrylzKYf0=-jjdle>zZuQTiQtq&1+NIV1h8F)VOwKuH!%Ie(S8_T%IW z@=gx`{sxY?5O;yLX8UVMtTi9`rDvJtwUbW=9E`K2zS`@k?+9ih3-Ss zxbFNDfNLa8W6Q~l>!bX-av@x7SPy|Ed&PN%}&Wax%O%U0C|!I zW%l#=V^I_rNupt*mzcQS6sLIvs-5QC~a*Xa&ZCNrIiABpr^1e zA+x2%mj6ttgz;hGBn%(iqIKU|V^N-XQlDL0?_CN*mg(Qp{gIOwIM|b3b6pqQ;cOlm zsr;rAZ5iv+f`Q;<44_8~P(^BxG-m8fC*OJ`rI?d{hyF}wf)5<7H9i5wykbi>y7Mm1%XR;( zZv}o@V6T;CZEvF9|TEr9Hxpyf4Du3~o zPpwyZZkT$xm6vQqmSn`dtt0w4g>LEQ1H%5Bdg~?waXy^S?Q-6&2v0VcQN8xg9uqN) z#QLshTRr+Z-uws5U!YR+?yqBdg8J6Wfu%4v9J%Usid-aeVqA1AQS#yLwTG9jC#mz& z{$TUSP??izn1m))uv>uT(!Y{n%_rPfRt4cCu_kVHQQld+?)fW+K{tsy5v!$De^XNo zwbf)w6pYG+j6=Oh#(fz%rn1a z@$1Z@6R9g$DWYBfTvr8DuiKggc) zDN*U=Z#*7hCRXf~l;-L%3dn+Uz4>F)-&&XiK_M0P#FNg6$ubP>i-oZ|F3Dd-vu!)_W!XZ#{PHM@4q>^k+t!E za`dGxOJQuzd5X_1{=F}fmaDp~JJ5s+4m%(~radblD}sbAT0a;hXL9fPUk?I72myREtFy^SoF8xf_zlj+{)X)-yC z@HBpnY}rqV$S(mLSn~Z|NHTe$PsHpNa5hg&IdQ{gUwUSrJrH>prnQB2@=adC)sdrh*K1hf zl@}2;?H&q3prRCZCwFdOl$ku1@7H<`S^}`C;@WZS`d2jMwHWcEn8 z$`c{9YsI^hqv+GHD2qJm>8xJNw*k0WaDxcD-9J%u5pJjMriQ|++Y*6#$KHn!9=m#6 zw2YargpCiN_=Kn@*&aj65P-inD%fe2A8wPD#CRAiE;l$!sS7Nl-6f(B-aGOs4I8fg zhI}hwey=n6D_7>O`mN}H1Pyqko(Gxxp)AQZ#;M&;Hvx2(uVQBLs(Ydp; z?e$=DXYw+z7w6j2(L(&Z6I#&H5wdT4F>u|7D8Jo?#l?I)REHfHhw=8%H;5>56Gx;8 zogT+CX>999He1sB#^hpv0*Vk12G~oZZF5L3gw-4beE@NDBAlCPOz*KTChfTq+&>!s z+&d(`Iy_x;(AO$c5FAQYk z%hoH`!}lpo25@`*@LCgfn1Km`VTu?OE(9756C9A=9z+|#Jeh0hyrjIdrn zD7VS{-lN{+XOK`<7*C9+JpPa(vcj=9eA8amXj`P!1V|+9<=~Z+XXEIFO>(M)-7HRF zbl*Lk`Vd4It`?+ea6kSSc`An92a5EdEoW?#-CH2EV11ZcEdsuEy<-Y-FM2C}ZJ+w? z?@MzJ3q20m4NI==BJ5W@sMO;k+}2V2DO)^kpa)hJ{`Hw$!FVb6t>L0Hh2+SbSmCDxcYuD(ZHcnUNE71E--s~w9PIk+T)w; zM>%NFcXtb1kFJG9Ml2=L_uduVMJ=Toj4fKBmQV|oIEG=YDv6Bk}3MtoGJe z_+*Ax=wr|&cC!PB_Ly0Hr~5Bx?E+ubsbgs%T#h|YBq#R;(rWA3!8+3;z8ipvLHcD6 zVeiiFb94WG-yt}nsUiJ0V#j>Y$SCN6#a+@IN90R_Z>;q^Vo?Yv7z{CeRyqi%2>43z zNXW~S^YdAFpjk6lO0pwkUy<-#%moO+#o~XV<)*lYSQhE4AZ5Y^>9jPxg7LX4l-(Xm zjWW|_J;2Aep`6PCxN?j@cHzfnDo0VZW|RHdMVu3gto*>O3Hd7GPt%oUwQ(TVsCg!l z;R?M1Ef_xZ^SNZ$XQ(0PfAjS|{U|x@hg->@G-UP)$Z*HpV+R|;97vteTz5SZNS~N( zf92-Tz$&zg$)zQw*JKlz*Ur4S7-|TGrt+y2m5F!%ql%K(gU3b-7}?DOCD8;vhJb6O zm2<%>ZKxyE5&SJBgs^fjg60$YKx~z{bYQT)GBBA?MLSDmnC^ir;<8i1WjN<}2Ip`M zmJo_GCTlgSu;B>bS_i0u^nT7T$x_BSSm7orJ^&_Gb?BfU?gPg1rxXSZ3GdV^nNJ?5 z>S74r>nyYfME^FNx7x{F$8ou=j$v{CpZSLQ-3!B$-<}z?x*C0F_ZI&(MAhWIi*pZN z#!tl{Ms&2Y(!naoMX69IV0CTnS3D&`)9xR#lMYVysWmv-n*)?^QX)tumbk)ikO<&$ z>Ro@i_+5s-v}V2MPnFSsdp|%b@&9PKW{giU=yowo+a<_WO#pC#AEh+gI;p~ZY6z3&Vhy|iSmjCKh8 z7#@rArU1L_#C~~Ti+E<1dq6Ao88SnzH3fu=%us#GCd$SBy?GWam(;O5fm%gMs^Hi*j2WEFY#GJzph`iTYAHJ`3y&5A6DEC%9x*1vFN0 zY*b#~-vt|k-5^?Vf`D6A&yjJ|zTvUL%IPQb0|Duvj>DJ=F1b6s45gF8K7zJFHyMWp z4#XJhR{zB0Fp`xw*$LRImm(Y<*$^qlNIHz_9#06g^1wVHC2~RG7)ScWex^0Bhl&=t z;v}yMjVdL&@Z=vSei?9Br?O)<&AS1z(74-ylL}!-8)gChszROC=AewpbZ_M&Cp$ z!X~-_Vo^yvW@FP^iTi^Fg=04Pybg?7!wv%uJzQ%c$XE403GSfrdtoG034gNRdV%Bq z^3|rA8O0-U2*@tmpjW@x;))a4l1-B`L>-FbuPE?_b5J}2ps=Pk_5I59z3j}`snM>a zXepKaz&&|INHTF#qp>UfiM*Tk2r8_ZpDZ}KPscghI8Una3~~X->Y= z2|?Wc8j+jEi2i8$9O7utO;ba~NL&=C_lC}PVn(uAHUJZoHCP9|c3^v@fa`wvx|Ecc zz7zl|5U5KuU`8+Fn5=+7r#vJ$07cLvX=81H%Gs;H>Xd%!*O)~094_PxQKMCX4T|jv z^7gY9XR`J{p&&dSb2#1Z+O7sxfu%S&)EdIL15JE$35^B^MY%Wk)`Tkwyjae_FnKgT z8%1-)Q*h_#^~TK;b^~Tu=)fMbA0-Z7emwB0qsZ+|`LbJ93cjO&J|mx7mIID6R%4o3uIKRrT>&|vYa*Y-@q@D3QAorQ z(#9m}QUFV<=!<*LB8BMt_Ns|r7n#?bBP^O|Pg~>#P+e^nL|v~&@MeMox=R?YDuE~e z_2nu0;#YXxz@n8=o#z6@6=LF(HML zB$7v*eH+8wTv5JKxmGWvQbgZeU32fCuLlqz{isx2CD1cKr+}PzSJ;({F+S}RuR;%M zV|CCx1&%#i#N3Jwp-KW*>8d!42PF3s4ED?d8neye(@3JZ4JWOKKhQOADRYWDjY~|MDoTv4{6(U&ju#ZJ4j2u(xC)w8Q*5UQkA|0y0B`s~GC=lA-b~Qf z?2iD(uG~CKE3F8#3()i1Cf~trL|F`d001!r(CoDq_Te+!3Z2?u(iffl)vBV1!}N zHUkcqc6Tk0I`u{|-wJMMb0utbYd&ke_GzMf)9YGR?wqc0_nF_(*-93VPZ+*3LK7T_ zQX;I$k_Kj&4vP)ozxGBqLX-)>YuI`2$Zy`4a)PNCeZk#OCP@yD?r!~faD5gaA3pUY zhH{W$!Xt#j#U3?L@8Xs{Jnr`s^j8i(b2x8us~||Me?7&Jh5hwU(}Pn=AS34-t7m@; zZQCfXEI=MwA8rjKzrQ*HM+tZfFJ!L!cS~99tVLYDki?IX0`O)@F{x(ErZY?Y0*9{q zZ^=<}qx-X+jfppWXM<$CD zycVO{kL*-B9gM#QLOP?c^9`(Tw_H}%f{l3iJO0*xZ3)F=+_K(|(Pqkkt$*cv229o= zOQ_qtD++Iv?fDOWM6oRZ6Naf-Eo$~Bck^J8*oOx$i-Lt@F1k{BP=W8Cy@-;2DO?fM zkYluN++ioqIz`beZ8(ZW-bPT1EyZ{k8`Ktu>vSB5sq+Pw+P_71?J33NDJ$nc8;oCV z6*%=2Iy)7d073eL1p|oQ#8=KmLxw;J>%=vO#*!a$trDY4R)^BnVs}tim=Y5zfWs=F z4v+={uujHhhmM#!7|rM>biV0(Y?RaELFr1Zv_+Z4@gC`c&~jZ6?!4&*z$44T6OUzi z(Y@<^X2v`t>KK^sAw0_D2IbC%c3%NOl(mA@b-@4jz|kp^#ug66aOBLG#87)wib7WK z4ore0Qx@NuxsxuHb1jj*{tC}4NIVL!04MW~;v7qiLP^*iW6wD1B3m}>!fWX0zqCg| zr%P0uvF7tYGlZ87j>!fHdb^wwAQ+dTpeZ6H`jW>qOo_-$+79k?+QfJvGe z1{T(d1p+*6b~~nSPx6IcS^W0?QK01s_MV|eL?+e?_^v&hk>DoQ;jxL_WRvT}`!UDy zz;!W@Rr05`+P6r%g-d1zhQEj6*+fb1O$o{b;>m}b(8jk!bl}$8RiOwD7<*F!@7>f9 z)SHx^RH0cgo>7DaS*NaYx`>m>C3u~@aKX~V@6MV`oWmv)XM#ARwh&8ZM*R^dB zXXvl;E<^9%^*%-K1yynn-}$9)FQqdrr5yn6#2j+_LV*I@Q`z=y4iHeJiaY3w-k(XThkvo^DlHSMzk7HyfNosFn>tFA;_W%dvq$g7K#na8 zwTi#$Dz|D60la{b!TXg~h7mSrfED70hkvIx&wj-;y2uDa?OUR;r}-A@5-ha?Ow*`S zqOeVSrrzKP!TI}y+n2*DLXa?8V~#@j(uT8mwweS^k01S#N=O?%Tn<2+3%^ixj>3)H zYho9&nYixS+XXQoN&4-^Jg+gIR3Tuj zgKZwc{&D#;LXo=GqeIG6?6m}P3dS2sRMCr=QQCZz0y>1U=BLPoK1eC~9qG^29)hN@K%6{tF*$+=js>R<<|kH8onkvQx8 z>joix{Ra2*)AUuucDDexYY4=NyponkXDmf!Xd1cifx*Rvn$Y&8lJ;laj0+ck@c6G| z3BjoTEPz5&!({l5W}=js9I{`L&6R|GS@3&5P7F-H7sP)~T=|Cj=jFo<_YI?@vDs6C zERf0CmiH$p1Q^LihK=Mkso_A%)Wu`7LS?PZ<|P?E2?Qz<`~* z8c}~$1J7^|D~V85ixJf;8bb^@GGZBOR8oiEYcbLdMFRi*z{w#*A$gr=9G^QyjL=O3#1kucHU@$iOqhBi@)tbh}=)o}YZbt44D`BVi+3KICaGpdeV^20PyNzf7 z3p200#3)z+G>7cx3IZPbI-QF*CVif~3|+fN;+EzL3=;s>NZxs4{hVoYNhF9co+Her>|_d+k# zcUi5SQpPD=hQ^VgNZpYwU&-~>7wbjaxibq`p&-q!xHV@?w1PeK>02+&#$thiu{E8G zq=iOMU>uukMWMzS)`Y$&a#$M|jWokuRDxk6%J`NcitNN09NHz9qO{d5zJdxrbdCsW zNZM{Sdepj+-o=4uhVXqZ0>1vSS&@4as%EVoQNVXY!Rb}j+MMgZ*eeKQ7%N(HFVO$) zzbH(OJfywPkE&5@c!X9);_Y08mn_WGW^lfw7lV}*BErPZ^V<3nb3EOVwZj(U+>AQ( zx=UylV5df+hW>Xaf|mdf9n6CH!cq6y%aeThP7hCkLXS3{9lQNXCVWY^rd<`aiRYDS zT)D>)iGG1Obw=zyG1N|G`8{}h;ZTMLg}=_7cpdju3d$bq4u~23JOH1)MdXjw-1q+X zE`P2}=5nPl7e*^*LN(@2gPa{^6P3AhA0V+jvpkl;8OWNpWV%QaihZ(c8wP zbs0+tf`!3W2Oqu76?8k%DFQ4^zlm+|!#OgxT$OB5%N8IIKN9}C!+XLi7rX^L{?b_` z(ts>q<6J)N7)wpuD zL^lF0<69&ot=t8%{i%*Ay$^8w=N4x;c)P-0N6;(ul#`{b-rfY}e-N-z{X%hQ$%BjBsmjj!~Xr8evNCP3Ari3qj=$Dql zm8^r<*rFR(UK~QeAcrUtQd{sV0}x`)Z|f|pe#~GINK=Sv;E?lnz(zP|N-x)tLGw`1 z&%gY7Nm{@2Y>fq~W91qpnJ-eaw|OV;@p>pGGh<=@&h7$ZOLRoo#l7v{7OT)tCb!?_ zZ}uGIFaFXu-W#G@DAT|~C}qHq>#+)Jl5-0po+{84L`j;v0&=4;A$vZDV?crO(x5Ua z@*{A?qi+tovR`m2-4V0dmF{3v9zc}ed{q{;sf2N9*!R}G9K;1e;L~y(N3PsZ)k5+L zIh3tDEJDi`bZIT0!8({9d8GT2=W~@eYUfm!bu2rJ`i(7B*T&aKbg3$pI~c;G6ev~) z`e5+WSsB6)W;e=A!PP!BJk0!K^ADV5ZSyv)V_~e3{@K;cM$GR_T{N2fA*0q0q z0D#{@=V^Gqun!mj%d3z*&ikPfhj0*i5e_dxytu=JsjTiv#UncBg@VQlTrojf$;jZb z-=%zH7cYLCs``KQ5abZKE_)olnW`-wpH^~gFsnWKNVG$cE(^F7x>oGNz%Pb`G!>1@ zH3eYTrQ#lB=T9#5)2j!vU2mc-j&B)8bGV;s{3SoOdo}q*hKYC@iM$Ipqeu8SrAa{_ zhJSQj_Zu;PICy%{ws}v;q!HhW*4}heZ_I?xMyjihVTi&UW7fQL814OYQCI0|7mj?R zdT^n*zA%FuP?DJfVTu|8`?HnS$P)liN`l@RWi{W9&nu8+XKG7$6u}4}QLg?*4CmTcN z$7!ryECWsuhFp}2X`AKicjp9mIia13g}H8#$@wD#urrfF&9&VCrqq*!*Oy**KNOBq zd-%2aRRe_hTC|5ya34fMY=Y%wuH{klW`5Rrk*-!igLzV8M&x2&v+w&BsI&I=$r&?3 zPKf8ItZ+PeJUgQFf{Eww()#FkngIp4wc4^yJ0Fjc>!N>#u?5{9guKtbm)w-&YId%> zIjI(*Eq=yNVU|VERejK$-I<`kX%u-Tr-#i}_X-2dBDpXqXy7+S5Nqi~2Zyjz8_Oc+ z2(`z`Ne z|KTLfr*O)=!j9OlcItfzSSvYrX0Lm9UkXA}Kh(OeRXvw4<=>HQ$jyDKRHD&Gs1Q;w zsu8I%`Z)b)TC#9UQf5-fQ=(jp^D#I3KhHC0{~xTKLzgaH)MZmQZR1JXwr$(CZQHhO z=bN@|+jiznqwY7VYSbU75uG!l5v|jSz2{o}8i zrbd49U@i@9EgB1SMgE@itZPQFtVE=KxR_AxBVgB&Lw;5xP2<9!-dT}E_ARW=o6bgHN$icdVW z5X%X6Ozo;c6>LS%2ccBoW@guK4480FzI>;8FL@ocx1Q&J5_J~;&#k`}E)7#SOp)F_ z@Sk7k7o>+_!T~P>1XJt@bW^GtQm9Qu#}};8!@r1NO2o~>5vGeIO>hKO{B!H`(x95> zD{5e$+4bJd!X!T+-{S==A5qdHSHQdl1ucfaG`JE{D;eQvA5S5~+n(?&ZmF48Pm_}_ z_afFQ(pl%8LZoF6jzVuzG%R_3nj*fD(aCDwh{O)RbM4hE+2{1l@TSHr@e{Ug)#-V< z$9sc;sb}qn57YvzEOYo<5aq<*?3$^lgfia$Z9ufh+5b$=2OqSobjp`Qp-h5lBVI)V zP3V_02S8%uQ>ZEB>KdicqY+SfWB3dUk60ALs3CTe$5LjiL9YsIAJi zpy*-qbOBOBM1I&*!#`L)F&^i|12aQjaAFA9gJ3XZwyXoATx#g!D)!(JR*EH{r2|vx zPYCq(75qg?Y+K2&2&g!?NQ(vk4uIbVKjU1)^CPc>3j)C-dLf<>6sy6uvE}6^en# z(TU0)6N2KTta$&hrov&fZdzx&CF^D&nfx8J00E_{VOXRddcvM7Y=MJ|*AW7EReen? zWb#h{r^JpRA=gV?; zlIKHJRI5$W+wvzDJ)7DaU4Fbh=MG2YkPJ7N$T*|Pa&ZBrch%&up&DAa6WhjPR2=p@ zT8&UtD&+&-G$dYr0}4rG*WOKGK2I=wa8n$xdV5~*K|-@#PvO9IsOJcVOaIa#p5~ zeCd9Ak8bzmA79-BY}QVS1X|fK(ZQx;nI9?T?e-&paA5-1{NmIn>Y+0_0k$_s)(%8z zo(_5p#v8q7@#+cpN!%>zc}8kuI9tQy&~h^{kGF{=K+`55lYhX6HQmDluNO@zim&f( z@B_?W!?9?1@)?CSmsPpZaM$6>kq~_lwSR9HHSb)Kf`F6jt7_C89gMfQg7ssundXSS zOnGGcP%M@3Bi5_D-1UfOT1174?rhE81zWT}gAaI!6>X-#p;$Ra9rki1q4U{XOZ^D; z=q%%Tr^W`Y$+G}0W>X6DKN;5Ii;qdGzgtz`E!ao-cGcfD3Ait=ODb`ZF)mIEYurA-c+t_NsN3j;qr>{ zjG6&F)`W$Lrlbo6PfK|+c0z4V^Jzf3lo1o)EJ4Sn@d$RoMPVJxCMvjop?9hJmlMU|2>E=4#xsd~u;wW2R!!?x zk9DHSj~)lL0|zkpXEb)^f&BTQwak0`*&HET znp=4ywU!)@L+F9Fg)4hM{PNuPT=M$*Tzy|S>J6FknL*$NlC)QxJUL3@xg5N|5%Ruf zsLRKZb8_*h(moOEgCsdd@HpGMrC&H1tI}~W_D8u|PKT=_mVx!=gM*iRnBY=y{W&YP zHAe`g(#I+CRY+EPeplT`UjKg0_V59baLHDAx0a>EQmKEH2=nf{GYzr5!$jS*k(pgq ziGz8sUGUl-I+;t2CjfK?Y!V$I;KO2Y%&3uF^^Huk0pN=JBcP#HGyf8y0=!C=ETdKr z_+J4hEV+`E=G$wa2(hXWZ$Jz;nGpM)IS3XR__g1UU@|S@b0X%p-$92-_eEhEk?Wx*>MSj!? zlzmd8xCwf0NFXonv@hrqGD$q**YWrKY zok3O^(f=LydKD@#Y}Y*W;DBR1n=)l-jz!ouxa4IHFDU{&q9%8d(o^omk|(ZLLnVSlr#%+&1I3DNpqh;)H(;|4$p-k*Yd0e#@vycA90P zqF5I_F2gfqU*aSLQD>M)J}2T6KB83KY=|4h4Dz3=7{Mf)4^ZE^nsyi(^tZsDy9yI) z=69j7FIZchtTUG$Ak#FZLc(Dlrb3t<(&3E@0bF-t0df+T7;Tkj(Sdth=0*h~ztmMd zJ8sHS1_a1zVn}f^)+9fxvC?66TbFKpV!q3dPJ-ht4JUKasPgw|ABQkMl;9Z@Sk-}y zxZ7a2`lhB~{nPHmHsZrOy7vlB-2G06vSy1)r3?e)EXp0uOHo=LX@yvh%A(|xFWTNZ zO0Wyaih`%Nbs_RKYYlC9a;v34V!31E&iD)(_-+JB!XynN>Da8g`bo4=`xkx#vQVj$ z|7aprI7VA2va7 zYg$cA19T@8F0MirM%5*XW4VVFd&j=4^XevhQ~6()Z3=13GdVXV(5AXu-G0I;ABH3g zML6^Hx#u%w0$q6>FE&kFo&ES+#o={*B|-G}#v%iG+li$-;~P7kN4ROC7-0xg8HX*- z$3c72Ge+YFSVlN;mC3e{zE@T_2(?&w4LX?7aKYY-%v~SQlC#EEP}Ne+Na@Dq9sJ@S z3fz)^X5fDW>zM$mEpMy}9j*)lDFJj86x>r@&?P2|M13lC$jqrxLitM*49;a_zF9lm zW%lHMsLbSNnS8lVbCARsMbdSUBqgR7ijt9-J)`$0pH=g-|8DABd-EVGI+P&+Pem#Ofugkld#RDz=iv!Eivw-z+*K=;)?uLn=c z2g zWAJZbFjxKvt<zX+P04j6?)`@2Th0&+QOHmIGQqS$HkKyCim7FR6?C=L62yC8#YzsE_y(9i}S zK?`m~(cg_|>_|2nO8rAjH!LC(O5Q(>s1J4@0n{v}6BXKyEd3z<6EOTg-}Hu!p!@7& zCs-uw{SENx6Zi)1T&z|1^C3?*(2zNW8|fW_Va#8calMj{g*iEv?XJLFxQQ3@bBilZ z;y?ZqhN|39H1OtKszRmdo_6VXH^VnCh454T6;Rd-y3DTfJxQgn`ehC6FRDqS)#!BU zt8?madsyEMeEyTP0rz^UOzsfgfdZc*6R-bTlV6fr(|Wwhb%lV>>-YG)L7%p(+D3)j zn$CG)p@RcGJQ?>$Gj=!P+mhY#(IeIMZio9Cj-5(nRzn?k7lpc|KxpTZFQk`{xBV=k z*H#d`q!cfG2>xTuXQ328^+lV~%i7@?S+|FIIRwUJ%Ehl+Qpv&>iGw`Ol;>v~YxzgQT(3?UQc$U(`sUL_LR3{Xly40q>muc~_ok1>NX% z3v)UXbDZ5&B2-l&`HzVw+XH8)k@VlC1qw$$9Yq|Pe+jdV+6kFjHZx`S#>p!mM{5=R zDgnwv2kJCC($Lul)3%Q+$WSnLd~^Asz>2!=^NuPMU_})i^fE_9nZ(P;&NFgvW7lku zoB#{|@#A-JTnlv%SQK|7`UQ*|uc3*Yy0`-8kn6o;Q0*36>bnlezoyvhzx2-APjHT( ziEhOgei$w!Z7fR?*T)sr+ST{qw61>wdSTP&dcih%XFX33x$`*nt3EH*=Y8wwpKPF<^^Sm|0`8$#3q=}rwrRPIAl2K2->AOcnd@L0o zbMo~1D0c4KF2xF;jp?GxyYJ8mX+>eUrulIYr3X@u1VZa5+`HbUd`8yZs?^gX z)vd3?)9Y7h@Ul+7f2mW9-bIiO&7EP1*OGIL=&|;CabHNg$T}4>Hilrj6=ZZ5t2xpy z599f6?0nSbx^$5tZtq3X5k0m}$2*YoDKQ08j;v--8r_sACL+9H2M7!2(x*ZX0Q9kg z*5c!TjCI(<3&sMf;@g}^5zz-C7itr6Hx8LW5KkV?OBhOW9`9L|#V#k5y~EB2Yxv>g zcpa~EBb;<%1iSR|FKZU+k9n8VQhg){Pwo@MSYrgXph8^l?Vc*8OacxWo*tBJ5i>yn z`d&13ma?t)sKI}p8xjzsA<}&6+&sP$9=-We%0^@Z@5&Cn&zMD_nrJ+f`w=l=Co?^~ zbYQ&<#_Cl8L;n@QXA+)3brYX}o|bcA`xQ^2PbKlOgM*VLP||v;-R92D3xnCKsp2ZA z#PPa!rAVO!QLieHqIBp@l25$u%Uxk;Nxay(3YMbK^vdPCwGhwOJsk z&rpHeZg#c^G|+vm%{I}!R^rs$5N<{0|0bD~)GI!_xZMv2$wiU3HNx zHciopVHgnSa5s~6DulCi*DOm(c-q$R`8y_Rg`O4Bj$4ar9Gbiqvr{fQ?RA>>(Rk-QYT$yT*ap_6O#+9sm1*#M+ zf*Pw0Hu%i>Y^a@S&ZtyyZoj@krtu+FlxHUYQUW?7}QarF=Q79&3{( z-61V^b;*KCs%nnr6vd&>7#8hG%8+)cpf_q@lIqEL*liiN^{@y7x9)ein)m)qP4 zVr;gZ>^hw)k383urY3Noblw4N?y*;lRR9~93z&Nw|{!t3qiBIzp0+Vz&vFyfev zQ&f`A8Famb)ihHfGFiYLN0QZfQhFV@1cWf;<1pD7evWCiuu^FqX8T2u*UANYAM@Yt z&Q_rk8hwZ-lf<3WtCN_t#o}n0kB;X;WoAOgpu!X6MvTDlfiXFePS`D=IOo<2;?kXD z<^-W!Hg9ODVemxROGgxFaERA;h4>1)@suzhMf;+h87k%9s9+q|jv58>k;~M^o?}@` zo)TQStio?&33X}tmH_3j&*bxl+h&mTME+{5%q#mm(%ZPJ%f zIj8e66Yt5pN1(gx7UVhIHCU<|b!Gd=?3sXaDNvxeE>|*?JWP^vUV<TA|3#HN2eF9ze}jkJNtTFXA@|yTbu~V_(Ls3Qk7YE92kuhMd5EsL&b=&I`cE zua_3x<3%aev?$Kt8#8#WVMjo_n|vn1IZg^KQXK;5zLut_VQFS{X%qD=Q^j^qqc3_I zw4h%QpN|n9WeAp=+tFcbdWR#PpK1R|M zQna$|A*r*M_NXdlA#6bI&^`CmyQx}TO6TgJJK-!aHJXeaxqbpy6|ql*A)^2@iikqg z`^P-8H0bnf7*>|8ko*#@hzx3~pB`GJ6Aa`6sBLC0XbAMtE@HvXY)iydQkkG&J=2+Y>#8+O$vRCEbG1rdcuAooIJ;bB84>&Or4dfZU&} z+?M!scBI&MsHQ18<}}n^q7$P#X=>4^qe0z}pfQJPZ}LS*FVu;@)5jBP1L9LPpN&AV zfmAO}!fY&Zdk4lr8p{bWkA7&NjqQGToWc`dk{6{HNcj3kNTzaIh8;*_)W=sPyuwm3 zkGy!oYirxO?phJz+2Z-|%rp@Zh|8*K^S5Uip?sq}GgPSH+j^rs-WH8F|5F2@Bra{T z*y-pKEnR))8$j4xq}wM*HX{K{XDr?ry@|G2504Dvz<5yf+Iu`baCT*g+Zoufo-1P) z`OvyI+HZdM=I~QWWWlxxOI^PpGax-_GQ|a8^8gc8TB@^cfznZydmG&gB#}2ipS$fe z#D|H@geXBEJ#>d83N-|b2+4w*^>c-37D?#B?+8c=RCaGZ)aG60(eS8(u38ReCs60# z#qVM7V+0k2(Lu(->yJ~=pRKGhRmB)tcu0}pyrC^vM$!tv%4;%Z(GE!l85`~dC6e-} z!S*qE9An3h#=j95{+DS(*|&YLgmRiW=LVd>e_>PbkHVuj%blbZ8N+zToPI7W#LgVrqsW`S^F1bbXjV(%t~ z^unSBO?2~#A>{EmZ^_d~1IQ>LdQ}>Ofx&j9SQkRG$_feLTp;oGZVVpkPLy0;Uq}#( zf>S0W1fp1gRmSt`>y@w=Vo~LEXwVOg{y(7JM&81%n^Y-8sLaBJ{_sl?UN4#et%(SS zXA8hMrL57YK#_d3KQt{^` z9Gppap_8*}W4w>3vFo*3>1!yD&Lo`ZE-Mz?MU0jh#mzdNliE)tbKG-;gtOuw2#4NK z=kRaA#i?=?J>{c48?A0 z!Dk{dupJK`xR{Ko2H9W~r)uQXO5UQkRmK&6is-FdntwC5r_2#gM33j`c@IFqhO9&X)s!aXDndI8Xjcuu$?*#+eY0i}0%kmYOI=pg%SS1SFJrKPIR` z!1x*1Wh4ZKT1Q~=yeJMfg9*zCFcDJL-U_0tZN9DK>sq>gytTl*F=4D{gWAy zPMTko4c;qG5bSfc!8^9nI&(mh3}RN^_LuCc6iC4S12UB>4-l;z+ej-7zMEbS+doe& z8+Pjc)NJSgmlh)Ic=O%m*C8^A!hF6l+U+oE{5CV?ka3y;?Et-9mKkyV)fyocg<37wR zDzf`&igKHcIDo?sVt%ulUk&j8jE_AjGWZ296=P^ZQ6(*7;H~3z)Le+!mWMP+SMaks z{R+ep(l{t)$3~9G*_LJi6oXp>;U0}GtndUD>84Cy6q^~;%D`{HnWf`YL^voIhH<|2ZLE= z@%!1XTtf+sNt>)BKV0Xc)6b^e1xULHh;UF#B!L8-jMeD``JJK&Rod=6ZNs-!v?o=<|vWedZuqhtEXy~p6_ zDRh}{)<%*^2+>BMI9-|J6_+1-{N+*{2OA8~TB0Gm;i!3|)6Nc(r0=7(uJWC5LYwj3IDqlFx}I!YJg7b5IRr; ze9A2R=@S=4GYVBVDWI_z$>9T67pvdJKQQ>|dz~?O1dTTp=}1Cx zpT>=)9gxNtAETV|n8uVAtitTTzyR{yN$uujC{t~btlq(ibvlqb`57+$%ePJ_fs6~? zvA^}lxIP|t9*t=|GL(5=!3(#ZGz0ED2wMtkAeeR|##>+%i`(LD6H*;tpY<+RFg0f1 zi68?E_;^_JKX~hr`tREBp1lul?K`g(h!so-%_MY-T!G|P>^Cxr)HhBw6XM>4u|5Jk z!}`#FEEoKtam}-%me-DLHj36M5POIaQ$-+;7PEoe#bm_v8^*t(j#415F#j%V|2Y9v z)#b7CQxlcdZr03RvBGWHGpA4`$^0AgGqOWyp+Dk*8qudhJAhbsT6WeSLKDMAVPUqB7nEbcUFS|G+GFgH)5xxhJp1}oR|%_`f}`l0lNkq zaN*gKj{QMOJXWUDU&$el zO0`66ppYx4(Bvq~cQMDSWz_A7b)<9GqW}D;Ty{AivMCb#LIc+lT3!tW5dP!`wpQOD zMTgbgV_-(9KSkAqQT>^K5ji{(NIv1LGS8k~YuFIEOPkbbH*VX!AW0R~SO`P#poYwa zEHfeUm6?V;K?Vl_u|CmZ|2}$KqENW|l_+xY8C)wNbO}lQ;&3k{wR3&&Iou*;7)=yK zKmPMHhh`t^t-ze4z~lz`-|`7m8VAT!7HaNp<-|--S>im;=>zhp^OIe@9FLH>j|0}S zRi5<3&@_^>Fg&=TcBmIjCi!x|;>bl1Op1I8x|ZIY?bBa&FM0{{a>j2f+9zb)0{%;O z-Ye%TFwhfP=Gkb-nHf;H-=cLZO+slQWIjXj`1Ba4%I=^!xLhPTabr~AK&;O2ST%=> ziwb;B+IxdaBC2}#9B9ZH>U5%(=9QS?C)rGJi6E>G<`xEuKh}taB=f1H!~~h5b`L^Tg`bXeLEUj~N8Ehae(W}YE(7PjO6cp7A(Wv6L#Eq0><_Dz z6NoGOB07U;zJtILm~ze0Eve|VnFlrHzhS)#$Lq4KG!BeDfB{?T~tF znE6W{q_3sGNj&<3*Fm1a4$?`^tT2+z>U&OH5+^N5nN7&zA!_-EMiP-POxO~Kf?c$6 zTlwMI3Am0!&vaaAR&kQBqBH7Y@s4~d4V}OpsHw_%=`uP1f>RewOb1kM*9k+rgX0> zF+CW$#CVEk$J)O|29$ayAg2H|WU5>}$MulqS1rnIQVALRpzJr;mawVYQV-HpPo=|H zH0=cGz}p$V7lj=CtJX>jpMUnrQ6M87NIB{U(T`_*@T$klAAI~~ymWQ}h3 zGd=&9B_ZEFM)$fTaW}yw(RAs61Ln)vO|_I&998efkQk|ViCligPZC+mF_jQ|fQz^u zJ*wwr3eGL;shgmf7-N<0uE1v=rVxv@YfOR>vlAY{SyewjO{i}x!)yX5n9CbJaXa}d zWFOz?e0xyNTKQtMTUDe`Ocohf7BPs~kh`b^sn>6;cig!bQCcL{1-JVhyoEUvxh$y| zZ<8v`o>LCK*ismr(uU;Ce)fW~Dj$mtA=+BSJH;;Y_7VouG%T3TW7zn2*npBbYVk}Q zqOPelD&XI>s8-Nkyn%HZauB()qpBs@tFtXhO$m%e2Dv4Bqq`F)5`$i`C$Y8Xh=(pE z($x_w3OA5T|JNL?UU?q*-`SsM78_cz!>J-O1ffos%AXwQ(G8@+5-)Y?`T=V*g@%&^ z7cs$og}SS7g)yr9+aY_*N^HJ|)zhRvC%0s6mq)7}C zqKu;%gv$53WW;4+UdaRwZuNz+@!XJ|+q%v30I`PThf#6*dX*>AbJG8~Fm^LOiaGVl zH<&M3^(V_&gUjyT71OzkN7N7^9nGi(KBykhm(B`t<| zkAqd?!l&VCFJVFEDyYFv z^xbYSgwHx)NGoRPDrR)*=sQZvb?E0-L`EjaHN7LLgm(ae5q!0~Z>#TJLe-=iu^|JwAl{eqfi2b>;t%CY_h$Ma3f`|DxFHmxAuVIEPgb%=ae z`OL8R=;<&{bsjh?jplW0QErqFY>9JHh!bk-{WZ0pu753F96p!x z-$DBkj~|N<3ua8-HxmFhZ+-6CJl@}v&4*+M0RmHuhx9;hjm~+0&WG(uxQrzh+bP6I zw8LP6Z(dKvYdy6Z=6w)-rCk7xeVQZU2<=mGGR}R2H4;duCCzvI^`C>x8P?@Jq`9es z{|%wjre3szUZDZSS`8mCR*TDD5tZF(Q8WcrT@+P&r}c+yS1)MUEgZtb^rclg{sDlD zaDP^NVR0x@ud9S(^%z5{TaUYE|B!iU#36sf-okNl%I1E$@3l>R^dAn~1D*!P95C&B zpreLz*)j)`X@|^p<$OAqcb-N)v+~Nfl;vj!``x7t(dAOD?1C^^tlhe?1@T%`wgX9AG5!O5F~#RR zK%~$Q@1X8laDTXG+^63KbU1-$c%o4rnJzqE(nz`xLV!$Skw_0Gn0CtoF(@nR()e-H zCPDJ;`x~MfI~mixZq}KX(VQkljU8zmAjq~?L3oKQ%=E*wO@)d}{|#1~E2;-+gbR$$ zHlI0{lzSv%HK8+!6@^D?zzl_m;8Z9IqGC6Qird8&uE~d%S?{7Ud&-_8JN(kG+o|s_ zf;kk`TRxOPzcaUifwe+r>|_&X*F{wHU0Gwr$*GzVEKc=qqJf1a!FaxV%1(>`9qef$ zirM6f^JnH^+3Kl~aaGEH(hXy+k~lUXdn+ zPSM>WT#_5h`4)>OAY-SSc~^=l49n&RJ*XWf0#p1w>Z7XW831+d2{tf191k=p?axu9 zv4Dad9{OV`fU-W+^P41Xcd2yK+U{6wQF;i13k@ojO%>G&w@Mj48#$itBZVcdfK<5% z$}3YhUJ84K%QszkG^C?9bic#5&(K3_zcMbx1%9oNClc0c(K-e^uDpj3a>fgfe8HIa z@Sop9>amL0;bNJWT#wY8KBl#IeNEY%?cchcVOhbnZdwaHd^NN=hS&8`IX1iunnbeu zXobM)r)<+E$wJsR2%M%opSF6t4Ozf0Y34vdO_^g}vIhvZ?o_C(yMfP3B-O*tRg|+{ z`owPsxvizGwtm08S#Xxvx+RhjKfiFr@7qK*{m_0gSCe{4G<4diKZ}#296jJUB88!f zdjse^ZvuAq^&_E8abz!8va17)cS#l_+~Lg*7IUVCy9Vzj0qL|0^?urO zn$iE5dJImstRSoXFsdwH?FwT)P`O_3n{)sNc?Pi|{wMP#?*n?MlPzN&Ciw@qe?}#? z3VE|S^PqKFp$+t7oOYG3nYvXAIqo}OsA_(1EhF;f{a@wqzHV2v5cCe5!$4IzPMgU& zcuCIt?j8hbcY?!$bm>z}tJ@iePss-?aAzeCE!9!cicmRt38TNT-<~wzI-LJy2WiR& zMpU&f(+;vo^T?6!UPUz^@LzuxwmsXPwoVsjTUF)H-oZb` z@{S#a!ka_SWzQ1}07NWX^Zn(qsx2d~A_`2%F~E zTDAP$4(4WI&D|o_mK2+aA#Yd*6A$W3$Zxtr#EpGes+lNT` zyk#k)V)x-eZ|7j&;0A_A$PUVV`cfu+qq_?jLo{x;NN!0dE;nS4kD9M(Sf<#V>QJYvtR+cB5-N+O}Wh)@1Z$d&5G^&U$e#b9Ryho2!+ z>Roc$5$X*}_EbIbV%MN?9CYdF;f?tFc#JJov(q`yJSz zlKu$a+I0|yQbNWI5SiFvi0MjG6@IlUBJpv17qc7;6w5aYk)K`V@Cm%@B~6 zXri*EdnT2f*s3s28>ldlj9!6-(}D#CxwU7zXg?9P=p;Rf?7<&h-<#R?{>f`LKpKF3 zbxp_n2BPbO0M8^JKXWGu0H5Kk_BV}-%f!wY?-{=Kmxk#QeJIk#1mZub-j0-406q4t zCBd)Aref7rl+7B(=Y6GObXPPNT~o>@x_0KNKK^_*pG>aGGo~91=uw_;_mZGqT6Yb4 zbBJ$>N4aSk_lCdfQ-yd>N+ads7s!iQ7+Y+TW(tS6I0mWq6er^z*Iva6lL>Qx0gDls z6h+Wusn6pf;)U(q96=uB`bUbCUe~5QNJ7ub%p>M(7`ReD?w{8(lk)bUG-{T? zWOXcIJz$M)*#>wZFKiU&C0wRH7>#PvJcd3Of%M&T0uWS(M1q};M!4YhaJ|)p%qiua z%dl6iG-{7^(o=;|Je0$gTWJJlBZJ%yY|+tLF~v>BRHScIK>+& zZ8R_K7-O2FB59Vk!f45?Ofq^~;k+p0>oWhgv9tS$TXj{>r@AJ8#xVB=fy{VCS$(z3 zrbuZVlQC*6d3}R_lYkBq!U2kmg>>8KR(#7KFy#bXJ(+ob+7dm&_>Ii9?6@r*cRZg6 zD-}s}S3$KovQ-UkWRW>0F;!(DzpPdXi?!R?H)@a+qGGV32jg#R7}7=epj=i6xRXsv z0+hVkJ>6TJ>34~1e{OMWjlJzQEM;880NTWkbK+u5qOHR1k=LccFn!cfPw(eCi`cDHef2&PE`2v1RcqjlW7!LLV~c31ngKv+haH=GMAT-1{4&uis^r&gnfphs#etT^P1Oq*ehlLCJdgdmg& ze(r+qDw*OWZy>nwjw&y*>ZSw z@gYY>Z;=@_L+FB3?b*f49zwqM;$i4W+JbbJS8(Bn%men(XMoZ}AN_~_YeB8g1e4se z&cYa?#9XAY4gexnSnT+y=N-{Sh>9qNULI7n~n#!z?0w5)Pg+sK)eqDn&H>9ev? zGZln>P8q^>E|5s-zztJGAv9sf-%ySpIMfA=Tt3V4j9v#iEfcm+Kh!j3ntmBy zO%agDB9Q<)GyijurqC4IlOb-Q4;R=p<)afQf3C4529;J0knEJ;aMhYnV#uKlZs>C`4y2b{u!APM>P7y;~C@a3i397{0 zE6;vy0WAsd2ns!fnIkADU_{&M2C5d8FdDbOeDa8jb$8`T2d5Yn-snQ0`SLdvFFtr~ zw?LF213Im7vtmjg9YOFAqzY>QIOjMZ7>nb`<91zn3uqQPVl;5|9@brM#Uii7Y5IPA z7OOcXtAP5@5)=92;)C~KLYfsBejZCcc=@a@@AJSUEAC4`Zu|Kw)S<{S3ZbY!_?`Ex zPp3o;%xpX+#$|e0CK)+KqCh!0AP`Zp`)pB3@t&=QltzCa#CYh#l5?x7HeuW%8UYLV z$p$5@`b?lTL^ES)Jk-;Gz7F$GL#d4ME%g2AquJ4WI#U@{2|vZAy3mq%4MgCx1s8)o z0j9wc>M4%&8yt0bc3S@6;GqLbk~N{bpfjjTFc7Ff zLrq@QMtDULVog7ib8T^d3mwo}ze)o#1Lw9B+SK44a0L)c2nd8H#sVM62$;J~ffGWy zLYeTJ7nv{?3Y(>FDh=3A;WwBn^zkC0jT`}W%}jCbQBSbCwzmLdfgO&U;7D3dY@Oczkpzg9brSQi6e=x856T#ldxEDCJM zX)PTAC$Sh5%fexp#D+;~8Ik&G%qvY-W)yT5z|G_l{2J(UW4wK=aDrtdLlkMVU=sPP z0e{Vz=Wz}B!9JRy1aJs)h!%=>VE~-5hUUn@oR(179*i9v#FqsV^&p9|^=jgcDZ#_q zxLrdO9g9xdLH7~H`0f*;kYYcn&j27oUU^7xpbMeN$V0wir+s*nfbqvU#Dt9we4ry> zG%@C5NR94jRT9G1TR=5dm!PQhY17ntzr`|E-VXkK$GH3YI zgbZ(EP54FJn^?=3H12g2v!jP*JMa*7E6UY%7fMCIZsG$% zPiT>6uKYO-&G$LC8@%P_s03Yz4lnnySYT>4Et1hzH%50V)$+6qKj#IdaU;caGK=!O zq<`NWSKT2$HcjOxL@wCzH^VMv1Y>!QmmaYpcB^)*1g4cXH37d+nX@_ycv^WcuiMQ# zEgdVzS!r3>!=#v$S#-(N_1n!tz00V-3pzxwy%g*%6g}{P56#rO;uY4n&I*V#r zO584AKmbY|6p|P=Q}Rq7l*K$zhcVr64$C4ct5CRCgXJNGptoejLb<>$au~bKIPU|y zS-MGv>vVzfxGvS_(LO*u%=n>dvkhv3BoR0_Kr*@D3v}a`JXK78PA-?Jr2zKWT87ve z9P}Wol@TIegsHt0?i_H7)^->$83}QSlw>28BsJ3) zAWl0qGIR*pP8suYLv$3P zuLM?6OAk=jwl z*F@+B?`fOdBrSwzib$x)`Z)1rsPhxy_#xRQ$cy#yRphILeDGl|2!HPd2s}7O2{4O8 z^_J|1*8}9Zu!^$R+%<$m*Cm-5?}aym3`G{~fU<0?dJFL;vOS9uIuE_$Ee59{3L_rT z!tUX8Va$EBpCHJ>cz4*f_F3Ks$l;=VEhBQK(AzQ&ydL`{C874Jk_{1KZyM}F{PHPr zUCA|WoCtYXG9E5Z$-`s6q8oL=dl!h>wgaE3Q7G(Ct@v+=MHeXz40*sTn&^AmPYOYZ zqVpj8=MH*GkPy1yg7g9poJWYb&1xni#*&e2S!3pi3$olz)~OC5-gN;`w{ z!jiV1CyIe9RrsLz8=*L}3=$I495q}SjMiXM)VwJv1_$o;2l{>sNSfHZ-q3zI1r2&0 zQ)br)a8F)0da~Wj5vY7!xv!i-M(A4LCN(-HSlqbfaC3~Ad=;YaTGbHSv&4}XzDiJBgd79?V3G9(^xUBpoxg8y5)Z4<;*!yK5Z9Mcf!B=lE>P*yADv>HWf zwa88NQZ8A}OJsB1>XH(lxUvc}VsYl|NAzNub%WA4PFwG#=9QmFmhqhl$A)J2_c*0> ztbB!H?y!NE$?Fm~DvSb9*p#uKcbV_TA93PT_4SdwN>>b7lnMM;RkFunlq+W`z0a3@ zD#I*pl9Xl$HfyT+$&#N(w!>ciIJmvIdu;G7ZLFg|4-ada$Uq!IXIGWB)!c!2=zOf5 z_}cJh^bXA56xib-n(ylrQYn$v46l~)>g!ZRrKS1`Co9mdfB{QeR8g@T(X);TnlWJJ zn2b(w?f(s+ONJ5>wu2n*;+GtG!Q~AOF9zq{n6?mSpvh;`h2nD^>74}?@xFjT@1Hq37j-ABtH`6Pza%PQbG@^m)_Qx{dXy}&TlED0@q|Qr1JOG> z(bq#9)5_rI?JCJSvUmL@t`EUFQ;RytnKSf9Zgocvh?wzWTKHhbUtvDhDUf>TY~J;| zmPh1QhOe=5kHgF&+b+~Mgy4wjmOTxL>=2jE7dp*s=iiZG)*ls<+4yb`OXT^i2Ll-G z)nn-t?9P5oUDO?QH&&vYqLc;h2^H}I>eFSCoaFrzU7xm(&e?piJPV?5$YtL1nT(yh z%xkb4?=iPo0BwMt+b)tMw-e#Zxcf_--hH*2aZwdKUFnh}6W|(;*YvMTux#^*E{HS( zOVAOaosqA@=gPTv^E%S?Y%>IyMdga!S9nLCG8GNCT$XlRA7Wiqwk@F}V|$a-=r8T+Xy_WMn0}c-k&d~f6OHTR z;l6o34k}DqM~rW0+bqsD=XQwCz^ebG40C)My%$)33Ncl(z`br+nCakWhN%AZ*j+>T z(I_uik1Ffv=ENtMWVMiUdV#x$7d1W@F-dGdl+TtGzhx$JV^7brrsqsJ-_}>Z?Tqzh z;vg~`LHEq*+pp$Xoi-gy*bdL9(C4bhp_TH69GFBQ&0SxPz6h(V>4#vu__4ugPCmB? zbVw}r(!eIjL|&p^<(x}H%hIzmLzeWUHt5`lvFUi}*Sc{rLjIt7Iwo_Nr4#}GJ(pYy z3PHqvKOb=iMNIHKR58?F=+Nfj5@M-j!^RdI5e9LfUU$%dgdK+1=>R&u;JlrIMr7nl zJDYG#c(r<`SUYQ+=p*Nh=$S=d$P=d6?dWMX)6t192yjSm%8jrypH4DIrPxHZVnW)D zOt%#`NV$Isbndr8r3<5e=b!-Sp4OrB-oIFf-u#@Oo8n=Z*d5kZr^i{OjF!zQA=Lgx*93MT(v05)J{qIERayOzu2Q6+JRRgG&U{=soL zs547m=Vb4oP+g_+Z?n8@iRLl~3fnmG!!#$*M4+aXU=t zK3XszNmz6w%%G;UoMv>g9?lkfOkNQO-Iiu}KgYdnFeWrZ=v@W3iqJkL7LQH^LS;u3 z>SdHCT=bW2io7e1sme)0qSKFS?r-k37q!;y`yIOs=R1(+#U}NP?vr!?XFqYVz#zg1n;hH(4rwe_k4THn zmU%y-=FnULp~7M36aaxCrkmB*U>@Zzt~9)My;4lSXhhcOe4(7xq53P?gEm@tw3lFzBeHv^ zu(Ba!CS{U-ri8QhlQ8iC(PSvag-V+N#c3$Ap}E{rzw!qg8t*goobQ&n{R0%Pc6l}s z!vp4rfm;41634B*25yK70%26`C-bZ@DrB0ihvQT=e@R&b`$MtjNrk%XROBe$45J@JQ#Z*NoRj-J??!@g*|M;mp;{*fRVGU312h4tkBa zjkEr9w;Lsace=QSPa>-{aNG#Ly>v~U>Lyc8wsAs~G>||=qn^tHB4Ix$=YV3AGeI|E zgifj7T%H`4q>3c=xe{_$%EVi9J%U?g_rr@I+4MIC8>S&}9~dkz?MA2OMeZUxtoD8>esfUqm;(8ZECBA5n<}ce5*^ zyocf6((KGbEX8fa!);>=wZ7VS${hA%z!%^O2qwHOi`6}$jE5EqScBNymkl}VCpnj} zk)Kft}iOw7L`Y6Ji%jJ5NNkUd~Cypib-|V{F>si z6)WjtsZ{GSwYD^NsG63ksm0j^|Iks=>YcIvBHKVZRN>lSWPH?7=U-HV%9*K8^|04C{W(IxC% z`7KdhcRHyuZ94t>Qpu5iynfc9a=#)XaUoAg>q|roIGmkja)boK+zqQJoE#GFjiTnlr(R&Xv!ujZtSQ7UE zN4O?oL?0|!8}p;d2$2LX7r2koiBiG^EM~O@HM86&)+Yf)@u5f)X&rqtP_XWhYR7_o z!qHWt!yt883*N!cWfa9ub=`#K<*t22Hcv4pi1J4dWh@I2ZnGUJx=|wE=D1DW@Ty$W zPgLfxG6Dm-2_P#Yvz#-fuI7@J*TgN2TiT?BeGE1s=FeGM8)r&vC3zu;S8Y^Lv6Syn z&eG8>!?e3quN-+_mA{&$`#pOJAGNI;cXf;HB_qD(4ybFCV(xe}ThL!r4XV~)eP>IC zli4?r?nJ8@Y+gdH`G#|?b{6?g^G5VA$X!Q|IGF!rf31fbVSFw4i;rYN> zuIRyZ4$SVS)K;VbtSANle8TQ<4gUnn;vJ>&!IZQpKXrNuU~Y_uYkauG`PV7h@Os_L z9>NcXbth3Io2_X_7+RG1N%)iiR07)$bNLwQCdr&Z;eF7NK=0+C((Y30&Ali+CcU>d z#fteeZtMGtb|1*DyKTQ+5MAE9V|BLY@)LdKXPOhE`B2?HW{>Q5tRJ7cpj`aQ4k%uJ z)J4A1X>o^5fFa{Xw7q%_L~;X4%fBvY|=hA!i1gdT%t4 zLOe}WbZ>u$Z$(h^QKuNsyCLxLa7A;JU>P;{5;kUKu3G&jO^q{-)3fYMVZHL9VPO#A zmm5B}vmU5l)r#bCUjQe^$x zQ7{!cl^FvOMmu*I4#{@-ul^AeXEivN=zYcd?EFgyecYRDIbpt>@RI!W zvf#o&C;B^TGvZ<7EwlXopE-bH>fV9n3!w*W{K-oRm(>y0*;c_Ryckic#0cDTJ}?fU*+O95_3<%xJA$4>;Z%5mNV+})I^LP?mEqM9QF9&RrhTxSEy6v;}Hu4ytEaavCKU*U1Ebq zGV=7ljN;1;i4pUxZXlhUA{UhumSFC1O&Pj11n|Y2%KLIC)hR_Bf$-}$pJ1LR;e6&r zsFQs-60?~TIq`B@y5%fUPYe`j<|xsN;N_&>xWCO9ZChMxq`b+Yiyf9`_xD8>?8@m= zSkwfrAtOJg`mtz<3qsX5MbT}wm6TA@ZOVtL*mH63e@eG#*IrUWL7~cPdT@Kr%P7=3 z0^{->>Kc8x07QPUP&~c2GIKXzuPW6%alTXW$Gkt?P9fClB9$JaZF*PZH?B|MH_Q%@ z;=Fl&|?6#-_vOBtj3f;Emf@TDrm2Tr8+{Mm{Ky@tF+c56@vUJBbo z+Vrze)k4zn;m?EbHdXl*nJyM^bc?g$tTes|rd+Yax6uU{{u)#>r?fN{0yBJNpiQAn zW9WGFTSviXR-`kdEQ5n;!hV4xs2D49#Z>J!0%1`huQM?X@TL$C>UC!BGv}WMpRs>T zBzJ-8;l<+1Fy^GoRfq|p<_K443mlV^6~_3L7_P{0?T`($5fp6LnJyN-F50Uy!b zYwDNM{5EM_ZM zxAJ(A!XT0iA}tJ|_{?7r$38*XEW?OrbPZdnry-Ca+AU0Rhs*7gF@+=e7WL5Alse3cax4)=b^J9 zPO$9>dT}m@H7v6TV z#+=P7XZ|Go(deXu%bHX$ua_TM^(`2CA0oVvL3$-)vVi9!P9!;=+*eOZ|AHUZ1{UD^ zK_iD5I8gA|)(5g##z_V?vA>GbX3qIXw~7i~X567uZlYU4oxIHU5IH$o;x7Z;!NHh& z^9UJ8n6SfzDdUfAup4gTb-4x^?27DvtgCg>XevL>!3iS7whP3t#SrY|Oyz4>;&Qwn z?A7rMS&qgll7if0-SC>WhmM_D>8YJNh6>`V1~9quDtU1%il-6_E<+2yJ*>^0YkZwt z7pEYE)o*~6N+@`@k8eK0rWw|9{Iai^KLI|K3w$>tv366c`zsOoZTx_kkhr&Y2ix!8KaitnC?JA0l&}D154F zA~rvJ&&ag*aIV|k=2C8l3G`FF&3=vM(nE8HVTrind%XfBorE}4meYs;rvvW`Y=r*` zAVpRT#uE!MA#ti#*8b&`2yIS$;(~>9xL#Qkh2B}&*kNld<&aiY+VY^^VxOTv0?`ik zq;*~lI=@V0!5zo%=4YN(l@Xez9J$kFiIqyce$Hj5lZ&6b!~*H#ekai=LL`qdp|rSW z5NV~&N^Yh@Q(im$oXdx5H6hpxFo6iSR+Iha{AMm-paPJ!PInW2)A-e^~Ik z&uH*9*8bAAWK~7dPCsi-NFzSqYwf>i@1U9u^_r%apD>yr3B#ePCGH;XU6riq)1#xU zl{|rG`r-NQ=NV{l*FZci<)W&A;yI3w78$)ji1iz0BV0c#FFZ%+lIV8HiB3IN-x~A_emP7H+eS+Um&j46P#k9M zM<4k~6{xiIbHIa14yQ;?zCDT(FxFpIe->CS!k8`8Ag#OC) zK$i>K2t%Nf?_KoqHb%wuK2@}?9N;XHaYS|P>xazKfr4-3J#$I9Qk>mBPO8rCXi1rp z`ACwb_^i{$;9#l7n1piVbcRwfV8oQ|_pnOnZ?!yb!q|LCVdne<+%!D=lZ$lV`I$S^^OXYhh}d_*OchcXCub}!-Vduu2~kSG4GWtz$eSwLAExbx{|Do5*LEet$>B! ziMg=vn%sq@(!?zp&b-d<)>I~xS-uXefjhc2imAeXeZ(9-n zt==Bz1LZOWkH9ITfE&()R0 z?3m{^)A z)wgDw#dopuwIQPt9P;jSuzS8{By{0#F zMfEl}S=99@*TpQb`)^H`Ukf`ZoAgDC$Pq8{I&q)n9fKLjXbo;6zV9WSxXRDTNGt!? zD>|V(DOY6(TM>xd12;l`Br1GknKL)N+lVzKHBHOqySUJucYAMb||9K^G4E7Yz$`MUe_)6K+do+ZI_ zC5H0A%CedT!Qsrt{a4J**xEo9NPad4;T6^7TFH z%R8rGa(_yIt!$>%K$4;~ccm~ops~w8m36iq0kf*;t|3F#9Dz)e9%;1P>P(mv z7exnm(Ha(Wx03Is*&tMW5m@tCDuFh5mRveV{}l8ze|IEHlMBqbqw`Ge#yedT&h|mF z5Vvac=xuk=obLYhvh0d}o@_FE(Qp#0pS`{XJ#1Y00vQ?p?{k~{0| zV5;UA9;q{2TbCeuOl6=?{+QN1E2Y`Z-eX(_dVoNitw{RfNe^DHn?@N1U++_*n>fKp zza0&GefhB2BP4--`aSOh>6daEdg8ejG{VZa=__D<`2bbog#v1#+lP|D|QU{ zz@+hYt=Dp`$tZ;&czo(g)p4byeoswS!)?R{t5Rl5u_+Obuj%8r%%*eS=6$i$97Re8BK zHay;QT($a_7B3sA{h-S{a41ot226J8)=lhbnlGBhls>3tAM(ta52=q8R}Jg2M);^Q zAWEOrI+KiYu^znizJ?rjdwaDtt^F+K{n|^|W+a8WS}P~-_Ru0PPkZ}S!`2WynJbcb z9u&Nxh{u#`f;G1p3VFRZ@3H12xUZM-mIquQ_c5q+m>3G2OiPk+>t~<2*(WgQ6P~aA zRQ;9urf!!>ENK4Ly%xM;l5ej2JDTmt1J}z|c9HgLYPT2d$u;G*O?I~kMlwe794a+% zvs73P+WluzIv;<`SNI#1evu*e3<}N@W^@)ly>ow(B9ZF)K2b~**03cuYCqeB!CqOy zcaZgAnI12gnVnuJDd>`VawLE--#^HTI{=Jl_bORp1mPYRCF4y)}iw5 zd^i_5{``Iz37<5>wOFw?txs+sy`b}y+kkY6cegRxy2dx#=IPq$%?I4_rvYKi;G^cL zOHIh@(VLea6?K@ycSZ8jKa`N&o-Rs1`^xU1HhtTTTc9tEnm$+eBmO-33al3m^h*Ol zMkB+?57EWPmBzY0T#8Zx&HOWiw>`7-xO{Z&IvZma&zSAeQdtj+~qX)1Di?P>C-IhLoPyf#KM({WCQ7}IB`m#?Ts-#jyGUg znIPLDZ5O%KlVdp{t6G+u0F~>~1A8t{CHZ(%E#u@0_Z?47>U1VppmS*r)uKH2d%P2pQx7H=@E@9FV5TUzgcg^ij$^qY_T5(ERP-1T zq-r`ElD_E?F2SFjg%@hDj)n}fru7Onx|~xetS-$wHAQ(^gTftXQ8w{oUMb1Yl9}3! zvcsR4laRsG8EcUvI}33E-l?1A>%{h-YZSSna3UGoC$5u!$a>$IiV!X{o8Kgd*oPH>0g--1{7pK8eeT|@7mu4N_UZhn z*z&?vj@~L_Onu{`tp&d9Z18H+$jY!m7OD5SKP={Bp%x@H_wjrpqfxcJp!@!seQS@* z)^WsK{i%vDy0j)gk7vXXJ?AP;;Is{!cTezaTA+_PxhalA!EE^HV^rBM!Ehp!bT zR~r>#nDp|eK7anKWY=Okfh7W=eyK@qgHaXPGT)WvZ?wC%H0qCEQ0cMgke=45@7XH<5E(*>aYEx0s9$L6^(;8)msYn|RG_@r*TX zsq0Mo+8fB{@bO=kd@U>Pa%N5o#|NNS*tkz6?)Io8@KqT;@T(w8(z}vu3HWdAdfK}B zrxV*l9*>jPJl7Al_BF}BpT{#A}zY!PI3P04D#~uUG;iWTH~?>f=iOG zD)&n41NuCU&5Kctk7v1KSoORKU3;h2hKo3bqvc0?BFj^Ws4sRu*i=ZoW7|_Ke7Kb8 zi_dZU@k3i$0%JW%^d7eMzDRXoWqly4JnAvh#!TyK$UFz9t6-m#kY9rFee z>d>9tvvQXOPEGjgN47|PmUgcH9sxSHCNE6l zFB~#g6qNR0{UJ(h1@^o23hp^sK`ny{@9MHaKAU!P13`dc0BPVjVAHjCx;U;#W&A0+ zfpPWRl-GAixBFm2z^;dRV$;p3DBF$UQR$^wFI;jA6H+@0C19g8>{2jEU*r~j_}vW0 zZ91f}JX~Jfe3kr(0}9hq;)xbLcER;w+J-f6JLR*%RsbNys{(qV-*m1cY+Pin1wrR2 zG>Y8nR~Qf5XkF0E3*Z!Jt=`$D718kpIg}#sH+4@}aVMipMDKLd_@eW0E9ApHqs5jHX!gAhR;}(`lD%XrEbo~voetu3 zFJ4}MRpFl&^INGsS9%?+3(;pFUb$Ov zIiKY^o)^<^yT{Gm=w2Kc^KLY-6hV1sX1U1j3gZFSJ%_r@!24-tgw zFnc`u=r`E{s;}`5)#H56zW+jw8vLoLFDqCXLoML#;TK;%x6Cu^EOoTjV@4N78vSlK zhS*$^pI&-7*3f|46hkXKSSp`>m3`BEx@WK!{ziqc*;9*r8$AP)cQ7w%sPKGA8qmKtJ=!^ZGEw2p+r% zs&#YGpeIyAx$rCnP3Z!bya|woE7miexb_7r({uJ38$DTjDE(yV1CzfHQLx<2l32j7 z)>H`=%SawZd3YE{T)jp;!5$W`PdzwwD z$n=%|pHIt+w!*7Z6~=EHLIMC@NB{umzxTAfg{h5=k)gA`DszJ@DaUpSQE~)8mFQ z%pWZ^^7SKw*y=|(k!?QCB5D==t(^NCo|vUfA;tCAaM*$y@kWKw`>zJ7r6%0*KiCs$ zSF(c%+edQ_Mz!7uh9HM>BY*BZC3P53fpK+v~>!q(2yBIGzcYMH;ZPKojJQ_GQZM-{0KWrGhfPc zLauEmU*hk#2VJ0ei3sUt7UGdaScm#T_MnsxTOEu?|>m<-{SCY1is=b$pVDv&P3=G4lFMk~nO5*8{#kbJL zwZ|h*$fb|Q@|OPn8PkR@`&efiw~Aw8@_D%BsEq0(e8ALUZCD-D61hbODz1`SM&J&&knj>kfAPQ$bU6{4>Upx@<;%Ri1^wX z(0C2P=_Z|9QcK5j(gCe+ULM-q)mneQWHc8ILde*3w*cBrl1MveIp?v)7R|Qo-x^%4%R!_E~nK_q)VMSe)Ze z^f@|jl3)#OXYNTO!diBgmjw)^E7I|k1V+YMdw4_C;nY-mi~J1hc!Z8|UANJM%=&X> zQZMZCinAyLK4JS1ZaQN@{pTbQU$1RI*Uci7Q~^axLQFf!19A|QR!Sl{oDUO^3Uv;+ z6$`dj&_N(xg;uIMuGb`TP&G}1AiV|26$&&ea+su?%AyOuq3)eEMJ0{094Oh5%U65X z^i-<4=^`uJHA=;Am$pZtxlpJD>t*IF*a_2BhbK~3kODsv?D%=ZUA(bJWNB7tUr79G z8-uV}!89sL*;gV+nlAAwBneLs;_+VkP77Zd?oCk&tcV-LHzPaBWfdpbV7+vy5PCVy z1t`CBI7CrvKyp3F+<&XYTE15UZ6OL~HNTyG$4kj}oL&DJ4ZFt`S2{h2AaU!ehQjFR zvleQ`!)!O6a8f+ZjS1$>a~{3%)k6Eh`OTxZ`RW9;SPI|9vnwlx&cd(a20H4;#4pdo zj>gj4(H{nGa9ukC7q>%TQLiY4^dB}dw~m0X_MCw+G4gwIIF!r%E=}KtnYffYmr$-W zo1uf5pVdOc-YR?j1rl#}*OnBz=lrHEk377?nSLS{NBx0I*b}U6lx@T5hp04j-}u>= z<;VTH9>21ix1P!yUnMH8o=a_qH8V8<{Bk0FTylla4SHzDp$-8u0J$yqcG(@x(E@lF zfu`=Vsu2WCxws=DkBfJjATH@U>O#FkF8Nbi+=!eX)fgCNdY_%7WvwCLg>Xkz>bzdL z1!^SWaYnvoS7svh3>LveT=1^&(OUXbS^A@IvRNdC4Lqh}5&24;X)R7baZTjE&}Y*G zUd-QB{zJj1osxqWlwv#)Mk$oO> z)S%2UHUX8xkNGBffxTFa;VBVAJ=i4sNpM}dJB=-*iGo;CZlpWUlfdN@+UM`BC{MsB z(CkD!jgNp_M>3-&tDGvq!mFI#z~3dJNGGGIG@;F*&E87ipjRs0{%~(g zMt62`k^ClEcAV}3OEkjSsRQ_@u-333>RE=`esMrS-+_e#0QqkV3slFM4k+~dJ19`p zl;}Fxeg>@IM}duPi7JTvonIYKNOmXj#g+(zUs?R5OZYlycM9kbq1?O)#P@Vd&%xQ= z(sYYBKAyj}&*D+%o?gUHZP(VY(Cl&B%!tJj;^0s*C7V9mQ?IuBH(V<@gHe!H@AfLV z)(1zy$%;(J?Y|fEMVtI=sZ&|JPR)N=Kw=ZIeg+X2x-KxTGoZ@(r>ayv?`nQe-#{0E zYAygn0?z+XRi=OHnyn~kHNb$>NqP5y4 zlYd;q`{@&RVfJ#u!U!yyoXi-Tlt^MRW-$~c1S1|>jK5^=khHZc@(gG34PE-i<$h5P zbBw_2;2z%D422+X{=Jjt=dtc|X49C)4#(TjN;d2|!_1JYhxWkRY}21w@P6#N?9bQsSYCs|3_;#0~XOgK?}J4mr$Uwo&K;gaBpX5YpVaZ zhV~EZ|1nPdjywgOQ3Did_=W>f&A=k^C!`Vge~2_O{d?5{>-(?7YrvGo=ZDdEX`p3O zfUQpWPed7DrT@>p`R~d({j=E_+Ijq;DzN)9&@uhRedKv4Yp9R5eL4UFg<=2Ne_w&! z`9A;}+gSb$2E1+jldtkN_@+T5B}WMf^np|;0D#b+v=alG_dkIBqXYe|Q~ia96C
Yf_`{OrK7rIYH90Oa@WROx@i{;$}{*2Tuz(&>-8e>w*z#@~CyPdEi_ zW$M-^BNYI^9R&m+^*aRMWAyJ({@w`;9UR;ofnPxXNB!M_Fm^L)zhn179Rf5)(&|2vq!M!vsu{xwYfowN5JaQ-W3{hji! l5#sNZsf&MKn?ERjix(B7A%HOj0DunsD8m2%U{`+}{ePlXsp0?t literal 0 HcmV?d00001 diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/repl-0.1.2.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/repl-0.1.2.tm index f2977c09..f976ae57 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/repl-0.1.2.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/repl-0.1.2.tm @@ -3,9 +3,7 @@ #todo - make repls configurable/pluggable packages -#list/string-rep bug -global run_commandstr "" - +# ----------------------------------- set stdin_info [chan configure stdin] if {[dict exists $stdin_info -inputmode]} { #this is the only way I currently know to detect console on windows.. doesn't work on Alma linux. @@ -19,37 +17,46 @@ if {[dict exists $stdin_info -mode]} { } #give up for now set tcl_interactive 1 +unset stdin_info +# ----------------------------------- + #------------------------------------------------------------------------------------- if {[package provide punk::libunknown] eq ""} { #maintenance - also in src/vfs/_config/punk_main.tcl - set libunks [list] - foreach tm_path [tcl::tm::list] { - set punkdir [file join $tm_path punk] - if {![file exists $punkdir]} {continue} - lappend libunks {*}[glob -nocomplain -dir $punkdir -type f libunknown-*.tm] - } - set libunknown "" - set libunknown_version_sofar "" - foreach lib $libunks { - #expecting to be of form libunknown-.tm - set vtail [lindex [split [file tail $lib] -] 1] - set thisver [file rootname $vtail] ;#file rootname x.y.z.tm - if {$libunknown_version_sofar eq ""} { - set libunknown_version_sofar $thisver - set libunknown $lib - } else { - if {[package vcompare $thisver $libunknown_version_sofar] == 1} { - set libunknown_version_sofar $thisver - set libunknown $lib + namespace eval ::punk::libunknown::boot { + variable libunknown_boot + set libunknown_boot {{} { + set libunks [list] + foreach tm_path [tcl::tm::list] { + set punkdir [file join $tm_path punk] + if {![file exists $punkdir]} {continue} + lappend libunks {*}[glob -nocomplain -dir $punkdir -type f libunknown-*.tm] } - } - } - if {$libunknown ne ""} { - source $libunknown - if {[catch {punk::libunknown::init -caller triggered_by_repl_package_require} errM]} { - puts "error initialising punk::libunknown\n$errM" - } + set libunknown "" + set libunknown_version_sofar "" + foreach lib $libunks { + #expecting to be of form libunknown-.tm + set vtail [lindex [split [file tail $lib] -] 1] + set thisver [file rootname $vtail] ;#file rootname x.y.z.tm + if {$libunknown_version_sofar eq ""} { + set libunknown_version_sofar $thisver + set libunknown $lib + } else { + if {[package vcompare $thisver $libunknown_version_sofar] == 1} { + set libunknown_version_sofar $thisver + set libunknown $lib + } + } + } + if {$libunknown ne ""} { + uplevel 1 [list source $libunknown] + if {[catch {punk::libunknown::init -caller triggered_by_repl_package_require} errM]} { + puts "error initialising punk::libunknown\n$errM" + } + } + }} + apply $libunknown_boot } } else { #This should be reasonably common - a punk shell will generally have libunknown loaded @@ -2817,38 +2824,41 @@ namespace eval repl { namespace eval ::punk::libunknown {} set ::punk::libunknown::epoch %lib_epoch% - set libunks [list] - foreach tm_path [tcl::tm::list] { - set punkdir [file join $tm_path punk] - if {![file exists $punkdir]} {continue} - lappend libunks {*}[glob -nocomplain -dir $punkdir -type f libunknown-*.tm] - } - set libunknown "" - set libunknown_version_sofar "" - foreach lib $libunks { - #expecting to be of form libunknown-.tm - set vtail [lindex [split [file tail $lib] -] 1] - set thisver [file rootname $vtail] ;#file rootname x.y.z.tm - if {$libunknown_version_sofar eq ""} { - set libunknown_version_sofar $thisver - set libunknown $lib - } else { - if {[package vcompare $thisver $libunknown_version_sofar] == 1} { + apply {{} { + set libunks [list] + foreach tm_path [tcl::tm::list] { + set punkdir [file join $tm_path punk] + if {![file exists $punkdir]} {continue} + lappend libunks {*}[glob -nocomplain -dir $punkdir -type f libunknown-*.tm] + } + set libunknown "" + set libunknown_version_sofar "" + foreach lib $libunks { + #expecting to be of form libunknown-.tm + set vtail [lindex [split [file tail $lib] -] 1] + set thisver [file rootname $vtail] ;#file rootname x.y.z.tm + if {$libunknown_version_sofar eq ""} { set libunknown_version_sofar $thisver set libunknown $lib + } else { + if {[package vcompare $thisver $libunknown_version_sofar] == 1} { + set libunknown_version_sofar $thisver + set libunknown $lib + } } } - } - if {$libunknown ne ""} { - source $libunknown - if {[catch {punk::libunknown::init -caller "repl::init init_script parent interp"} errM]} { - puts "repl::init problem - error initialising punk::libunknown\n$errM" + if {$libunknown ne ""} { + uplevel 1 [list source $libunknown] + if {[catch {punk::libunknown::init -caller "repl::init init_script parent interp"} errM]} { + puts "repl::init problem - error initialising punk::libunknown\n$errM" + } + #package require punk::lib + #puts [punk::libunknown::package_query snit] + } else { + puts "repl::init problem - can't load punk::libunknown" } - #package require punk::lib - #puts [punk::libunknown::package_query snit] - } else { - puts "repl::init problem - can't load punk::libunknown" - } + }} + #----------------------------------------------------------------------------- package require punk::packagepreference @@ -3543,34 +3553,38 @@ namespace eval repl { if {[package provide punk::libunknown] eq ""} { namespace eval ::punk::libunknown {} set ::punk::libunknown::epoch %lib_epoch% - set libunks [list] - foreach tm_path [tcl::tm::list] { - set punkdir [file join $tm_path punk] - if {![file exists $punkdir]} {continue} - lappend libunks {*}[glob -nocomplain -dir $punkdir -type f libunknown-*.tm] - } - set libunknown "" - set libunknown_version_sofar "" - foreach lib $libunks { - #expecting to be of form libunknown-.tm - set vtail [lindex [split [file tail $lib] -] 1] - set thisver [file rootname $vtail] ;#file rootname x.y.z.tm - if {$libunknown_version_sofar eq ""} { - set libunknown_version_sofar $thisver - set libunknown $lib - } else { - if {[package vcompare $thisver $libunknown_version_sofar] == 1} { + + apply {{} { + set libunks [list] + foreach tm_path [tcl::tm::list] { + set punkdir [file join $tm_path punk] + if {![file exists $punkdir]} {continue} + lappend libunks {*}[glob -nocomplain -dir $punkdir -type f libunknown-*.tm] + } + set libunknown "" + set libunknown_version_sofar "" + foreach lib $libunks { + #expecting to be of form libunknown-.tm + set vtail [lindex [split [file tail $lib] -] 1] + set thisver [file rootname $vtail] ;#file rootname x.y.z.tm + if {$libunknown_version_sofar eq ""} { set libunknown_version_sofar $thisver set libunknown $lib + } else { + if {[package vcompare $thisver $libunknown_version_sofar] == 1} { + set libunknown_version_sofar $thisver + set libunknown $lib + } } } - } - if {$libunknown ne ""} { - source $libunknown - if {[catch {punk::libunknown::init -caller "repl::init init_script code interp for punk"} errM]} { - puts "error initialising punk::libunknown\n$errM" + if {$libunknown ne ""} { + uplevel 1 [list source $libunknown] + if {[catch {punk::libunknown::init -caller "repl::init init_script code interp for punk"} errM]} { + puts "error initialising punk::libunknown\n$errM" + } } - } + }} + } else { puts stderr "punk::libunknown [package provide punk::libunknown] already loaded" } @@ -3594,6 +3608,9 @@ namespace eval repl { } else { puts stderr "repl code interp loaded vfs,vfs::zip lag:[expr {[clock millis] - $tsstart}]" } + unset errM + unset tsstart + #puts stderr "package unknown: [package unknown]" #puts stderr ----- @@ -3634,6 +3651,8 @@ namespace eval repl { puts stderr "========================" lappend ::codethread_initstatus "error $errM" error "$errM" + } else { + unset errM } } } @@ -3682,7 +3701,8 @@ namespace eval repl { thread::id } set init_script [string map $scriptmap $init_script] - + #REVIEW - the same initscript sent for all values of $safe and it switches on values of $safe provided in %args% + #we already know $safe in this thread when generating the script - so why send the large script to the thread to then switch on that? #thread::send $codethread $init_script if {![catch { 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 new file mode 100644 index 0000000000000000000000000000000000000000..fcb76636a0670797560a57e80a0d00bf7c4fb42d GIT binary patch literal 9910 zcmch6dpwkB|Np4Aw#4daD|CfI>sYJJ6gH(zDU?u5+-B}!n3K6@oDWZIN@q$3gi4f< z5{lCHXp;(U(!r^sT9VEbI()C|o*9Q`c=q@FzOV1}$Bg^FuFv&3zCZ8l(-_e2qZQ2J z115`&g8-J$8#vP0fX%}gxB&14I3MRSaE2jRjr)mM0-OLiTmxTuidbwRiwodhCZP{_ z0^rXis8l3M$O9anh${pE-bg5X#D@~b^g9t~En*9C0T&ap{Bd>=5OL8yf(L}&m=NHB zLIFk>;tZh0;W79;h5;X=`(j?Wfj=%FSUfIZ^4Lf{76G6J1jfOoPcQ-)3OS@P-yGj++7@HN016LN8$pZvkz~T#OVYDz1GGHfi3@#8r z7ivn5C%qvQd5Rw!g0)=C6M7OlmVraRaadd&=`VuM_?Xb!5a{xG1i?aU2#kqCufSD& z0K+8|u;@bQGQv_%bHJft1OCGJd>Dq15GWMsE>A;bpSI*Z!2N)xCI}4$Gh9hq@jw*5|o{-c&OgdvvIB$L;>wZG+=HHjNxJdE))s4 zAS6uI+p^oN{_AZPz_s7ugDHtlL;*ukq`gSSV)Pn)(2_+!+iJ)KRzMqyk-J2`snUZ( zGda1TC4*Hc_X&vQ5T$q^00(r83$qw?3aG4r#}}|5K(m8nltrFo z(=h^f7Xz<5fqQXqE(9D`1aMq0h>UDrKyRJ()eEfYL8??CUAcS&6Nn^;SyK|5jpe-v{7VXhl$S874KWj)Vm1r-ONRx2~+C89FUB&RNJ)qPj zihS!a?SW^~$a3u~yl>wArz%9~(@%f40ONYWe%Id)F&NYO756u10GOsUus};hz-|V! z02jbkgrdy=NW5J0kqbOwvH8kE2;X(f4O6PH5 z-vk4)2(E(bafSg51!7aE6G|J2%o$+-XTv}Yp0oWOfFwz5lo5nNBv;x0 zH+9Cy2qq&(;vt>K;lK_{0J2IEJ%bFCG?oS+L(Pix-^d6C0O=-Xu(0F6=deOB7*AmUPvA@PU0EJD zAlXR2z}~=s)ED^TP+?cu1Q{GwHI0nKsbmDxTU=6u24E%cZPpy&>r}t~XrrZ<|sD zq~E012qA>RzB?!Z@1GVH7X4CJf~{a73Jbgi_tk?1V8S*BFZpg5Dz&owfoc`YfOk0eQ9Ra?G?y~NR$Pc~!8%{g^W10S zX(DAhXf6af7IGfxbkwlmZ!|;E?#F2c*HwNf!{noY7Q`a4s|V06K!`lyodjORd9d^` zb^vOps1+iz0kwmpwcdFXyd%L|Ke{7{If*~cWx-_-Q2PdCko}o)6ghp}X`borR z<8aglOdt=3+y-_PkpR++|1#>b&2vcFsKvzCY){B{QH7yy04q>Rs^n^`waUs6I77Zc z(il1<`mmiM-;lI`14lLJ0dyn*4B#XZHb3}IoH&r$K$4B90s&;XBPvVT!qXN{fBFDs z$dW?)rC9t8WAC-6TN4#Q@{U^Ja0H$ZJcms*s$r?g=D)v3h zR&spI0G>gRIdVlX_>vJXpF~_3E3yK6OA%dt*l;XhIC$|PZNJgf5y~M4$8fp~AX|d8 z0)-x)CMg(r^+F^9O2?%0VMM$8#>)MHR9b!HG?@<#g#{@YGed$VRdr|u#UP{&T`4!K zkqtxE30ir;BI1k1IV5Q)Dnu^|;k za{dnx9UUVd)dzngfBhivDr5CObF++Z1|Av~CYi8&JDHaJ4+HHR;6wkv(_14jry&6M z4LzsYuNXdJB85Wvo|3?JcP;8!^Xcel3WcRkp=iRV(k4cV5EvL6n*5AzM{r0({)SEU z;<_H9?&`QNw1__wA~mnmuczq;v7I|@={hTCy}7gI#vwmFr{TkXd#kD9!KdgQeEPMK z_d(exlKrCA;Of5D=jzG|t6bG@TZV`KHbGr)Ox%42OM_t(%+Gxt9KZ4zR4iqbzXi&*_+^Wm*|?~{2}hax%p z)0GPX=F}Y1x_0ljUA|@X_C2|uxi6;GgeT72c%j~+jEPis|~S+i_1z2lo!E}Usu zQpF72GxL#^`SQ1p%l6FMTe0`g<4;6eCapIqKXE1XH%IL*U!w8p=L4Y^FP;v?)7 z?q(O&54+Rq*qPM${N|Xpg09Cr zvn2hqMhA~}JX`i~eR1a(+mi>CnUrRybsmaY$Az?ISElDSwkq<*WPhrQQ{{d%`*(HJ z#ispp9x)F$shmAkSGs(Xvt}pUzx}j>MQoq3fJ6||{MX9azxCnJl#L~ti z9qFMVKi*V1zN}(`d4)n&*?GMcpYJaTzZ$tCc5$pj$n59^d9ymLZ60m=;JasGi2s`l zzZ}o7b8xA^^7Bvl7G1;AHY8o~nbi8@lS8%X`DV7Z=~zm>gFT;Gb^OwUt8A-MusqUr z=i&1y8^_-5tS{|u(NeEy)lEB^($Zp}e(|CGuGYYh4wnyPo+vN7^KRp-gzkp6*NoxW zei7#PZ>71F+1&eWewO8J*Wkrl6z81bZ~suJbo$Z1bAP-&!^f?#E$oF-vSnL}+Xf5E z!x0YmLPCOqE(bIwuB=Wt!aH4+NZX)1(!Z>}y(Rcr&B@E<>4stZGE9`TlrlPgKV8OH zYOwIe`l5Y|(Tb&OvF##_w&L@-FNGB2_e-ofo=R04LTacT#kAR0&ZiC;ctmL{S8VZF zHKprni{2CcEFWw2?fOn{pWAJop0nZT6@Faw75d)Dkji~Tj(>FN*3w4iGQNvdaA#St z=XVj7<2{Wu_TQ|#@KbD$sX{{Xq^>p3f5|2;{V{S&40U8|f*;jH?e60Di{qB8U1**2 zcFgWXrZOX2$2DPzC!0MEBX%e!6yz=q{?4zYXJ>tN)c&3>-l)p(arL9p@8A70#n))Z zUncA`9v)^2{E`D&rBf^8lP*nr{$%HK3m*7-6ueS)zFy!^pyaB(bj5D4kUgWb_3()D#dS6}Zv~_(wWe=*@bm98 zqjdMD8MCZtYnMOLvdKQ*&>&Eut`;4<%?}|N8+Ww{B~5BLZhO&f4*Bh@Mw=$z`S*R}hnxAgAQ(MH2Z1#TdQEu9;AbbHg9YV!y0COl{7_cR#Y zi)x!Y%;|ISmvs?*i;|Xm6IvsSlaIU(h|W9+eFrC<}z@nyRV;JzT>@1OApt@MNRLS;?$pyeB4+_)c79{U!%LN&G(jm z&aBkN@Ra)Kd(2YxDWg5oEPVW%OR>_P6~w$#mwFs>u4jDEFD!1ZCVvZ#*<1Hpm&x6XG*nGf@SIO}nI z&GdVxM!#J*1N4l$txr8Twq0dsqV>!6BY5zq{e{jt5#A3pXfXn#R`X5C`c!9YX12x0lsi{X#iUhv8 zh>Nv5HB#2kHh*qzylT8&dBTy!jh=}`+r8E~pZ&?v=c4Hmuy#eZ)1;{BU%I=M{I+-1 zTM+)m=fZvR>Z-q3A7wQ*t9sov%5rwQRlOrHL1#;GN>*XvOy5hWvx1KTjw2fiBKd}Vac8j&Atyp2bS-aawiF5cAyd<}p#uokgvT#J zcw@KG@ZKl$N0UugZhv8lH6$OKZE`08Ia`z+0UxV}` zT-NRTNnd?|uS4wh>ld#nd>z?G@nY1hT%)>ziYpZ;6yM<#$_&cLAt;{VYU@QyR$71k zI*dY52-~xgS7$snx~lpVh*Yo6YTznFdwlPI?Zo2KYqn`jjM*7;EpGO8zdi1jw^tQ0 z?>|fAJpUYMdrGl(x!ci3meidfvIIAB-^LLl1(Tq1-L(0wYJcCFX{Tg%I9ao0ejuAY z{rQ2%<(r;#{-GO}oN{XAw5{}KHqKGYKY8kTH~JKgpJ&R$o<-(&&V1`ws#R=tKHc-? z2j`PlDpL(p6-(YbzGi~v=`hkWX`0fW?t~udUurwz&&Ed_ z+oih3#$wf^SaGKfx literal 0 HcmV?d00001 diff --git a/src/vendormodules/metaface-1.2.5.tm b/src/vendormodules/metaface-1.2.5.tm deleted file mode 100644 index ebcf579e..00000000 --- a/src/vendormodules/metaface-1.2.5.tm +++ /dev/null @@ -1,6411 +0,0 @@ -package require dictutils -package provide metaface [namespace eval metaface { - variable version - set version 1.2.5 -}] - - - - -#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 vinfo $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 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 {}} -proc ::p::-1::M {_ID_} { - 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 { - foreach m [dict keys [set ::p::${IID}::_iface::o_methods]] { - lappend members $m - } - } - return $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 {}} -proc ::p::-1::P {_ID_} { - 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 { - foreach prop [dict keys [set ::p::${IID}::_iface::o_properties]] { - lappend members $prop - } - } - 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_} { - 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/vendormodules/modpod-0.1.4.tm b/src/vendormodules/modpod-0.1.5.tm similarity index 80% rename from src/vendormodules/modpod-0.1.4.tm rename to src/vendormodules/modpod-0.1.5.tm index 64e1bd9d..63875951 100644 --- a/src/vendormodules/modpod-0.1.4.tm +++ b/src/vendormodules/modpod-0.1.5.tm @@ -7,7 +7,7 @@ # (C) 2024 # # @@ Meta Begin -# Application modpod 0.1.4 +# Application modpod 0.1.5 # Meta platform tcl # Meta license # @@ Meta End @@ -17,7 +17,7 @@ # doctools header # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #*** !doctools -#[manpage_begin modpod_module_modpod 0 0.1.4] +#[manpage_begin modpod_module_modpod 0 0.1.5] #[copyright "2024"] #[titledesc {Module API}] [comment {-- Name section and table of contents description --}] #[moddesc {-}] [comment {-- Description at end of page heading --}] @@ -65,6 +65,7 @@ package require punk::args #changes +#0.1.5 - Reduce pollution of global namespace with procs,variables #0.1.4 - when mounting with vfs::zip (because zipfs not available) - mount relative to executable folder instead of module dir # (given just a module name it's easier to find exepath than look at package ifneeded script to get module path) @@ -316,104 +317,107 @@ namespace eval modpod::lib { set opt_offsettype [dict get $argd opts -offsettype] + #mount_stub should not pollute global namespace. set mount_stub [string map [list %offsettype% $opt_offsettype] { #zip file with Tcl loader prepended. Requires either builtin zipfs, or vfs::zip to mount while zipped. #Alternatively unzip so that extracted #modpod-package-version folder is in same folder as .tm file. #generated using: modpod::lib::make_zip_modpod -offsettype %offsettype% - if {[catch {file normalize [info script]} modfile]} { + if {[catch {file normalize [info script]}]} { error "modpod zip stub error. Unable to determine module path. (possible safe interp restrictions?)" } - if {$modfile eq "" || ![file exists $modfile]} { - error "modpod zip stub error. Unable to determine module path" - } - set moddir [file dirname $modfile] - set exedir [file dirname [file normalize [info nameofexecutable]]] - set mod_and_ver [file rootname [file tail $modfile]] - lassign [split $mod_and_ver -] moduletail version - - #determine module namespace so we can mount appropriately - proc intersect {A B} { - if {[llength $A] == 0} {return {}} - if {[llength $B] == 0} {return {}} - if {[llength $B] > [llength $A]} { - set res $A - set A $B - set B $res + apply {{modfile} { + if {$modfile eq "" || ![file exists $modfile]} { + error "modpod zip stub error. Unable to determine module path" } - set res {} - foreach x $A {set ($x) {}} - foreach x $B { - if {[info exists ($x)]} { - lappend res $x + set moddir [file dirname $modfile] + set exedir [file dirname [file normalize [info nameofexecutable]]] + set mod_and_ver [file rootname [file tail $modfile]] + lassign [split $mod_and_ver -] moduletail version + set do_intersect {{A B} { + if {[llength $A] == 0} {return {}} + if {[llength $B] == 0} {return {}} + if {[llength $B] > [llength $A]} { + set res $A + set A $B + set B $res + } + set res {} + foreach x $A {set ($x) {}} + foreach x $B { + if {[info exists ($x)]} { + lappend res $x + } + } + return $res + }} + #determine module namespace so we can mount appropriately + set lcase_tmfile_segments [string tolower [file split $moddir]] + set lcase_modulepaths [string tolower [tcl::tm::list]] + foreach lc_mpath $lcase_modulepaths { + set mpath_segments [file split $lc_mpath] + if {[llength [apply $do_intersect $lcase_tmfile_segments $mpath_segments]] == [llength $mpath_segments]} { + set tail_segments [lrange [file split $moddir] [llength $mpath_segments] end] ;#use properly cased tail + break } } - return $res - } - set lcase_tmfile_segments [string tolower [file split $moddir]] - set lcase_modulepaths [string tolower [tcl::tm::list]] - foreach lc_mpath $lcase_modulepaths { - set mpath_segments [file split $lc_mpath] - if {[llength [intersect $lcase_tmfile_segments $mpath_segments]] == [llength $mpath_segments]} { - set tail_segments [lrange [file split $moddir] [llength $mpath_segments] end] ;#use properly cased tail - break + if {[llength $tail_segments]} { + set fullpackage [join [concat $tail_segments $moduletail] ::] ;#full name of package as used in package require + set mount_at #modpod/[file join {*}$tail_segments]/#mounted-modpod-$mod_and_ver + } else { + set fullpackage $moduletail + set mount_at #modpod/#mounted-modpod-$mod_and_ver } - } - if {[llength $tail_segments]} { - set fullpackage [join [concat $tail_segments $moduletail] ::] ;#full name of package as used in package require - set mount_at #modpod/[file join {*}$tail_segments]/#mounted-modpod-$mod_and_ver - } else { - set fullpackage $moduletail - set mount_at #modpod/#mounted-modpod-$mod_and_ver - } - if {[info commands tcl::zipfs::mount] ne ""} { - #argument order changed to be consistent with vfs::zip::Mount etc - #early versions: zipfs::Mount mountpoint zipname - #since 2023-09: zipfs::Mount zipname mountpoint - #don't use 'file exists' when testing mountpoints. (some versions at least give massive delays on windows platform for non-existance) - #This is presumably related to // being interpreted as a network path - set mountpoints [dict keys [tcl::zipfs::mount]] - if {"//zipfs:/$mount_at" ni $mountpoints} { - #despite API change tcl::zipfs package version was unfortunately not updated - so we don't know argument order without trying it - if {[catch { - #tcl::zipfs::mount $modfile //zipfs:/#mounted-modpod-$mod_and_ver ;#extremely slow if this is a wrong guess (artifact of aforementioned file exists issue ?) - #puts "tcl::zipfs::mount $modfile $mount_at" - tcl::zipfs::mount $modfile $mount_at - } errM]} { - #try old api - if {![catch {tcl::zipfs::mount //zipfs:/$mount_at $modfile}]} { - puts stderr "modpod stub>>> tcl::zipfs::mount failed.\nbut old api: tcl::zipfs::mount succeeded\n tcl::zipfs::mount //zipfs://$mount_at $modfile" - puts stderr "Consider upgrading tcl runtime to one with fixed zipfs API" + if {[info commands tcl::zipfs::mount] ne ""} { + #argument order changed to be consistent with vfs::zip::Mount etc + #early versions: zipfs::Mount mountpoint zipname + #since 2023-09: zipfs::Mount zipname mountpoint + #don't use 'file exists' when testing mountpoints. (some versions at least give massive delays on windows platform for non-existance) + #This is presumably related to // being interpreted as a network path + set mountpoints [dict keys [tcl::zipfs::mount]] + if {"//zipfs:/$mount_at" ni $mountpoints} { + #despite API change tcl::zipfs package version was unfortunately not updated - so we don't know argument order without trying it + if {[catch { + #tcl::zipfs::mount $modfile //zipfs:/#mounted-modpod-$mod_and_ver ;#extremely slow if this is a wrong guess (artifact of aforementioned file exists issue ?) + #puts "tcl::zipfs::mount $modfile $mount_at" + tcl::zipfs::mount $modfile $mount_at + } errM]} { + #try old api + if {![catch {tcl::zipfs::mount //zipfs:/$mount_at $modfile}]} { + puts stderr "modpod stub>>> tcl::zipfs::mount failed.\nbut old api: tcl::zipfs::mount succeeded\n tcl::zipfs::mount //zipfs://$mount_at $modfile" + puts stderr "Consider upgrading tcl runtime to one with fixed zipfs API" + } } - } - if {![file exists //zipfs:/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm]} { - puts stderr "modpod stub>>> mount at //zipfs:/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm failed\n zipfs mounts: [zipfs mount]" - #tcl::zipfs::unmount //zipfs:/$mount_at - error "Unable to find $mod_and_ver.tm in $modfile for module $fullpackage" - } - } - # #modpod-$mod_and_ver subdirectory always present in the archive so it can be conveniently extracted and run in that form - source //zipfs:/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm - } else { - #fallback to slower vfs::zip - #NB. We don't create the intermediate dirs - but the mount still works - - if {![file exists $exedir/$mount_at]} { - if {[catch {package require vfs::zip} errM]} { - set msg "Unable to load vfs::zip package to mount module $mod_and_ver (and zipfs not available either)" - append msg \n "If neither zipfs or vfs::zip are available - the module can still be loaded by manually unzipping the file $modfile in place." - append msg \n "The unzipped data will all be contained in a folder named #modpod-$mod_and_ver in the same parent folder as $modfile" - error $msg - } else { - set fd [vfs::zip::Mount $modfile $exedir/$mount_at] - if {![file exists $exedir/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm]} { - vfs::zip::Unmount $fd $exedir/$mount_at + if {![file exists //zipfs:/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm]} { + puts stderr "modpod stub>>> mount at //zipfs:/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm failed\n zipfs mounts: [zipfs mount]" + #tcl::zipfs::unmount //zipfs:/$mount_at error "Unable to find $mod_and_ver.tm in $modfile for module $fullpackage" } + } + # #modpod-$mod_and_ver subdirectory always present in the archive so it can be conveniently extracted and run in that form + uplevel 1 [list source //zipfs:/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm] + } else { + #fallback to slower vfs::zip + #NB. We don't create the intermediate dirs - but the mount still works + + if {![file exists $exedir/$mount_at]} { + if {[catch {package require vfs::zip} errM]} { + set msg "Unable to load vfs::zip package to mount module $mod_and_ver (and zipfs not available either)" + append msg \n "If neither zipfs or vfs::zip are available - the module can still be loaded by manually unzipping the file $modfile in place." + append msg \n "The unzipped data will all be contained in a folder named #modpod-$mod_and_ver in the same parent folder as $modfile" + error $msg + } else { + set fd [vfs::zip::Mount $modfile $exedir/$mount_at] + if {![file exists $exedir/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm]} { + vfs::zip::Unmount $fd $exedir/$mount_at + error "Unable to find $mod_and_ver.tm in $modfile for module $fullpackage" + } + } } + uplevel 1 [list source $exedir/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm] } - source $exedir/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm - } + }} [file normalize [info script]] + #zipped data follows }] #todo - test if supplied zipfile has #modpod-loadcript.tcl or some other script/executable before even creating? @@ -664,7 +668,7 @@ namespace eval modpod::system { package provide modpod [namespace eval modpod { variable pkg modpod variable version - set version 0.1.4 + set version 0.1.5 }] return diff --git a/src/vendormodules/overtype-1.7.1.tm b/src/vendormodules/overtype-1.7.1.tm new file mode 100644 index 00000000..18fa78ea --- /dev/null +++ b/src/vendormodules/overtype-1.7.1.tm @@ -0,0 +1,4772 @@ +# -*- tcl -*- +# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix 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) Julian Noble 2003-2023 +# +# @@ Meta Begin +# Application overtype 1.7.1 +# Meta platform tcl +# Meta license BSD +# @@ Meta End + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# doctools header +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[manpage_begin overtype_module_overtype 0 1.7.1] +#[copyright "2024"] +#[titledesc {overtype text layout - ansi aware}] [comment {-- Name section and table of contents description --}] +#[moddesc {overtype text layout}] [comment {-- Description at end of page heading --}] +#[require overtype] +#[keywords module text ansi] +#[description] +#[para] - + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section Overview] +#[para] overview of overtype +#[subsection Concepts] +#[para] - + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[subsection dependencies] +#[para] packages used by overtype +#[list_begin itemized] + +package require Tcl 8.6- +package require textutil +package require punk::lib ;#required for lines_as_list +package require punk::ansi ;#required to detect, split, strip and calculate lengths +package require punk::char ;#box drawing - and also unicode character width determination for proper layout of text with double-column-width chars +package require punk::assertion +#*** !doctools +#[item] [package {Tcl 8.6}] +#[item] [package textutil] +#[item] [package punk::ansi] +#[para] - required to detect, split, strip and calculate lengths of text possibly containing ansi codes +#[item] [package punk::char] +#[para] - box drawing - and also unicode character width determination for proper layout of text with double-column-width chars + +# #package require frobz +# #*** !doctools +# #[item] [package {frobz}] + +#*** !doctools +#[list_end] + +#PERFORMANCE notes +#overtype is very performance sensitive - used in ansi output all over the place ie needs to be optimised +#NOTE use of tcl::dict::for tcl::string::range etc instead of ensemble versions. This is for the many tcl 8.6/8.7 interps which don't compile ensemble commands when in safe interps +#similar for tcl::namespace::eval - but this is at least on some versions of Tcl - faster even in a normal interp. Review to see if that holds for Tcl 9. +#for string map: when there are exactly 2 elements - it is faster to use a literal which has a special case optimisation in the c code +#ie use tcl::string::map {\n ""} ... instead of tcl::string::map [list \n ""] ... +#note that we can use unicode (e.g \uFF31) and other escapes such as \t within these curly braces - we don't have to use double quotes +#generally using 'list' is preferred for the map as less error prone. +#can also use: tcl::string::map "token $var" .. but be careful regarding quoting and whitespace in var. This should be used sparingly if at all. + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[section API] + + +#Julian Noble - 2003 +#Released under standard 'BSD license' conditions. +# +#todo - ellipsis truncation indicator for center,right + +#v1.4 2023-07 - naive ansi color handling - todo - fix tcl::string::range +# - need to extract and replace ansi codes? + +tcl::namespace::eval overtype { + namespace import ::punk::assertion::assert + punk::assertion::active true + + namespace path ::punk::lib + + namespace export * + variable default_ellipsis_horizontal "..." ;#fallback + variable default_ellipsis_vertical "..." + tcl::namespace::eval priv { + proc _init {} { + upvar ::overtype::default_ellipsis_horizontal e_h + upvar ::overtype::default_ellipsis_vertical e_v + set e_h [format %c 0x2026] ;#Unicode Horizontal Ellipsis + set e_v [format %c 0x22EE] + #The unicode ellipsis looks more natural than triple-dash which is centred vertically whereas ellipsis is at floorline of text + #Also - unicode ellipsis has semantic meaning that other processors can interpret + #unicode does also provide a midline horizontal ellipsis 0x22EF + + #set e [format %c 0x2504] ;#punk::char::charshort boxd_ltdshhz - Box Drawings Light Triple Dash Horizontal + #if {![catch {package require punk::char}]} { + # set e [punk::char::charshort boxd_ltdshhz] + #} + } + } + priv::_init +} +proc overtype::about {} { + return "Simple text formatting. Author JMN. BSD-License" +} + +tcl::namespace::eval overtype { + variable grapheme_widths [tcl::dict::create] + + variable escape_terminals + #single "final byte" in the range 0x40–0x7E (ASCII @A–Z[\]^_`a–z{|}~). + tcl::dict::set escape_terminals CSI [list @ \\ ^ _ ` | ~ 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 "\{" "\}"] + #tcl::dict::set escape_terminals CSI [list J K m n A B C D E F G s u] ;#basic + tcl::dict::set escape_terminals OSC [list \007 \033\\] ;#note mix of 1 and 2-byte terminals + + #self-contained 2 byte ansi escape sequences - review more? + variable ansi_2byte_codes_dict + set ansi_2byte_codes_dict [tcl::dict::create\ + "reset_terminal" "\u001bc"\ + "save_cursor_posn" "\u001b7"\ + "restore_cursor_posn" "\u001b8"\ + "cursor_up_one" "\u001bM"\ + "NEL - Next Line" "\u001bE"\ + "IND - Down one line" "\u001bD"\ + "HTS - Set Tab Stop" "\u001bH"\ + ] + + #debatable whether strip should reveal the somethinghidden - some terminals don't hide it anyway. + # "PM - Privacy Message" "\u001b^somethinghidden\033\\"\ +} + + + + +proc overtype::string_columns {text} { + if {[punk::ansi::ta::detect $text]} { + #error "error string_columns is for calculating character length of string - ansi codes must be stripped/rendered first e.g with punk::ansi::ansistrip. Alternatively try punk::ansi::printing_length" + set text [punk::ansi::ansistrip $text] + } + return [punk::char::ansifreestring_width $text] +} + +#todo - consider a way to merge overtype::left/centre/right +#These have similar algorithms/requirements - and should be refactored to be argument-wrappers over a function called something like overtype::renderblock +#overtype::renderblock could render the input to a defined (possibly overflowing in x or y) rectangle overlapping the underlay. +#(i.e not even necessariy having it's top left within the underlay) +tcl::namespace::eval overtype::priv { +} + +#could return larger than renderwidth +proc _get_row_append_column {row} { + #obsolete? + upvar outputlines outputlines + set idx [expr {$row -1}] + if {$row <= 1 || $row > [llength $outputlines]} { + return 1 + } else { + upvar opt_expand_right expand_right + upvar renderwidth renderwidth + set existinglen [punk::ansi::printing_length [lindex $outputlines $idx]] + set endpos [expr {$existinglen +1}] + if {$expand_right} { + return $endpos + } else { + if {$endpos > $renderwidth} { + return [expr {$renderwidth + 1}] + } else { + return $endpos + } + } + } +} + +tcl::namespace::eval overtype { + #*** !doctools + #[subsection {Namespace overtype}] + #[para] Core API functions for overtype + #[list_begin definitions] + + + + #tcl::string::range should generally be avoided for both undertext and overtext which contain ansi escapes and other cursor affecting chars such as \b and \r + #render onto an already-rendered (ansi already processed) 'underlay' string, a possibly ansi-laden 'overlay' string. + #The underlay and overlay can be multiline blocks of text of varying line lengths. + #The overlay may just be an ansi-colourised block - or may contain ansi cursor movements and cursor save/restore calls - in which case the apparent length and width of the overlay can't be determined as if it was a block of text. + #This is a single-shot rendering of strings - ie there is no way to chain another call containing a cursor-restore to previously rendered output and have it know about any cursor-saves in the first call. + # a cursor start position other than top-left is a possible addition to consider. + #see editbuf in punk::repl for a more stateful ansi-processor. Both systems use loops over overtype::renderline + proc renderspace {args} { + #*** !doctools + #[call [fun overtype::renderspace] [arg args] ] + #[para] usage: ?-transparent [lb]0|1[rb]? ?-expand_right [lb]1|0[rb]? ?-ellipsis [lb]1|0[rb]? ?-ellipsistext ...? undertext overtext + + # @c overtype starting at left (overstrike) + # @c can/should we use something like this?: 'format "%-*s" $len $overtext + variable default_ellipsis_horizontal + + if {[llength $args] < 2} { + error {usage: ?-width ? ?-startcolumn ? ?-transparent [0|1|]? ?-expand_right [1|0]? ?-ellipsis [1|0]? ?-ellipsistext ...? undertext overtext} + } + set optargs [lrange $args 0 end-2] + if {[llength $optargs] % 2 == 0} { + set overblock [lindex $args end] + set underblock [lindex $args end-1] + #lassign [lrange $args end-1 end] underblock overblock + set argsflags [lrange $args 0 end-2] + } else { + set optargs [lrange $args 0 end-1] + if {[llength $optargs] %2 == 0} { + set overblock [lindex $args end] + set underblock "" + set argsflags [lrange $args 0 end-1] + } else { + error "renderspace expects opt-val pairs followed by: or just " + } + } + set opts [tcl::dict::create\ + -bias ignored\ + -width \uFFEF\ + -height \uFFEF\ + -startcolumn 1\ + -ellipsis 0\ + -ellipsistext $default_ellipsis_horizontal\ + -ellipsiswhitespace 0\ + -expand_right 0\ + -appendlines 1\ + -transparent 0\ + -exposed1 \uFFFD\ + -exposed2 \uFFFD\ + -experimental 0\ + -cp437 0\ + -looplimit \uFFEF\ + -crm_mode 0\ + -reverse_mode 0\ + -insert_mode 0\ + -wrap 0\ + -info 0\ + -console {stdin stdout stderr}\ + ] + #expand_right is perhaps consistent with the idea of the page_size being allowed to grow horizontally.. + # it does not necessarily mean the viewport grows. (which further implies need for horizontal scrolling) + # - it does need to be within some concept of terminal width - as columns must be addressable by ansi sequences. + # - This implies the -width option value must grow if it is tied to the concept of renderspace terminal width! REVIEW. + # - further implication is that if expand_right grows the virtual renderspace terminal width - + # then some sort of reflow/rerender needs to be done for preceeding lines? + # possibly not - as expand_right is distinct from a normal terminal-width change event, + # expand_right being primarily to support other operations such as textblock::table + + #todo - viewport width/height as separate concept to terminal width/height? + #-ellipsis args not used if -wrap is true + foreach {k v} $argsflags { + switch -- $k { + -looplimit - -width - -height - -startcolumn - -bias - -ellipsis - -ellipsistext - -ellipsiswhitespace + - -transparent - -exposed1 - -exposed2 - -experimental + - -expand_right - -appendlines + - -reverse_mode - -crm_mode - -insert_mode + - -cp437 + - -info - -console { + tcl::dict::set opts $k $v + } + -wrap - -autowrap_mode { + #temp alias -autowrap_mode for consistency with renderline + #todo - + tcl::dict::set opts -wrap $v + } + default { + error "overtype::renderspace unknown option '$k'. Known options: [tcl::dict::keys $opts]" + } + } + } + #set opts [tcl::dict::merge $defaults $argsflags] + # -- --- --- --- --- --- + #review - expand_left for RTL text? + set opt_expand_right [tcl::dict::get $opts -expand_right] + #for repl - standard output line indicator is a dash - todo, add a different indicator for a continued line. + set opt_width [tcl::dict::get $opts -width] + set opt_height [tcl::dict::get $opts -height] + set opt_startcolumn [tcl::dict::get $opts -startcolumn] + set opt_appendlines [tcl::dict::get $opts -appendlines] + set opt_transparent [tcl::dict::get $opts -transparent] + set opt_ellipsistext [tcl::dict::get $opts -ellipsistext] + set opt_ellipsiswhitespace [tcl::dict::get $opts -ellipsiswhitespace] + set opt_exposed1 [tcl::dict::get $opts -exposed1] ;#widechar_exposed_left - todo + set opt_exposed2 [tcl::dict::get $opts -exposed2] ;#widechar_exposed_right - todo + # -- --- --- --- --- --- + set opt_crm_mode [tcl::dict::get $opts -crm_mode] + set opt_reverse_mode [tcl::dict::get $opts -reverse_mode] + set opt_insert_mode [tcl::dict::get $opts -insert_mode] + ##### + # review -wrap should map onto DECAWM terminal mode - the wrap 2 idea may not fit in with this?. + set opt_autowrap_mode [tcl::dict::get $opts -wrap] + #??? wrap 1 is hard wrap cutting word at exact column, or 1 column early for 2w-glyph, wrap 2 is for language-based word-wrap algorithm (todo) + ##### + # -- --- --- --- --- --- + set opt_cp437 [tcl::dict::get $opts -cp437] + set opt_info [tcl::dict::get $opts -info] + + + + # ---------------------------- + # -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 + } + } + } + # ---------------------------- + + set underblock [tcl::string::map {\r\n \n} $underblock] + set overblock [tcl::string::map {\r\n \n} $overblock] + + + #set underlines [split $underblock \n] + + #underblock is a 'rendered' block - so width height make sense + #only non-cursor affecting and non-width occupying ANSI codes should be present. + #ie SGR codes and perhaps things such as PM - although generally those should have been pushed to the application already + #renderwidth & renderheight were originally used with reference to rendering into a 'column' of output e.g a table column - before cursor row/col was implemented. + + if {$opt_width eq "\uFFEF" || $opt_height eq "\uFFEF"} { + lassign [blocksize $underblock] _w renderwidth _h renderheight + if {$opt_width ne "\uFFEF"} { + set renderwidth $opt_width + } + if {$opt_height ne "\uFFEF"} { + set renderheight $opt_height + } + } else { + set renderwidth $opt_width + set renderheight $opt_height + } + #initial state for renderspace 'terminal' reset + set initial_state [dict create\ + renderwidth $renderwidth\ + renderheight $renderheight\ + crm_mode $opt_crm_mode\ + reverse_mode $opt_reverse_mode\ + insert_mode $opt_insert_mode\ + autowrap_mode $opt_autowrap_mode\ + cp437 $opt_cp437\ + ] + #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 + + # -- --- --- --- + #REVIEW - do we need ansi resets in the underblock? + if {$underblock eq ""} { + set underlines [lrepeat $renderheight ""] + } else { + set underblock [textblock::join_basic -- $underblock] ;#ensure properly rendered - ansi per-line resets & replays + 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] + #} + # -- --- --- --- + + #todo - reconsider the 'line' as the natural chunking mechanism for the overlay. + #In practice an overlay ANSI stream can be a single line with ansi moves/restores etc - or even have no moves or newlines, just relying on wrapping at the output renderwidth + #In such cases - we process the whole shebazzle for the first output line - only reducing by the applied amount at the head each time, reprocessing the long tail each time. + #(in cases where there are interline moves or cursor jumps anyway) + #This works - but doesn't seem efficient. + #On the other hand.. maybe it depends on the data. For simpler files it's more efficient than splitting first + + #a hack until we work out how to avoid infinite loops... + # + set looplimit [tcl::dict::get $opts -looplimit] + if {$looplimit eq "\uFFEF"} { + #looping for each char is worst case (all newlines?) - anything over that is an indication of something broken? + #do we need any margin above the length? (telnet mapscii.me test) + set looplimit [expr {[tcl::string::length $overblock] + 10}] + } + + #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 $overblock] + } + 1 { + set inputchunks [punk::ansi::ta::split_codes $overblock] + } + 2 { + + #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 { + #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 + } + if {[llength $lflines]} { + lset lflines end [tcl::string::range [lindex $lflines end] 0 end-1] + } + #set inputchunks $lflines[unset lflines] + set inputchunks [lindex [list $lflines [unset lflines]] 0] + + } + 4 { + set inputchunks [list] + foreach ln [split $overblock \n] { + lappend inputchunks $ln\n + } + if {[llength $inputchunks]} { + lset inputchunks end [tcl::string::range [lindex $inputchunks end] 0 end-1] + } + } + } + + + + + set replay_codes_underlay [tcl::dict::create 1 ""] + #lappend replay_codes_overlay "" + set replay_codes_overlay "[punk::ansi::a]" + set unapplied "" + set cursor_saved_position [tcl::dict::create] + set cursor_saved_attributes "" + + + 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] + + set loop 0 + #while {$overidx < [llength $inputchunks]} { } + + while {[llength $inputchunks]} { + #set overtext [lindex $inputchunks $overidx]; lset inputchunks $overidx "" + set overtext [lpop inputchunks 0] + if {![tcl::string::length $overtext]} { + incr loop + continue + } + #puts "----->[ansistring VIEW -lf 1 -vt 1 -nul 1 $overtext]<----" + set undertext [lindex $outputlines [expr {$row -1}]] + set renderedrow $row + + #renderline pads each underaly line to width with spaces and should track where end of data is + + + #set overtext [tcl::string::cat [lindex $replay_codes_overlay $overidx] $overtext] + set overtext $replay_codes_overlay$overtext + 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\ + -cp437 $opt_cp437\ + -info 1\ + -crm_mode [tcl::dict::get $vtstate crm_mode]\ + -insert_mode [tcl::dict::get $vtstate insert_mode]\ + -autowrap_mode [tcl::dict::get $vtstate autowrap_mode]\ + -reverse_mode [tcl::dict::get $vtstate reverse_mode]\ + -cursor_restore_attributes $cursor_saved_attributes\ + -transparent $opt_transparent\ + -width [tcl::dict::get $vtstate renderwidth]\ + -exposed1 $opt_exposed1\ + -exposed2 $opt_exposed2\ + -expand_right $opt_expand_right\ + -cursor_column $col\ + -cursor_row $row\ + ] + set rinfo [renderline {*}$renderopts $undertext $overtext] + + set instruction [tcl::dict::get $rinfo instruction] + tcl::dict::set vtstate crm_mode [tcl::dict::get $rinfo crm_mode] + tcl::dict::set vtstate insert_mode [tcl::dict::get $rinfo insert_mode] + tcl::dict::set vtstate autowrap_mode [tcl::dict::get $rinfo autowrap_mode] ;# + tcl::dict::set vtstate reverse_mode [tcl::dict::get $rinfo reverse_mode] + #how to support reverse_mode in rendered linelist? we need to examine all pt/code blocks and flip each SGR stack? + # - review - the answer is probably that we don't need to - it is set/reset only during application of overtext + + #Note carefully the difference betw overflow_right and unapplied. + #overflow_right may need to be included in next run before the unapplied data + #overflow_right most commonly has data when in insert_mode + set rendered [tcl::dict::get $rinfo result] + set overflow_right [tcl::dict::get $rinfo overflow_right] + set overflow_right_column [tcl::dict::get $rinfo overflow_right_column] + set unapplied [tcl::dict::get $rinfo unapplied] + set unapplied_list [tcl::dict::get $rinfo unapplied_list] + set post_render_col [tcl::dict::get $rinfo cursor_column] + set post_render_row [tcl::dict::get $rinfo cursor_row] + set c_saved_pos [tcl::dict::get $rinfo cursor_saved_position] + set c_saved_attributes [tcl::dict::get $rinfo cursor_saved_attributes] + 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] + 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] + set replay_codes_overlay [tcl::dict::get $rinfo replay_codes_overlay] + if {0 && [tcl::dict::get $vtstate reverse_mode]} { + #test branch - todo - prune + puts stderr "---->[ansistring VIEW $replay_codes_overlay] rendered: $rendered" + #review + #JMN3 + set existing_reverse_state 0 + #split_codes_single is single esc sequence - but could have multiple sgr codes within one esc sequence + #e.g \x1b\[0;31;7m has a reset,colour red and reverse + set codeinfo [punk::ansi::codetype::sgr_merge [list $replay_codes_overlay] -info 1] + set codestate_reverse [dict get $codeinfo codestate reverse] + switch -- $codestate_reverse { + 7 { + set existing_reverse_state 1 + } + 27 { + set existing_reverse_state 0 + } + "" { + } + } + if {$existing_reverse_state == 0} { + set rflip [a+ reverse] + } else { + #reverse of reverse + set rflip [a+ noreverse] + } + #note that mergeresult can have multiple esc (due to unmergeables or non sgr codes) + set replay_codes_overlay [punk::ansi::codetype::sgr_merge [list [dict get $codeinfo mergeresult] $rflip]] + puts stderr "---->[ansistring VIEW $replay_codes_overlay] rendered: $rendered" + } + + + + #-- todo - detect looping properly + if {$row > 1 && $overtext ne "" && $unapplied eq $overtext && $post_render_row == $row && $instruction eq ""} { + puts stderr "overtype::renderspace loop?" + puts [ansistring VIEW $rinfo] + break + } + #-- + + if {[tcl::dict::size $c_saved_pos] >= 1} { + set cursor_saved_position $c_saved_pos + set cursor_saved_attributes $c_saved_attributes + } + + + set overflow_handled 0 + + + + set nextprefix "" + + + #todo - handle potential insertion mode as above for cursor restore? + #keeping separate branches for debugging - review and merge as appropriate when stable + set instruction_type [lindex $instruction 0] ;#some instructions have params + tcl::dict::incr instruction_stats $instruction_type + switch -- $instruction_type { + reset { + #reset the 'renderspace terminal' (not underlying terminal) + set row 1 + set col 1 + 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 + if {![llength $unapplied_list]} { + if {$overflow_right ne ""} { + incr row + } + } else { + puts stderr "renderspace end of input line - has unapplied: [ansistring VIEW $unapplied] (review)" + } + set col $opt_startcolumn + } + up { + + #renderline knows it's own line number, and knows not to go above row l + #it knows that a move whilst 1-beyond the width conflicts with the linefeed and reduces the move by one accordingly. + #row returned should be correct. + #column may be the overflow column - as it likes to report that to the caller. + + #Note that an ansi up sequence after last column going up to a previous line and also beyond the last column, will result in the next grapheme going onto the following line. + #this seems correct - as the column remains beyond the right margin so subsequent chars wrap (?) review + #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 + } + down { + if {$data_mode == 0} { + #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]}] + if {$diff > 0} { + lappend outputlines {*}[lrepeat $diff ""] + } + lappend outputlines "" + } + } + set row $post_render_row + set col $post_render_col + } else { + if {$post_render_row > [llength $outputlines]} { + if {$opt_appendlines} { + set diff [expr {$post_render_row - [llength $outputlines]}] + if {$diff > 0} { + lappend outputlines {*}[lrepeat $diff ""] + } + lappend outputlines "" + } + } + 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 + } + + } + } + 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] + #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 + set replay_codes_overlay [tcl::dict::get $rinfo replay_codes_overlay]$cursor_saved_attributes + #set replay_codes_overlay $cursor_saved_attributes + set cursor_saved_position [tcl::dict::create] + set cursor_saved_attributes "" + } else { + #TODO + #?restore without save? + #should move to home position and reset ansi SGR? + #puts stderr "overtype::renderspace cursor_restore without save data available" + } + #If we were inserting prior to hitting the cursor_restore - there could be overflow_right data - generally the overtype functions aren't for inserting - but ansi can enable it + #if we were already in overflow when cursor_restore was hit - it shouldn't have been processed as an action - just stored. + if {!$overflow_handled && $overflow_right ne ""} { + #wrap before restore? - possible effect on saved cursor position + #this overflow data has previously been rendered so has no cursor movements or further save/restore operations etc + #we can just insert another call to renderline to solve this.. ? + #It would perhaps be more properly handled as a queue of instructions from our initial renderline call + #we don't need to worry about overflow next call (?)- but we should carry forward our gx and ansi stacks + + puts stdout ">>>[a+ red bold]overflow_right during restore_cursor[a]" + + set sub_info [overtype::renderline\ + -info 1\ + -width [tcl::dict::get $vtstate renderwidth]\ + -insert_mode [tcl::dict::get $vtstate insert_mode]\ + -autowrap_mode [tcl::dict::get $vtstate autowrap_mode]\ + -expand_right [tcl::dict::get $opts -expand_right]\ + ""\ + $overflow_right\ + ] + set foldline [tcl::dict::get $sub_info result] + tcl::dict::set vtstate insert_mode [tcl::dict::get $sub_info insert_mode] ;#probably not needed..? + tcl::dict::set vtstate autowrap_mode [tcl::dict::get $sub_info autowrap_mode] ;#nor this.. + linsert outputlines $renderedrow $foldline + #review - row & col set by restore - but not if there was no save.. + } + set overflow_handled 1 + + } + move { + ######## + if {$post_render_row > [llength $outputlines]} { + #Ansi moves need to create new lines ? + #if {$opt_appendlines} { + # set diff [expr {$post_render_row - [llength $outputlines]}] + # if {$diff > 0} { + # lappend outputlines {*}[lrepeat $diff ""] + # } + # set row $post_render_row + #} else { + set row [llength $outputlines] + #} + } else { + set row $post_render_row + } + ####### + set col $post_render_col + #overflow + unapplied? + } + clear_and_move { + #e.g 2J + if {$post_render_row > [llength $outputlines]} { + set row [llength $outputlines] + } else { + set row $post_render_row + } + set 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 \000 $renderwidth]\x1b\[0m + if 0 { + + 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"} { + incr numcells 1 + } else { + incr numcells [grapheme_width_cached $grapheme] + } + } + } + + } + } + } + #replays/resets each line + lappend clearedlines \x1b\[0m$replay_codes_overlay[string repeat \000 $numcells]\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] + + } + lf_start { + #raw newlines + # ---------------------- + #test with fruit.ans + #test - treating as newline below... + #append rendered $overflow_right + #set overflow_right "" + set row $renderedrow + incr row + if {$row > [llength $outputlines]} { + lappend outputlines "" + } + set col $opt_startcolumn + # ---------------------- + } + lf_mid { + + set edit_mode 0 + if {$edit_mode} { + set inputchunks [linsert $inputchunks 0 $overflow_right$unapplied] + set overflow_right "" + set unapplied "" + set row $post_render_row + #set col $post_render_col + set col $opt_startcolumn + if {$row > [llength $outputlines]} { + lappend outputlines {*}[lrepeat 1 ""] + } + } 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] + set overflow_right "" + set 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 + } + } + set overflow_right [join $remaining_overflow ""] + } + } + } + } + set row $post_render_row + set col $opt_startcolumn + if {$row > [llength $outputlines]} { + lappend outputlines {*}[lrepeat 1 ""] + } + } 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 ""] + } + } + } + } + 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 + } + + 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 ""] + } + set col $opt_startcolumn + + } + newlines_above { + #we get a newlines_above instruction when received at column 1 + #In some cases we want to treat that as request to insert a new blank line above, and move our row 1 down (staying with the data) + #in other cases - we want to treat at column 1 the same as any other + + 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 + if {$insert_lines_above > 0} { + set row $renderedrow + set outputlines [linsert $outputlines $renderedrow-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 + #? set row $post_render_row #can renderline tell us? + } + } + 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 + # + + + set overflow_right "" + set row $renderedrow + #only add newline if we're at the bottom + if {$row > [llength $outputlines]} { + 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]}] + if {$diff > 0} { + lappend outputlines {*}[lrepeat $diff ""] + } + 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 + } + } + } + } + wrapmoveforward { + #doesn't seem to be used by fruit.ans testfile + #used by dzds.ans + #note that cursor_forward may move deep into the next line - or even span multiple lines !TODO + set c $renderwidth + set r $post_render_row + if {$post_render_col > $renderwidth} { + set i $c + while {$i <= $post_render_col} { + if {$c == $renderwidth+1} { + incr r + if {$opt_appendlines} { + if {$r < [llength $outputlines]} { + lappend outputlines "" + } + } + set c $opt_startcolumn + } else { + incr c + } + incr i + } + set col $c + } else { + #why are we getting this instruction then? + puts stderr "wrapmoveforward - test" + set r [expr {$post_render_row +1}] + set c $post_render_col + } + set row $r + set col $c + } + wrapmovebackward { + set c $renderwidth + set r $post_render_row + if {$post_render_col < 1} { + set c 1 + set i $c + while {$i >= $post_render_col} { + if {$c == 0} { + if {$r > 1} { + incr r -1 + set c $renderwidth + } else { + #leave r at 1 set c 1 + #testfile besthpav.ans first line top left border alignment + set c 1 + break + } + } else { + incr c -1 + } + incr i -1 + } + set col $c + } else { + puts stderr "Wrapmovebackward - but postrendercol >= 1???" + } + set row $r + set col $c + } + overflow { + #normal single-width grapheme overflow + #puts "----normal overflow --- [ansistring VIEWSTYLE -lf 1 -nul 1 -vt 1 $rendered]" + set row $post_render_row ;#renderline will not advance row when reporting overflow char + if {[tcl::dict::get $vtstate autowrap_mode]} { + incr row + set col $opt_startcolumn ;#whether wrap or not - next data is at column 1 ?? + } else { + set col $post_render_col + #set unapplied "" ;#this seems wrong? + #set unapplied [tcl::string::range $unapplied 1 end] + #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' + set idx 0 + set next_grapheme_index -1 + foreach u $unapplied_list { + if {![punk::ansi::ta::detect $u]} { + set next_grapheme_index $idx + break + } + incr idx + } + assert {$next_grapheme_index >= 0} + #drop the overflow grapheme - keeping all codes in place. + set unapplied [join [lreplace $unapplied_list $next_grapheme_index $next_grapheme_index] ""] + #we need to run the reduced unapplied on the same line - further graphemes will just overflow again, but codes or control chars could trigger jumps to other lines + + set overflow_handled 1 + #handled by dropping overflow if any + } + } + overflow_splitchar { + set row $post_render_row ;#renderline will not advance row when reporting overflow char + + #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 + if {[tcl::dict::get $vtstate autowrap_mode]} { + if {$renderwidth < 2} { + #edge case of rendering to a single column output - any 2w char will just cause a loop if we don't substitute with something, or drop the character + set idx 0 + set triggering_grapheme_index -1 + foreach u $unapplied_list { + if {![punk::ansi::ta::detect $u]} { + set triggering_grapheme_index $idx + break + } + incr idx + } + set unapplied [join [lreplace $unapplied_list $triggering_grapheme_index $triggering_grapheme_index $opt_exposed1] ""] + } else { + set col $opt_startcolumn + incr row + } + } else { + set overflow_handled 1 + #handled by dropping entire overflow if any + if {$renderwidth < 2} { + set idx 0 + set triggering_grapheme_index -1 + foreach u $unapplied_list { + if {![punk::ansi::ta::detect $u]} { + set triggering_grapheme_index $idx + break + } + incr idx + } + set unapplied [join [lreplace $unapplied_list $triggering_grapheme_index $triggering_grapheme_index $opt_exposed1] ""] + } + } + + } + vt { + + #can vt add a line like a linefeed can? + set row $post_render_row + set col $post_render_col + } + set_window_title { + set newtitle [lindex $instruction 1] + puts stderr "overtype::renderspace set_window_title [ansistring VIEW $newtitle] instruction '$instruction'" + # + } + reset_colour_palette { + puts stderr "overtype::renderspace instruction '$instruction' unimplemented" + } + default { + puts stderr "overtype::renderspace unhandled renderline instruction '$instruction'" + } + + } + + + if {!$opt_expand_right && ![tcl::dict::get $vtstate autowrap_mode]} { + #not allowed to overflow column or wrap therefore we get overflow data to truncate + if {[tcl::dict::get $opts -ellipsis]} { + set show_ellipsis 1 + if {!$opt_ellipsiswhitespace} { + #we don't want ellipsis if only whitespace was lost + set lostdata "" + if {$overflow_right ne ""} { + append lostdata $overflow_right + } + if {$unapplied ne ""} { + append lostdata $unapplied + } + if {[tcl::string::trim $lostdata] eq ""} { + set show_ellipsis 0 + } + #set lostdata [tcl::string::range $overtext end-[expr {$overflowlength-1}] end] + if {[tcl::string::trim [punk::ansi::ansistrip $lostdata]] eq ""} { + set show_ellipsis 0 + } + } + if {$show_ellipsis} { + set rendered [overtype::right $rendered $opt_ellipsistext] + } + set overflow_handled 1 + } else { + #no wrap - no ellipsis - silently truncate + set overflow_handled 1 + } + } + + + + if {$renderedrow <= [llength $outputlines]} { + lset outputlines [expr {$renderedrow-1}] $rendered + } else { + if {$opt_appendlines} { + lappend outputlines $rendered + } else { + #? + lset outputlines [expr {$renderedrow-1}] $rendered + } + } + + if {!$overflow_handled} { + append nextprefix $overflow_right + } + + append nextprefix $unapplied + + 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] + } + } + } + + if {$nextprefix ne ""} { + set inputchunks [linsert $inputchunks 0 $nextprefix] + } + + + incr overidx + incr loop + if {$loop >= $looplimit} { + puts stderr "overtype::renderspace looplimit reached ($looplimit)" + lappend outputlines "[a+ red bold] - looplimit $looplimit reached[a]" + set Y [a+ yellow bold] + set RST [a] + set sep_header ----DEBUG----- + 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" + tcl::dict::for {k v} $rinfo { + append debugmsg "${Y}$k [ansistring VIEW -lf 1 -vt 1 $v]$RST" \n + } + append debugmsg "${Y}[string repeat - [string length $sep_header]]$RST" \n + + puts stdout $debugmsg + #todo - config regarding error dumps rather than just dumping in working dir + set fd [open [pwd]/error_overtype.txt w] + puts $fd $debugmsg + close $fd + error $debugmsg + break + } + } + + set result [join $outputlines \n] + if {!$opt_info} { + return $result + } else { + #emit to debug window like basictelnet does? make debug configurable as syslog or even a telnet server to allow on 2nd window? + #append result \n$instruction_stats\n + set inforesult [dict create\ + result $result\ + last_instruction $instruction\ + instruction_stats $instruction_stats\ + ] + if {$opt_info == 2} { + return [pdict -channel none inforesult] + } else { + return $inforesult + } + } + } + + #todo - left-right ellipsis ? + proc centre {args} { + variable default_ellipsis_horizontal + if {[llength $args] < 2} { + error {usage: ?-transparent [0|1]? ?-bias [left|right]? ?-overflow [1|0]? undertext overtext} + } + + foreach {underblock overblock} [lrange $args end-1 end] break + + #todo - vertical vs horizontal overflow for blocks + set opts [tcl::dict::create\ + -bias left\ + -ellipsis 0\ + -ellipsistext $default_ellipsis_horizontal\ + -ellipsiswhitespace 0\ + -overflow 0\ + -transparent 0\ + -exposed1 \uFFFD\ + -exposed2 \uFFFD\ + ] + set argsflags [lrange $args 0 end-2] + foreach {k v} $argsflags { + switch -- $k { + -bias - -ellipsis - -ellipsistext - -ellipsiswhitespace - -overflow - -transparent - -exposed1 - -exposed2 { + tcl::dict::set opts $k $v + } + default { + set known_opts [tcl::dict::keys $opts] + error "overtype::centre unknown option '$k'. Known options: $known_opts" + } + } + } + #set opts [tcl::dict::merge $defaults $argsflags] + # -- --- --- --- --- --- + set opt_transparent [tcl::dict::get $opts -transparent] + set opt_ellipsis [tcl::dict::get $opts -ellipsis] + set opt_ellipsistext [tcl::dict::get $opts -ellipsistext] + set opt_ellipsiswhitespace [tcl::dict::get $opts -ellipsiswhitespace] + set opt_exposed1 [tcl::dict::get $opts -exposed1] + set opt_exposed2 [tcl::dict::get $opts -exposed2] + # -- --- --- --- --- --- + + + set underblock [tcl::string::map {\r\n \n} $underblock] + set overblock [tcl::string::map {\r\n \n} $overblock] + + set underlines [split $underblock \n] + #set renderwidth [tcl::mathfunc::max {*}[lmap v $underlines {punk::ansi::printing_length $v}]] + lassign [blocksize $underblock] _w renderwidth _h renderheight + set overlines [split $overblock \n] + lassign [blocksize $overblock] _w overblock_width _h overblock_height + set under_exposed_max [expr {$renderwidth - $overblock_width}] + if {$under_exposed_max > 0} { + #background block is wider + if {$under_exposed_max % 2 == 0} { + #even left/right exposure + set left_exposed [expr {$under_exposed_max / 2}] + } else { + set beforehalf [expr {$under_exposed_max / 2}] ;#1 less than half due to integer division + if {[tcl::string::tolower [tcl::dict::get $opts -bias]] eq "left"} { + set left_exposed $beforehalf + } else { + #bias to the right + set left_exposed [expr {$beforehalf + 1}] + } + } + } else { + set left_exposed 0 + } + + set outputlines [list] + if {[punk::ansi::ta::detect_sgr [lindex $overlines 0]]} { + set replay_codes "[punk::ansi::a]" + } else { + set replay_codes "" + } + set replay_codes_underlay "" + set replay_codes_overlay "" + foreach undertext $underlines overtext $overlines { + set overtext_datalen [punk::ansi::printing_length $overtext] + set ulen [punk::ansi::printing_length $undertext] + if {$ulen < $renderwidth} { + set udiff [expr {$renderwidth - $ulen}] + set undertext "$undertext[string repeat { } $udiff]" + } + set undertext $replay_codes_underlay$undertext + set overtext $replay_codes_overlay$overtext + + set overflowlength [expr {$overtext_datalen - $renderwidth}] + #review - right-to-left langs should elide on left! - extra option required + + if {$overflowlength > 0} { + #overlay line wider or equal + #review - we still expand_right for centred for now.. possibly should do something like -expand_leftright with ellipsis each end? + set rinfo [renderline -info 1 -insert_mode 0 -transparent $opt_transparent -expand_right [tcl::dict::get $opts -overflow] -exposed1 $opt_exposed1 -exposed2 $opt_exposed2 $undertext $overtext] + set rendered [tcl::dict::get $rinfo result] + set overflow_right [tcl::dict::get $rinfo overflow_right] + set unapplied [tcl::dict::get $rinfo unapplied] + #todo - get replay_codes from overflow_right instead of wherever it was truncated? + + #overlay line data is wider - trim if overflow not specified in opts - and overtype an ellipsis at right if it was specified + if {![tcl::dict::get $opts -overflow]} { + #lappend outputlines [tcl::string::range $overtext 0 [expr {$renderwidth - 1}]] + #set overtext [tcl::string::range $overtext 0 $renderwidth-1 ] + if {$opt_ellipsis} { + set show_ellipsis 1 + if {!$opt_ellipsiswhitespace} { + #we don't want ellipsis if only whitespace was lost + #don't use tcl::string::range on ANSI data + #set lostdata [tcl::string::range $overtext end-[expr {$overflowlength-1}] end] + set lostdata "" + if {$overflow_right ne ""} { + append lostdata $overflow_right + } + if {$unapplied ne ""} { + append lostdata $unapplied + } + if {[tcl::string::trim $lostdata] eq ""} { + set show_ellipsis 0 + } + } + if {$show_ellipsis} { + set rendered [overtype::right $rendered $opt_ellipsistext] + } + } + } + lappend outputlines $rendered + #lappend outputlines [renderline -insert_mode 0 -transparent $opt_transparent $undertext $overtext] + } else { + #background block is wider than or equal to data for this line + #lappend outputlines [renderline -insert_mode 0 -startcolumn [expr {$left_exposed + 1}] -transparent $opt_transparent -exposed1 $opt_exposed1 -exposed2 $opt_exposed2 $undertext $overtext] + set rinfo [renderline -info 1 -insert_mode 0 -startcolumn [expr {$left_exposed + 1}] -transparent $opt_transparent -exposed1 $opt_exposed1 -exposed2 $opt_exposed2 $undertext $overtext] + lappend outputlines [tcl::dict::get $rinfo result] + } + set replay_codes_underlay [tcl::dict::get $rinfo replay_codes_underlay] + set replay_codes_overlay [tcl::dict::get $rinfo replay_codes_overlay] + } + return [join $outputlines \n] + } + + #overtype::right is for a rendered ragged underblock and a rendered ragged overblock + #ie we can determine the block width for bost by examining the lines and picking the longest. + # + proc right {args} { + #NOT the same as align-right - which should be done to the overblock first if required + variable default_ellipsis_horizontal + # @d !todo - implement overflow, length checks etc + + if {[llength $args] < 2} { + error {usage: ?-overflow [1|0]? ?-transparent 0|? undertext overtext} + } + foreach {underblock overblock} [lrange $args end-1 end] break + + set opts [tcl::dict::create\ + -bias ignored\ + -ellipsis 0\ + -ellipsistext $default_ellipsis_horizontal\ + -ellipsiswhitespace 0\ + -overflow 0\ + -transparent 0\ + -exposed1 \uFFFD\ + -exposed2 \uFFFD\ + -align "left"\ + ] + set argsflags [lrange $args 0 end-2] + tcl::dict::for {k v} $argsflags { + switch -- $k { + -bias - -ellipsis - -ellipsistext - -ellipsiswhitespace - -overflow - -transparent - -exposed1 - -exposed2 - -align { + tcl::dict::set opts $k $v + } + default { + set known_opts [tcl::dict::keys $opts] + error "overtype::centre unknown option '$k'. Known options: $known_opts" + } + } + } + #set opts [tcl::dict::merge $defaults $argsflags] + # -- --- --- --- --- --- + set opt_transparent [tcl::dict::get $opts -transparent] + set opt_ellipsis [tcl::dict::get $opts -ellipsis] + set opt_ellipsistext [tcl::dict::get $opts -ellipsistext] + set opt_ellipsiswhitespace [tcl::dict::get $opts -ellipsiswhitespace] + set opt_overflow [tcl::dict::get $opts -overflow] + set opt_exposed1 [tcl::dict::get $opts -exposed1] + set opt_exposed2 [tcl::dict::get $opts -exposed2] + set opt_align [tcl::dict::get $opts -align] + # -- --- --- --- --- --- + + set underblock [tcl::string::map {\r\n \n} $underblock] + set overblock [tcl::string::map {\r\n \n} $overblock] + + set underlines [split $underblock \n] + lassign [blocksize $underblock] _w renderwidth _h renderheight + set overlines [split $overblock \n] + #set overblock_width [tcl::mathfunc::max {*}[lmap v $overlines {punk::ansi::printing_length $v}]] + lassign [blocksize $overblock] _w overblock_width _h overblock_height + set under_exposed_max [expr {max(0,$renderwidth - $overblock_width)}] + set left_exposed $under_exposed_max + + + + set outputlines [list] + if {[punk::ansi::ta::detect_sgr [lindex $overlines 0]]} { + set replay_codes "[punk::ansi::a]" + } else { + set replay_codes "" + } + set replay_codes_underlay "" + set replay_codes_overlay "" + foreach undertext $underlines overtext $overlines { + set overtext_datalen [punk::ansi::printing_length $overtext] + set ulen [punk::ansi::printing_length $undertext] + if {$ulen < $renderwidth} { + set udiff [expr {$renderwidth - $ulen}] + #puts xxx + append undertext [string repeat { } $udiff] + } + if {$overtext_datalen < $overblock_width} { + set odiff [expr {$overblock_width - $overtext_datalen}] + switch -- $opt_align { + left { + set startoffset 0 + } + right { + set startoffset $odiff + } + default { + set half [expr {$odiff / 2}] + #set lhs [string repeat { } $half] + #set righthalf [expr {$odiff - $half}] ;#remainder - may be one more - so we are biased left + #set rhs [string repeat { } $righthalf] + set startoffset $half + } + } + } else { + set startoffset 0 ;#negative? + } + + set undertext $replay_codes_underlay$undertext + set overtext $replay_codes_overlay$overtext + + set overflowlength [expr {$overtext_datalen - $renderwidth}] + if {$overflowlength > 0} { + #raw overtext wider than undertext column + set rinfo [renderline\ + -info 1\ + -insert_mode 0\ + -transparent $opt_transparent\ + -exposed1 $opt_exposed1 -exposed2 $opt_exposed2\ + -overflow $opt_overflow\ + -startcolumn [expr {1 + $startoffset}]\ + $undertext $overtext] + set replay_codes [tcl::dict::get $rinfo replay_codes] + set rendered [tcl::dict::get $rinfo result] + if {!$opt_overflow} { + if {$opt_ellipsis} { + set show_ellipsis 1 + if {!$opt_ellipsiswhitespace} { + #we don't want ellipsis if only whitespace was lost + set lostdata [tcl::string::range $overtext end-[expr {$overflowlength-1}] end] + if {[tcl::string::trim $lostdata] eq ""} { + set show_ellipsis 0 + } + } + if {$show_ellipsis} { + set ellipsis $replay_codes$opt_ellipsistext + #todo - overflow on left if allign = right?? + set rendered [overtype::right $rendered $ellipsis] + } + } + } + lappend outputlines $rendered + } else { + #padded overtext + #lappend outputlines [renderline -insert_mode 0 -transparent $opt_transparent -startcolumn [expr {$left_exposed + 1}] $undertext $overtext] + #Note - we still need overflow(exapnd_right) here - as although the overtext is short - it may oveflow due to the startoffset + set rinfo [renderline -info 1 -insert_mode 0 -transparent $opt_transparent -expand_right $opt_overflow -startcolumn [expr {$left_exposed + 1 + $startoffset}] $undertext $overtext] + lappend outputlines [tcl::dict::get $rinfo result] + } + set replay_codes [tcl::dict::get $rinfo replay_codes] + set replay_codes_underlay [tcl::dict::get $rinfo replay_codes_underlay] + set replay_codes_overlay [tcl::dict::get $rinfo replay_codes_overlay] + } + + return [join $outputlines \n] + } + + proc left {args} { + overtype::block -blockalign left {*}$args + } + #overtype a (possibly ragged) underblock with a (possibly ragged) overblock + proc block {args} { + variable default_ellipsis_horizontal + # @d !todo - implement overflow, length checks etc + + if {[llength $args] < 2} { + error {usage: ?-blockalign left|centre|right? ?-textalign left|centre|right? ?-overflow [1|0]? ?-transparent 0|? undertext overtext} + } + #foreach {underblock overblock} [lrange $args end-1 end] break + lassign [lrange $args end-1 end] underblock overblock + + set opts [tcl::dict::create\ + -ellipsis 0\ + -ellipsistext $default_ellipsis_horizontal\ + -ellipsiswhitespace 0\ + -overflow 0\ + -transparent 0\ + -exposed1 \uFFFD\ + -exposed2 \uFFFD\ + -textalign "left"\ + -textvertical "top"\ + -blockalign "left"\ + -blockalignbias left\ + -blockvertical "top"\ + ] + set argsflags [lrange $args 0 end-2] + tcl::dict::for {k v} $argsflags { + switch -- $k { + -blockalignbias - -ellipsis - -ellipsistext - -ellipsiswhitespace - -overflow - -transparent - -exposed1 - -exposed2 - -textalign - -blockalign - -blockvertical { + tcl::dict::set opts $k $v + } + default { + error "overtype::block unknown option '$k'. Known options: [tcl::dict::keys $opts]" + } + } + } + # -- --- --- --- --- --- + set opt_transparent [tcl::dict::get $opts -transparent] + set opt_ellipsis [tcl::dict::get $opts -ellipsis] + set opt_ellipsistext [tcl::dict::get $opts -ellipsistext] + set opt_ellipsiswhitespace [tcl::dict::get $opts -ellipsiswhitespace] + set opt_overflow [tcl::dict::get $opts -overflow] + set opt_exposed1 [tcl::dict::get $opts -exposed1] + set opt_exposed2 [tcl::dict::get $opts -exposed2] + set opt_textalign [tcl::dict::get $opts -textalign] + set opt_blockalign [tcl::dict::get $opts -blockalign] + if {$opt_blockalign eq "center"} { + set opt_blockalign "centre" + } + # -- --- --- --- --- --- + + set underblock [tcl::string::map {\r\n \n} $underblock] + set overblock [tcl::string::map {\r\n \n} $overblock] + + set underlines [split $underblock \n] + lassign [blocksize $underblock] _w renderwidth _h renderheight + set overlines [split $overblock \n] + #set overblock_width [tcl::mathfunc::max {*}[lmap v $overlines {punk::ansi::printing_length $v}]] + lassign [blocksize $overblock] _w overblock_width _h overblock_height + set under_exposed_max [expr {max(0,$renderwidth - $overblock_width)}] + + switch -- $opt_blockalign { + left { + set left_exposed 0 + } + right { + set left_exposed $under_exposed_max + } + centre { + if {$under_exposed_max > 0} { + #background block is wider + if {$under_exposed_max % 2 == 0} { + #even left/right exposure + set left_exposed [expr {$under_exposed_max / 2}] + } else { + set beforehalf [expr {$under_exposed_max / 2}] ;#1 less than half due to integer division + if {[tcl::string::tolower [tcl::dict::get $opts -blockalignbias]] eq "left"} { + set left_exposed $beforehalf + } else { + #bias to the right + set left_exposed [expr {$beforehalf + 1}] + } + } + } else { + set left_exposed 0 + } + } + default { + set left_exposed 0 + } + } + + + + set outputlines [list] + if {[punk::ansi::ta::detect_sgr [lindex $overlines 0]]} { + set replay_codes "[punk::ansi::a]" + } else { + set replay_codes "" + } + set replay_codes_underlay "" + set replay_codes_overlay "" + foreach undertext $underlines overtext $overlines { + set overtext_datalen [punk::ansi::printing_length $overtext] + set ulen [punk::ansi::printing_length $undertext] + if {$ulen < $renderwidth} { + set udiff [expr {$renderwidth - $ulen}] + #puts xxx + append undertext [string repeat { } $udiff] + } + if {$overtext_datalen < $overblock_width} { + set odiff [expr {$overblock_width - $overtext_datalen}] + switch -- $opt_textalign { + left { + set startoffset 0 + } + right { + set startoffset $odiff + } + default { + set half [expr {$odiff / 2}] + #set lhs [string repeat { } $half] + #set righthalf [expr {$odiff - $half}] ;#remainder - may be one more - so we are biased left + #set rhs [string repeat { } $righthalf] + set startoffset $half + } + } + } else { + set startoffset 0 ;#negative? + } + + set undertext $replay_codes_underlay$undertext + set overtext $replay_codes_overlay$overtext + + set overflowlength [expr {$overtext_datalen - $renderwidth}] + if {$overflowlength > 0} { + #raw overtext wider than undertext column + set rinfo [renderline -info 1 -insert_mode 0 -transparent $opt_transparent -exposed1 $opt_exposed1 -exposed2 $opt_exposed2 -expand_right $opt_overflow -startcolumn [expr {1 + $startoffset}] $undertext $overtext] + set replay_codes [tcl::dict::get $rinfo replay_codes] + set rendered [tcl::dict::get $rinfo result] + set overflow_right [tcl::dict::get $rinfo overflow_right] + set unapplied [tcl::dict::get $rinfo unapplied] + if {!$opt_overflow} { + if {$opt_ellipsis} { + set show_ellipsis 1 + if {!$opt_ellipsiswhitespace} { + #we don't want ellipsis if only whitespace was lost + #don't use tcl::string::range on ANSI data + #set lostdata [tcl::string::range $overtext end-[expr {$overflowlength-1}] end] + set lostdata "" + if {$overflow_right ne ""} { + append lostdata $overflow_right + } + if {$unapplied ne ""} { + append lostdata $unapplied + } + if {[tcl::string::trim $lostdata] eq ""} { + set show_ellipsis 0 + } + } + if {$show_ellipsis} { + set rendered [overtype::block -blockalign right $rendered $opt_ellipsistext] + } + } + + #if {$opt_ellipsis} { + # set show_ellipsis 1 + # if {!$opt_ellipsiswhitespace} { + # #we don't want ellipsis if only whitespace was lost + # set lostdata [tcl::string::range $overtext end-[expr {$overflowlength-1}] end] + # if {[tcl::string::trim $lostdata] eq ""} { + # set show_ellipsis 0 + # } + # } + # if {$show_ellipsis} { + # set ellipsis [tcl::string::cat $replay_codes $opt_ellipsistext] + # #todo - overflow on left if allign = right?? + # set rendered [overtype::right $rendered $ellipsis] + # } + #} + } + lappend outputlines $rendered + } else { + #padded overtext + #lappend outputlines [renderline -insert_mode 0 -transparent $opt_transparent -startcolumn [expr {$left_exposed + 1}] $undertext $overtext] + #Note - we still need expand_right here - as although the overtext is short - it may oveflow due to the startoffset + set rinfo [renderline -info 1 -insert_mode 0 -transparent $opt_transparent -expand_right $opt_overflow -startcolumn [expr {$left_exposed + 1 + $startoffset}] $undertext $overtext] + #puts stderr "--> [ansistring VIEW -lf 1 -nul 1 $rinfo] <--" + set overflow_right [tcl::dict::get $rinfo overflow_right] + set unapplied [tcl::dict::get $rinfo unapplied] + lappend outputlines [tcl::dict::get $rinfo result] + } + set replay_codes [tcl::dict::get $rinfo replay_codes] + set replay_codes_underlay [tcl::dict::get $rinfo replay_codes_underlay] + set replay_codes_overlay [tcl::dict::get $rinfo replay_codes_overlay] + } + + return [join $outputlines \n] + } + + variable optimise_ptruns 10 ;# can be set to zero to disable the ptruns branches + + # ## ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### + # renderline written from a left-right line orientation perspective as a first-shot at getting something useful. + # ultimately right-to-left, top-to-bottom and bottom-to-top are probably needed. + # ## ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### + # + # + #-returnextra enables returning of overflow and length + #review - use punk::ansi::ta::detect to short-circuit processing and do simpler string calcs as an optimisation? + #review - DECSWL/DECDWL double width line codes - very difficult/impossible to align and compose with other elements + #(could render it by faking it with sixels and a lot of work - find/make a sixel font and ensure it's exactly 2 cols per char? + # This would probably be impractical to support for different fonts) + #todo - review transparency issues with single/double width characters + #bidi - need a base direction and concept of directional runs for RTL vs LTR - may be best handled at another layer? + proc renderline {args} { + #*** !doctools + #[call [fun overtype::renderline] [arg args] ] + #[para] renderline is the core engine for overtype string processing (frames & textblocks), and the raw mode commandline repl for the Tcl Punk Shell + #[para] It is also a central part of an ansi (micro) virtual terminal-emulator of sorts + #[para] This system does a half decent job at rendering 90's ANSI art to manipulable colour text blocks that can be joined & framed for layout display within a unix or windows terminal + #[para] Renderline helps maintain ANSI text styling reset/replay codes so that the styling of one block doesn't affect another. + #[para] Calling on the punk::ansi library - it can coalesce codes to keep the size down. + #[para] It is a giant mess of doing exactly what common wisdom says not to do... lots at once. + #[para] renderline is part of the Unicode and ANSI aware Overtype system which 'renders' a block of text onto a static underlay + #[para] The underlay is generally expected to be an ordered set of lines or a rectangular text block analogous to a terminal screen - but it can also be ragged in line length, or just blank. + #[para] The overlay couuld be similar - in which case it may often be used to overwrite a column or section of the underlay. + #[para] The overlay could however be a sequence of ANSI-laden text that jumps all over the place. + # + #[para] renderline itself only deals with a single line - or sometimes a single character. It is generally called from a loop that does further terminal-like or textblock processing. + #[para] By suppyling the -info 1 option - it can return various fields indicating the state of the render. + #[para] The main 3 are the result, overflow_right, and unapplied. + #[para] Renderline handles cursor movements from either keystrokes or ANSI sequences but for a full system the aforementioned loop will need to be in place to manage the set of lines under manipulation. + + #puts stderr "renderline '$args'" + variable optimise_ptruns + + if {[llength $args] < 2} { + error {usage: ?-info 0|1? ?-startcolumn ? ?-cursor_column ? ?-cursor_row |""? ?-transparent [0|1|]? ?-expand_right [1|0]? undertext overtext} + } + set under [lindex $args end-1] + set over [lindex $args end] + #lassign [lrange $args end-1 end] under over + if {[string last \n $under] >= 0} { + error "overtype::renderline not allowed to contain newlines in undertext" + } + #if {[string first \n $over] >=0 || [string first \n $under] >= 0} { + # error "overtype::renderline not allowed to contain newlines" + #} + + #generally faster to create a new dict in the proc than to use a namespace variable to create dict once and link to variable (2024 8.6/8.7) + set opts [tcl::dict::create\ + -etabs 0\ + -width \uFFEF\ + -expand_right 0\ + -transparent 0\ + -startcolumn 1\ + -cursor_column 1\ + -cursor_row ""\ + -insert_mode 1\ + -crm_mode 0\ + -autowrap_mode 1\ + -reverse_mode 0\ + -info 0\ + -exposed1 \uFFFD\ + -exposed2 \uFFFD\ + -cursor_restore_attributes ""\ + -cp437 0\ + -experimental {}\ + ] + #-cursor_restore_attributes only - for replay stack - position and actual setting/restoring handled by throwback to caller + + #cursor_row, when numeric will allow detection of certain row moves that are still within our row - allowing us to avoid an early return + #An empty string for cursor_row tells us we have no info about our own row context, and to return with an unapplied string if any row move occurs + + #exposed1 and exposed2 for first and second col of underying 2wide char which is truncated by transparency, currsor movements to 2nd charcol, or overflow/expand_right + #todo - return info about such grapheme 'cuts' in -info structure and/or create option to raise an error + + 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 + - -crm_mode - -insert_mode - -autowrap_mode - -reverse_mode + - -info - -exposed1 - -exposed2 - -cursor_restore_attributes { + tcl::dict::set opts $k $v + } + default { + error "overtype::renderline unknown option '$k'. Known options: [tcl::dict::keys $opts]" + } + } + } + # -- --- --- --- --- --- --- --- --- --- --- --- + set opt_width [tcl::dict::get $opts -width] + set opt_etabs [tcl::dict::get $opts -etabs] + set opt_expand_right [tcl::dict::get $opts -expand_right] + set opt_colstart [tcl::dict::get $opts -startcolumn] ;#lhs limit for overlay - an offset to cursor_column - first visible column is 1. 0 or < 0 are before the start of the underlay + set opt_colcursor [tcl::dict::get $opts -cursor_column];#start cursor column relative to overlay + set opt_row_context [tcl::dict::get $opts -cursor_row] + if {[string length $opt_row_context]} { + if {![tcl::string::is integer -strict $opt_row_context] || $opt_row_context <1 } { + error "overtype::renderline -cursor_row must be empty for unspecified/unknown or a non-zero positive integer. received: '$opt_row_context'" + } + } + # -- --- --- --- --- --- --- --- --- --- --- --- + #The _mode flags correspond to terminal modes that can be set/reset via escape sequences (e.g DECAWM wraparound mode) + set opt_insert_mode [tcl::dict::get $opts -insert_mode];#should usually be 1 for each new line in editor mode but must be initialised to 1 externally (review) + #default is for overtype + # -- --- --- --- --- --- --- --- --- --- --- --- + set opt_autowrap_mode [tcl::dict::get $opts -autowrap_mode] ;#DECAWM - char or movement can go beyond leftmost/rightmost col to prev/next line + set opt_reverse_mode [tcl::dict::get $opts -reverse_mode] ;#DECSNM + set opt_crm_mode [tcl::dict::get $opts -crm_mode];# CRM - show control character mode + # -- --- --- --- --- --- --- --- --- --- --- --- + set temp_cursor_saved [tcl::dict::get $opts -cursor_restore_attributes] + + set cp437_glyphs [tcl::dict::get $opts -cp437] + set cp437_map [tcl::dict::create] + if {$cp437_glyphs} { + set cp437_map [set ::punk::ansi::cp437_map] + #for cp437 images we need to map these *after* splitting ansi + #some old files might use newline for its glyph.. but we can't easily support that. + #Not sure how old files did it.. maybe cr lf in sequence was newline and any lone cr or lf were displayed as glyphs? + tcl::dict::unset cp437_map \n + } + + set opt_transparent [tcl::dict::get $opts -transparent] + if {$opt_transparent eq "0"} { + set do_transparency 0 + } else { + set do_transparency 1 + if {$opt_transparent eq "1"} { + set opt_transparent {[\s]} + } + } + # -- --- --- --- --- --- --- --- --- --- --- --- + set opt_returnextra [tcl::dict::get $opts -info] + # -- --- --- --- --- --- --- --- --- --- --- --- + set opt_exposed1 [tcl::dict::get $opts -exposed1] + set opt_exposed2 [tcl::dict::get $opts -exposed2] + # -- --- --- --- --- --- --- --- --- --- --- --- + + if {$opt_row_context eq ""} { + set cursor_row 1 + } else { + set cursor_row $opt_row_context + } + + set insert_mode $opt_insert_mode ;#default 1 + set autowrap_mode $opt_autowrap_mode ;#default 1 + set crm_mode $opt_crm_mode ;#default 0 (Show Control Character mode) + set reverse_mode $opt_reverse_mode + + #----- + # + if {[info exists punk::console::tabwidth]} { + #punk console is updated if punk::console::set_tabstop_width is used or rep is started/restarted + #It is way too slow to test the current width by querying the terminal here - so it could conceivably get out of sync + #todo - we also need to handle the new threaded repl where console config is in a different thread. + # - also - concept of sub-regions being mini-consoles with their own settings - 'id' for console, or use in/out channels as id? + set tw $::punk::console::tabwidth + } else { + set tw 8 + } + + set overdata $over + if {!$cp437_glyphs} { + #REVIEW! tabify will give different answers for an ANSI colourised string vs plain text + if {!$opt_etabs} { + if {[string first \t $under] >= 0} { + #set under [textutil::tabify::untabify2 $under] + set under [textutil::tabify::untabifyLine $under $tw] + } + if {[string first \t $over] >= 0} { + #set overdata [textutil::tabify::untabify2 $over] + set overdata [textutil::tabify::untabifyLine $over $tw] + } + } + } + #------- + + #ta_detect ansi and do simpler processing? + + #we repeat tests for grapheme width in different loops - rather than create another datastructure to store widths based on column, + #we'll use the grapheme_width_cached function as a lookup table of all graphemes encountered - as there will often be repeats in different positions anyway. + + # -- --- --- --- --- --- --- --- + if {$under ne ""} { + if {[punk::ansi::ta::detect $under]} { + set undermap [punk::ansi::ta::split_codes_single $under] + } else { + #single plaintext part + set undermap [list $under] + } + } else { + set undermap [list] + } + set understacks [list] + set understacks_gx [list] + set pm_list [list] + + set i_u -1 ;#underlay may legitimately be empty + set undercols [list] + set u_codestack [list] + #u_gx_stack probably isn't really a stack - I don't know if g0 g1 can stack or not - for now we support only g0 anyway + set u_gx_stack [list] ;#separate stack for g0 (g1 g2 g3?) graphics on and off (DEC special graphics) + #set pt_underchars "" ;#for string_columns length calculation for expand_right 0 truncation + set remainder [list] ;#for returnextra + foreach {pt code} $undermap { + #pt = plain text + #append pt_underchars $pt + if {$pt ne ""} { + if {$cp437_glyphs} { + set pt [tcl::string::map $cp437_map $pt] + } + set is_ptrun 0 + if {$optimise_ptruns && [tcl::string::length $pt] >= $optimise_ptruns} { + set p1 [tcl::string::index $pt 0] + set hex [format %x [scan $p1 %c]] ;#punk::char::char_hex + set re [tcl::string::cat {^[} \\U$hex {]+$}] + set is_ptrun [regexp $re $pt] + } + if {$is_ptrun} { + #switch -- $p1 { + # " " - - - _ - ! - @ - # - $ - % - ^ - & - * - = - + - : - . - , - / - | - ? - + # 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 { + # set width 1 + # } + # default { + # if {$p1 eq "\u0000"} { + # #use null as empty cell representation - review + # #use of this will probably collide with some application at some point + # #consider an option to set the empty cell character + # set width 1 + # } else { + # set width [grapheme_width_cached $p1] ;# when zero??? + # } + # } + #} + set width [grapheme_width_cached $p1] ;# when zero??? + set ptlen [string length $pt] + if {$width <= 1} { + #review - 0 and 1? + incr i_u $ptlen + lappend understacks {*}[lrepeat $ptlen $u_codestack] + lappend understacks_gx {*}[lrepeat $ptlen $u_gx_stack] + lappend undercols {*}[lrepeat $ptlen $p1] + } else { + incr i_u $ptlen ;#2nd col empty str - so same as above + set 2ptlen [expr {$ptlen * 2}] + lappend understacks {*}[lrepeat $2ptlen $u_codestack] + lappend understacks_gx {*}[lrepeat $2ptlen $u_gx_stack] + set l [concat {*}[lrepeat $ptlen [list $p1 ""]]] + lappend undercols {*}$l + unset l + } + + } else { + foreach grapheme [punk::char::grapheme_split $pt] { + #an ugly but easy hack to serve *some* common case ascii quickly with byte-compiled literal switch - feels dirty. + #.. but even 0.5uS per char (grapheme_width_cached) adds up quickly when stitching lots of lines together. + #todo - test decimal value instead, compare performance + 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 { + set width 1 + } + default { + if {$grapheme eq "\u0000"} { + #use null as empty cell representation - review + #use of this will probably collide with some application at some point + #consider an option to set the empty cell character + set width 1 + } else { + #zero width still acts as 1 below??? review what should happen + set width [grapheme_width_cached $grapheme] + #we still want most controls and other zero-length codepoints such as \u200d (zero width joiner) to stay zero-length + #we substitute lone ESC that weren't captured within ANSI context as a debugging aid to see malformed ANSI + #todo - default to off and add a flag (?) to enable this substitution + set sub_stray_escapes 0 + if {$sub_stray_escapes && $width == 0} { + if {$grapheme eq "\x1b"} { + set gvis [ansistring VIEW $grapheme] ;#can only use with graphemes that have a single replacement char.. + set grapheme $gvis + set width 1 + } + } + } + } + } + + #set width [grapheme_width_cached $grapheme] + incr i_u + lappend understacks $u_codestack + lappend understacks_gx $u_gx_stack + + lappend undercols $grapheme + if {$width > 1} { + #presumably there are no triple-column or wider unicode chars.. until the aliens arrive.(?) + #but what about emoji combinations etc - can they be wider than 2? + #todo - if -etabs enabled - then we treat \t as the width determined by our elastic tabstop + incr i_u + lappend understacks $u_codestack + lappend understacks_gx $u_gx_stack + lappend undercols "" + } + } + + } + } + #underlay should already have been rendered and not have non-sgr codes - but let's retain the check for them and not stack them if other codes are here + + #only stack SGR (graphics rendition) codes - not title sets, cursor moves etc + #keep any remaining PMs in place + if {$code ne ""} { + set c1c2 [tcl::string::range $code 0 1] + + set leadernorm [tcl::string::range [tcl::string::map [list\ + \x1b\[ 7CSI\ + \x9b 8CSI\ + \x1b\( 7GFX\ + \x1b^ 7PMX\ + \x1bX 7SOS\ + ] $c1c2] 0 3];# leadernorm is 1st 2 chars mapped to normalised indicator - or is original 2 chars + + switch -- $leadernorm { + 7CSI - 8CSI { + #need to exclude certain leaders after the lb e.g < for SGR 1006 mouse + #REVIEW - what else could end in m but be mistaken as a normal SGR code here? + set maybemouse "" + if {[tcl::string::index $c1c2 0] eq "\x1b"} { + set maybemouse [tcl::string::index $code 2] + } + + if {$maybemouse ne "<" && [tcl::string::index $code end] eq "m"} { + if {[punk::ansi::codetype::is_sgr_reset $code]} { + set u_codestack [list "\x1b\[m"] + } elseif {[punk::ansi::codetype::has_sgr_leadingreset $code]} { + set u_codestack [list $code] + } else { + #basic simplification first.. straight dups + set dup_posns [lsearch -all -exact $u_codestack $code] ;#-exact because of square-bracket glob chars + set u_codestack [lremove $u_codestack {*}$dup_posns] + lappend u_codestack $code + } + } + } + 7GFX { + switch -- [tcl::string::index $code 2] { + "0" { + set u_gx_stack [list gx0_on] ;#we'd better use a placeholder - or debugging will probably get into a big mess + } + B { + set u_gx_stack [list] + } + } + } + 7PMX - 7SOS { + #we can have PMs or SOS (start of string) in the underlay - though mostly the PMs should have been processed.. + #attach the PM/SOS (entire ANSI sequence) to the previous grapheme! + #It should not affect the size - but terminal display may get thrown out if terminal doesn't support them. + + #note that there may in theory already be ANSI stored - we don't assume it was a pure grapheme string + set graphemeplus [lindex $undercols end] + if {$graphemeplus ne "\0"} { + append graphemeplus $code + } else { + set graphemeplus $code + } + lset undercols end $graphemeplus + #The grapheme_width_cached function will be called on this later - and doesn't account for ansi. + #we need to manually cache the item with it's proper width + variable grapheme_widths + #stripped and plus version keys pointing to same length + dict set grapheme_widths $graphemeplus [grapheme_width_cached [::punk::ansi::ansistrip $graphemeplus]] + + } + default { + + } + + } + + #if {[punk::ansi::codetype::is_sgr_reset $code]} { + # #set u_codestack [list] + #} elseif {[punk::ansi::codetype::has_sgr_leadingreset $code]} { + #} elseif {[punk::ansi::codetype::is_sgr $code]} { + #} else { + # #leave SGR stack as is + # if {[punk::ansi::codetype::is_gx_open $code]} { + # } elseif {[punk::ansi::codetype::is_gx_close $code]} { + # } + #} + } + #consider also if there are other codes that should be stacked..? + } + + #NULL empty cell indicator + if {$opt_width ne "\uFFEF"} { + if {[llength $understacks]} { + set cs $u_codestack + set gs $u_gx_stack + } else { + set cs [list] + set gs [list] + } + if {[llength $undercols]< $opt_width} { + set diff [expr {$opt_width- [llength $undercols]}] + if {$diff > 0} { + #set undercols [list {*}$undercols {*}[lrepeat $diff "\u0000"]] ;#2024 - much slower + lappend undercols {*}[lrepeat $diff "\u0000"] + lappend understacks {*}[lrepeat $diff $cs] + lappend understacks_gx {*}[lrepeat $diff $gs] + } + } + } + + if {$opt_width ne "\uFFEF"} { + set renderwidth $opt_width + } else { + set renderwidth [llength $undercols] + } + + + if 0 { + # ----------------- + # if we aren't extending understacks & understacks_gx each time we incr idx above the undercols length.. this doesn't really serve a purpose + # Review. + # ----------------- + #replay code for last overlay position in input line + # whether or not we get that far - we need to return it for possible replay on next line + if {[llength $understacks]} { + lappend understacks $u_codestack + lappend understacks_gx $u_gx_stack + } else { + #in case overlay onto emptystring as underlay + lappend understacks [list] + lappend understacks_gx [list] + } + # ----------------- + } + + #trailing codes in effect for underlay + if {[llength $u_codestack]} { + #set replay_codes_underlay [join $u_codestack ""] + set replay_codes_underlay [punk::ansi::codetype::sgr_merge_list {*}$u_codestack] + } else { + set replay_codes_underlay "" + } + + + # -- --- --- --- --- --- --- --- + #### + #if opt_colstart - we need to build a space (or any singlewidth char ?) padding on the left containing the right number of columns. + #this will be processed as transparent - and handle doublewidth underlay characters appropriately + set startpadding [string repeat " " [expr {$opt_colstart -1}]] + #overdata with left padding spaces based on col-start under will show through for left-padding portion regardless of -transparency + if {$startpadding ne "" || $overdata ne ""} { + if {[punk::ansi::ta::detect $overdata]} { + set overmap [punk::ansi::ta::split_codes_single $startpadding$overdata] + } else { + #single plaintext part + set overmap [list $startpadding$overdata] + } + } else { + set overmap [list] + } + #### + + + #todo - detect plain ascii no-ansi input line (aside from leading ansi reset) + #will that allow some optimisations? + + #todo - detect repeated transparent char in overlay + #regexp {^(.)\1+$} ;#backtracking regexp - relatively slow. + # - try set c [string index $data 0]; regexp [string map [list %c% $c] {^[%c%]+$}] $data + #we should be able to optimize to pass through the underlay?? + + #??? + set colcursor $opt_colstart + #TODO - make a little virtual column object + #we need to refer to column1 or columnmin? or columnmax without calculating offsets due to to startcolumn + #need to lock-down what start column means from perspective of ANSI codes moving around - the offset perspective is unclear and a mess. + + + #set re_diacritics {[\u0300-\u036f]+|[\u1ab0-\u1aff]+|[\u1dc0-\u1dff]+|[\u20d0-\u20ff]+|[\ufe20-\ufe2f]+} + #as at 2024-02 punk::char::grapheme_split uses these - not aware of more complex graphemes + + set overstacks [list] + set overstacks_gx [list] + + set o_codestack [list]; #SGR codestack (not other codes such as movement,insert key etc) + set o_gxstack [list] + set pt_overchars "" + set i_o 0 + set overlay_grapheme_control_list [list] ;#tag each with g, sgr or other. 'other' are things like cursor-movement or insert-mode or codes we don't recognise/use + #experiment + set overlay_grapheme_control_stacks [list] + foreach {pt code} $overmap { + if {$pt ne ""} { + #todo - wrap in test for empty pt (we used split_codes_single - and it may be common for sgr sequences to be unmerged and so have empty pts between) + if {$cp437_glyphs} { + set pt [tcl::string::map $cp437_map $pt] + } + append pt_overchars $pt + #will get empty pt between adjacent codes + if {!$crm_mode} { + + set is_ptrun 0 + if {$optimise_ptruns && [tcl::string::length $pt] >= $optimise_ptruns} { + set p1 [tcl::string::index $pt 0] + set re [tcl::string::cat {^[} \\U[format %x [scan $p1 %c]] {]+$}] + set is_ptrun [regexp $re $pt] + + #leading only? we would have to check for graphemes at the trailing boundary? + #set re [tcl::string::cat {^[} \\U[format %x [scan $p1 %c]] {]+}] + #set is_ptrun [regexp -indices $re $pt runrange] + #if {$is_ptrun && 1} { + #} + } + if {$is_ptrun} { + #review - in theory a run over a certain length won't be part of some grapheme combo (graphemes can be long e.g 44?, but not as runs(?)) + #could be edge cases for runs at line end? (should be ok as we include trailing \n in our data) + set len [string length $pt] + set g_element [list g $p1] + + #lappend overstacks {*}[lrepeat $len $o_codestack] + #lappend overstacks_gx {*}[lrepeat $len $o_gxstack] + #incr i_o $len + #lappend overlay_grapheme_control_list {*}[lrepeat $len [list g $p1]] + #lappend overlay_grapheme_control_stacks {*}[lrepeat $len $o_codestack] + + set pi 0 + incr i_o $len + while {$pi < $len} { + lappend overstacks $o_codestack + lappend overstacks_gx $o_gxstack + lappend overlay_grapheme_control_list $g_element + lappend overlay_grapheme_control_stacks $o_codestack + incr pi + } + } else { + foreach grapheme [punk::char::grapheme_split $pt] { + lappend overstacks $o_codestack + lappend overstacks_gx $o_gxstack + incr i_o + lappend overlay_grapheme_control_list [list g $grapheme] + lappend overlay_grapheme_control_stacks $o_codestack + } + } + } else { + set tsbegin [clock micros] + foreach grapheme_original [punk::char::grapheme_split $pt] { + set pt_crm [ansistring VIEW -nul 1 -lf 2 -vt 2 -ff 2 $grapheme_original] + #puts stderr "ptlen [string length $pt] graphemelen[string length $grapheme_original] pt_crmlen[string length $pt_crm] $pt_crm" + foreach grapheme [punk::char::grapheme_split $pt_crm] { + if {$grapheme eq "\n"} { + lappend overlay_grapheme_control_stacks $o_codestack + lappend overlay_grapheme_control_list [list crmcontrol "\x1b\[00001E"] + } else { + lappend overstacks $o_codestack + lappend overstacks_gx $o_gxstack + incr i_o + lappend overlay_grapheme_control_list [list g $grapheme] + lappend overlay_grapheme_control_stacks $o_codestack + } + } + } + set elapsed [expr {[clock micros] - $tsbegin}] + puts stderr "ptlen [string length $pt] elapsedus:$elapsed" + } + } + + #only stack SGR (graphics rendition) codes - not title sets, cursor moves etc + #order of if-else based on assumptions: + # that pure resets are fairly common - more so than leading resets with other info + # that non-sgr codes are not that common, so ok to check for resets before verifying it is actually SGR at all. + if {$code ne ""} { + #we need to immediately set crm_mode here if \x1b\[3h received + if {$code eq "\x1b\[3h"} { + set crm_mode 1 + } elseif {$code eq "\x1b\[3l"} { + set crm_mode 0 + } + #else crm_mode could be set either way from options + if {$crm_mode && $code ne "\x1b\[00001E"} { + #treat the code as type 'g' like above - only allow through codes to reset mode REVIEW for now just \x1b\[3l ? + #we need to somehow convert further \n in the graphical rep to an instruction for newline that will bypass further crm_mode processing or we would loop. + set code_as_pt [ansistring VIEW -nul 1 -lf 1 -vt 1 -ff 1 $code] + #split using standard split for first foreach loop - grapheme based split when processing 2nd foreach loop + set chars [split $code_as_pt ""] + set codeparts [list] ;#list of 2-el lists each element {crmcontrol } or {g } + foreach c $chars { + if {$c eq "\n"} { + #use CNL (cursor next line) \x1b\[00001E ;#leading zeroes ok for this processor - used as debugging aid to distinguish + lappend codeparts [list crmcontrol "\x1b\[00001E"] + } else { + if {[llength $codeparts] > 0 && [lindex $codeparts end 0] eq "g"} { + set existing [lindex $codeparts end 1] + lset codeparts end [list g [string cat $existing $c]] + } else { + lappend codeparts [list g $c] + } + } + } + + set partidx 0 + foreach record $codeparts { + lassign $record rtype rval + switch -exact -- $rtype { + g { + append pt_overchars $rval + foreach grapheme [punk::char::grapheme_split $rval] { + lappend overstacks $o_codestack + lappend overstacks_gx $o_gxstack + incr i_o + lappend overlay_grapheme_control_list [list g $grapheme] + lappend overlay_grapheme_control_stacks $o_codestack + } + } + crmcontrol { + #leave o_codestack + lappend overlay_grapheme_control_stacks $o_codestack + lappend overlay_grapheme_control_list [list crmcontrol $rval] + } + } + } + } else { + lappend overlay_grapheme_control_stacks $o_codestack + #there will always be an empty code at end due to foreach on 2 vars with odd-sized list ending with pt (overmap coming from perlish split) + if {[punk::ansi::codetype::is_sgr_reset $code]} { + set o_codestack [list "\x1b\[m"] ;#reset better than empty list - fixes some ansi art issues + lappend overlay_grapheme_control_list [list sgr $code] + } elseif {[punk::ansi::codetype::has_sgr_leadingreset $code]} { + set o_codestack [list $code] + lappend overlay_grapheme_control_list [list sgr $code] + } elseif {[priv::is_sgr $code]} { + #basic simplification first - remove straight dupes + set dup_posns [lsearch -all -exact $o_codestack $code] ;#must be -exact because of square-bracket glob chars + set o_codestack [lremove $o_codestack {*}$dup_posns] + lappend o_codestack $code + lappend overlay_grapheme_control_list [list sgr $code] + } elseif {[regexp {\x1b7|\x1b\[s} $code]} { + #experiment + #cursor_save - for the replays review. + #jmn + #set temp_cursor_saved [punk::ansi::codetype::sgr_merge_list {*}$o_codestack] + lappend overlay_grapheme_control_list [list other $code] + } elseif {[regexp {\x1b8|\x1b\[u} $code]} { + #experiment + #cursor_restore - for the replays + set o_codestack [list $temp_cursor_saved] + lappend overlay_grapheme_control_list [list other $code] + } else { + #review + if {[punk::ansi::codetype::is_gx_open $code]} { + set o_gxstack [list "gx0_on"] + lappend overlay_grapheme_control_list [list gx0 gx0_on] ;#don't store code - will complicate debugging if we spit it out and jump character sets + } elseif {[punk::ansi::codetype::is_gx_close $code]} { + set o_gxstack [list] + lappend overlay_grapheme_control_list [list gx0 gx0_off] ;#don't store code - will complicate debugging if we spit it out and jump character sets + } else { + lappend overlay_grapheme_control_list [list other $code] + } + } + } + } + + } + #replay code for last overlay position in input line - should take account of possible trailing sgr code after last grapheme + set max_overlay_grapheme_index [expr {$i_o -1}] + lappend overstacks $o_codestack + lappend overstacks_gx $o_gxstack + + #set replay_codes_overlay [join $o_codestack ""] + set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}$o_codestack] + + #if {[tcl::dict::exists $overstacks $max_overlay_grapheme_index]} { + # set replay_codes_overlay [join [tcl::dict::get $overstacks $max_overlay_grapheme_index] ""] + #} else { + # set replay_codes_overlay "" + #} + # -- --- --- --- --- --- --- --- + + + #potential problem - combinining diacritics directly following control chars like \r \b + + # -- --- --- + #we need to initialise overflow_idx before any potential row-movements - as they need to perform a loop break and force in_excess to 1 + if {$opt_expand_right} { + #expand_right true means we can have lines as long as we want, but either way there can be excess data that needs to be thrown back to the calling loop. + #we currently only support horizontal expansion to the right (review regarding RTL text!) + set overflow_idx -1 + } else { + #expand_right zero - we can't grow beyond our column width - so we get ellipsis or truncation + if {$opt_width ne "\uFFEF"} { + set overflow_idx [expr {$opt_width}] + } else { + #review - this is also the cursor position when adding a char at end of line? + set overflow_idx [expr {[llength $undercols]}] ;#index at which we would be *in* overflow a row move may still override it + } + } + # -- --- --- + + set outcols $undercols ;#leave undercols as is, outcols can potentially be appended to. + + set unapplied "" ;#if we break for move row (but not for /v ?) + set unapplied_list [list] + + set insert_lines_above 0 ;#return key + set insert_lines_below 0 + set instruction "" + + # -- --- --- + #cursor_save_dec, cursor_restore_dec etc + set cursor_restore_required 0 + set cursor_saved_attributes "" + set cursor_saved_position "" + # -- --- --- + + #set idx 0 ;# line index (cursor - 1) + #set idx [expr {$opt_colstart + $opt_colcursor} -1] + + #idx is the per column output index + set idx [expr {$opt_colcursor -1}] ;#don't use opt_colstart here - we have padded and won't start emitting until idx reaches opt_colstart-1 + #cursor_column is usually one above idx - but we have opt_colstart which is like a margin - todo: remove cursor_column from the following loop and calculate it's offset when breaking or at end. + #(for now we are incrementing/decrementing both in sync - which is a bit silly) + set cursor_column $opt_colcursor + + #idx_over is the per grapheme overlay index + set idx_over -1 + + + #movements only occur within the overlay range. + #an underlay is however not necessary.. e.g + #renderline -expand_right 1 "" data + + #set re_mode {\x1b\[\?([0-9]*)(h|l)} ;#e.g DECAWM + #set re_col_move {\x1b\[([0-9]*)(C|D|G)$} + #set re_row_move {\x1b\[([0-9]*)(A|B)$} + #set re_both_move {\x1b\[([0-9]*)(?:;){0,1}([0-9]*)H$} ;# or "f" ? + #set re_vt_sequence {\x1b\[([0-9]*)(?:;){0,1}([0-9]*)~$} + #set re_cursor_save {\x1b\[s$} ;#note probable incompatibility with DECSLRM (set left right margin)! + #set re_cursor_restore {\x1b\[u$} + #set re_cursor_save_dec {\x1b7$} + #set re_cursor_restore_dec {\x1b8$} + #set re_other_single {\x1b(D|M|E)$} + #set re_decstbm {\x1b\[([0-9]*)(?:;){0,1}([0-9]*)r$} ;#DECSTBM set top and bottom margins + + #puts "-->$overlay_grapheme_control_list<--" + #puts "-->overflow_idx: $overflow_idx" + for {set gci 0} {$gci < [llength $overlay_grapheme_control_list]} {incr gci} { + set gc [lindex $overlay_grapheme_control_list $gci] + lassign $gc type item + + #emit plaintext chars first using existing SGR codes from under/over stack as appropriate + #then check if the following code is a cursor movement within the line and adjust index if so + #foreach ch $overlay_graphemes {} + switch -- $type { + g { + set ch $item + #crm_mode affects both graphic and control + if {0 && $crm_mode} { + set chars [ansistring VIEW -nul 1 -lf 2 -vt 2 -ff 2 $ch] + set chars [string map [list \n "\x1b\[00001E"] $chars] + if {[llength [split $chars ""]] > 1} { + priv::render_unapplied $overlay_grapheme_control_list $gci + #prefix the unapplied controls with the string version of this control + set unapplied_list [linsert $unapplied_list 0 {*}[split $chars ""]] + set unapplied [join $unapplied_list ""] + #incr idx_over + break + } else { + set ch $chars + } + } + incr idx_over; #idx_over (until unapplied reached anyway) is per *grapheme* in the overlay - not per col. + if {($idx < ($opt_colstart -1))} { + incr idx [grapheme_width_cached $ch] + continue + } + #set within_undercols [expr {$idx <= [llength $undercols]-1}] ;#within our active data width + set within_undercols [expr {$idx <= $renderwidth-1}] + + #https://www.enigma.com/resources/blog/the-secret-world-of-newline-characters + #\x85 NEL in the c1 control set is treated by some terminal emulators (e.g Hyper) as a newline, + #on some it's invisble but doesn't change the line, on some it's a visible glyph of width 1. + #This is hard to process in any standard manner - but I think the Hyper behaviour of doing what it was intended is perhaps most reasonable + #We will map it to the same behaviour as lf here for now... but we need also to consider the equivalent ANSI sequence: \x1bE + + set chtest [tcl::string::map [list \n \x85 \b \r \v \x7f ] $ch] + #puts --->chtest:$chtest + #specials - each shoud have it's own test of what to do if it happens after overflow_idx reached + switch -- $chtest { + "" { + set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] + if {$idx == 0} { + #puts "---a at col 1" + #linefeed at column 1 + #leave the overflow_idx ;#? review + set instruction lf_start ;#specific instruction for newline at column 1 + priv::render_unapplied $overlay_grapheme_control_list $gci + break + } elseif {$overflow_idx != -1 && $idx == $overflow_idx} { + #linefeed after final column + #puts "---c at overflow_idx=$overflow_idx" + incr cursor_row + set overflow_idx $idx ;#override overflow_idx even if it was set to -1 due to expand_right = 1 + set instruction lf_overflow ;#only special treatment is to give it it's own instruction in case caller needs to handle differently + priv::render_unapplied $overlay_grapheme_control_list $gci + break + } else { + #linefeed occurred in middle or at end of text + #puts "---mid-or-end-text-linefeed idx:$idx overflow_idx:$overflow_idx" + if {$insert_mode == 0} { + incr cursor_row + if {$idx == -1 || $overflow_idx > $idx} { + #don't set overflow_idx higher if it's already set lower and we're adding graphemes to overflow + set overflow_idx $idx ;#override overflow_idx even if it was set to -1 due to expand_right = 1 + } + set instruction lf_mid + priv::render_unapplied $overlay_grapheme_control_list $gci + break + } else { + incr cursor_row + #don't adjust the overflow_idx + priv::render_unapplied $overlay_grapheme_control_list $gci + set instruction lf_mid + break ;# could have overdata following the \n - don't keep processing + } + } + + } + "" { + #will we want/need to use raw for keypresses in terminal? (terminal with LNM in standard reset mode means enter= this is the usual config for terminals) + #So far we are assuming the caller has translated to and handle above.. REVIEW. + + #consider also the old space-carriagereturn softwrap convention used in some terminals. + #In the context of rendering to a block of text - this works similarly in that the space gets eaten so programs emitting space-cr at the terminal width col will pretty much get what they expect. + set idx [expr {$opt_colstart -1}] + set cursor_column $opt_colstart ;#? + } + "" { + #literal backspace char - not necessarily from keyboard + #review - backspace effect on double-width chars - we are taking a column-editing perspective in overtype + #(important for -transparent option - hence replacement chars for half-exposed etc) + #review - overstrike support as per nroff/less (generally considered an old technology replaced by unicode mechanisms and/or ansi SGR) + if {$idx > ($opt_colstart -1)} { + incr idx -1 + incr cursor_column -1 + } else { + set flag 0 + if $flag { + #review - conflicting requirements? Need a different sequence for destructive interactive backspace? + priv::render_unapplied $overlay_grapheme_control_list $gci + set instruction backspace_at_start + break + } + } + } + "" { + #literal del character - some terminals send just this for what is generally expected to be a destructive backspace + #We instead treat this as a pure delete at current cursor position - it is up to the repl or terminal to remap backspace key to a sequence that has the desired effect. + priv::render_delchar $idx + } + "" { + #end processing this overline. rest of line is remainder. cursor for column as is. + #REVIEW - this theoretically depends on terminal's vertical tabulation setting (name?) + #e.g it could be configured to jump down 6 rows. + #On the other hand I've seen indications that some modern terminal emulators treat it pretty much as a linefeed. + #todo? + incr cursor_row + set overflow_idx $idx + #idx_over has already been incremented as this is both a movement-control and in some sense a grapheme + priv::render_unapplied $overlay_grapheme_control_list $gci + set instruction vt + break + } + default { + if {$overflow_idx != -1} { + #review - how to check arbitrary length item such as tab is going to overflow .. before we get to overflow_idx? + #call grapheme_width_cached on each ch, or look for tab specifically as it's currently the only known reason to have a grapheme width > 2? + #we need to decide what a tab spanning the overflow_idx means and how it affects wrap etc etc + if {$idx == $overflow_idx-1} { + set owidth [grapheme_width_cached $ch] + if {$owidth == 2} { + #review split 2w overflow? + #we don't want to make the decision here to split a 2w into replacement characters at end of line and beginning of next line + #better to consider the overlay char as unable to be applied to the line + #render empty column(?) - and reduce overlay grapheme index by one so that the current ch goes into unapplied + #throwing back to caller with instruction complicates its job - but is necessary to avoid making decsions for it here. + priv::render_addchar $idx "" [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode + #change the overflow_idx + set overflow_idx $idx + incr idx + incr idx_over -1 ;#set overlay grapheme index back one so that sgr stack from previous overlay grapheme used + priv::render_unapplied $overlay_grapheme_control_list [expr {$gci-1}] ;#note $gci-1 instead of just gci + #throw back to caller's loop - add instruction to caller as this is not the usual case + #caller may for example choose to render a single replacement char to this line and omit the grapheme, or wrap it to the next line + set instruction overflow_splitchar + break + } elseif {$owidth > 2} { + #? tab? + #TODO! + puts stderr "overtype::renderline long overtext grapheme '[ansistring VIEW -lf 1 -vt 1 $ch]' not handled" + #tab of some length dependent on tabstops/elastic tabstop settings? + } + } elseif {$idx >= $overflow_idx} { + #REVIEW + set next_gc [lindex $overlay_grapheme_control_list $gci+1] ;#next grapheme or control + lassign $next_gc next_type next_item + if {$autowrap_mode || $next_type ne "g"} { + set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci-1]] + #set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] + #don't incr idx beyond the overflow_idx + #idx_over already incremented - decrement so current overlay grapheme stacks go to unapplied + incr idx_over -1 + #priv::render_unapplied $overlay_grapheme_control_list [expr {$gci-1}] ;#back one index here too + priv::render_this_unapplied $overlay_grapheme_control_list $gci ;# + set instruction overflow + break + } else { + #no point throwing back to caller for each grapheme that is overflowing + #without this branch - renderline would be called with overtext reducing only by one grapheme per call + #processing a potentially long overtext each time (ie - very slow) + set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] + #JMN4 + + } + } + } else { + #review. + #overflow_idx = -1 + #This corresponds to expand_right being true (at least until overflow_idx is in some cases forced to a value when throwing back to calling loop) + } + + if {($do_transparency && [regexp $opt_transparent $ch])} { + #pre opt_colstart is effectively transparent (we have applied padding of required number of columns to left of overlay) + if {$idx > [llength $outcols]-1} { + lappend outcols " " + #tcl::dict::set understacks $idx [list] ;#review - use idx-1 codestack? + #lset understacks $idx [list] ;#will get index $i out of range error + lappend understacks [list] ;#REVIEW + incr idx + incr cursor_column + } else { + #todo - punk::char::char_width + set g [lindex $outcols $idx] + #JMN + set uwidth [grapheme_width_cached $g] + if {[lindex $outcols $idx] eq ""} { + #2nd col of 2-wide char in underlay + incr idx + incr cursor_column + } elseif {$uwidth == 0} { + #e.g control char ? combining diacritic ? + incr idx + incr cursor_column + } elseif {$uwidth == 1} { + set owidth [grapheme_width_cached $ch] + incr idx + incr cursor_column + if {$owidth > 1} { + incr idx + incr cursor_column + } + } elseif {$uwidth > 1} { + if {[grapheme_width_cached $ch] == 1} { + if {!$insert_mode} { + #normal singlewide transparent overlay onto double-wide underlay + set next_pt_overchar [tcl::string::index $pt_overchars $idx_over+1] ;#lookahead of next plain-text char in overlay + if {$next_pt_overchar eq ""} { + #special-case trailing transparent - no next_pt_overchar + incr idx + incr cursor_column + } else { + if {[regexp $opt_transparent $next_pt_overchar]} { + incr idx + incr cursor_column + } else { + #next overlay char is not transparent.. first-half of underlying 2wide char is exposed + #priv::render_addchar $idx $opt_exposed1 [tcl::dict::get $overstacks $idx_over] [tcl::dict::get $overstacks_gx $idx_over] $insert_mode + priv::render_addchar $idx $opt_exposed1 [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode + incr idx + incr cursor_column + } + } + } else { + #? todo - decide what transparency even means for insert mode + incr idx + incr cursor_column + } + } else { + #2wide transparency over 2wide in underlay - review + incr idx + incr cursor_column + } + } + } + } else { + + set idxchar [lindex $outcols $idx] + #non-transparent char in overlay or empty cell + if {$idxchar eq "\u0000"} { + #empty/erased cell indicator + set uwidth 1 + } else { + set uwidth [grapheme_width_cached $idxchar] + } + if {$within_undercols} { + if {$idxchar eq ""} { + #2nd col of 2wide char in underlay + if {!$insert_mode} { + priv::render_addchar $idx $ch [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] 0 + #JMN - this has to expose if our startposn chopped an underlay - but not if we already overwrote the first half of the widechar underlay grapheme + #e.g renderline \uFF21\uFF21--- a\uFF23\uFF23 + #vs + # renderline -startcolumn 2 \uFF21---- \uFF23 + if {[lindex $outcols $idx-1] != ""} { + #verified it's an empty following a filled - so it's a legit underlay remnant (REVIEW - when would it not be??) + #reset previous to an exposed 1st-half - but leave understacks code as is + priv::render_addchar [expr {$idx-1}] $opt_exposed1 [lindex $understacks $idx-1] [lindex $understacks_gx $idx-1] 0 + } + incr idx + } else { + set prevcolinfo [lindex $outcols $idx-1] + #for insert mode - first replace the empty 2ndhalf char with exposed2 before shifting it right + #REVIEW - this leaves a replacement character permanently in our columns.. but it is consistent regarding length (?) + #The alternative is to disallow insertion at a column cursor that is at 2nd half of 2wide char + #perhaps by inserting after the char - this may be worthwhile - but may cause other surprises + #It is perhaps best avoided at another level and try to make renderline do exactly as it's told + #the advantage of this 2w splitting method is that the inserted character ends up in exactly the column we expect. + priv::render_addchar $idx $opt_exposed2 [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] 0 ;#replace not insert + priv::render_addchar $idx $ch [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] 1 ;#insert - same index + if {$prevcolinfo ne ""} { + #we've split the 2wide - it may already have been rendered as an exposed1 - but not for example if our startcolumn was current idx + priv::render_addchar [expr {$idx-1}] $opt_exposed1 [lindex $understacks $idx-1] [lindex $understacks_gx $idx-1] 0 ;#replace not insert + } ;# else?? + incr idx + } + if {$cursor_column < [llength $outcols] || $overflow_idx == -1} { + incr cursor_column + } + } elseif {$uwidth == 0} { + #what if this is some other c0/c1 control we haven't handled specifically? + + #by emitting a preceding empty-string column - we associate whatever this char is with the preceeding non-zero-length character and any existing zero-lengths that follow it + #e.g combining diacritic - increment before over char REVIEW + #arguably the previous overchar should have done this - ie lookahead for combiners? + #if we can get a proper grapheme_split function - this should be easier to tidy up. + priv::render_addchar $idx "" [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode + incr idx + priv::render_addchar $idx $ch [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode + incr idx + incr cursor_column 2 + + if {$cursor_column > [llength $outcols] && $overflow_idx != -1} { + set cursor_column [llength $outcols] + } + } elseif {$uwidth == 1} { + #includes null empty cells + set owidth [grapheme_width_cached $ch] + if {$owidth == 1} { + priv::render_addchar $idx $ch [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode + incr idx + } else { + priv::render_addchar $idx $ch [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode + incr idx + priv::render_addchar $idx "" [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode + #if next column in underlay empty - we've overwritten first half of underlying 2wide grapheme + #replace with rhs exposure in case there are no more overlay graphemes coming - use underlay's stack + if {([llength $outcols] >= $idx +2) && [lindex $outcols $idx+1] eq ""} { + priv::render_addchar [expr {$idx+1}] $opt_exposed2 [lindex $understacks $idx+1] [lindex $understacks_gx $idx+1] $insert_mode + } + incr idx + } + if {($cursor_column < [llength $outcols]) || $overflow_idx == -1} { + incr cursor_column + } + } elseif {$uwidth > 1} { + set owidth [grapheme_width_cached $ch] + if {$owidth == 1} { + #1wide over 2wide in underlay + if {!$insert_mode} { + priv::render_addchar $idx $ch [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode + incr idx + incr cursor_column + priv::render_addchar $idx $opt_exposed2 [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode + #don't incr idx - we are just putting a broken-indication in the underlay - which may get overwritten by next overlay char + } else { + #insert mode just pushes all to right - no exposition char here + priv::render_addchar $idx $ch [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode + incr idx + incr cursor_column + } + } else { + #2wide over 2wide + priv::render_addchar $idx $ch [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode + incr idx 2 + incr cursor_column 2 + } + + if {$cursor_column > [llength $outcols] && $overflow_idx != -1} { + set cursor_column [llength $outcols] + } + } + } else { + priv::render_addchar $idx $ch [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode + incr idx + incr cursor_column + } + } + } + } ;# end switch + + + } + other - crmcontrol { + if {$crm_mode && $type ne "crmcontrol" && $item ne "\x1b\[00001E"} { + if {$item eq "\x1b\[3l"} { + set crm_mode 0 + } else { + #When our initial overlay split was done - we weren't in crm_mode - so there are codes that weren't mapped to unicode control character representations + #set within_undercols [expr {$idx <= $renderwidth-1}] + #set chars [ansistring VIEW -nul 1 -lf 2 -vt 2 -ff 2 $item] + set chars [ansistring VIEW -nul 1 -lf 1 -vt 1 -ff 1 $item] + priv::render_unapplied $overlay_grapheme_control_list $gci + #prefix the unapplied controls with the string version of this control + set unapplied_list [linsert $unapplied_list 0 {*}[split $chars ""]] + set unapplied [join $unapplied_list ""] + + break + } + } + + #todo - consider CSI s DECSLRM vs ansi.sys \x1b\[s - we need \x1b\[s for oldschool ansi art - but may have to enable only for that. + #we should possibly therefore reverse this mapping so that x1b7 x1b8 are the primary codes for save/restore? + set code [tcl::string::map [list \x1b7 \x1b\[s \x1b8 \x1b\[u ] $item] + #since this element isn't a grapheme - advance idx_over to next grapheme overlay when about to fill 'unapplied' + + + #remap of DEC cursor_save/cursor_restore from ESC sequence to equivalent CSI + #probably not ideal - consider putting cursor_save/cursor_restore in functions so they can be called from the appropriate switch branch instead of using this mapping + #review - cost/benefit of function calls within these switch-arms instead of inline code? + + set c1 [tcl::string::index $code 0] + set c1c2c3 [tcl::string::range $code 0 2] + #set re_ST_open {(?:\033P|\u0090|\033X|\u0098|\033\^|\u009e|\033_|\u009f)} + #tcl 8.7 - faster to use inline list than to store it in a local var outside of loop. + #(somewhat surprising) + set leadernorm [tcl::string::range [tcl::string::map [list\ + \x1b\[< 1006\ + \x1b\[ 7CSI\ + \x1bY 7MAP\ + \x1bP 7DCS\ + \x90 8DCS\ + \x9b 8CSI\ + \x1b\] 7OSC\ + \x9d 8OSC\ + \x1b 7ESC\ + ] $c1c2c3] 0 3] ;#leadernorm is 1st 1,2 or 3 chars mapped to 4char normalised indicator - or is original first chars (1,2 or 3 len) + + #we leave the tail of the code unmapped for now + switch -- $leadernorm { + 1006 { + #https://invisible-island.net/xterm/ctlseqs/ctlseqs.html + #SGR (1006) CSI < followed by colon separated encoded-button-value,px,py ordinates and final M for button press m for button release + set codenorm [tcl::string::cat $leadernorm [tcl::string::range $code 3 end]] + } + 7CSI - 7OSC { + #set codenorm [tcl::string::cat $leadernorm [tcl::string::range $code 2 end]] + set codenorm $leadernorm[tcl::string::range $code 2 end] + } + 7DCS { + #ESC P + #Device Control String https://invisible-island.net/xterm/ctlseqs/ctlseqs.html#h4-Controls-beginning-with-ESC:ESC-F.C74 + set codenorm [tcl::string::cat $leadernorm [tcl::string::range $code 2 end]] + } + 8DCS { + #8-bit Device Control String + set codenorm [tcl::string::cat $leadernorm [tcl::string::range $code 1 end]] + } + 7MAP { + #map to another type of code to share implementation branch + set codenorm $leadernorm[tcl::string::range $code 1 end] + } + 7ESC { + #set codenorm [tcl::string::cat $leadernorm [tcl::string::range $code 1 end]] + set codenorm $leadernorm[tcl::string::range $code 1 end] + } + 8CSI - 8OSC { + set codenorm [tcl::string::cat $leadernorm [tcl::string::range $code 1 end]] + } + default { + puts stderr "Sequence detected as ANSI, but not handled in leadernorm switch. code: [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + #we haven't made a mapping for this + #could in theory be 1,2 or 3 in len + #although we shouldn't be getting here if the regexp for ansi codes is kept in sync with our switch branches + set codenorm $code + } + } + + switch -- $leadernorm { + 7MAP { + switch -- [lindex $codenorm 4] { + Y { + #vt52 movement. we expect 2 chars representing position (limited range) + set params [tcl::string::range $codenorm 5 end] + if {[tcl::string::length $params] != 2} { + #shouldn't really get here or need this branch if ansi splitting was done correctly + puts stderr "overtype::renderline ESC Y recognised as vt52 move, but incorrect parameters length ([string length $params] vs expected 2) [ansistring VIEW -lf 1 -vt 1 -nul 1 $code] not implemented codenorm:[ansistring VIEW -lf 1 -vt 1 -nul 1 $codenorm]" + } + set line [tcl::string::index $params 5] + set column [tcl::string::index $params 1] + set r [expr {[scan $line %c] -31}] + set c [expr {[scan $column %c] -31}] + + #MAP to: + #CSI n;m H - CUP - Cursor Position + set leadernorm 7CSI + set codenorm "$leadernorm${r}\;${c}H" + } + } + } + } + + #we've mapped 7 and 8bit escapes to values we can handle as literals in switch statements to take advantange of jump tables. + switch -- $leadernorm { + 1006 { + #TODO + # + switch -- [tcl::string::index $codenorm end] { + M { + puts stderr "mousedown $codenorm" + } + m { + puts stderr "mouseup $codenorm" + } + } + + } + {7CSI} - {8CSI} { + set param [tcl::string::range $codenorm 4 end-1] + #puts stdout "--> CSI [tcl::string::index $leadernorm 0] bit param:$param" + set code_end [tcl::string::index $codenorm end] ;#used for e.g h|l set/unset mode + + switch -exact -- $code_end { + A { + #Row move - up + set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] + #todo + lassign [split $param {;}] num modifierkey + if {$modifierkey ne ""} { + puts stderr "modifierkey:$modifierkey" + } + + if {$num eq ""} {set num 1} + incr cursor_row -$num + + if {$cursor_row < 1} { + set cursor_row 1 + } + + #ensure rest of *overlay* is emitted to remainder + incr idx_over + priv::render_unapplied $overlay_grapheme_control_list $gci + set instruction up + #retain cursor_column + break + } + B { + #CUD - Cursor Down + #Row move - down + lassign [split $param {;}] num modifierkey + set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] + #move down + if {$modifierkey ne ""} { + puts stderr "modifierkey:$modifierkey" + } + if {$num eq ""} {set num 1} + incr cursor_row $num + + + incr idx_over ;#idx_over hasn't encountered a grapheme and hasn't advanced yet + priv::render_unapplied $overlay_grapheme_control_list $gci + set instruction down + #retain cursor_column + break + } + C { + #CUF - Cursor Forward + #Col move + #puts stdout "->forward" + #todo - consider right-to-left cursor mode (e.g Hebrew).. some day. + #cursor forward + #right-arrow/move forward + lassign [split $param {;}] num modifierkey + if {$modifierkey ne ""} { + puts stderr "modifierkey:$modifierkey" + } + if {$num eq ""} {set num 1} + + #todo - retrict to moving 1 position past datalen? restrict to column width? + #should ideally wrap to next line when interactive and not on last row + #(some ansi art seems to expect this behaviour) + #This presumably depends on the terminal's wrap mode + #e.g DECAWM autowrap mode + # CSI ? 7 h - set: autowrap (also tput smam) + # CSI ? 7 l - reset: no autowrap (also tput rmam) + set version 2 + if {$version eq "2"} { + set max [llength $outcols] + if {$overflow_idx == -1} { + incr max + } + if {$cursor_column == $max+1} { + #move_forward while in overflow + incr cursor_column -1 + } + + if {($cursor_column + $num) <= $max} { + incr idx $num + incr cursor_column $num + } else { + if {$autowrap_mode} { + set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] + #jmn + if {$idx == $overflow_idx} { + incr num + } + + #horizontal movement beyond line extent needs to wrap - throw back to caller + #we may have both overflow_right and unapplied data + #(can have overflow_right if we were in insert_mode and processed chars prior to this movement) + #leave row as is - caller will need to determine how many rows the column-movement has consumed + incr cursor_column $num ;#give our caller the necessary info as columns from start of row + #incr idx_over + #should be gci following last one applied + priv::render_unapplied $overlay_grapheme_control_list $gci + set instruction wrapmoveforward + break + } else { + set cursor_column $max + set idx [expr {$cursor_column -1}] + } + } + } else { + #review - dead branch + if {!$expand_right || ($cursor_column + $num) <= [llength $outcols+1]} { + incr idx $num + incr cursor_column $num + } else { + if {!$insert_mode} { + #block editing style with arrow keys + #overtype mode + set idxstart $idx + set idxend [llength $outcols] + set moveend [expr {$idxend - $idxstart}] + if {$moveend < 0} {set moveend 0} ;#sanity? + #puts "idxstart:$idxstart idxend:$idxend outcols[llength $outcols] undercols:[llength $undercols]" + incr idx $moveend + incr cursor_column $moveend + #if {[tcl::dict::exists $understacks $idx]} { + # set stackinfo [tcl::dict::get $understacks $idx] ;#use understack at end - which may or may not have already been replaced by stack from overtext + #} else { + # set stackinfo [list] + #} + if {$idx < [llength $understacks]} { + set stackinfo [lindex $understacks $idx] ;#use understack at end - which may or may not have already been replaced by stack from overtext + } else { + set stackinfo [list] + } + if {$idx < [llength $understacks_gx]} { + #set gxstackinfo [tcl::dict::get $understacks_gx $idx] + set gxstackinfo [lindex $understacks_gx $idx] + } else { + set gxstackinfo [list] + } + #pad outcols + set movemore [expr {$num - $moveend}] + #assert movemore always at least 1 or we wouldn't be in this branch + for {set m 1} {$m <= $movemore} {incr m} { + incr idx + incr cursor_column + priv::render_addchar $idx " " $stackinfo $gxstackinfo $insert_mode + } + } else { + #normal - insert + incr idx $num + incr cursor_column $num + if {$idx > [llength $outcols]} { + set idx [llength $outcols];#allow one beyond - for adding character at end of line + set cursor_column [expr {[llength $outcols]+1}] + } + } + } + } + } + D { + #Col move + #puts stdout "<-back" + #cursor back + #left-arrow/move-back when ltr mode + lassign [split $param {;}] num modifierkey + if {$modifierkey ne ""} { + puts stderr "modifierkey:$modifierkey" + } + if {$num eq ""} {set num 1} + + set version 2 + if {$version eq "2"} { + #todo - startcolumn offset! + if {$cursor_column - $num >= 1} { + incr idx -$num + incr cursor_column -$num + } else { + if {!$autowrap_mode} { + set cursor_column 1 + set idx 0 + } else { + set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] + incr cursor_column -$num + priv::render_unapplied $overlay_grapheme_control_list $gci + set instruction wrapmovebackward + break + } + } + } else { + incr idx -$num + incr cursor_column -$num + if {$idx < $opt_colstart-1} { + #wrap to previous line and position cursor at end of data + set idx [expr {$opt_colstart-1}] + set cursor_column $opt_colstart + } + } + } + E { + #CNL - Cursor Next Line + if {$param eq ""} { + set downmove 1 + } else { + set downmove [expr {$param}] + } + puts stderr "renderline CNL down-by-$downmove" + set cursor_column 1 + set cursor_row [expr {$cursor_row + $downmove}] + set idx [expr {$cursor_column -1}] + set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] + incr idx_over + priv::render_unapplied $overlay_grapheme_control_list $gci + set instruction move + break + + } + F { + #CPL - Cursor Previous Line + if {$param eq ""} { + set upmove 1 + } else { + set upmove [expr {$param}] + } + puts stderr "renderline CPL up-by-$upmove" + set cursor_column 1 + set cursor_row [expr {$cursor_row -$upmove}] + if {$cursor_row < 1} { + set cursor_row 1 + } + set idx [expr {$cursor_column - 1}] + set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] + incr idx_over + priv::render_unapplied $overlay_grapheme_control_list $gci + set instruction move + break + + } + G { + #CHA - Cursor Horizontal Absolute (move to absolute column no) + if {$param eq ""} { + set targetcol 1 + } else { + set targetcol $param + if {![string is integer -strict $targetcol]} { + puts stderr "renderline CHA (Cursor Horizontal Absolute) error. Unrecognised parameter '$param'" + } + set targetcol [expr {$param}] + set max [llength $outcols] + if {$overflow_idx == -1} { + incr max + } + if {$targetcol > $max} { + puts stderr "renderline CHA (Cursor Horizontal Absolute) error. Param '$param' > max: $max" + set targetcol $max + } + } + #adjust to colstart - as column 1 is within overlay + #??? REVIEW + set idx [expr {($targetcol -1) + $opt_colstart -1}] + + set cursor_column $targetcol + #puts stderr "renderline absolute col move ESC G (TEST)" + } + H - f { + #CSI n;m H - CUP - Cursor Position + + #CSI n;m f - HVP - Horizontal Vertical Position REVIEW - same as CUP with differences (what?) in some terminal modes + # - 'counts as effector format function (like CR or LF) rather than an editor function (like CUD or CNL)' + # - REVIEW + #see Annex A at: https://www.ecma-international.org/wp-content/uploads/ECMA-48_5th_edition_june_1991.pdf + + #test e.g ansicat face_2.ans + #$re_both_move + lassign [split $param {;}] paramrow paramcol + #missing defaults to 1 + #CSI ;5H = CSI 1;5H -> row 1 col 5 + #CSI 17;H = CSI 17H = CSI 17;1H -> row 17 col 1 + + if {$paramcol eq ""} {set paramcol 1} + if {$paramrow eq ""} {set paramrow 1} + if {![string is integer -strict $paramcol] || ![string is integer -strict $paramrow]} { + puts stderr "renderline CUP (CSI H) unrecognised param $param" + #ignore? + } else { + set max [llength $outcols] + if {$overflow_idx == -1} { + incr max + } + if {$paramcol > $max} { + set target_column $max + } else { + set target_column [expr {$paramcol}] + } + + + if {$paramrow < 1} { + puts stderr "renderline CUP (CSI H) bad row target 0. Assuming 1" + set target_row 1 + } else { + set target_row [expr {$paramrow}] + } + if {$target_row == $cursor_row} { + #col move only - no need for break and move + #puts stderr "renderline CUP col move only to col $target_column param:$param" + set cursor_column $target_column + set idx [expr {$cursor_column -1}] + } else { + set cursor_row $target_row + set cursor_column $target_column + set idx [expr {$cursor_column -1}] + set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] + incr idx_over + priv::render_unapplied $overlay_grapheme_control_list $gci + set instruction move + break + } + } + } + J { + set modegroup [tcl::string::index $codenorm 4] ;#e.g ? + switch -exact -- $modegroup { + ? { + #CSI ? Pn J - selective erase + puts stderr "overtype::renderline ED - SELECTIVE ERASE IN DISPLAY (UNIMPLEMENTED) [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + } + default { + puts stderr "overtype::renderline ED - ERASE IN DISPLAY (TESTING) [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + if {$param eq ""} {set param 0} + switch -exact -- $param { + 0 { + #clear from cursor to end of screen + } + 1 { + #clear from cursor to beginning of screen + } + 2 { + #clear entire screen + #ansi.sys - move cursor to upper left REVIEW + set cursor_row 1 + set cursor_column 1 + set idx [expr {$cursor_column -1}] + set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] + incr idx_over + if {[llength $outcols]} { + priv::render_erasechar 0 [llength $outcols] + } + priv::render_unapplied $overlay_grapheme_control_list $gci + set instruction clear_and_move + break + } + 3 { + #clear entire screen. presumably cursor doesn't move - otherwise it would be same as 2J ? + + } + default { + } + } + + } + } + } + K { + #see DECECM regarding background colour + set modegroup [tcl::string::index $codenorm 4] ;#e.g ? + switch -exact -- $modegroup { + ? { + puts stderr "overtype::renderline DECSEL - SELECTIVE ERASE IN LINE (UNIMPLEMENTED) [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + set param [string range $param 1 end] ;#chop qmark + if {$param eq ""} {set param 0} + switch -exact -- $param { + 0 { + #clear from cursor to end of line - depending on DECSCA + } + 1 { + #clear from cursor to beginning of line - depending on DECSCA + + } + 2 { + #clear entire line - depending on DECSCA + } + default { + puts stderr "overtype::renderline DECSEL - SELECTIVE ERASE IN LINE PARAM '$param' unrecognised [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + } + } + + } + default { + puts stderr "overtype::renderline EL - ERASE IN LINE (TESTING) [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + if {$param eq ""} {set param 0} + switch -exact -- $param { + 0 { + #clear from cursor to end of line + } + 1 { + #clear from cursor to beginning of line + + } + 2 { + #clear entire line + } + default { + puts stderr "overtype::renderline EL - ERASE IN LINE PARAM '$param' unrecognised [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + } + } + } + } + } + L { + puts stderr "overtype::renderline IL - Insert Line - not implemented [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + } + 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]" + + } + T { + #CSI Pn T - SD Pan Up (empty lines introduced at top) + #CSI Pn+T - kitty extension (lines at top come from scrollback buffer) + #Pn new lines appear at top of the display, Pn old lines disappear at the bottom of the display + if {$param eq "" || $param eq "0"} {set param 1} + if {[string index $param end] eq "+"} { + puts stderr "overtype::renderline CSI Pn + T - kitty Pan Up - not implemented [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + } else { + puts stderr "overtype::renderline CSI Pn T - SD Pan Up - not implemented [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + } + } + X { + puts stderr "overtype::renderline X ECH ERASE CHARACTER - $param" + #ECH - erase character + if {$param eq "" || $param eq "0"} {set param 1}; #param=count of chars to erase + priv::render_erasechar $idx $param + #cursor position doesn't change. + } + q { + set code_secondlast [tcl::string::index $codenorm end-1] + switch -exact -- $code_secondlast { + {"} { + #DECSCA - Select Character Protection Attribute + #(for use with selective erase: DECSED and DECSEL) + set param [tcl::string::range $codenorm 4 end-2] + if {$param eq ""} {set param 0} + #TODO - store like SGR in stacks - replays? + switch -exact -- $param { + 0 - 2 { + #canerase + puts stderr "overtype::renderline - DECSCA canerase not implemented - [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + } + 1 { + #cannoterase + puts stderr "overtype::renderline - DECSCA cannoterase not implemented - [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + } + default { + puts stderr "overtype::renderline DECSCA param '$param' not understood [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + } + } + + } + default { + puts stderr "overtype::renderline - CSI ... q not implemented - [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + } + } + + } + r { + #$re_decstbm + #https://www.vt100.net/docs/vt510-rm/DECSTBM.html + #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 + + incr idx_over + priv::render_unapplied $overlay_grapheme_control_list $gci + set instruction move ;#own instruction? decstbm? + break + } + s { + #code conflict between ansi emulation and DECSLRM - REVIEW + #ANSISYSSC (when no parameters) - like other terminals - essentially treat same as DECSC + # todo - when parameters - support DECSLRM instead + + if {$param ne ""} { + #DECSLRM - should only be recognised if DECLRMM is set (vertical split screen mode) + lassign [split $param {;}] margin_left margin_right + puts stderr "overtype DECSLRM not yet supported - got [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + if {$margin_left eq ""} { + set margin_left 1 + } + set columns_per_page 80 ;#todo - set to 'page width (DECSCPP set columns per page)' - could be 132 or?? + if {$margin_right eq ""} { + set margin_right $columns_per_page + } + puts stderr "DECSLRM margin left: $margin_left margin right: $margin_right" + if {![string is integer -strict $margin_left] || $margin_left < 0} { + puts stderr "DECSLRM invalid margin_left" + } + if {![string is integer -strict $margin_right] || $margin_right < 0} { + puts stderr "DECSLRM invalid margin_right" + } + set scrolling_region_size [expr {$margin_right - $margin_left}] + if {$scrolling_region_size < 2 || $scrolling_region_size > $columns_per_page} { + puts stderr "DECSLRM region size '$scrolling_regsion_size' must be between 1 and $columns_per_page" + } + #todo + + + } else { + #DECSC + #//notes on expected behaviour: + #DECSC - saves following items in terminal's memory + #cursor position + #character attributes set by the SGR command + #character sets (G0,G1,G2 or G3) currently in GL and GR + #Wrap flag (autowrap or no autowrap) + #State of origin mode (DECOM) + #selective erase attribute + #any single shift 2 (SS2) or single shift 3(SSD) functions sent + + #$re_cursor_save + #cursor save could come after last column + if {$overflow_idx != -1 && $idx == $overflow_idx} { + #bartman2.ans test file - fixes misalignment at bottom of dialog bubble + #incr cursor_row + #set cursor_column 1 + #bwings1.ans test file - breaks if we actually incr cursor (has repeated saves) + set cursor_saved_position [list row [expr {$cursor_row+1}] column 1] + } else { + set cursor_saved_position [list row $cursor_row column $cursor_column] + } + #there may be overlay stackable codes emitted that aren't in the understacks because they come between the last emmited character and the cursor_save control. + #we need the SGR and gx overlay codes prior to the cursor_save + + #a real terminal would not be able to know the state of the underlay.. so we should probably ignore it. + #set sgr_stack [lindex $understacks $idx] + #set gx_stack [lindex $understacks_gx $idx] ;#not actually a stack - just a boolean state (for now?) + + set sgr_stack [list] + set gx_stack [list] + + #we shouldn't need to scan for intermediate cursor save/restores - as restores would throw-back to the calling loop - so our overlay 'line' is since those. + #The overlay_grapheme_control_list had leading resets from previous lines - so we go back to the beginning not just the first grapheme. + + foreach gc [lrange $overlay_grapheme_control_list 0 $gci-1] { + lassign $gc type code + #types g other sgr gx0 + switch -- $type { + gx0 { + #code is actually a stand-in for the graphics on/off code - not the raw code + #It is either gx0_on or gx0_off + set gx_stack [list $code] + } + sgr { + #code is the raw code + if {[punk::ansi::codetype::is_sgr_reset $code]} { + #jmn + set sgr_stack [list "\x1b\[m"] + } elseif {[punk::ansi::codetype::has_sgr_leadingreset $code]} { + set sgr_stack [list $code] + lappend overlay_grapheme_control_list [list sgr $code] + } elseif {[priv::is_sgr $code]} { + #often we don't get resets - and codes just pile up. + #as a first step to simplifying - at least remove earlier straight up dupes + set dup_posns [lsearch -all -exact $sgr_stack $code] ;#needs -exact - codes have square-brackets (glob chars) + set sgr_stack [lremove $sgr_stack {*}$dup_posns] + lappend sgr_stack $code + } + } + } + } + set cursor_saved_attributes "" + switch -- [lindex $gx_stack 0] { + gx0_on { + append cursor_saved_attributes "\x1b(0" + } + gx0_off { + append cursor_saved_attributes "\x1b(B" + } + } + #append cursor_saved_attributes [join $sgr_stack ""] + append cursor_saved_attributes [punk::ansi::codetype::sgr_merge_list {*}$sgr_stack] + + #as there is apparently only one cursor storage element we don't need to throw back to the calling loop for a save. + + #don't incr index - or the save will cause cursor to move to the right + #carry on + } + } + u { + #ANSISYSRC save cursor (when no parameters) (DECSC) + + #$re_cursor_restore + #we are going to jump somewhere.. for now we will assume another line, and process accordingly. + #The caller has the cursor_saved_position/cursor_saved_attributes if any (?review - if we always pass it back it, we could save some calls for moves in same line) + #don't set overflow at this point. The existing underlay to the right must be preserved. + #we only want to jump and render the unapplied at the new location. + + #lset overstacks $idx_over [list] + #set replay_codes_overlay "" + + #if {$cursor_saved_attributes ne ""} { + # set replay_codes_overlay $cursor_saved_attributes ;#empty - or last save if it happend in this input chunk + #} else { + #jj + #set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] + set replay_codes_overlay "" + #} + + #like priv::render_unapplied - but without the overlay's ansi reset or gx stacks from before the restore code + incr idx_over + + set unapplied "" + set unapplied_list [list] + foreach gc [lrange $overlay_grapheme_control_list $gci+1 end] { + lassign $gc type item + if {$type eq "gx0"} { + if {$item eq "gx0_on"} { + lappend unapplied_list "\x1b(0" + } elseif {$item eq "gx0_off"} { + lappend unapplied_list "\x1b(B" + } + } else { + lappend unapplied_list $item + } + #incr idx_over + } + set unapplied [join $unapplied_list ""] + #if the save occured within this line - that's ok - it's in the return value list and caller can prepend for the next loop. + set instruction restore_cursor + break + } + "{" { + + puts stderr "renderline warning - CSI.. - unimplemented [ansistring VIEW -lf 1 -nul 1 $code]" + } + "}" { + set code_secondlast [tcl::string::index $codenorm end-1] + switch -exact -- $code_secondlast { + ' { + puts stderr "renderline warning - DECIC - Insert Column - CSI...' - unimplemented [ansistring VIEW -lf 1 -nul 1 $code]" + } + default { + puts stderr "renderline warning - CSI.. - unimplemented [ansistring VIEW -lf 1 -nul 1 $code]" + } + } + } + ~ { + set code_secondlast [tcl::string::index $codenorm end-1] ;#used for e.g CSI x '~ + switch -exact -- $code_secondlast { + ' { + #DECDC - editing sequence - Delete Column + puts stderr "renderline warning - DECDC - unimplemented" + } + default { + #$re_vt_sequence + lassign [split $param {;}] key mod + + #Note that f1 to f4 show as ESCOP|Q|R|S (VT220?) but f5+ show as ESC\[15~ + # + #e.g esc \[2~ insert esc \[2;2~ shift-insert + #mod - subtract 1, and then use bitmask + #shift = 1, (left)Alt = 2, control=4, meta=8 (meta seems to do nothing on many terminals on windows? Intercepted by windows?) + #puts stderr "vt key:$key mod:$mod code:[ansistring VIEW $code]" + if {$key eq "1"} { + #home + } elseif {$key eq "2"} { + #Insert + if {$mod eq ""} { + #no modifier key + set insert_mode [expr {!$insert_mode}] + #rather than set the cursor - we return the insert mode state so the caller can decide + } + } elseif {$key eq "3"} { + #Delete - presumably this shifts other chars in the line, with empty cells coming in from the end + switch -- $mod { + "" { + priv::render_delchar $idx + } + "5" { + #ctrl-del - delete to end of word (pwsh) - possibly word on next line if current line empty(?) + } + } + } elseif {$key eq "4"} { + #End + } elseif {$key eq "5"} { + #pgup + } elseif {$key eq "6"} { + #pgDn + } elseif {$key eq "7"} { + #Home + #?? + set idx [expr {$opt_colstart -1}] + set cursor_column 1 + } elseif {$key eq "8"} { + #End + } elseif {$key eq "11"} { + #F1 - or ESCOP or e.g shift F1 ESC\[1;2P + } elseif {$key eq "12"} { + #F2 - or ESCOQ + } elseif {$key eq "13"} { + #F3 - or ESCOR + } elseif {$key eq "14"} { + #F4 - or ESCOS + } elseif {$key eq "15"} { + #F5 or shift F5 ESC\[15;2~ + } elseif {$key eq "17"} { + #F6 + } elseif {$key eq "18"} { + #F7 + } elseif {$key eq "19"} { + #F8 + } elseif {$key eq "20"} { + #F9 + } elseif {$key eq "21"} { + #F10 + } elseif {$key eq "23"} { + #F11 + } elseif {$key eq "24"} { + #F12 + } + + } + } + + } + h - l { + #set mode unset mode + #we are matching only last char to get to this arm - but are there other sequences ending in h|l we need to handle? + + #$re_mode if first after CSI is "?" + #some docs mention ESC=h|l - not seen on windows terminals.. review + #e.g https://www2.math.upenn.edu/~kazdan/210/computer/ansi.html + set modegroup [tcl::string::index $codenorm 4] ;#e.g ? = + switch -exact -- $modegroup { + ? { + set smparams [tcl::string::range $codenorm 5 end-1] ;#params between ? and h|l + #one or more modes can be set + set smparam_list [split $smparams {;}] + foreach num $smparam_list { + switch -- $num { + "" { + #ignore empties e.g extra/trailing semicolon in params + } + 5 { + #DECSNM - reverse video + #How we simulate this to render within a block of text is an open question. + #track all SGR stacks and constantly flip based on the current SGR reverse state? + #It is the job of the calling loop to do this - so at this stage we'll just set the states + + if {$code_end eq "h"} { + #set (enable) + set reverse_mode 1 + } else { + #reset (disable) + set reverse_mode 0 + } + + } + 7 { + #DECAWM autowrap + if {$code_end eq "h"} { + #set (enable) + set autowrap_mode 1 + if {$opt_width ne "\uFFEF"} { + set overflow_idx $opt_width + } else { + #review - this is also the cursor position when adding a char at end of line? + set overflow_idx [expr {[llength $undercols]}] ;#index at which we would be *in* overflow a row move may still override it + } + #review - can idx ever be beyond overflow_idx limit when we change e.g with a width setting and cursor movements? + # presume not usually - but sanity check with warning for now. + if {$idx >= $overflow_idx} { + puts stderr "renderline warning - idx '$idx' >= overflow_idx '$overflow_idx' - unexpected" + } + } else { + #reset (disable) + set autowrap_mode 0 + #REVIEW! + set overflow_idx -1 + } + } + 25 { + if {$code_end eq "h"} { + #visible cursor + + } else { + #invisible cursor + + } + } + 117 { + #DECECM - Erase Color Mode + #https://invisible-island.net/ncurses/ncurses.faq.html + #The Erase color selection controls the background color used when text is erased or new + #text is scrolled on to the screen. Screen background causes newly erased areas or + #scrolled text to be written using color index zero, the screen background. This is VT + #and DECterm compatible. Text background causes erased areas or scrolled text to be + #written using the current text background color. This is PC console compatible and is + #the factory default. + + #see also: https://unix.stackexchange.com/questions/251726/clear-to-end-of-line-uses-the-wrong-background-color-in-screen + } + } + } + } + = { + set num [tcl::string::range $codenorm 5 end-1] ;#param between = and h|l + puts stderr "overtype::renderline CSI=...h|l code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code] not implemented" + } + default { + #e.g CSI 4 h + set num [tcl::string::range $codenorm 4 end-1] ;#param before h|l + switch -exact -- $num { + 3 { + puts stderr "CRM MODE $code_end" + #CRM - Show control character mode + # 'No control functions are executed except LF,FF and VT which are represented in the CRM FONT before a CRLF(new line) is executed' + # + #use ansistring VIEW -nul 1 -lf 2 -ff 2 -vt 2 + #https://vt100.net/docs/vt510-rm/CRM.html + #NOTE - vt100 CRM always does auto-wrap at right margin. + #disabling auto-wrap in set-up or by sequence is disabled. + #We should default to turning off auto-wrap when crm_mode enabled.. but + #displaying truncated (on rhs) crm can still be very useful - and we have optimisation in overflow to avoid excess renderline calls (per grapheme) + #we therefore could reasonably put in an exception to allow auto_wrap to be disabled after crm_mode is engaged, + #although this would be potentially an annoying difference to some.. REVIEW + if {$code_end eq "h"} { + set crm_mode 1 + set autowrap_mode 1 + if {$opt_width ne "\uFFEF"} { + set overflow_idx $opt_width + } else { + #review - this is also the cursor position when adding a char at end of line? + set overflow_idx [expr {[llength $undercols]}] ;#index at which we would be *in* overflow a row move may still override it + } + } else { + set crm_mode 0 + } + } + 4 { + #IRM - Insert/Replace Mode + if {$code_end eq "h"} { + #CSI 4 h + set insert_mode 1 + } else { + #CSI 4 l + #replace mode + set insert_mode 0 + } + } + default { + puts stderr "overtype::renderline CSI...h|l code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code] not implemented" + } + } + } + } + } + | { + switch -- [tcl::string::index $codenorm end-1] { + {$} { + #CSI ... $ | DECSCPP set columns per page- (recommended in vt510 docs as preferable to DECCOLM) + #real terminals generally only supported 80/132 + #some other virtuals support any where from 2 to 65,536? + #we will allow arbitrary widths >= 2 .. to some as yet undetermined limit. + #CSI $ | + #empty or 0 param is 80 for compatibility - other numbers > 2 accepted + set page_width -1 ;#flag as unset + if {$param eq ""} { + set page_width 80 + } elseif {[string is integer -strict $param] && $param >=2} { + set page_width [expr {$param}] ;#we should allow leading zeros in the number - but lets normalize using expr + } else { + puts stderr "overtype::renderline unacceptable DECSPP value '$param'" + } + + if {$page_width > 2} { + puts stderr "overtype::renderline DECSCPP - not implemented - but selected width '$page_width' looks ok" + #if cursor already beyond new page_width - will move to right colum - otherwise no cursor movement + + } + + } + default { + puts stderr "overtype::renderline unrecognised CSI code ending in pipe (|) [ansistring VIEW -lf 1 -vt 1 -nul 1 $code] not implemented" + } + } + } + default { + puts stderr "overtype::renderline CSI code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code] not implemented" + } + } + } + 7ESC { + # + #re_other_single {\x1b(D|M|E)$} + #also vt52 Y.. + #also PM \x1b^...(ST) + switch -- [tcl::string::index $codenorm 4] { + c { + #RIS - reset terminal to initial state - where 'terminal' in this case is the renderspace - not the underlying terminal! + puts stderr "renderline reset" + priv::render_unapplied $overlay_grapheme_control_list $gci + set instruction reset + break + } + D { + #\x84 + #index (IND) + #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_unapplied $overlay_grapheme_control_list $gci + set instruction down + #retain cursor_column + break + } + E { + #\x85 + #review - is behaviour different to lf? + #todo - possibly(?) same logic as handling above. i.e return instruction depends on where column_cursor is at the time we get NEL + #leave implementation until logic for is set in stone... still under review + #It's arguable NEL is a pure cursor movement as opposed to the semantic meaning of crlf or lf in a file. + # + #Next Line (NEL) "Move the cursor to the left margin on the next line. If the cursor is at the bottom margin, scroll the page up" + puts stderr "overtype::renderline ESC E unimplemented" + + } + H { + #\x88 + #Tab Set + puts stderr "overtype::renderline ESC H tab set unimplemented" + } + M { + #\x8D + #Reverse Index (RI) + #vt102-docs: "Moves cursor up one line in same column. If cursor is at top margin, screen performs a scroll-down" + puts stderr "overtype::renderline ESC M not fully implemented" + + set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] + #move up + incr cursor_row -1 + if {$cursor_row < 1} { + set cursor_row 1 + } + #ensure rest of *overlay* is emitted to remainder + priv::render_unapplied $overlay_grapheme_control_list $gci + set instruction up ;#need instruction for scroll-down? + #retain cursor_column + break + } + N { + #\x8e - affects next character only + puts stderr "overtype::renderline single shift select G2 command UNIMPLEMENTED. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + } + O { + #\x8f - affects next character only + puts stderr "overtype::renderline single shift select G3 command UNIMPLEMENTED. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + } + P { + #\x90 + #DCS - shouldn't get here - handled in 7DCS branch + #similarly \] OSC (\x9d) and \\ (\x9c) ST + } + V { + #\x96 + + } + W { + #\x97 + } + X { + #\x98 + #SOS + if {[string index $code end] eq "\007"} { + set sos_content [string range $code 2 end-1] ;#ST is \007 + } else { + set sos_content [string range $code 2 end-2] ;#ST is \x1b\\ + } + #return in some useful form to the caller + #TODO! + lappend sos_list [list string $sos_content row $cursor_row column $cursor_column] + puts stderr "overtype::renderline ESCX SOS UNIMPLEMENTED. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + } + ^ { + #puts stderr "renderline PM" + #Privacy Message. + if {[string index $code end] eq "\007"} { + set pm_content [string range $code 2 end-1] ;#ST is \007 + } else { + set pm_content [string range $code 2 end-2] ;#ST is \x1b\\ + } + #We don't want to render it - but we need to make it available to the application + #see the textblock library in punk, for the exception we make here for single backspace. + #It is unlikely to be encountered as a useful PM - so we hack to pass it through as a fix + #for spacing issues on old terminals which miscalculate the single-width 'Symbols for Legacy Computing' + if {$pm_content eq "\b"} { + #puts stderr "renderline PM sole backspace special handling for \U1FB00 - \U1FBFF" + #esc^\b\007 or esc^\besc\\ + #HACKY pass-through - targeting terminals that both mis-space legacy symbols *and* don't support PMs + #The result is repair of the extra space. If the terminal is a modern one and does support PM - the \b should be hidden anyway. + #If the terminal has the space problem AND does support PMs - then this just won't fix it. + #The fix relies on the symbol-supplier to cooperate by appending esc^\b\esc\\ to the problematic symbols. + + #priv::render_addchar $idx $code [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode + #idx has been incremented after last grapheme added + priv::render_append_to_char [expr {$idx -1}] $code + } + #lappend to a dict element in the result for application-specific processing + lappend pm_list $pm_content + } + _ { + #APC Application Program Command + #just warn for now.. + puts stderr "overtype::renderline ESC_ APC command UNIMPLEMENTED. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + } + default { + puts stderr "overtype::renderline ESC code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code] not implemented codenorm:[ansistring VIEW -lf 1 -vt 1 -nul 1 $codenorm]" + } + } + + } + 7DCS - 8DCS { + puts stderr "overtype::renderline DCS - DEVICE CONTROL STRING command UNIMPLEMENTED. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + #ST (string terminator) \x9c or \x1b\\ + if {[tcl::string::index $codenorm end] eq "\x9c"} { + set code_content [tcl::string::range $codenorm 4 end-1] ;#ST is 8-bit 0x9c + } else { + set code_content [tcl::string::range $codenorm 4 end-2] ;#ST is \x1b\\ + } + + } + 7OSC - 8OSC { + # OSCs are terminated with ST of either \007 or \x1b\\ - we allow either whether code was 7 or 8 bit + if {[tcl::string::index $codenorm end] eq "\007"} { + set code_content [tcl::string::range $codenorm 4 end-1] ;#ST is \007 + } else { + set code_content [tcl::string::range $codenorm 4 end-2] ;#ST is \x1b\\ + } + set first_colon [tcl::string::first {;} $code_content] + if {$first_colon == -1} { + #there probably should always be a colon - but we'll try to make sense of it without + set osc_code $code_content ;#e.g \x1b\]104\007 vs \x1b\]104\;\007 + } else { + set osc_code [tcl::string::range $code_content 0 $first_colon-1] + } + switch -exact -- $osc_code { + 2 { + set newtitle [tcl::string::range $code_content 2 end] + priv::render_unapplied $overlay_grapheme_control_list $gci + set instruction [list set_window_title $newtitle] + break + } + 4 { + #OSC 4 - set colour palette + #can take multiple params + #e.g \x1b\]4\;1\;red\;2\;green\x1b\\ + set params [tcl::string::range $code_content 2 end] ;#strip 4 and first semicolon + set cmap [dict create] + foreach {cnum spec} [split $params {;}] { + if {$cnum >= 0 && $cnum <= 255} { + #todo - parse spec from names like 'red' to RGB + #todo - accept rgb:ab/cd/ef as well as rgb:/a/b/c (as alias for aa/bb/cc) + #also - what about rgb:abcd/defg/hijk and 12-bit abc/def/ghi ? + dict set cmap $cnum $spec + } else { + #todo - log + puts stderr "overtype::renderline OSC 4 set colour palette - bad color number: $cnum must be from 0 to 255. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + } + } + + puts stderr "overtype::renderline OSC 4 set colour palette unimplemented. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + + + } + 10 - 11 - 12 - 13 - 14 - 15 - 16 - 17 { + #OSC 10 through 17 - so called 'dynamic colours' + #can take multiple params - each successive parameter changes the next colour in the list + #- e.g if code started at 11 - next param is for 12. 17 takes only one param because there are no more + #10 change text foreground colour + #11 change text background colour + #12 change text cursor colour + #13 change mouse foreground colour + #14 change mouse background colour + #15 change tektronix foreground colour + #16 change tektronix background colour + #17 change highlight colour + set params [tcl::string::range $code_content 2 end] + + puts stderr "overtype::renderline OSC $osc_code set dynamic colours unimplemented. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + + + } + 18 { + #why is this not considered one of the dynamic colours above? + #https://www.xfree86.org/current/ctlseqs.html + #tektronix cursor color + puts stderr "overtype::renderline OSC 18 - set tektronix cursor color unimplemented. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + } + 99 { + #kitty desktop notifications + #https://sw.kovidgoyal.net/kitty/desktop-notifications/ + # 99 ; metadata ; payload + puts stderr "overtype::renderline OSC 99 kitty desktop notification unimplemented. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + } + 104 { + #reset colour palette + #we want to do it for the current rendering context only (vvt) - not just pass through to underlying vt + puts stderr "overtype::renderline OSC 104 reset colour palette unimplemented. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + priv::render_unapplied $overlay_grapheme_control_list $gci + set instruction [list reset_colour_palette] + break + } + 1337 { + #iterm2 graphics and file transfer + puts stderr "overtype::renderline OSC 1337 iterm2 graphics/file_transfer unimplemented. 1st 100 chars of code [ansistring VIEW -lf 1 -vt 1 -nul 1 [string range $code 0 99]]" + } + 5113 { + puts stderr "overtype::renderline OSC 5113 kitty file transfer unimplemented. 1st 100 chars of code [ansistring VIEW -lf 1 -vt 1 -nul 1 [string range $code 0 99]]" + } + default { + puts stderr "overtype::renderline OSC - UNIMPLEMENTED. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + } + } + + } + default { + } + } + + + } + default { + #don't need to handle sgr or gx0 types + #we have our sgr gx0 codes already in stacks for each overlay grapheme + } + } + } + + #-------- + if {$opt_expand_right == 0} { + #need to truncate to the width of the original undertext + #review - string_width vs printing_length here. undertext requirement to be already rendered therefore punk::char::string_width ok? + #set num_under_columns [punk::char::string_width $pt_underchars] ;#plaintext underchars + } + if {$overflow_idx == -1} { + #overflow was initially unlimited and hasn't been overridden + } else { + + } + #-------- + + + #coalesce and replay codestacks for outcols grapheme list + set outstring "" ;#output prior to overflow + set overflow_right "" ;#remainder after overflow point reached + set i 0 + set cstack [list] + set prevstack [list] + set prev_g0 [list] + #note overflow_idx may already have been set lower if we had a row move above due to \v or ANSI moves + set in_overflow 0 ;#used to stop char-width scanning once in overflow + if {$overflow_idx == 0} { + #how does caller avoid an infinite loop if they have autowrap on and keep throwing graphemes to the next line? REVIEW + set in_overflow 1 + } + set trailing_nulls 0 + foreach ch [lreverse $outcols] { + if {$ch eq "\u0000"} { + incr trailing_nulls + } else { + break + } + } + if {$trailing_nulls} { + set first_tail_null_posn [expr {[llength $outcols] - $trailing_nulls}] + } else { + set first_tail_null_posn -1 + } + + #puts stderr "first_tail_null_posn: $first_tail_null_posn" + #puts stderr "colview: [ansistring VIEW $outcols]" + + foreach ch $outcols { + #puts "---- [ansistring VIEW $ch]" + + set gxleader "" + if {$i < [llength $understacks_gx]} { + #set g0 [tcl::dict::get $understacks_gx $i] + set g0 [lindex $understacks_gx $i] + if {$g0 ne $prev_g0} { + if {$g0 eq [list "gx0_on"]} { + set gxleader "\x1b(0" + } else { + set gxleader "\x1b(B" + } + } + set prev_g0 $g0 + } else { + set prev_g0 [list] + } + + set sgrleader "" + if {$i < [llength $understacks]} { + #set cstack [tcl::dict::get $understacks $i] + set cstack [lindex $understacks $i] + if {$cstack ne $prevstack} { + if {[llength $prevstack] && ![llength $cstack]} { + #This reset is important e.g testfile fruit.ans - we get overhang on rhs without it. But why is cstack empty? + append sgrleader \033\[m + } else { + append sgrleader [punk::ansi::codetype::sgr_merge_list {*}$cstack] + } + } + set prevstack $cstack + } else { + set prevstack [list] + } + + + + if {$in_overflow} { + if {$i == $overflow_idx} { + set 0 [lindex $understacks_gx $i] + set gxleader "" + if {$g0 eq [list "gx0_on"]} { + set gxleader "\x1b(0" + } elseif {$g0 eq [list "gx0_off"]} { + set gxleader "\x1b(B" + } + append overflow_right $gxleader + set cstack [lindex $understacks $i] + set sgrleader "" + #whether cstack is same or differs from previous char's stack - we must have an output at the start of the overflow_right + #if {[llength $prevstack] && ![llength $cstack]} { + # append sgrleader \033\[m + #} + append sgrleader [punk::ansi::codetype::sgr_merge_list {*}$cstack] + append overflow_right $sgrleader + append overflow_right $ch + } else { + append overflow_right $gxleader + append overflow_right $sgrleader + append overflow_right $ch + } + } else { + if {$overflow_idx != -1 && $i+1 == $overflow_idx} { + #one before overflow + #will be in overflow in next iteration + set in_overflow 1 + if {[grapheme_width_cached $ch]> 1} { + #we overflowed with second-half of a double-width char - replace first-half with user-supplied exposition char (should be 1 wide) + set ch $opt_exposed1 + } + } + append outstring $gxleader + append outstring $sgrleader + if {$ch eq "\u0000"} { + if {$cp437_glyphs} { + #map all nulls including at tail to space + append outstring " " + } else { + if {$trailing_nulls && $i < $first_tail_null_posn} { + append outstring " " ;#map inner nulls to space + } else { + append outstring \u0000 + } + } + } else { + append outstring $ch + } + } + incr i + } + #flower.ans good test for null handling - reverse line building + #review - presence of overflow_right doesn't indicate line's trailing nulls should remain. + #The cells could have been erased? + #if {!$cp437_glyphs} { + # #if {![ansistring length $overflow_right]} { + # # set outstring [tcl::string::trimright $outstring "\u0000"] + # #} + # set outstring [tcl::string::trimright $outstring "\u0000"] + # set outstring [tcl::string::map {\u0000 " "} $outstring] + #} + + + #REVIEW + #set overflow_right [tcl::string::trimright $overflow_right "\u0000"] + #set overflow_right [tcl::string::map {\u0000 " "} $overflow_right] + + set replay_codes "" + if {[llength $understacks] > 0} { + if {$overflow_idx == -1} { + #set tail_idx [tcl::dict::size $understacks] + set tail_idx [llength $understacks] + } else { + set tail_idx [llength $undercols] + } + if {$tail_idx-1 < [llength $understacks]} { + #set replay_codes [join [lindex $understacks $tail_idx-1] ""] ;#tail replay codes + set replay_codes [punk::ansi::codetype::sgr_merge_list {*}[lindex $understacks $tail_idx-1]] ;#tail replay codes + } + if {$tail_idx-1 < [llength $understacks_gx]} { + set gx0 [lindex $understacks_gx $tail_idx-1] + if {$gx0 eq [list "gx0_on"]} { + #if it was on, turn gx0 off at the point we stop processing overlay + append outstring "\x1b(B" + } + } + } + if {[string length $overflow_right]} { + #puts stderr "remainder:$overflow_right" + } + #pdict $understacks + + if {[punk::ansi::ta::detect_sgr $outstring]} { + append outstring [punk::ansi::a] ;#without this - we would get for example, trailing backgrounds after rightmost column + + #close off any open gx? + #probably should - and overflow_right reopen? + } + + if {$opt_returnextra} { + #replay_codes is the codestack at the boundary - used for ellipsis colouring to match elided text - review + #replay_codes_underlay is the set of codes in effect at the very end of the original underlay + + #review + #replay_codes_overlay is the set of codes in effect at the very end of the original overlay (even if not all overlay was applied) + #todo - replay_codes for gx0 mode + + #overflow_idx may change during ansi & character processing + if {$overflow_idx == -1} { + set overflow_right_column "" + } else { + set overflow_right_column [expr {$overflow_idx+1}] + } + set result [tcl::dict::create\ + result $outstring\ + visualwidth [punk::ansi::printing_length $outstring]\ + instruction $instruction\ + stringlen [string length $outstring]\ + overflow_right_column $overflow_right_column\ + overflow_right $overflow_right\ + unapplied $unapplied\ + unapplied_list $unapplied_list\ + insert_mode $insert_mode\ + autowrap_mode $autowrap_mode\ + crm_mode $crm_mode\ + reverse_mode $reverse_mode\ + insert_lines_above $insert_lines_above\ + insert_lines_below $insert_lines_below\ + cursor_saved_position $cursor_saved_position\ + cursor_saved_attributes $cursor_saved_attributes\ + cursor_column $cursor_column\ + cursor_row $cursor_row\ + expand_right $opt_expand_right\ + replay_codes $replay_codes\ + replay_codes_underlay $replay_codes_underlay\ + replay_codes_overlay $replay_codes_overlay\ + pm_list $pm_list\ + ] + if {$opt_returnextra == 1} { + #puts stderr "renderline: $result" + return $result + } else { + #human/debug - map special chars to visual glyphs + set viewop VIEW + switch -- $opt_returnextra { + 2 { + #codes and character data + set viewop VIEWCODES ;#ansi colorisation of codes - green for SGR, blue/blue reverse for cursor_save/cursor_restore, cyan for movements, orange for others + } + 3 { + set viewop VIEWSTYLE ;#ansi colorise the characters within the output with preceding codes, stacking codes only within each dict value - may not be same SGR effect as the effect in-situ. + } + } + tcl::dict::set result result [ansistring $viewop -lf 1 -vt 1 [tcl::dict::get $result result]] + tcl::dict::set result overflow_right [ansistring VIEW -lf 1 -vt 1 [tcl::dict::get $result overflow_right]] + tcl::dict::set result unapplied [ansistring VIEW -lf 1 -vt 1 [tcl::dict::get $result unapplied]] + tcl::dict::set result unapplied_list [ansistring VIEW -lf 1 -vt 1 [tcl::dict::get $result unapplied_list]] + tcl::dict::set result replay_codes [ansistring $viewop -lf 1 -vt 1 [tcl::dict::get $result replay_codes]] + tcl::dict::set result replay_codes_underlay [ansistring $viewop -lf 1 -vt 1 [tcl::dict::get $result replay_codes_underlay]] + tcl::dict::set result replay_codes_overlay [ansistring $viewop -lf 1 -vt 1 [tcl::dict::get $result replay_codes_overlay]] + tcl::dict::set result cursor_saved_attributes [ansistring $viewop -lf 1 -vt 1 [tcl::dict::get $result cursor_saved_attributes]] + return $result + } + } else { + #puts stderr "renderline returning: result $outstring instruction $instruction unapplied $unapplied overflow_right $overflow_right" + return $outstring + } + #return [join $out ""] + } + + #*** !doctools + #[list_end] [comment {--- end definitions namespace overtype ---}] +} + +tcl::namespace::eval overtype::piper { + proc overcentre {args} { + if {[llength $args] < 2} { + error {usage: ?-bias left|right? ?-transparent [0|1|]? ?-exposed1 ? ?-exposed2 ? ?-overflow [1|0]? overtext pipelinedata} + } + lassign [lrange $args end-1 end] over under + set argsflags [lrange $args 0 end-2] + tailcall overtype::centre {*}$argsflags $under $over + } + proc overleft {args} { + if {[llength $args] < 2} { + error {usage: ?-startcolumn ? ?-transparent [0|1|]? ?-exposed1 ? ?-exposed2 ? ?-overflow [1|0]? overtext pipelinedata} + } + lassign [lrange $args end-1 end] over under + set argsflags [lrange $args 0 end-2] + tailcall overtype::left {*}$argsflags $under $over + } +} + + +# -- --- --- --- --- --- --- --- --- --- --- +proc overtype::transparentline {args} { + foreach {under over} [lrange $args end-1 end] break + set argsflags [lrange $args 0 end-2] + set defaults [tcl::dict::create\ + -transparent 1\ + -exposed 1 " "\ + -exposed 2 " "\ + ] + set newargs [tcl::dict::merge $defaults $argsflags] + tailcall overtype::renderline {*}$newargs $under $over +} +#renderline may not make sense as it is in the long run for blocks of text - but is handy in the single-line-handling form anyway. +# We are trying to handle ansi codes in a block of text which is acting like a mini-terminal in some sense. +#We can process standard cursor moves such as \b \r - but no way to respond to other cursor movements e.g moving to other lines. +# +tcl::namespace::eval overtype::piper { + proc renderline {args} { + if {[llength $args] < 2} { + error {usage: ?-start ? ?-transparent [0|1|]? ?-overflow [1|0]? overtext pipelinedata} + } + foreach {over under} [lrange $args end-1 end] break + set argsflags [lrange $args 0 end-2] + tailcall overtype::renderline {*}$argsflags $under $over + } +} +interp alias "" piper_renderline "" overtype::piper::renderline + +#intended primarily for single grapheme - but will work for multiple +#WARNING: query CAN contain ansi or newlines - but if cache was not already set manually,the answer will be incorrect! +#We deliberately allow this for PM/SOS attached within a column +#(a cache of ansifreestring_width calls - as these are quite regex heavy) +proc overtype::grapheme_width_cached {ch} { + variable grapheme_widths + if {[tcl::dict::exists $grapheme_widths $ch]} { + return [tcl::dict::get $grapheme_widths $ch] + } + set width [punk::char::ansifreestring_width $ch] + tcl::dict::set grapheme_widths $ch $width + return $width +} + + + +proc overtype::test_renderline {} { + set t \uFF5E ;#2-wide tilde + set u \uFF3F ;#2-wide underscore + set missing \uFFFD + return [list $t $u A${t}B] +} + +#maintenance warning +#same as textblock::size - but we don't want that circular dependency +#block width and height can be tricky. e.g \v handled differently on different terminal emulators and can affect both +proc overtype::blocksize {textblock} { + if {$textblock eq ""} { + return [tcl::dict::create width 0 height 1] ;#no such thing as zero-height block - for consistency with non-empty strings having no line-endings + } + if {[tcl::string::first \t $textblock] >= 0} { + if {[info exists punk::console::tabwidth]} { + set tw $::punk::console::tabwidth + } else { + set tw 8 + } + set textblock [textutil::tabify::untabify2 $textblock $tw] + } + #ansistrip on entire block in one go rather than line by line - result should be the same - review - make tests + if {[punk::ansi::ta::detect $textblock]} { + set textblock [punk::ansi::ansistrip $textblock] + } + if {[tcl::string::last \n $textblock] >= 0} { + set num_le [expr {[tcl::string::length $textblock]-[tcl::string::length [tcl::string::map {\n {}} $textblock]]}] ;#faster than splitting into single-char list + set width [tcl::mathfunc::max {*}[lmap v [split $textblock \n] {::punk::char::ansifreestring_width $v}]] + } else { + set num_le 0 + set width [punk::char::ansifreestring_width $textblock] + } + #our concept of block-height is likely to be different to other line-counting mechanisms + set height [expr {$num_le + 1}] ;# one line if no le - 2 if there is one trailing le even if no data follows le + + return [tcl::dict::create width $width height $height] ;#maintain order in 'image processing' standard width then height - caller may use lassign [dict values [blocksize ]] width height +} + +tcl::namespace::eval overtype::priv { + variable cache_is_sgr [tcl::dict::create] + + #we are likely to be asking the same question of the same ansi codes repeatedly + #caching the answer saves some regex expense - possibly a few uS to lookup vs under 1uS + #todo - test if still worthwhile after a large cache is built up. (limit cache size?) + proc is_sgr {code} { + variable cache_is_sgr + if {[tcl::dict::exists $cache_is_sgr $code]} { + return [tcl::dict::get $cache_is_sgr $code] + } + set answer [punk::ansi::codetype::is_sgr $code] + tcl::dict::set cache_is_sgr $code $answer + return $answer + } + # better named render_to_unapplied? + proc render_unapplied {overlay_grapheme_control_list gci} { + upvar idx_over idx_over + upvar unapplied unapplied + upvar unapplied_list unapplied_list ;#maintaining as a list allows caller to utilize it without having to re-split + upvar overstacks overstacks + upvar overstacks_gx overstacks_gx + upvar overlay_grapheme_control_stacks og_stacks + + #set unapplied [join [lrange $overlay_grapheme_control_list $gci+1 end]] + set unapplied "" + set unapplied_list [list] + #append unapplied [join [lindex $overstacks $idx_over] ""] + #append unapplied [punk::ansi::codetype::sgr_merge_list {*}[lindex $overstacks $idx_over]] + set sgr_merged [punk::ansi::codetype::sgr_merge_list {*}[lindex $og_stacks $gci]] + if {$sgr_merged ne ""} { + lappend unapplied_list $sgr_merged + } + switch -- [lindex $overstacks_gx $idx_over] { + "gx0_on" { + lappend unapplied_list "\x1b(0" + } + "gx0_off" { + lappend unapplied_list "\x1b(B" + } + } + + foreach gc [lrange $overlay_grapheme_control_list $gci+1 end] { + lassign $gc type item + #types g other sgr gx0 + if {$type eq "gx0"} { + if {$item eq "gx0_on"} { + lappend unapplied_list "\x1b(0" + } elseif {$item eq "gx0_off"} { + lappend unapplied_list "\x1b(B" + } + } else { + lappend unapplied_list $item + } + } + set unapplied [join $unapplied_list ""] + } + + #clearer - renders the specific gci forward as unapplied - prefixed with it's merged sgr stack + proc render_this_unapplied {overlay_grapheme_control_list gci} { + upvar idx_over idx_over + upvar unapplied unapplied + upvar unapplied_list unapplied_list + upvar overstacks overstacks + upvar overstacks_gx overstacks_gx + upvar overlay_grapheme_control_stacks og_stacks + + #set unapplied [join [lrange $overlay_grapheme_control_list $gci+1 end]] + set unapplied "" + set unapplied_list [list] + + set sgr_merged [punk::ansi::codetype::sgr_merge_list {*}[lindex $og_stacks $gci]] + if {$sgr_merged ne ""} { + lappend unapplied_list $sgr_merged + } + switch -- [lindex $overstacks_gx $idx_over] { + "gx0_on" { + lappend unapplied_list "\x1b(0" + } + "gx0_off" { + lappend unapplied_list "\x1b(B" + } + } + + foreach gc [lrange $overlay_grapheme_control_list $gci end] { + lassign $gc type item + #types g other sgr gx0 + if {$type eq "gx0"} { + if {$item eq "gx0_on"} { + lappend unapplied_list "\x1b(0" + } elseif {$item eq "gx0_off"} { + lappend unapplied_list "\x1b(B" + } + } else { + lappend unapplied_list $item + } + } + set unapplied [join $unapplied_list ""] + } + proc render_delchar {i} { + upvar outcols o + upvar understacks ustacks + upvar understacks_gx gxstacks + set nxt [llength $o] + if {$i < $nxt} { + set o [lreplace $o $i $i] + set ustacks [lreplace $ustacks $i $i] + set gxstacks [lreplace $gxstacks $i $i] + } elseif {$i == 0 || $i == $nxt} { + #nothing to do + } else { + puts stderr "render_delchar - attempt to delchar at index $i >= number of outcols $nxt - shouldn't happen" + } + } + proc render_erasechar {i count} { + upvar outcols o + upvar understacks ustacks + upvar understacks_gx gxstacks + upvar replay_codes_overlay replay + #ECH clears character attributes from erased character positions + #ECH accepts 0 or empty parameter, which is equivalent to 1. Caller of render_erasechar should do that mapping and only supply 1 or greater. + if {![tcl::string::is integer -strict $count] || $count < 1} { + error "render_erasechar count must be integer >= 1" + } + set start $i + set end [expr {$i + $count -1}] + #we restrict ECH to current line - as some terminals do - review - is that the only way it's implemented? + if {$i > [llength $o]-1} { + return + } + if {$end > [llength $o]-1} { + set end [expr {[llength $o]-1}] + } + set num [expr {$end - $start + 1}] + set o [lreplace $o $start $end {*}[lrepeat $num \u0000]] ;#or space? + #DECECM ??? + set ustacks [lreplace $ustacks $start $end {*}[lrepeat $num [list $replay]]] + set gxstacks [lreplace $gxstacks $start $end {*}[lrepeat $num [list]]] ;# ??? review + return + } + proc render_setchar {i c } { + upvar outcols o + lset o $i $c + } + + #Initial usecase is for old-terminal hack to add PM-wrapped \b + #review - can be used for other multibyte sequences that occupy one column? + #combiners? diacritics? + proc render_append_to_char {i c} { + upvar outcols o + if {$i > [llength $o]-1} { + error "render_append_to_char cannot append [ansistring VIEW -lf 1 -nul 1 $c] to existing char at index $i while $i >= llength outcols [llength $o]" + } + set existing [lindex $o $i] + if {$existing eq "\0"} { + lset o $i $c + } else { + lset o $i $existing$c + } + } + #is actually addgrapheme? + proc render_addchar {i c sgrstack gx0stack {insert_mode 0}} { + upvar outcols o + upvar understacks ustacks + upvar understacks_gx gxstacks + + # -- --- --- + #this is somewhat of a hack.. probably not really the equivalent of proper reverse video? review + #we should ideally be able to reverse the video of a sequence that already includes SGR reverse/noreverse attributes + upvar reverse_mode do_reverse + #if {$do_reverse} { + # lappend sgrstack [a+ reverse] + #} else { + # lappend sgrstack [a+ noreverse] + #} + + #JMN3 + if {$do_reverse} { + #note we can't just look for \x1b\[7m or \x1b\[27m + # it may be a more complex sequence like \x1b\[0\;\;7\;31m etc + + set existing_reverse_state 0 + set codeinfo [punk::ansi::codetype::sgr_merge $sgrstack -info 1] + set codestate_reverse [dict get $codeinfo codestate reverse] + switch -- $codestate_reverse { + 7 { + set existing_reverse_state 1 + } + 27 { + set existing_reverse_state 0 + } + "" { + } + } + if {$existing_reverse_state == 0} { + set rflip [a+ reverse] + } else { + #reverse of reverse + set rflip [a+ noreverse] + } + #note that mergeresult can have multiple esc (due to unmergeables or non sgr codes) + set sgrstack [list [dict get $codeinfo mergeresult] $rflip] + #set sgrstack [punk::ansi::codetype::sgr_merge [list [dict get $codeinfo mergeresult] $rflip]] + } + + # -- --- --- + + set nxt [llength $o] + if {!$insert_mode} { + if {$i < $nxt} { + #These lists must always be in sync + lset o $i $c + } else { + lappend o $c + } + if {$i < [llength $ustacks]} { + lset ustacks $i $sgrstack + lset gxstacks $i $gx0stack + } else { + lappend ustacks $sgrstack + lappend gxstacks $gx0stack + } + } else { + #insert of single-width vs double-width when underlying is double-width? + if {$i < $nxt} { + set o [linsert $o $i $c] + } else { + lappend o $c + } + if {$i < [llength $ustacks]} { + set ustacks [linsert $ustacks $i $sgrstack] + set gxstacks [linsert $gxstacks $i $gx0stack] + } else { + lappend ustacks $sgrstack + lappend gxstacks $gx0stack + } + } + } + +} + + + +# -- --- --- --- --- --- --- --- --- --- --- +tcl::namespace::eval overtype { + interp alias {} ::overtype::center {} ::overtype::centre +} + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Ready +package provide overtype [tcl::namespace::eval overtype { + variable version + set version 1.7.1 +}] +return + +#*** !doctools +#[manpage_end] diff --git a/src/vendormodules/patterncmd-0.1.tm b/src/vendormodules/patterncmd-0.1.tm deleted file mode 100644 index 8008673a..00000000 --- a/src/vendormodules/patterncmd-0.1.tm +++ /dev/null @@ -1,639 +0,0 @@ -package provide patterncmd [namespace eval patterncmd { - variable version - set version 0.1 -}] - - -namespace eval pattern { - variable idCounter 1 ;#used by pattern::uniqueKey - - namespace eval cmd { - namespace eval util { - package require overtype - variable colwidths_lib [dict create] - variable colwidths_lib_default 15 - - dict set colwidths_lib "library" [list ch " " num 21 head "|" tail ""] - dict set colwidths_lib "version" [list ch " " num 7 head "|" tail ""] - dict set colwidths_lib "type" [list ch " " num 9 head "|" tail ""] - dict set colwidths_lib "note" [list ch " " num 31 head "|" tail "|"] - - proc colhead {type args} { - upvar #0 ::pattern::cmd::util::colwidths_$type colwidths - set line "" - foreach colname [dict keys $colwidths] { - append line "[col $type $colname [string totitle $colname] {*}$args]" - } - return $line - } - proc colbreak {type} { - upvar #0 ::pattern::cmd::util::colwidths_$type colwidths - set line "" - foreach colname [dict keys $colwidths] { - append line "[col $type $colname {} -backchar - -headoverridechar + -tailoverridechar +]" - } - return $line - } - proc col {type col val args} { - # args -head bool -tail bool ? - #---------------------------------------------------------------------------- - set known_opts [list -backchar -headchar -tailchar -headoverridechar -tailoverridechar -justify] - dict set default -backchar "" - dict set default -headchar "" - dict set default -tailchar "" - dict set default -headoverridechar "" - dict set default -tailoverridechar "" - dict set default -justify "left" - if {([llength $args] % 2) != 0} { - error "(pattern::cmd::util::col) ERROR: uneven options supplied - must be of form '-option value' " - } - foreach {k v} $args { - if {$k ni $known_opts} { - error "((pattern::cmd::util::col) ERROR: option '$k' not in known options: '$known_opts'" - } - } - set opts [dict merge $default $args] - set backchar [dict get $opts -backchar] - set headchar [dict get $opts -headchar] - set tailchar [dict get $opts -tailchar] - set headoverridechar [dict get $opts -headoverridechar] - set tailoverridechar [dict get $opts -tailoverridechar] - set justify [dict get $opts -justify] - #---------------------------------------------------------------------------- - - - - upvar #0 ::pattern::cmd::util::colwidths_$type colwidths - #calculate headwidths - set headwidth 0 - set tailwidth 0 - foreach {key def} $colwidths { - set thisheadlen [string length [dict get $def head]] - if {$thisheadlen > $headwidth} { - set headwidth $thisheadlen - } - set thistaillen [string length [dict get $def tail]] - if {$thistaillen > $tailwidth} { - set tailwidth $thistaillen - } - } - - - set spec [dict get $colwidths $col] - if {[string length $backchar]} { - set ch $backchar - } else { - set ch [dict get $spec ch] - } - set num [dict get $spec num] - set headchar [dict get $spec head] - set tailchar [dict get $spec tail] - - if {[string length $headchar]} { - set headchar $headchar - } - if {[string length $tailchar]} { - set tailchar $tailchar - } - #overrides only apply if the head/tail has a length - if {[string length $headchar]} { - if {[string length $headoverridechar]} { - set headchar $headoverridechar - } - } - if {[string length $tailchar]} { - if {[string length $tailoverridechar]} { - set tailchar $tailoverridechar - } - } - set head [string repeat $headchar $headwidth] - set tail [string repeat $tailchar $tailwidth] - - set base [string repeat $ch [expr {$headwidth + $num + $tailwidth}]] - if {$justify eq "left"} { - set left_done [overtype::left $base "$head$val"] - return [overtype::right $left_done "$tail"] - } elseif {$justify in {centre center}} { - set mid_done [overtype::centre $base $val] - set left_mid_done [overtype::left $mid_done $head] - return [overtype::right $left_mid_done $tail] - } else { - set right_done [overtype::right $base "$val$tail"] - return [overtype::left $right_done $head] - } - - } - - } - } - -} - -#package require pattern - -proc ::pattern::libs {} { - set libs [list \ - pattern {-type core -note "alternative:pattern2"}\ - pattern2 {-type core -note "alternative:pattern"}\ - patterncmd {-type core}\ - metaface {-type core}\ - patternpredator2 {-type core}\ - patterndispatcher {-type core}\ - patternlib {-type core}\ - patterncipher {-type optional -note optional}\ - ] - - - - package require overtype - set result "" - - append result "[cmd::util::colbreak lib]\n" - append result "[cmd::util::colhead lib -justify centre]\n" - append result "[cmd::util::colbreak lib]\n" - foreach libname [dict keys $libs] { - set libinfo [dict get $libs $libname] - - append result [cmd::util::col lib library $libname] - if {[catch [list package present $libname] ver]} { - append result [cmd::util::col lib version "N/A"] - } else { - append result [cmd::util::col lib version $ver] - } - append result [cmd::util::col lib type [dict get $libinfo -type]] - - if {[dict exists $libinfo -note]} { - set note [dict get $libinfo -note] - } else { - set note "" - } - append result [cmd::util::col lib note $note] - append result "\n" - } - append result "[cmd::util::colbreak lib]\n" - return $result -} - -proc ::pattern::record {recname fields} { - if {[uplevel 1 [list namespace which $recname]] ne ""} { - error "(pattern::record) Can't create command '$recname': A command of that name already exists" - } - - set index -1 - set accessor [list ::apply { - {index rec args} - { - if {[llength $args] == 0} { - return [lindex $rec $index] - } - if {[llength $args] == 1} { - return [lreplace $rec $index $index [lindex $args 0]] - } - error "Invalid number of arguments." - } - - }] - - set map {} - foreach field $fields { - dict set map $field [linsert $accessor end [incr index]] - } - uplevel 1 [list namespace ensemble create -command $recname -map $map -parameters rec] -} -proc ::pattern::record2 {recname fields} { - if {[uplevel 1 [list namespace which $recname]] ne ""} { - error "(pattern::record) Can't create command '$recname': A command of that name already exists" - } - - set index -1 - set accessor [list ::apply] - - set template { - {rec args} - { - if {[llength $args] == 0} { - return [lindex $rec %idx%] - } - if {[llength $args] == 1} { - return [lreplace $rec %idx% %idx% [lindex $args 0]] - } - error "Invalid number of arguments." - } - } - - set map {} - foreach field $fields { - set body [string map [list %idx% [incr index]] $template] - dict set map $field [list ::apply $body] - } - uplevel 1 [list namespace ensemble create -command $recname -map $map -parameters rec] -} - -proc ::argstest {args} { - package require cmdline - -} - -proc ::pattern::objects {} { - set result [::list] - - foreach ns [namespace children ::pp] { - #lappend result [::list [namespace tail $ns] [set ${ns}::(self)]] - set ch [namespace tail $ns] - if {[string range $ch 0 2] eq "Obj"} { - set OID [string range $ch 3 end] ;#OID need not be digits (!?) - lappend result [::list $OID [list OID $OID object_command [set pp::${ch}::v_object_command] usedby [array names ${ns}::_iface::o_usedby]]] - } - } - - return $result -} - - - -proc ::pattern::name {num} { - #!todo - fix - #set ::p::${num}::(self) - - lassign [interp alias {} ::p::$num] _predator info - if {![string length $_predator$info]} { - error "No object found for num:$num (no interp alias for ::p::$num)" - } - set invocants [dict get $info i] - set invocants_with_role_this [dict get $invocants this] - set invocant_this [lindex $invocants_with_role_this 0] - - - #lassign $invocant_this id info - #set map [dict get $info map] - #set fields [lindex $map 0] - lassign $invocant_this _id _ns _defaultmethod name _etc - return $name -} - - -proc ::pattern::with {cmd script} { - foreach c [info commands ::p::-1::*] { - interp alias {} [namespace tail $c] {} $c $cmd - } - interp alias {} . {} $cmd . - interp alias {} .. {} $cmd .. - return [uplevel 1 $script] -} - - - - - -#system diagnostics etc - -proc ::pattern::varspace_list {IID} { - namespace upvar ::p::${IID}::_iface o_varspace o_varspace o_variables o_variables - - set varspaces [list] - dict for {vname vdef} $o_variables { - set vs [dict get $vdef varspace] - if {$vs ni $varspaces} { - lappend varspaces $vs - } - } - if {$o_varspace ni $varspaces} { - lappend varspaces $o_varspace - } - return $varspaces -} - -proc ::pattern::check_interfaces {} { - foreach ns [namespace children ::p] { - set IID [namespace tail $ns] - if {[string is digit $IID]} { - foreach ref [array names ${ns}::_iface::o_usedby] { - set OID [string range $ref 1 end] - if {![namespace exists ::p::${OID}::_iface]} { - puts -nonewline stdout "\r\nPROBLEM!!!!!!!!! nonexistant/invalid object $OID referenced by Interface $IID\r\n" - } else { - puts -nonewline stdout . - } - - - #if {![info exists ::p::${OID}::(self)]} { - # puts "PROBLEM!!!!!!!!! nonexistant object $OID referenced by Interface $IID" - #} - } - } - } - puts -nonewline stdout "\r\n" -} - - -#from: http://wiki.tcl.tk/8766 (Introspection on aliases) -#usedby: metaface-1.1.6+ -#required because aliases can be renamed. -#A renamed alias will still return it's target with 'interp alias {} oldname' -# - so given newname - we require which_alias to return the same info. - proc ::pattern::which_alias {cmd} { - uplevel 1 [list ::trace add execution $cmd enterstep ::error] - catch {uplevel 1 $cmd} res - uplevel 1 [list ::trace remove execution $cmd enterstep ::error] - #puts stdout "which_alias $cmd returning '$res'" - return $res - } -# [info args] like proc following an alias recursivly until it reaches -# the proc it originates from or cannot determine it. -# accounts for default parameters set by interp alias -# - - -proc ::pattern::aliasargs {cmd} { - set orig $cmd - - set defaultargs [list] - - # loop until error or return occurs - while {1} { - # is it a proc already? - if {[string equal [info procs $cmd] $cmd]} { - set result [info args $cmd] - # strip off the interp set default args - return [lrange $result [llength $defaultargs] end] - } - # is it a built in or extension command we can get no args for? - if {![string equal [info commands $cmd] $cmd]} { - error "\"$orig\" isn't a procedure" - } - - # catch bogus cmd names - if {[lsearch [interp aliases {}] $cmd]==-1} { - if {[catch {::pattern::which_alias $cmd} alias]} { - error "\"$orig\" isn't a procedure or alias or command" - } - #set cmd [lindex $alias 0] - if {[llength $alias]>1} { - set cmd [lindex $alias 0] - set defaultargs [concat [lrange $alias 1 end] $defaultargs] - } else { - set cmd $alias - } - } else { - - if {[llength [set cmdargs [interp alias {} $cmd]]]>0} { - # check if it is aliased in from another interpreter - if {[catch {interp target {} $cmd} msg]} { - error "Cannot resolve \"$orig\", alias leads to another interpreter." - } - if {$msg != {} } { - error "Not recursing into slave interpreter \"$msg\".\ - \"$orig\" could not be resolved." - } - # check if defaults are set for the alias - if {[llength $cmdargs]>1} { - set cmd [lindex $cmdargs 0] - set defaultargs [concat [lrange $cmdargs 1 end] $defaultargs] - } else { - set cmd $cmdargs - } - } - } - } -} - -proc ::pattern::aliasbody {cmd} { - set orig $cmd - - set defaultargs [list] - - # loop until error or return occurs - while {1} { - # is it a proc already? - if {[string equal [info procs $cmd] $cmd]} { - set result [info body $cmd] - # strip off the interp set default args - return $result - #return [lrange $result [llength $defaultargs] end] - } - # is it a built in or extension command we can get no args for? - if {![string equal [info commands $cmd] $cmd]} { - error "\"$orig\" isn't a procedure" - } - - # catch bogus cmd names - if {[lsearch [interp aliases {}] $cmd]==-1} { - if {[catch {::pattern::which_alias $cmd} alias]} { - error "\"$orig\" isn't a procedure or alias or command" - } - #set cmd [lindex $alias 0] - if {[llength $alias]>1} { - set cmd [lindex $alias 0] - set defaultargs [concat [lrange $alias 1 end] $defaultargs] - } else { - set cmd $alias - } - } else { - - if {[llength [set cmdargs [interp alias {} $cmd]]]>0} { - # check if it is aliased in from another interpreter - if {[catch {interp target {} $cmd} msg]} { - error "Cannot resolve \"$orig\", alias leads to another interpreter." - } - if {$msg != {} } { - error "Not recursing into slave interpreter \"$msg\".\ - \"$orig\" could not be resolved." - } - # check if defaults are set for the alias - if {[llength $cmdargs]>1} { - set cmd [lindex $cmdargs 0] - set defaultargs [concat [lrange $cmdargs 1 end] $defaultargs] - } else { - set cmd $cmdargs - } - } - } - } - } - - - - - -proc ::pattern::uniqueKey2 {} { - #!todo - something else?? - return [clock seconds]-[incr ::pattern::idCounter] -} - -#used by patternlib package -proc ::pattern::uniqueKey {} { - return [incr ::pattern::idCounter] - #uuid with tcllibc is about 30us compared with 2us - # for large datasets, e.g about 100K inserts this would be pretty noticable! - #!todo - uuid pool with background thread to repopulate when idle? - #return [uuid::uuid generate] -} - - - -#------------------------------------------------------------------------------------------------------------------------- - -proc ::pattern::test1 {} { - set msg "OK" - - puts stderr "next line should say:'--- saystuff:$msg" - ::>pattern .. Create ::>thing - - ::>thing .. PatternMethod saystuff args { - puts stderr "--- saystuff: $args" - } - ::>thing .. Create ::>jjj - - ::>jjj . saystuff $msg - ::>jjj .. Destroy - ::>thing .. Destroy -} - -proc ::pattern::test2 {} { - set msg "OK" - - puts stderr "next line should say:'--- property 'stuff' value:$msg" - ::>pattern .. Create ::>thing - - ::>thing .. PatternProperty stuff $msg - - ::>thing .. Create ::>jjj - - puts stderr "--- property 'stuff' value:[::>jjj . stuff]" - ::>jjj .. Destroy - ::>thing .. Destroy -} - -proc ::pattern::test3 {} { - set msg "OK" - - puts stderr "next line should say:'--- property 'stuff' value:$msg" - ::>pattern .. Create ::>thing - - ::>thing .. Property stuff $msg - - puts stderr "--- property 'stuff' value:[::>thing . stuff]" - ::>thing .. Destroy -} - -#--------------------------------- -#unknown/obsolete - - - - - - - -#proc ::p::internals::showargs {args {ch stdout}} {puts $ch $args} - -if {0} { - proc ::p::internals::new_interface {{usedbylist {}}} { - set OID [incr ::p::ID] - ::p::internals::new_object ::p::ifaces::>$OID "" $OID - puts "obsolete >> new_interface created object $OID" - foreach usedby $usedbylist { - set ::p::${OID}::_iface::o_usedby(i$usedby) 1 - } - set ::p::${OID}::_iface::o_varspace "" ;#default varspace is the object's namespace. (varspace is absolute if it has leading :: , otherwise it's a relative namespace below the object's namespace) - #NOTE - o_varspace is only the default varspace for when new methods/properties are added. - # it is possible to create some methods/props with one varspace value, then create more methods/props with a different varspace value. - - set ::p::${OID}::_iface::o_constructor [list] - set ::p::${OID}::_iface::o_variables [list] - set ::p::${OID}::_iface::o_properties [dict create] - set ::p::${OID}::_iface::o_methods [dict create] - array set ::p::${OID}::_iface::o_definition [list] - set ::p::${OID}::_iface::o_open 1 ;#open for extending - return $OID - } - - - #temporary way to get OID - assumes single 'this' invocant - #!todo - make generic. - proc ::pattern::get_oid {_ID_} { - #puts stderr "#* get_oid: [lindex [dict get $_ID_ i this] 0 0]" - return [lindex [dict get $_ID_ i this] 0 0] - - #set invocants [dict get $_ID_ i] - #set invocant_roles [dict keys $invocants] - #set role_members [dict get $invocants this] - ##set this_invocant [lindex $role_members 0] ;#for the role 'this' we assume only one invocant in the list. - #set this_invocant [lindex [dict get $_ID_ i this] 0] ; - #lassign $this_invocant OID this_info - # - #return $OID - } - - #compile the uncompiled level1 interface - #assert: no more than one uncompiled interface present at level1 - proc ::p::meta::PatternCompile {self} { - error "PatternCompile ????" - - upvar #0 $self SELFMAP - set ID [lindex $SELFMAP 0 0] - - set patterns [lindex $SELFMAP 1 1] ;#list of level1 interfaces - - set iid -1 - foreach i $patterns { - if {[set ::p::${i}::_iface::o_open]} { - set iid $i ;#found it - break - } - } - - if {$iid > -1} { - #!todo - - ::p::compile_interface $iid - set ::p::${iid}::_iface::o_open 0 - } else { - #no uncompiled interface present at level 1. Do nothing. - return - } - } - - - proc ::p::meta::Def {self} { - error ::p::meta::Def - - upvar #0 $self SELFMAP - set self_ID [lindex $SELFMAP 0 0] - set IFID [lindex $SELFMAP 1 0 end] - - set maxc1 0 - set maxc2 0 - - set arrName ::p::${IFID}:: - - upvar #0 $arrName state - - array set methods {} - - foreach nm [array names state] { - if {[regexp {^m-1,name,(.+)} $nm _match mname]} { - set methods($mname) [set state($nm)] - - if {[string length $mname] > $maxc1} { - set maxc1 [string length $mname] - } - if {[string length [set state($nm)]] > $maxc2} { - set maxc2 [string length [set state($nm)]] - } - } - } - set bg1 [string repeat " " [expr {$maxc1 + 2}]] - set bg2 [string repeat " " [expr {$maxc2 + 2}]] - - - set r {} - foreach nm [lsort -dictionary [array names methods]] { - set arglist $state(m-1,args,$nm) - append r "[overtype::left $bg1 $nm] : [overtype::left $bg2 $methods($nm)] [::list $arglist]\n" - } - return $r - } - - -} \ No newline at end of file diff --git a/src/vendormodules/patterncmd-1.2.4.tm b/src/vendormodules/patterncmd-1.2.4.tm deleted file mode 100644 index ca061a7c..00000000 --- a/src/vendormodules/patterncmd-1.2.4.tm +++ /dev/null @@ -1,645 +0,0 @@ -package provide patterncmd [namespace eval patterncmd { - variable version - - set version 1.2.4 -}] - - -namespace eval pattern { - variable idCounter 1 ;#used by pattern::uniqueKey - - namespace eval cmd { - namespace eval util { - package require overtype - variable colwidths_lib [dict create] - variable colwidths_lib_default 15 - - dict set colwidths_lib "library" [list ch " " num 21 head "|" tail ""] - dict set colwidths_lib "version" [list ch " " num 7 head "|" tail ""] - dict set colwidths_lib "type" [list ch " " num 9 head "|" tail ""] - dict set colwidths_lib "note" [list ch " " num 31 head "|" tail "|"] - - proc colhead {type args} { - upvar #0 ::pattern::cmd::util::colwidths_$type colwidths - set line "" - foreach colname [dict keys $colwidths] { - append line "[col $type $colname [string totitle $colname] {*}$args]" - } - return $line - } - proc colbreak {type} { - upvar #0 ::pattern::cmd::util::colwidths_$type colwidths - set line "" - foreach colname [dict keys $colwidths] { - append line "[col $type $colname {} -backchar - -headoverridechar + -tailoverridechar +]" - } - return $line - } - proc col {type col val args} { - # args -head bool -tail bool ? - #---------------------------------------------------------------------------- - set known_opts [list -backchar -headchar -tailchar -headoverridechar -tailoverridechar -justify] - dict set default -backchar "" - dict set default -headchar "" - dict set default -tailchar "" - dict set default -headoverridechar "" - dict set default -tailoverridechar "" - dict set default -justify "left" - if {([llength $args] % 2) != 0} { - error "(pattern::cmd::util::col) ERROR: uneven options supplied - must be of form '-option value' " - } - foreach {k v} $args { - if {$k ni $known_opts} { - error "((pattern::cmd::util::col) ERROR: option '$k' not in known options: '$known_opts'" - } - } - set opts [dict merge $default $args] - set backchar [dict get $opts -backchar] - set headchar [dict get $opts -headchar] - set tailchar [dict get $opts -tailchar] - set headoverridechar [dict get $opts -headoverridechar] - set tailoverridechar [dict get $opts -tailoverridechar] - set justify [dict get $opts -justify] - #---------------------------------------------------------------------------- - - - - upvar #0 ::pattern::cmd::util::colwidths_$type colwidths - #calculate headwidths - set headwidth 0 - set tailwidth 0 - foreach {key def} $colwidths { - set thisheadlen [string length [dict get $def head]] - if {$thisheadlen > $headwidth} { - set headwidth $thisheadlen - } - set thistaillen [string length [dict get $def tail]] - if {$thistaillen > $tailwidth} { - set tailwidth $thistaillen - } - } - - - set spec [dict get $colwidths $col] - if {[string length $backchar]} { - set ch $backchar - } else { - set ch [dict get $spec ch] - } - set num [dict get $spec num] - set headchar [dict get $spec head] - set tailchar [dict get $spec tail] - - if {[string length $headchar]} { - set headchar $headchar - } - if {[string length $tailchar]} { - set tailchar $tailchar - } - #overrides only apply if the head/tail has a length - if {[string length $headchar]} { - if {[string length $headoverridechar]} { - set headchar $headoverridechar - } - } - if {[string length $tailchar]} { - if {[string length $tailoverridechar]} { - set tailchar $tailoverridechar - } - } - set head [string repeat $headchar $headwidth] - set tail [string repeat $tailchar $tailwidth] - - set base [string repeat $ch [expr {$headwidth + $num + $tailwidth}]] - if {$justify eq "left"} { - set left_done [overtype::left $base "$head$val"] - return [overtype::right $left_done "$tail"] - } elseif {$justify in {centre center}} { - set mid_done [overtype::centre $base $val] - set left_mid_done [overtype::left $mid_done $head] - return [overtype::right $left_mid_done $tail] - } else { - set right_done [overtype::right $base "$val$tail"] - return [overtype::left $right_done $head] - } - - } - - } - } - -} - -#package require pattern - -proc ::pattern::libs {} { - set libs [list \ - pattern {-type core -note "alternative:pattern2"}\ - pattern2 {-type core -note "alternative:pattern"}\ - patterncmd {-type core}\ - metaface {-type core}\ - patternpredator2 {-type core}\ - patterndispatcher {-type core}\ - patternlib {-type core}\ - patterncipher {-type optional -note optional}\ - ] - - - - package require overtype - set result "" - - append result "[cmd::util::colbreak lib]\n" - append result "[cmd::util::colhead lib -justify centre]\n" - append result "[cmd::util::colbreak lib]\n" - foreach libname [dict keys $libs] { - set libinfo [dict get $libs $libname] - - append result [cmd::util::col lib library $libname] - if {[catch [list package present $libname] ver]} { - append result [cmd::util::col lib version "N/A"] - } else { - append result [cmd::util::col lib version $ver] - } - append result [cmd::util::col lib type [dict get $libinfo -type]] - - if {[dict exists $libinfo -note]} { - set note [dict get $libinfo -note] - } else { - set note "" - } - append result [cmd::util::col lib note $note] - append result "\n" - } - append result "[cmd::util::colbreak lib]\n" - return $result -} - -proc ::pattern::record {recname fields} { - if {[uplevel 1 [list namespace which $recname]] ne ""} { - error "(pattern::record) Can't create command '$recname': A command of that name already exists" - } - - set index -1 - set accessor [list ::apply { - {index rec args} - { - if {[llength $args] == 0} { - return [lindex $rec $index] - } - if {[llength $args] == 1} { - return [lreplace $rec $index $index [lindex $args 0]] - } - error "Invalid number of arguments." - } - - }] - - set map {} - foreach field $fields { - dict set map $field [linsert $accessor end [incr index]] - } - uplevel 1 [list namespace ensemble create -command $recname -map $map -parameters rec] -} -proc ::pattern::record2 {recname fields} { - if {[uplevel 1 [list namespace which $recname]] ne ""} { - error "(pattern::record) Can't create command '$recname': A command of that name already exists" - } - - set index -1 - set accessor [list ::apply] - - set template { - {rec args} - { - if {[llength $args] == 0} { - return [lindex $rec %idx%] - } - if {[llength $args] == 1} { - return [lreplace $rec %idx% %idx% [lindex $args 0]] - } - error "Invalid number of arguments." - } - } - - set map {} - foreach field $fields { - set body [string map [list %idx% [incr index]] $template] - dict set map $field [list ::apply $body] - } - uplevel 1 [list namespace ensemble create -command $recname -map $map -parameters rec] -} - -proc ::argstest {args} { - package require cmdline - -} - -proc ::pattern::objects {} { - set result [::list] - - foreach ns [namespace children ::pp] { - #lappend result [::list [namespace tail $ns] [set ${ns}::(self)]] - set ch [namespace tail $ns] - if {[string range $ch 0 2] eq "Obj"} { - set OID [string range $ch 3 end] ;#OID need not be digits (!?) - lappend result [::list $OID [list OID $OID object_command [set pp::${ch}::v_object_command] usedby [array names ${ns}::_iface::o_usedby]]] - } - } - - - - - return $result -} - - - -proc ::pattern::name {num} { - #!todo - fix - #set ::p::${num}::(self) - - lassign [interp alias {} ::p::$num] _predator info - if {![string length $_predator$info]} { - error "No object found for num:$num (no interp alias for ::p::$num)" - } - set invocants [dict get $info i] - set invocants_with_role_this [dict get $invocants this] - set invocant_this [lindex $invocants_with_role_this 0] - - - #lassign $invocant_this id info - #set map [dict get $info map] - #set fields [lindex $map 0] - lassign $invocant_this _id _ns _defaultmethod name _etc - return $name -} - - -proc ::pattern::with {cmd script} { - foreach c [info commands ::p::-1::*] { - interp alias {} [namespace tail $c] {} $c $cmd - } - interp alias {} . {} $cmd . - interp alias {} .. {} $cmd .. - - return [uplevel 1 $script] -} - - - - - -#system diagnostics etc - -proc ::pattern::varspace_list {IID} { - namespace upvar ::p::${IID}::_iface o_varspace o_varspace o_variables o_variables - - set varspaces [list] - dict for {vname vdef} $o_variables { - set vs [dict get $vdef varspace] - if {$vs ni $varspaces} { - lappend varspaces $vs - } - } - if {$o_varspace ni $varspaces} { - lappend varspaces $o_varspace - } - return $varspaces -} - -proc ::pattern::check_interfaces {} { - foreach ns [namespace children ::p] { - set IID [namespace tail $ns] - if {[string is digit $IID]} { - foreach ref [array names ${ns}::_iface::o_usedby] { - set OID [string range $ref 1 end] - if {![namespace exists ::p::${OID}::_iface]} { - puts -nonewline stdout "\r\nPROBLEM!!!!!!!!! nonexistant/invalid object $OID referenced by Interface $IID\r\n" - } else { - puts -nonewline stdout . - } - - - #if {![info exists ::p::${OID}::(self)]} { - # puts "PROBLEM!!!!!!!!! nonexistant object $OID referenced by Interface $IID" - #} - } - } - } - puts -nonewline stdout "\r\n" -} - - -#from: http://wiki.tcl.tk/8766 (Introspection on aliases) -#usedby: metaface-1.1.6+ -#required because aliases can be renamed. -#A renamed alias will still return it's target with 'interp alias {} oldname' -# - so given newname - we require which_alias to return the same info. - proc ::pattern::which_alias {cmd} { - uplevel 1 [list ::trace add execution $cmd enterstep ::error] - catch {uplevel 1 $cmd} res - uplevel 1 [list ::trace remove execution $cmd enterstep ::error] - #puts stdout "which_alias $cmd returning '$res'" - return $res - } -# [info args] like proc following an alias recursivly until it reaches -# the proc it originates from or cannot determine it. -# accounts for default parameters set by interp alias -# - - - -proc ::pattern::aliasargs {cmd} { - set orig $cmd - - set defaultargs [list] - - # loop until error or return occurs - while {1} { - # is it a proc already? - if {[string equal [info procs $cmd] $cmd]} { - set result [info args $cmd] - # strip off the interp set default args - return [lrange $result [llength $defaultargs] end] - } - # is it a built in or extension command we can get no args for? - if {![string equal [info commands $cmd] $cmd]} { - error "\"$orig\" isn't a procedure" - } - - # catch bogus cmd names - if {[lsearch [interp aliases {}] $cmd]==-1} { - if {[catch {::pattern::which_alias $cmd} alias]} { - error "\"$orig\" isn't a procedure or alias or command" - } - #set cmd [lindex $alias 0] - if {[llength $alias]>1} { - set cmd [lindex $alias 0] - set defaultargs [concat [lrange $alias 1 end] $defaultargs] - } else { - set cmd $alias - } - } else { - - if {[llength [set cmdargs [interp alias {} $cmd]]]>0} { - # check if it is aliased in from another interpreter - if {[catch {interp target {} $cmd} msg]} { - error "Cannot resolve \"$orig\", alias leads to another interpreter." - } - if {$msg != {} } { - error "Not recursing into slave interpreter \"$msg\".\ - \"$orig\" could not be resolved." - } - # check if defaults are set for the alias - if {[llength $cmdargs]>1} { - set cmd [lindex $cmdargs 0] - set defaultargs [concat [lrange $cmdargs 1 end] $defaultargs] - } else { - set cmd $cmdargs - } - } - } - } - } -proc ::pattern::aliasbody {cmd} { - set orig $cmd - - set defaultargs [list] - - # loop until error or return occurs - while {1} { - # is it a proc already? - if {[string equal [info procs $cmd] $cmd]} { - set result [info body $cmd] - # strip off the interp set default args - return $result - #return [lrange $result [llength $defaultargs] end] - } - # is it a built in or extension command we can get no args for? - if {![string equal [info commands $cmd] $cmd]} { - error "\"$orig\" isn't a procedure" - } - - # catch bogus cmd names - if {[lsearch [interp aliases {}] $cmd]==-1} { - if {[catch {::pattern::which_alias $cmd} alias]} { - error "\"$orig\" isn't a procedure or alias or command" - } - #set cmd [lindex $alias 0] - if {[llength $alias]>1} { - set cmd [lindex $alias 0] - set defaultargs [concat [lrange $alias 1 end] $defaultargs] - } else { - set cmd $alias - } - } else { - - if {[llength [set cmdargs [interp alias {} $cmd]]]>0} { - # check if it is aliased in from another interpreter - if {[catch {interp target {} $cmd} msg]} { - error "Cannot resolve \"$orig\", alias leads to another interpreter." - } - if {$msg != {} } { - error "Not recursing into slave interpreter \"$msg\".\ - \"$orig\" could not be resolved." - } - # check if defaults are set for the alias - if {[llength $cmdargs]>1} { - set cmd [lindex $cmdargs 0] - set defaultargs [concat [lrange $cmdargs 1 end] $defaultargs] - } else { - set cmd $cmdargs - } - } - } - } - } - - - - - -proc ::pattern::uniqueKey2 {} { - #!todo - something else?? - return [clock seconds]-[incr ::pattern::idCounter] -} - -#used by patternlib package -proc ::pattern::uniqueKey {} { - return [incr ::pattern::idCounter] - #uuid with tcllibc is about 30us compared with 2us - # for large datasets, e.g about 100K inserts this would be pretty noticable! - #!todo - uuid pool with background thread to repopulate when idle? - #return [uuid::uuid generate] -} - - - -#------------------------------------------------------------------------------------------------------------------------- - -proc ::pattern::test1 {} { - set msg "OK" - - puts stderr "next line should say:'--- saystuff:$msg" - ::>pattern .. Create ::>thing - - ::>thing .. PatternMethod saystuff args { - puts stderr "--- saystuff: $args" - } - ::>thing .. Create ::>jjj - - ::>jjj . saystuff $msg - ::>jjj .. Destroy - ::>thing .. Destroy -} - -proc ::pattern::test2 {} { - set msg "OK" - - puts stderr "next line should say:'--- property 'stuff' value:$msg" - ::>pattern .. Create ::>thing - - ::>thing .. PatternProperty stuff $msg - - ::>thing .. Create ::>jjj - - puts stderr "--- property 'stuff' value:[::>jjj . stuff]" - ::>jjj .. Destroy - ::>thing .. Destroy -} - -proc ::pattern::test3 {} { - set msg "OK" - - puts stderr "next line should say:'--- property 'stuff' value:$msg" - ::>pattern .. Create ::>thing - - ::>thing .. Property stuff $msg - - puts stderr "--- property 'stuff' value:[::>thing . stuff]" - ::>thing .. Destroy -} - -#--------------------------------- -#unknown/obsolete - - - - - - - - -#proc ::p::internals::showargs {args {ch stdout}} {puts $ch $args} -if {0} { - proc ::p::internals::new_interface {{usedbylist {}}} { - set OID [incr ::p::ID] - ::p::internals::new_object ::p::ifaces::>$OID "" $OID - puts "obsolete >> new_interface created object $OID" - foreach usedby $usedbylist { - set ::p::${OID}::_iface::o_usedby(i$usedby) 1 - } - set ::p::${OID}::_iface::o_varspace "" ;#default varspace is the object's namespace. (varspace is absolute if it has leading :: , otherwise it's a relative namespace below the object's namespace) - #NOTE - o_varspace is only the default varspace for when new methods/properties are added. - # it is possible to create some methods/props with one varspace value, then create more methods/props with a different varspace value. - - set ::p::${OID}::_iface::o_constructor [list] - set ::p::${OID}::_iface::o_variables [list] - set ::p::${OID}::_iface::o_properties [dict create] - set ::p::${OID}::_iface::o_methods [dict create] - array set ::p::${OID}::_iface::o_definition [list] - set ::p::${OID}::_iface::o_open 1 ;#open for extending - return $OID - } - - - #temporary way to get OID - assumes single 'this' invocant - #!todo - make generic. - proc ::pattern::get_oid {_ID_} { - #puts stderr "#* get_oid: [lindex [dict get $_ID_ i this] 0 0]" - return [lindex [dict get $_ID_ i this] 0 0] - - #set invocants [dict get $_ID_ i] - #set invocant_roles [dict keys $invocants] - #set role_members [dict get $invocants this] - ##set this_invocant [lindex $role_members 0] ;#for the role 'this' we assume only one invocant in the list. - #set this_invocant [lindex [dict get $_ID_ i this] 0] ; - #lassign $this_invocant OID this_info - # - #return $OID - } - - #compile the uncompiled level1 interface - #assert: no more than one uncompiled interface present at level1 - proc ::p::meta::PatternCompile {self} { - ???? - - upvar #0 $self SELFMAP - set ID [lindex $SELFMAP 0 0] - - set patterns [lindex $SELFMAP 1 1] ;#list of level1 interfaces - - set iid -1 - foreach i $patterns { - if {[set ::p::${i}::_iface::o_open]} { - set iid $i ;#found it - break - } - } - - if {$iid > -1} { - #!todo - - ::p::compile_interface $iid - set ::p::${iid}::_iface::o_open 0 - } else { - #no uncompiled interface present at level 1. Do nothing. - return - } - } - - - proc ::p::meta::Def {self} { - error ::p::meta::Def - - upvar #0 $self SELFMAP - set self_ID [lindex $SELFMAP 0 0] - set IFID [lindex $SELFMAP 1 0 end] - - set maxc1 0 - set maxc2 0 - - set arrName ::p::${IFID}:: - - upvar #0 $arrName state - - array set methods {} - - foreach nm [array names state] { - if {[regexp {^m-1,name,(.+)} $nm _match mname]} { - set methods($mname) [set state($nm)] - - if {[string length $mname] > $maxc1} { - set maxc1 [string length $mname] - } - if {[string length [set state($nm)]] > $maxc2} { - set maxc2 [string length [set state($nm)]] - } - } - } - set bg1 [string repeat " " [expr {$maxc1 + 2}]] - set bg2 [string repeat " " [expr {$maxc2 + 2}]] - - - set r {} - foreach nm [lsort -dictionary [array names methods]] { - set arglist $state(m-1,args,$nm) - append r "[overtype::left $bg1 $nm] : [overtype::left $bg2 $methods($nm)] [::list $arglist]\n" - } - return $r - } - - - -} \ No newline at end of file diff --git a/src/vendormodules/patternpredator1-1.0.tm b/src/vendormodules/patternpredator1-1.0.tm deleted file mode 100644 index 067c5540..00000000 --- a/src/vendormodules/patternpredator1-1.0.tm +++ /dev/null @@ -1,664 +0,0 @@ -package provide patternpredator1 1.0 - -proc ::p::internals::trailing, {map command stack i arglist pending} { - error "trailing ',' is not a valid sequence. If the comma was meant to be an argument, precede it with the -- operator." -} -proc ::p::internals::trailing.. {map command stack i arglist pending} { - error "trailing .. references not implemented." -} - -proc ::p::internals::trailing. {map command _ID_ stack i arglist pending} { - if {![llength $map]} { - error "Trailing . but no map - command:'$command' stack:$stack i:$i arglist:$arglist pending:$pending" - } - - - - #trailing dot - get reference. - #puts ">>trailing dot>> map:$map command:$command _ID_:$_ID_ stack:$stack i:$i arglist:$arglist pending:$pending" - lassign [lindex $map 0] OID alias itemCmd cmd - - - #lassign $command command _ID_ - - - if {$pending eq {}} { - #no pending operation requiring evaluation. - - #presumably we're getting a ref to the object, not a property or method. - #set traceCmd [::list ::p::objectRef_TraceHandler $cmd $_self $OID] - #if {[::list {array read write unset} $traceCmd] ni [trace info variable $refname]} { - # trace add variable $refname {array read write unset} $traceCmd - #} - set refname ::p::${OID}::_ref::__OBJECT ;#!todo - avoid potential collision with ref to member named '__OBJECT'. - #object ref - ensure trace-var is an array upon which the objects methods & properties can be accessed as indices - array set $refname [list] - #!todo?- populate array with object methods/properties now? - - - set _ID_ [list i [list this [list [list $OID [list map $map]]]]] - - #!todo - review. What if $map is out of date? - - set traceCmd [list ::p::predator::object_read_trace $OID $_ID_] - if {[list {read} $traceCmd] ni [trace info variable $refname]} { - trace add variable $refname {read} $traceCmd - } - - set traceCmd [list ::p::predator::object_array_trace $OID $_ID_] - if {[list {array} $traceCmd] ni [trace info variable $refname]} { - trace add variable $refname {array} $traceCmd - } - - set traceCmd [list ::p::predator::object_write_trace $OID $_ID_] - if {[list {write} $traceCmd] ni [trace info variable $refname]} { - trace add variable $refname {write} $traceCmd - } - - set traceCmd [list ::p::predator::object_unset_trace $OID $_ID_] - if {[list {unset} $traceCmd] ni [trace info variable $refname]} { - trace add variable $refname {unset} $traceCmd - } - - - #set command $refname - return $refname - } else { - #puts "- 11111111 '$command' '$stack'" - - if {[string range $command 0 171] eq "::p::-1::"} { - #!todo - review/enable this branch? - - #reference to meta-member - - #STALE map problem!! - - puts "\naaaaa command: $command\n" - - set field [namespace tail [lindex $command 0]] - set map [lindex $stack 0] - set OID [lindex $map 0 0] - - - if {[llength $stack]} { - set refname ::p::${OID}::_ref::[join [concat $field [lrange $stack 1 end]] +] - set command [interp alias {} $refname {} {*}$command {*}$stack] - } else { - set refname ::p::${OID}::_ref::$field - set command [interp alias {} $refname {} {*}$command] - } - puts "???? command '$command' \n refname '$refname' \n" - - } else { - #Property or Method reference (possibly with curried indices or arguments) - - #we don't want our references to look like objects. - #(If they did, they might be found by namespace tidyup code and treated incorrectly) - set field [string map {> __OBJECT_} [namespace tail $command]] - - #!todo? - # - make every object's OID unpredictable and sparse (UUID) and modify 'namespace child' etc to prevent iteration/inspection of ::p namespace. - - - #references created under ::p::${OID}::_ref are effectively inside a 'varspace' within the object itself. - # - this would in theory allow a set of interface functions on the object which have direct access to the reference variables. - - - if {[llength $stack]} { - set refname ::p::${OID}::_ref::[join [concat $field $stack] +] - #puts stdout " ------------>>>> refname:$refname" - if {[string length $_ID_]} { - set command [interp alias {} $refname {} $command $_ID_ {*}$stack] - } else { - set command [interp alias {} $refname {} $command {*}$stack] - } - } else { - set refname ::p::${OID}::_ref::$field - #!review - for consistency.. we don't directly return method name. - if {[string length $_ID_]} { - set command [interp alias {} $refname {} $command $_ID_] - } else { - set command [interp alias {} $refname {} $command] - } - } - - - #puts ">>>!>>>> refname $refname \n" - - - #NOTE! - we always create a command alias even if $field is not a method. - #( - - #!todo? - build a list of properties from all interfaces (cache it on object??) - set iflist [lindex $map 1 0] - - - - - set found 0 - foreach IFID [lreverse $iflist] { - #if {$field in [dict keys [set ::p::${IFID}::_iface::o_methods]]} { - # set found 1 - # break - #} - if {[llength [info commands ::p::${IFID}::_iface::(GET)$field]] || [llength [info commands ::p::${IFID}::_iface::(SET)$field]]} { - set found 1 - break - } - } - - - if {$found} { - #property reference - - #? - #set readref [string map [list ::_ref:: ::_ref::(GET) - #set writeref [string map [list ::_ref:: ::_ref::(SET) - - #puts "-2222222222 $refname" - - #puts "---HERE! $OID $property ::p::${OID}::_ref::${property}" - #trace remove variable $refname {read write unset} [list ::p::internals::commandrefMisuse_TraceHandler $alias $field] - foreach tinfo [trace info variable $refname] { - #puts "-->removing traces on $refname: $tinfo" - if {[lindex $tinfo 1 0] eq "::p::internals::commandrefMisuse_TraceHandler"} { - trace remove variable $refname {*}$tinfo - } - } - - - - - - #!todo - move to within trace info test below.. no need to test for refsync trace if no other trace? - #We only trace on entire property.. not array elements (if references existed to both the array and an element both traces would be fired -(entire array trace first)) - set Hndlr [::list ::p::predator::refsync_TraceHandler $OID $alias "" $field] - if { [::list {write unset} $Hndlr] ni [trace info variable ::p::${OID}::o_${field}]} { - trace add variable ::p::${OID}::o_${field} {write unset} $Hndlr - } - - set _ID_ [dict create i [dict create this [list [list $OID [list map $map] ]]]] - - #supply all data in easy-access form so that prop_trace_read is not doing any extra work. - set get_cmd ::p::${OID}::(GET)$field - set traceCmd [list ::p::predator::prop_trace_read $get_cmd $_ID_ $refname $field $stack] - - if {[list {read} $traceCmd] ni [trace info variable $refname]} { - - #synch the refvar with the real var if it exists - #catch {set $refname [$refname]} - if {[array exists ::p::${OID}::o_$field]} { - if {![llength $stack]} { - #unindexed reference - array set $refname [array get ::p::${OID}::o_$field] - } else { - #refs to nonexistant array members common? (catch vs 'info exists') - if {[info exists ::p::${OID}::o_${field}([lindex $stack 0])]} { - set $refname [set ::p::${OID}::o_${field}([lindex $stack 0])] - } - } - } else { - #catch means retrieving refs to non-initialised props slightly slower. - set errorInfo_prev $::errorInfo ;#preserve errorInfo across these catches! - - if {![llength $stack]} { - catch {set $refname [set ::p::${OID}::o_$field]} - } else { - if {[llength $stack] == 1} { - catch {set $refname [lindex [set ::p::${OID}::o_$field] [lindex $stack 0]]} - } else { - catch {set $refname [lindex [set ::p::${OID}::o_$field] $stack]} - } - } - - #! what if someone has put a trace on ::errorInfo?? - set ::errorInfo $errorInfo_prev - - } - - trace add variable $refname {read} $traceCmd - - set traceCmd [list ::p::predator::prop_trace_write $_ID_ $OID $alias $refname] - trace add variable $refname {write} $traceCmd - - set traceCmd [list ::p::predator::prop_trace_unset $_ID_ $OID $alias $refname] - trace add variable $refname {unset} $traceCmd - - set traceCmd [list ::p::predator::prop_trace_array $_ID_ $OID $alias $refname] - trace add variable $refname {array} $traceCmd - - } - - - } else { - #matching variable in order to detect attempted use as property and throw error - #puts "$refname ====> adding refMisuse_traceHandler $alias $field" - trace add variable $refname {read write unset} [list ::p::internals::commandrefMisuse_TraceHandler $alias $field] - } - } - - return $command - } -} - - -#script to inline at placeholder @reduce_pending_stack@ -set ::p::internals::reduce_pending_stack { - if {$pending eq {idx}} { - if {$OID ne {null}} { - #pattern object - #set command [list ::p::${OID}::$itemCmd [dict create i [dict create this [list $OID]]]] - set command ::p::${OID}::$itemCmd - set _ID_ [dict create i [dict create this [list [list $OID [list map $map]]]]] - #todo: set _ID_ [dict create i [dict create this [list [list $OID - - - {}]]] context {}] - - } else { - set command [list $itemCmd $command] - } - } - if {![llength [info commands [lindex $command 0]]]} { - set cmdname [namespace tail [lindex $command 0]] - if {[llength [info commands ::p::${OID}::(UNKNOWN)]]} { - lset command 0 ::p::${OID}::(UNKNOWN) - #puts stdout "!\n calling UNKNOWN $command $cmdname $stack\n\n" - - if {[string length $_ID_]} { - set interim [uplevel 1 [list {*}$command $_ID_ $cmdname {*}$stack]] ;#delegate to UNKNOWN, along with original commandname as 1st arg. - } else { - set interim [uplevel 1 [list {*}$command $cmdname {*}$stack]] ;#delegate to UNKNOWN, along with original commandname as 1st arg. - } - } else { - return -code error -errorinfo "1)error running command:'$command' argstack:'$stack'\n - command not found and no 'unknown' handler" "method '$command' not found" - } - } else { - #puts "---??? uplevelling $command $_ID_ $stack" - - if {[string length $_ID_]} { - set interim [uplevel 1 [list {*}$command $_ID_ {*}$stack]] - } else { - set interim [uplevel 1 [list {*}$command {*}$stack]] - } - #puts "---?2? interim:$interim" - } - - - - if {[string first ::> $interim] >= 0} { - #puts "--- ---> tailcalling $interim [lrange $args $i end]" - tailcall {*}$interim {*}[lrange $args $i end] ;#don't use a return statement as tailcall implies return - } else { - #the interim result is not a pattern object - but the . indicates we should treat it as a command - #tailcall ::p::internals::predator [list [list {null} {} {lindex} $interim {}]] {*}[lrange $args $i end] - #set nextmap [list [list {null} {} {lindex} $interim {}]] - #tailcall ::p::internals::predator [dict create i [dict create this [list null ]] map $nextmap] {*}[lrange $args $i end] - #tailcall ::p::internals::predator [dict create i [dict create this [list [list null [list]] ]] xmap $nextmap] {*}[lrange $args $i end] - - tailcall ::p::internals::predator [dict create i [dict create this [list [list null [list map [list [list {null} {} {lindex} $interim {}]]]] ]] callerinfo ""] {*}[lrange $args $i end] - - } -} - - - - -proc ::p::predator1 {subject args} [string map [list @reduce_pending_stack@ $::p::internals::reduce_pending_stack] { - #set OID [lindex [dict get $subject i this] 0 0] - - set this_invocant [lindex [dict get $subject i this] 0] ;#for the role 'this' we assume only one invocant in the list. - lassign $this_invocant OID this_info - - if {$OID ne {null}} { - #upvar #0 ::p::${OID}::_meta::map map - #if {![dict exists [lindex [dict get $subject i this] 0 1] map]} { - # set map [set ::p::${OID}::_meta::map] - #} else { - # set map [dict get [lindex [dict get $subject i this] 0 1] map] - #} - #seems to be faster just to grab from the variable, than to unwrap from $_ID_ !? - #set map [set ::p::${OID}::_meta::map] - - - - # if {![dict exists $this_info map]} { - set map [set ::p::${OID}::_meta::map] - #} else { - # set map [dict get $this_info map] - #} - - - - - - lassign [lindex $map 0] OID alias itemCmd cmd - - set cheat 1 - #------- - #the common optimised case first. A single . followed by args which contain no other operators (non-chained call) - #(it should be functionally equivalent to remove this shortcut block) - if {$cheat} { - if {([llength $args] > 1) && ([lindex $args 0] eq {.}) && ([llength [lsearch -all $args .]] == 1) && ({,} ni $args) && ({..} ni $args) && ({--} ni $args)} { - set command ::p::${OID}::[lindex $args 1] - - if {![llength [info commands $command]]} { - if {[llength [info commands ::p::${OID}::(UNKNOWN)]]} { - set cmdname [namespace tail $command] - lset command 0 ::p::${OID}::(UNKNOWN) - #return [uplevel 1 [list {*}$command [dict create i [dict create this [list [list $OID [list map $map]]]]] $cmdname {*}[lrange $args 2 end]]] ;#delegate to UNKNOWN, along with original commandname as 1st arg. - tailcall {*}$command [dict create i [dict create this [list [list $OID [list map [list [lindex $map 0] {{} {}} ] ] ]]]] $cmdname {*}[lrange $args 2 end] ;#delegate to UNKNOWN, along with original commandname as 1st arg. - } else { - return -code error -errorinfo "2)error running command:'$command' argstack:'[lrange $args 2 end]'\n - command not found and no 'unknown' handler" "method '$command' not found" - } - } else { - #puts " -->> tailcalling $command [lrange $args 2 end]" - #tailcall $command [dict create i [dict create this [list [list $OID [list map $map]] ]]] {*}[lrange $args 2 end] - #tailcall $command [dict create i [dict create this [list [list $OID {}] ]]] {*}[lrange $args 2 end] - - #jjj - #tailcall $command [list i [list this [list [list $OID [list map $map]] ]]] {*}[lrange $args 2 end] - tailcall $command [list i [list this [list [list $OID [list map [list [lindex $map 0] { {} {} } ]]] ]]] {*}[lrange $args 2 end] - } - } - } - #------------ - - - if {![llength $args]} { - #return $map - return [lindex $map 0 1] - } elseif {[llength $args] == 1} { - #short-circuit the single index case for speed. - if {$args ni {.. . -- - & @}} { - if {$cheat} { - - lassign [lindex $map 0] OID alias itemCmd - #return [::p::${OID}::$itemCmd [lindex $args 0]] - #tailcall ::p::${OID}::$itemCmd [dict create i [dict create this [list [list $OID [list map $map]]]]] [lindex $args 0] - tailcall ::p::${OID}::$itemCmd [list i [list this [list [list $OID [list map $map]]]]] [lindex $args 0] - } - } elseif {[lindex $args 0] eq {--}} { - #!todo - we could hide the invocant by only allowing this call from certain uplevel procs.. - # - combined with using UUIDs for $OID, and a secured/removed metaface on the object - # - (and also hiding of [interp aliases] command so they can't iterate and examine all aliases) - # - this could effectively hide the object's namespaces,vars etc from the caller (?) - return $map - } - } - } else { - #null OID - assume map is included in the _ID_ dict. - #set map [dict get $subject map] - set map [dict get $this_info map] - - lassign [lindex $map 0] OID alias itemCmd cmd - } - #puts "predator==== subject:$subject args:$args map:$map cmd:$cmd " - - - - #set map $invocant ;#retain 'invocant' in case we need original caller info.. 'map' is the data for whatever is at base of stack. - set command $cmd - set stack [list] - - #set operators [list . , ..] ;#(exclude --) - - - #!todo? short-circuit/inline commonest/simplest case {llength $args == 2} - - - set argProtect 0 - set pending "" ;#pending operator e.g . , idx .. & @ - set _ID_ "" - - set i 0 - - while {$i < [llength $args]} { - set word [lindex $args $i] - - if {$argProtect} { - #argProtect must be checked first. - # We are here because a previous operator necessitates that this word is an argument, not another operator. - set argProtect 0 - lappend stack $word - if {$pending eq {}} { - set pending idx ;#An argument only implies the index operator if no existing operator is in effect. (because '>obj $arg' must be equivalent to '>obj . item $arg' - } - incr i - } else { - switch -- $word {.} { - #$i is the operator, $i + 1 is the command. - if {[llength $args] > ($i + 1)} { - #there is at least a command, possibly args too - - if {$pending ne {}} { - #puts ">>>> >>>>> about to reduce. pending:$pending command:$command _ID_:$_ID_ stack:$stack" - - - #always bounces back into the predator via tailcall - @reduce_pending_stack@ - } else { - if {$OID ne {null}} { - #set command ::p::${OID}::[lindex $args $i+1] - #lappend stack [dict create i [dict create this [list $OID]]] - - set command ::p::${OID}::[lindex $args $i+1] - set _ID_ [list i [list this [list [list $OID [list map $map]]]]] - - } else { - #set command [list $command [lindex $args $i+1]] - lappend stack [lindex $args $i+1] - } - set pending . - set argProtect 0 - incr i 2 - } - } else { - #this is a trailing . - #puts "----> MAP $map ,command $command ,stack $stack" - if {$OID ne {null}} { - return [::p::internals::trailing. $map $command $_ID_ $stack $i $args $pending] - } else { - #!todo - fix. This is broken! - #the usefulness of a reference to an already-resolved value is questionable.. but for consistency it should probably be made to work. - - #for a null object - we need to supply the map in the invocation data - set command ::p::internals::predator - - set this_info [dict create map [list [list {null} {} {lindex} $command {}]] ] - set this_invocant [list null $this_info] - - set _ID_ [dict create i [dict create this [list $this_invocant]] ] - - return [::p::internals::trailing. $map $command $_ID_ $stack $i $args $pending] - } - } - } {--} { - #argSafety operator (see also "," & -* below) - set argProtect 1 - incr i - } {,} { - set argProtect 1 - if {$i+1 < [llength $args]} { - #not trailing - if {$pending ne {}} { - @reduce_pending_stack@ - } else { - if {$OID ne {null}} { - #set command [list ::p::[lindex $map 0 0]::$itemCmd [lindex $args $i+1]] - #set command [list $command . $itemCmd [lindex $args $i+1]] - - set stack [list . $itemCmd [lindex $args $i+1]] - - set _ID_ "" - - #lappend stack [dict create i [dict create this [list $OID]]] - - set pending "." - } else { - # this is an index operation into what is presumed to be a previously returned standard tcl list. (as opposed to an index operation into a returned pattern object) - #set command [list $itemCmd $command [lindex $args $i+1]] - #set command [list ::p::internals::predator [list [list {null} {} {lindex} $command {}]] [lindex $args $i+1] ] - - - #set command ::p::internals::predator - #set _ID_ [dict create i [dict create this [list null]] map [list [list {null} {} {lindex} [lindex $args $i+1] {}]] ] - #lappend stack [lindex $args $i+1] - - - set command [list $itemCmd $command] ;#e.g {lindex {a b c}} - - #set command ::p::internals::predator - #set _ID_ [dict create i [dict create this [list null]] map [list [list {null} {} {lindex} $nextcommand {}]]] - set _ID_ {} - lappend stack [lindex $args $i+1] - - - set pending "." ;#*not* idx or "," - } - - set argProtect 0 - incr i 2 - } - } else { - return [::p::internals::trailing, $map $command $stack $i $args $pending] - } - } {..} { - #Metaface operator - if {$i+1 < [llength $args]} { - #operator is not trailing. - if {$pending ne {}} { - @reduce_pending_stack@ - } else { - incr i - - #set command [list ::p::-1::[lindex $args $i] [dict create i [dict create this [list $OID]]]] - set command ::p::-1::[lindex $args $i] - - #_ID_ is a list, 1st element being a dict of invocants. - # Each key of the dict is an invocant 'role' - # Each value is a list of invocant-aliases fulfilling that role - #lappend stack [list [list caller [lindex $map 0 1] ]] - #lappend stack [list [dict create this [lindex $map 0 1]]] ;#'this' being the 'subject' in a standard singledispatch method call. - #lappend stack [dict create i [dict create this [list [lindex $map 0 1]]]] - - set _ID_ [dict create i [dict create this [list [list $OID [list map $map]]]]] - - set pending .. - incr i - } - } else { - return [::p::internals::trailing.. $map $command $stack $i $args $pending] - } - } {&} { - #conglomeration operator - if {$i+1 < [llength $args]} { - if {$pending ne {} } { - @reduce_pending_stack@ - - #set interim [uplevel 1 [list {*}$command {*}$stack]] - #tailcall {*}$interim {*}[lrange $args $i end] ;#don't use a return statement as tailcall implies return - } - - set command [list ::p::-1::Conglomerate $command] - lappend stack [lindex $args $i+1] - set pending & - incr i - - - - } else { - error "trailing & not supported" - } - } {@} { - #named-invocant operator - if {$i+1 < [llength $args]} { - if {$pending ne {} } { - @reduce_pending_stack@ - } else { - error "@ not implemented" - - set pending @ - incr i - } - } else { - error "trailing @ not supported" - } - } default { - if {[string index $word 0] ni {. -}} { - lappend stack $word - if {$pending eq {}} { - set pending idx - } - incr i - } else { - if {[string match "-*" $word]} { - #argSafety operator (tokens that appear to be Tcl 'options' automatically 'protect' the subsequent argument) - set argProtect 1 - lappend stack $word - incr i - } else { - if {([string index $word 0] eq ".") && ([string index $word end] eq ".") } { - #interface accessor! - error "interface casts not yet implemented!" - - set ifspec [string range $word 1 end] - if {$ifspec eq "!"} { - #create 'snapshot' reference with all current interfaces - - } else { - foreach ifname [split $ifspec ,] { - #make each comma-separated interface-name accessible via the 'casted object' - - } - } - - } else { - #has a leading . only. treat as an argument not an operator. - lappend stack $word - if {$pending eq {}} { - set pending idx - } - incr i - } - } - } - } - - - } - } - - #assert: $pending ne "" - #(we've run out of args, and if no 'operators' were found, then $pending will have been set to 'idx' - equivalent to '. item' ) - - #puts "---> evalling command + stack:'$command' '$stack' (pending:'$pending')" - if {$pending in {idx}} { - if {$OID ne {null}} { - #pattern object - set command ::p::${OID}::$itemCmd - set _ID_ [dict create i [dict create this [list [list $OID [list map $map] ] ]]] - } else { - # some other kind of command - set command [list $itemCmd $command] - } - } - if {![llength [info commands [lindex $command 0]]]} { - set cmdname [namespace tail [lindex $command 0]] - if {[llength [info commands ::p::${OID}::(UNKNOWN)]]} { - lset command 0 ::p::${OID}::(UNKNOWN) - #puts stdout "!\n calling UNKNOWN $command $cmdname $stack\n\n" - - if {[string length $_ID_]} { - tailcall {*}$command $_ID_ $cmdname {*}$stack ;#delegate to UNKNOWN, along with original commandname as 1st arg. - } else { - tailcall {*}$command $cmdname {*}$stack ;#delegate to UNKNOWN, along with original commandname as 1st arg. - } - } else { - return -code error -errorinfo "3)error running command:'$command' argstack:'$stack'\n - command not found and no 'unknown' handler" "method '$command' not found" - } - } - #puts "... tailcalling $command $stack" - if {[string length $_ID_]} { - tailcall {*}$command $_ID_ {*}$stack - } else { - tailcall {*}$command {*}$stack - } -}] diff --git a/src/vendormodules/patternpredator2-1.2.4.tm b/src/vendormodules/patternpredator2-1.2.4.tm deleted file mode 100644 index 680ea88f..00000000 --- a/src/vendormodules/patternpredator2-1.2.4.tm +++ /dev/null @@ -1,754 +0,0 @@ -package provide patternpredator2 1.2.4 - -proc ::p::internals::jaws {OID _ID_ args} { - #puts stderr ">>>(patternpredator2 lib)jaws called with _ID_:$_ID_ args: $args" - #set OID [lindex [dict get $_ID_ i this] 0 0] ;#get_oid - - yield - set w 1 - - set stack [list] - set wordcount [llength $args] - set terminals [list . .. , # @ !] ;#tokens which require the current stack to be evaluated first - set unsupported 0 - set operator "" - set operator_prev "" ;#used only by argprotect to revert to previous operator - - - if {$OID ne "null"} { - #!DO NOT use upvar here for MAP! (calling set on a MAP in another iteration/call will overwrite a map for another object!) - #upvar #0 ::p::${OID}::_meta::map MAP - set MAP [set ::p::${OID}::_meta::map] - } else { - # error "jaws - OID = 'null' ???" - set MAP [list invocantdata [lindex [dict get $_ID_ i this] 0] ] ;#MAP taken from _ID_ will be missing 'interfaces' key - } - set invocantdata [dict get $MAP invocantdata] - lassign $invocantdata OID alias default_method object_command wrapped - - set finished_args 0 ;#whether we've completely processed all args in the while loop and therefor don't need to peform the final word processing code - - #don't use 'foreach word $args' - we sometimes need to backtrack a little by manipulating $w - while {$w < $wordcount} { - set word [lindex $args [expr {$w -1}]] - #puts stdout "w:$w word:$word stack:$stack" - - if {$operator eq "argprotect"} { - set operator $operator_prev - lappend stack $word - incr w - } else { - if {[llength $stack]} { - if {$word in $terminals} { - set reduction [list 0 $_ID_ {*}$stack ] - #puts stderr ">>>jaws yielding value: $reduction triggered by word $word in position:$w" - - - set _ID_ [yield $reduction] - set stack [list] - #set OID [::pattern::get_oid $_ID_] - set OID [lindex [dict get $_ID_ i this] 0 0] ;#get_oid - - if {$OID ne "null"} { - set MAP [set ::p::${OID}::_meta::map] ;#Do not use upvar here! - } else { - set MAP [list invocantdata [lindex [dict get $_ID_ i this] 0] interfaces [list level0 {} level1 {}]] - #puts stderr "WARNING REVIEW: jaws-branch - leave empty??????" - } - - #review - 2018. switched to _ID_ instead of MAP - lassign [lindex [dict get $_ID_ i this] 0] OID alias default_method object_command - #lassign [dict get $MAP invocantdata] OID alias default_method object_command - - - #puts stdout "---->>> yielded _ID_: $_ID_ OID:$OID alias:$alias default_method:$default_method object_command:$object_command" - set operator $word - #don't incr w - #incr w - } else { - if {$operator eq "argprotect"} { - set operator $operator_prev - set operator_prev "" - lappend stack $word - } else { - #only look for leading argprotect chacter (-) if we're not already in argprotect mode - if {$word eq "--"} { - set operator_prev $operator - set operator "argprotect" - #Don't add the plain argprotector to the stack - } elseif {[string match "-*" $word]} { - #argSafety operator (tokens that appear to be Tcl 'options' automatically 'protect' the subsequent argument) - set operator_prev $operator - set operator "argprotect" - lappend stack $word - } else { - lappend stack $word - } - } - - - incr w - } - } else { - #no stack - switch -- $word {.} { - - if {$OID ne "null"} { - #we know next word is a property or method of a pattern object - incr w - set nextword [lindex $args [expr {$w - 1}]] - set command ::p::${OID}::$nextword - set stack [list $command] ;#2018 j - set operator . - if {$w eq $wordcount} { - set finished_args 1 - } - } else { - # don't incr w - #set nextword [lindex $args [expr {$w - 1}]] - set command $object_command ;#taken from the MAP - set stack [list "_exec_" $command] - set operator . - } - - - } {..} { - incr w - set nextword [lindex $args [expr {$w -1}]] - set command ::p::-1::$nextword - #lappend stack $command ;#lappend a small number of items to an empty list is slower than just setting the list. - set stack [list $command] ;#faster, and intent is clearer than lappend. - set operator .. - if {$w eq $wordcount} { - set finished_args 1 - } - } {,} { - #puts stdout "Stackless comma!" - - - if {$OID ne "null"} { - set command ::p::${OID}::$default_method - } else { - set command [list $default_method $object_command] - #object_command in this instance presumably be a list and $default_method a list operation - #e.g "lindex {A B C}" - } - #lappend stack $command - set stack [list $command] - set operator , - } {--} { - set operator_prev $operator - set operator argprotect - #no stack - - } {!} { - set command $object_command - set stack [list "_exec_" $object_command] - #puts stdout "!!!! !!!! $stack" - set operator ! - } default { - if {$operator eq ""} { - if {$OID ne "null"} { - set command ::p::${OID}::$default_method - } else { - set command [list $default_method $object_command] - } - set stack [list $command] - set operator , - lappend stack $word - } else { - #no stack - so we don't expect to be in argprotect mode already. - if {[string match "-*" $word]} { - #argSafety operator (tokens that appear to be Tcl 'options' automatically 'protect' the subsequent argument) - set operator_prev $operator - set operator "argprotect" - lappend stack $word - } else { - lappend stack $word - } - - } - } - incr w - } - - } - } ;#end while - - #process final word outside of loop - #assert $w == $wordcount - #trailing operators or last argument - if {!$finished_args} { - set word [lindex $args [expr {$w -1}]] - if {$operator eq "argprotect"} { - set operator $operator_prev - set operator_prev "" - - lappend stack $word - incr w - } else { - - - switch -- $word {.} { - if {![llength $stack]} { - #set stack [list "_result_" [::p::internals::ref_to_object $_ID_]] - yieldto return [::p::internals::ref_to_object $_ID_] - error "assert: never gets here" - - } else { - #puts stdout "==== $stack" - #assert - whenever _ID_ changed in this proc - we have updated the $OID variable - yieldto return [::p::internals::ref_to_stack $OID $_ID_ $stack] - error "assert: never gets here" - } - set operator . - - } {..} { - #trailing .. after chained call e.g >x . item 0 .. - #puts stdout "$$$$$$$$$$$$ [list 0 $_ID_ {*}$stack] $$$$" - #set reduction [list 0 $_ID_ {*}$stack] - yieldto return [yield [list 0 $_ID_ {*}$stack]] - } {#} { - set unsupported 1 - } {,} { - set unsupported 1 - } {&} { - set unsupported 1 - } {@} { - set unsupported 1 - } {--} { - - #set reduction [list 0 $_ID_ {*}$stack[set stack [list]]] - #puts stdout " -> -> -> about to call yield $reduction <- <- <-" - set _ID_ [yield [list 0 $_ID_ {*}$stack[set stack [list]]] ] - #set OID [::pattern::get_oid $_ID_] - set OID [lindex [dict get $_ID_ i this] 0 0] ;#get_oid - - if {$OID ne "null"} { - set MAP [set ::p::${OID}::_meta::map] ;#DO not use upvar here! - } else { - set MAP [list invocantdata [lindex [dict get $_ID_ i this] 0] interfaces {level0 {} level1 {}} ] - } - yieldto return $MAP - } {!} { - #error "untested branch" - set _ID_ [yield [list 0 $_ID_ {*}$stack[set stack [list]]]] - #set OID [::pattern::get_oid $_ID_] - set OID [lindex [dict get $_ID_ i this] 0 0] ;#get_oid - - if {$OID ne "null"} { - set MAP [set ::p::${OID}::_meta::map] ;#DO not use upvar here! - } else { - set MAP [list invocantdata [lindex [dict get $_ID_ i this] 0] ] - } - lassign [dict get $MAP invocantdata] OID alias default_command object_command - set command $object_command - set stack [list "_exec_" $command] - set operator ! - } default { - if {$operator eq ""} { - #error "untested branch" - lassign [dict get $MAP invocantdata] OID alias default_command object_command - #set command ::p::${OID}::item - set command ::p::${OID}::$default_command - lappend stack $command - set operator , - - } - #do not look for argprotect items here (e.g -option) as the final word can't be an argprotector anyway. - lappend stack $word - } - if {$unsupported} { - set unsupported 0 - error "trailing '$word' not supported" - - } - - #if {$operator eq ","} { - # incr wordcount 2 - # set stack [linsert $stack end-1 . item] - #} - incr w - } - } - - - #final = 1 - #puts stderr ">>>jaws final return value: [list 1 $_ID_ {*}$stack]" - - return [list 1 $_ID_ {*}$stack] -} - - - -#trailing. directly after object -proc ::p::internals::ref_to_object {_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 object_command - set refname ::p::${OID}::_ref::__OBJECT - - array set $refname [list] ;#important to initialise the variable as an array here - or initial read attempts on elements will not fire traces - - set traceCmd [list ::p::predator::object_read_trace $OID $_ID_] - if {[list {read} $traceCmd] ni [trace info variable $refname]} { - #puts stdout "adding read trace on variable '$refname' - traceCmd:'$traceCmd'" - trace add variable $refname {read} $traceCmd - } - set traceCmd [list ::p::predator::object_array_trace $OID $_ID_] - if {[list {array} $traceCmd] ni [trace info variable $refname]} { - trace add variable $refname {array} $traceCmd - } - - set traceCmd [list ::p::predator::object_write_trace $OID $_ID_] - if {[list {write} $traceCmd] ni [trace info variable $refname]} { - trace add variable $refname {write} $traceCmd - } - - set traceCmd [list ::p::predator::object_unset_trace $OID $_ID_] - if {[list {unset} $traceCmd] ni [trace info variable $refname]} { - trace add variable $refname {unset} $traceCmd - } - return $refname -} - - -proc ::p::internals::create_or_update_reference {OID _ID_ refname command} { - #if {[lindex $fullstack 0] eq "_exec_"} { - # #strip it. This instruction isn't relevant for a reference. - # set commandstack [lrange $fullstack 1 end] - #} else { - # set commandstack $fullstack - #} - #set argstack [lassign $commandstack command] - #set field [string map {> __OBJECT_} [namespace tail $command]] - - - - set reftail [namespace tail $refname] - set argstack [lassign [split $reftail +] field] - set field [string map {> __OBJECT_} [namespace tail $command]] - - #puts stderr "refname:'$refname' command: $command field:$field" - - - if {$OID ne "null"} { - upvar #0 ::p::${OID}::_meta::map MAP - } else { - #set map [dict get [lindex [dict get $_ID_ i this] 0 1] map] - set MAP [list invocantdata [lindex [dict get $_ID_ i this] 0] interfaces {level0 {} level1 {}}] - } - lassign [dict get $MAP invocantdata] OID alias default_method object_command - - - - if {$OID ne "null"} { - interp alias {} $refname {} $command $_ID_ {*}$argstack - } else { - interp alias {} $refname {} $command {*}$argstack - } - - - #set iflist [lindex $map 1 0] - set iflist [dict get $MAP interfaces level0] - #set iflist [dict get $MAP interfaces level0] - set field_is_property_like 0 - foreach IFID [lreverse $iflist] { - #tcl (braced) expr has lazy evaluation for &&, || & ?: operators - so this should be reasonably efficient. - if {[llength [info commands ::p::${IFID}::_iface::(GET)$field]] || [llength [info commands ::p::${IFID}::_iface::(SET)$field]]} { - set field_is_property_like 1 - #There is a setter or getter (but not necessarily an entry in the o_properties dict) - break - } - } - - - - - #whether field is a property or a method - remove any commandrefMisuse_TraceHandler - foreach tinfo [trace info variable $refname] { - #puts "-->removing traces on $refname: $tinfo" - if {[lindex $tinfo 1 0] eq "::p::internals::commandrefMisuse_TraceHandler"} { - trace remove variable $refname {*}$tinfo - } - } - - if {$field_is_property_like} { - #property reference - - - set this_invocantdata [lindex [dict get $_ID_ i this] 0] - lassign $this_invocantdata OID _alias _defaultmethod object_command - #get fully qualified varspace - - # - set propdict [$object_command .. GetPropertyInfo $field] - if {[dict exist $propdict $field]} { - set field_is_a_property 1 - set propinfo [dict get $propdict $field] - set varspace [dict get $propinfo varspace] - if {$varspace eq ""} { - set full_varspace ::p::${OID} - } else { - if {[::string match "::*" $varspace]} { - set full_varspace $varspace - } else { - set full_varspace ::p::${OID}::$varspace - } - } - } else { - set field_is_a_property 0 - #no propertyinfo - this field was probably established as a PropertyRead and/or PropertyWrite without a Property - #this is ok - and we still set the trace infrastructure below (app may convert it to a normal Property later) - set full_varspace ::p::${OID} - } - - - - - - #We only trace on entire property.. not array elements (if references existed to both the array and an element both traces would be fired -(entire array trace first)) - set Hndlr [::list ::p::predator::propvar_write_TraceHandler $OID $field] - if { [::list {write} $Hndlr] ni [trace info variable ${full_varspace}::o_${field}]} { - trace add variable ${full_varspace}::o_${field} {write} $Hndlr - } - set Hndlr [::list ::p::predator::propvar_unset_TraceHandler $OID $field] - if { [::list {unset} $Hndlr] ni [trace info variable ${full_varspace}::o_${field}]} { - trace add variable ${full_varspace}::o_${field} {unset} $Hndlr - } - - - #supply all data in easy-access form so that propref_trace_read is not doing any extra work. - set get_cmd ::p::${OID}::(GET)$field - set traceCmd [list ::p::predator::propref_trace_read $get_cmd $_ID_ $refname $field $argstack] - - if {[list {read} $traceCmd] ni [trace info variable $refname]} { - set fieldvarname ${full_varspace}::o_${field} - - - #synch the refvar with the real var if it exists - #catch {set $refname [$refname]} - if {[array exists $fieldvarname]} { - if {![llength $argstack]} { - #unindexed reference - array set $refname [array get $fieldvarname] - #upvar $fieldvarname $refname - } else { - set s0 [lindex $argstack 0] - #refs to nonexistant array members common? (catch vs 'info exists') - if {[info exists ${fieldvarname}($s0)]} { - set $refname [set ${fieldvarname}($s0)] - } - } - } else { - #refs to uninitialised props actually should be *very* common. - #If we use 'catch', it means retrieving refs to non-initialised props is slower. Fired catches can be relatively expensive. - #Because it's common to get a ref to uninitialised props (e.g for initial setting of their value) - we will use 'info exists' instead of catch. - - #set errorInfo_prev $::errorInfo ;#preserve errorInfo across catches! - - #puts stdout " ---->>!!! ref to uninitialised prop $field $argstack !!!<------" - - - if {![llength $argstack]} { - #catch {set $refname [set ::p::${OID}::o_$field]} - if {[info exists $fieldvarname]} { - set $refname [set $fieldvarname] - #upvar $fieldvarname $refname - } - } else { - if {[llength $argstack] == 1} { - #catch {set $refname [lindex [set ::p::${OID}::o_$field] [lindex $argstack 0]]} - if {[info exists $fieldvarname]} { - set $refname [lindex [set $fieldvarname] [lindex $argstack 0]] - } - - } else { - #catch {set $refname [lindex [set ::p::${OID}::o_$field] $argstack]} - if {[info exists $fieldvarname]} { - set $refname [lindex [set $fieldvarname] $argstack] - } - } - } - - #! what if someone has put a trace on ::errorInfo?? - #set ::errorInfo $errorInfo_prev - } - trace add variable $refname {read} $traceCmd - - set traceCmd [list ::p::predator::propref_trace_write $_ID_ $OID $full_varspace $refname] - trace add variable $refname {write} $traceCmd - - set traceCmd [list ::p::predator::propref_trace_unset $_ID_ $OID $refname] - trace add variable $refname {unset} $traceCmd - - - set traceCmd [list ::p::predator::propref_trace_array $_ID_ $OID $refname] - # puts "**************** installing array variable trace on ref:$refname - cmd:$traceCmd" - trace add variable $refname {array} $traceCmd - } - - } else { - #puts "$refname ====> adding refMisuse_traceHandler $alias $field" - #matching variable in order to detect attempted use as property and throw error - - #2018 - #Note that we are adding a trace on a variable (the refname) which does not exist. - #this is fine - except that the trace won't fire for attempt to write it as an array using syntax such as set $ref(someindex) - #we could set the ref to an empty array - but then we have to also undo this if a property with matching name is added - ##array set $refname {} ;#empty array - # - the empty array would mean a slightly better error message when misusing a command ref as an array - #but this seems like a code complication for little benefit - #review - - trace add variable $refname {read write unset array} [list ::p::internals::commandrefMisuse_TraceHandler $OID $field] - } -} - - - -#trailing. after command/property -proc ::p::internals::ref_to_stack {OID _ID_ fullstack} { - if {[lindex $fullstack 0] eq "_exec_"} { - #strip it. This instruction isn't relevant for a reference. - set commandstack [lrange $fullstack 1 end] - } else { - set commandstack $fullstack - } - set argstack [lassign $commandstack command] - set field [string map {> __OBJECT_} [namespace tail $command]] - - - #!todo? - # - make every object's OID unpredictable and sparse (UUID) and modify 'namespace child' etc to prevent iteration/inspection of ::p namespace. - # - this would only make sense for an environment where any meta methods taking a code body (e.g .. Method .. PatternMethod etc) are restricted. - - - #references created under ::p::${OID}::_ref are effectively inside a 'varspace' within the object itself. - # - this would in theory allow a set of interface functions on the object which have direct access to the reference variables. - - - set refname ::p::${OID}::_ref::[join [concat $field $argstack] +] - - if {[llength [info commands $refname]]} { - #todo - review - what if the field changed to/from a property/method? - #probably should fix that where such a change is made and leave this short circuit here to give reasonable performance for existing refs - return $refname - } - ::p::internals::create_or_update_reference $OID $_ID_ $refname $command - return $refname -} - - -namespace eval pp { - variable operators [list .. . -- - & @ # , !] - variable operators_notin_args "" - foreach op $operators { - append operators_notin_args "({$op} ni \$args) && " - } - set operators_notin_args [string trimright $operators_notin_args " &"] ;#trim trailing spaces and ampersands - #set operators_notin_args {({.} ni $args) && ({,} ni $args) && ({..} ni $args)} -} -interp alias {} strmap {} string map ;#stop code editor from mono-colouring our big string mapped code blocks! - - - - - -# 2017 ::p::predator2 is the development version - intended for eventual use as the main dispatch mechanism. -#each map is a 2 element list of lists. -# form: {$commandinfo $interfaceinfo} -# commandinfo is of the form: {ID Namespace defaultmethod commandname _?} - -#2018 -#each map is a dict. -#form: {invocantdata {ID Namespace defaultmethod commandname _?} interfaces {level0 {} level1 {}}} - - -#OID = Object ID (integer for now - could in future be a uuid) -proc ::p::predator2 {_ID_ args} { - #puts stderr "predator2: _ID_:'$_ID_' args:'$args'" - #set invocants [dict get $_ID_ i] - #set invocant_roles [dict keys $invocants] - - #For now - we are 'this'-centric (single dispatch). todo - adapt for multiple roles, multimethods etc. - #set this_role_members [dict get $invocants this] - #set this_invocant [lindex [dict get $_ID_ i this] 0] ;#for the role 'this' we assume only one invocant in the list. - #lassign $this_invocant this_OID this_info_dict - - set this_OID [lindex [dict get $_ID_ i this] 0 0] ;#get_oid - - - set cheat 1 ;# - #------- - #Optimise the next most common use case. A single . followed by args which contain no other operators (non-chained call) - #(it should be functionally equivalent to remove this shortcut block) - if {$cheat} { - if { ([lindex $args 0] eq {.}) && ([llength $args] > 1) && ([llength [lsearch -all -inline $args .]] == 1) && ({,} ni $args) && ({..} ni $args) && ({--} ni $args) && ({!} ni $args)} { - - set remaining_args [lassign $args dot method_or_prop] - - #how will we do multiple apis? (separate interface stacks) apply? apply [list [list _ID_ {*}$arglist] ::p::${stackid?}::$method_or_prop ::p::${this_OID}] ??? - set command ::p::${this_OID}::$method_or_prop - #REVIEW! - #e.g what if the method is named "say hello" ?? (hint - it will break because we will look for 'say') - #if {[llength $command] > 1} { - # error "methods with spaces not included in test suites - todo fix!" - #} - #Dont use {*}$command - (so we can support methods with spaces) - #if {![llength [info commands $command]]} {} - if {[namespace which $command] eq ""} { - if {[namespace which ::p::${this_OID}::(UNKNOWN)] ne ""} { - #lset command 0 ::p::${this_OID}::(UNKNOWN) ;#seems wrong - command could have spaces - set command ::p::${this_OID}::(UNKNOWN) - #tailcall {*}$command $_ID_ $cmdname {*}[lrange $args 2 end] ;#delegate to UNKNOWN, along with original commandname as 1st arg. - tailcall $command $_ID_ $method_or_prop {*}[lrange $args 2 end] ;#delegate to UNKNOWN, along with original commandname as 1st arg. - } else { - return -code error -errorinfo "(::p::predator2) error running command:'$command' argstack:'[lrange $args 2 end]'\n - command not found and no 'unknown' handler" "method '$method_or_prop' not found" - } - } else { - #tailcall {*}$command $_ID_ {*}$remaining_args - tailcall $command $_ID_ {*}$remaining_args - } - } - } - #------------ - - - if {([llength $args] == 1) && ([lindex $args 0] eq "..")} { - return $_ID_ - } - - - #puts stderr "pattern::predator (test version) called with: _ID_:$_ID_ args:$args" - - - - #puts stderr "this_info_dict: $this_info_dict" - - - - - if {![llength $args]} { - #should return some sort of public info.. i.e probably not the ID which is an implementation detail - #return cmd - return [lindex [dict get [set ::p::${this_OID}::_meta::map] invocantdata] 0] ;#Object ID - - #return a dict keyed on object command name - (suitable as use for a .. Create 'target') - #lassign [dict get [set ::p::${this_OID}::_meta::map] invocantdata] this_OID alias default_method object_command wrapped - #return [list $object_command [list -id $this_OID ]] - } elseif {[llength $args] == 1} { - #short-circuit the single index case for speed. - if {[lindex $args 0] ni {.. . -- - & @ # , !}} { - #lassign [dict get [set ::p::${this_OID}::_meta::map] invocantdata] this_OID alias default_method - lassign [lindex [dict get $_ID_ i this] 0] this_OID alias default_method - - tailcall ::p::${this_OID}::$default_method $_ID_ [lindex $args 0] - } elseif {[lindex $args 0] eq {--}} { - - #!todo - we could hide the invocant by only allowing this call from certain uplevel procs.. - # - combined with using UUIDs for $OID, and a secured/removed metaface on the object - # - (and also hiding of [interp aliases] command so they can't iterate and examine all aliases) - # - this could effectively hide the object's namespaces,vars etc from the caller (?) - return [set ::p::${this_OID}::_meta::map] - } - } - - - - #upvar ::p::coroutine_instance c ;#coroutine names must be unique per call to predator (not just per object - or we could get a clash during some cyclic calls) - #incr c - #set reduce ::p::reducer${this_OID}_$c - set reduce ::p::reducer${this_OID}_[incr ::p::coroutine_instance] - #puts stderr "..................creating reducer $reduce with args $this_OID _ID_ $args" - coroutine $reduce ::p::internals::jaws $this_OID $_ID_ {*}$args - - - set current_ID_ $_ID_ - - set final 0 - set result "" - while {$final == 0} { - #the argument given here to $reduce will be returned by 'yield' within the coroutine context (jaws) - set reduction_args [lassign [$reduce $current_ID_[set current_ID_ [list]] ] final current_ID_ command] - #puts stderr "..> final:$final current_ID_:'$current_ID_' command:'$command' reduction_args:'$reduction_args'" - #if {[string match *Destroy $command]} { - # puts stdout " calling Destroy reduction_args:'$reduction_args'" - #} - if {$final == 1} { - - if {[llength $command] == 1} { - if {$command eq "_exec_"} { - tailcall {*}$reduction_args - } - if {[llength [info commands $command]]} { - tailcall {*}$command $current_ID_ {*}$reduction_args - } - set cmdname [namespace tail $command] - set this_OID [lindex [dict get $current_ID_ i this] 0 0] - if {[llength [info commands ::p::${this_OID}::(UNKNOWN)]]} { - lset command 0 ::p::${this_OID}::(UNKNOWN) - tailcall {*}$command $current_ID_ $cmdname {*}$reduction_args ;#delegate to UNKNOWN, along with original commandname as 1st arg. - } else { - return -code error -errorinfo "1)error running command:'$command' argstack:'$reduction_args'\n - command not found and no 'unknown' handler" "method '$cmdname' not found" - } - - } else { - #e.g lindex {a b c} - tailcall {*}$command {*}$reduction_args - } - - - } else { - if {[lindex $command 0] eq "_exec_"} { - set result [uplevel 1 [list {*}[lrange $command 1 end] {*}$reduction_args]] - - set current_ID_ [list i [list this [list [list "null" {} {lindex} $result {} ] ] ] context {} ] - } else { - if {[llength $command] == 1} { - if {![llength [info commands $command]]} { - set cmdname [namespace tail $command] - set this_OID [lindex [dict get $current_ID_ i this] 0 0] - if {[llength [info commands ::p::${this_OID}::(UNKNOWN)]]} { - - lset command 0 ::p::${this_OID}::(UNKNOWN) - set result [uplevel 1 [list {*}$command $current_ID_ $cmdname {*}$reduction_args]] ;#delegate to UNKNOWN, along with original commandname as 1st arg. - } else { - return -code error -errorinfo "2)error running command:'$command' argstack:'$reduction_args'\n - command not found and no 'unknown' handler" "method '$cmdname' not found" - } - } else { - #set result [uplevel 1 [list {*}$command $current_ID_ {*}$reduction_args ]] - set result [uplevel 1 [list {*}$command $current_ID_ {*}$reduction_args ]] - - } - } else { - set result [uplevel 1 [list {*}$command {*}$reduction_args]] - } - - if {[llength [info commands $result]]} { - if {([llength $result] == 1) && ([string first ">" [namespace tail $result]] == 0)} { - #looks like a pattern command - set current_ID_ [$result .. INVOCANTDATA] - - - #todo - determine if plain .. INVOCANTDATA is sufficient instead of .. UPDATEDINVOCANTDATA - #if {![catch {$result .. INVOCANTDATA} result_invocantdata]} { - # set current_ID_ $result_invocantdata - #} else { - # return -code error -errorinfo "3)error running command:'$command' argstack:'$reduction_args'\n - Failed to access result:'$result' as a pattern object." "Failed to access result:'$result' as a pattern object" - #} - } else { - #non-pattern command - set current_ID_ [list i [list this [list [list "null" {} {lindex} $result {} ] ] ] context {}] - } - } else { - set current_ID_ [list i [list this [list [list "null" {} {lindex} $result {} ] ] ] context {}] - #!todo - allow further operations on non-command values. e.g dicts, lists & strings (treat strings as lists) - - } - } - - } - } - error "Assert: Shouldn't get here (end of ::p::predator2)" - #return $result -} diff --git a/src/vendormodules/tarjar-2.4.1.tm b/src/vendormodules/tarjar-2.4.1.tm deleted file mode 100644 index d912b668af85feeabca8a7e3720a9974a2e5988f..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 114688 zcmeIbX?I)4u`cYd*0e351LyKwm)cY?QAzc2;spy9!F(!vk9jD!PZvg%YXfcwTkuM z^oN5{t21ej`=?XGkBw=2aC4Yo{U7e^%&-6U{g1b{?_;6y(e>ZiX#!E25AQd(@%UF+ zlYjH|U$(VguKnNHpx+vX?^@$_cM!fG9S*u-du!{#M)>@vFT=O}c6T`GZiK!6``!2Z zVKfZW<8FA?9(2d6lklqlq8}RJcsf1Z-Q46aV#>z!#d2-A)_4yewi}+##;2o6cQ^dl zZFRyLv2{Is6kd({({50_9(Oz8WYn2qF1`MsI|;K%e|Qv5XX9>zBSb49JUi}B!b$(= zcp477DADcB2B9?xt#CLRO()ZF>ooL6<1oUM$6>A4noPUndy|va0JFc>n+;#|yW_{} z)=>ihJnp~jjwb+7Ys&V*VSm^f_q&sgARTr$j>2?2>P-S#CH;BPpN7YeWl|W=6B~TM zuv+0|YtZlT$szg!q^HLM`u1oz?GC4y(XfM2wZi1I+wP;tSs1oXFzw!GfEU)I&QTxn zwKk3A3+>U#3EDvgOcb!$4Ziz7J8iXJw2r!u8lQ1C{n7A|j2>+fn&Zh-U>f?03pQ<; z4~8WJZG}O9*zI+@oqM4>?8K+mX=op}#;rD>8P;m+p*8GaIKyeHKP2qBfh*cj0)&-X zV#i}0`d~7`l)0of+uAP*?Lsfp@u2Zb*2#1f(ANnT0|>&&Pe!wG8*Hh%^hF0fg z3-dif5uys`9M`plskYkf?qt$u=Zd&!5co3ew8nxG!GS&WbUVGTQH&_7%c{a$E~ zyR9j=RLf?`MxQF;U=ds6d*LPU{39&xStz!~TD~#vg%c3sFdWGiwBCrrkj}B9JXha4#k3U>CWJ~* zVBeXJIwKIv{_tgYGVLD$7k9%qg794NVYu7v_4@5Ty15%(wJ=p;EjJs6MBJNA(cLd7 zs?b9L^zEP!JUT%wO!9QxouC!al@QkY8?15CogR;fzQ8uF@o*JbH|`%DVGB;$E$q8d zPtdS6n~n}nThrrvq)`gX?rTt-2>>FSV{!&EcoHUE;vh)dI=lIqD#y4CdZ@Mpkw_g%rZKvRJj9?p-Yf@;GN8X^l=DMHkoxX z$@jo!8nQip>7SluvI`HuvMqrJl3=zGALYZTNnq{u-%$;AFpF* zz5Z*XBD=dnSi0CJKp%h^Bx?vZf=;pZl%DSHavUgeI7`TUIvxSZ&?z@WAjh1{PEQAY zGDHyoULAKaS+edhuPQwY`(zbqwZvPxn@ug+Z*@8+BPKU#@2n=e4+Jn1W|#+Pq)w}7D1R3NiE3- z8H@wZS7m~c$gUSfFc5s8dLxj6HHs$F*=b|ihs1!<%oIOJgg^_yYP-WW`sxq+C;eZf zl8%GKO?eLb!*I_+ultJf1sd4hopgczv!S##agq)BO}R>FZftK=G;<1COxj^n15#nw zoj!#YtUnf0C8PG>9&x2Vg;WaaN@j??cnUECEFa()w=f!+3SmNcv<^W|r$T1OGaxVb zwiG~{sIaM^6zVu+oz9G6l8QOA)36o?*4)_IXnyQNCjqF*?&=P?pbhXR0w0WqD`AT$ z^ka6~;pha#$?q{l($ZF^6B;6{jZS@E`r--ZW6LSI7XepFk_loPOCx=<$<_-XRc|~x z5jlzLOvxOxp;iYP%&FLR#xD3zmGiI$4?87Iu%ce$lVyC^ z`2<_88@iBJ4adUy^3qGly&@WYJ39Kd3tqas1nPZ$XRkl(jY9V|7H|^$-TnouEY%?M zjzO8gcKM#q& z50{rNmaE3IyX$c7bPs1oHY`?`-(d^9JcLhc!stX)BHUXb{_WJmogmG#WCVikIbhZ@ zpU*=g7Fe5()}>#Tf_VCABw0HDwvKtGaIr?@gZ5$O(0 za(ZGbmL{!D*Yl|n#7hE#S{%8^Fi|8Is;?#DGWg4h!Z2)LCv9{F0|jPPF~Qaew3RM| z>BHC+fEi1RE+LA-B%I48gZ_KLrTeso**p%*GKyHUQP)r%yL%|I@!DuyUsLh(hgnxG!G zw(FKoWdVgYXrD@$6cJm8lr_nXAuO6yDB>#H6IzCyX$&Q>d5kKuq;dZxR9C9yROnR* zRd%Fi4p@r zwZVvDEf5wmI%TYr5uiC99YRx!HH!m6FORUN()jYRE9VEsVBoR7K711DpO+qe9_lC> zAEtSwX3ohdUA?&k1w)ikGO#%f*u={#ef~{ z))eS;K7-9u8f58gbJ-H_X{SOp*zLY_dO@1LEER=_?d~48CJ;QRWcOO&cgxGzHd{bJ z6#%TSG82I4f*KbTVet3B=wC$4>h?i@x-y9Tb+Ls|FaE}8Io?Gi?Z8P{q>UoL3XK|) zXoF(uK8>tx01N2>%?Y5i2h$VEDT@T2ilT9bTvbk^qD)cvAq#y1OjnixDn?D4((j07 z5HcW8e87)(9O{M;7NHf0NDDP#(C<;tgvbpZDrP8DYJ+o#8TfDn%14tjWl%IL)*)?>?Xp7(zsD_Tg@;|p z?~pn~5yULOX(?--0W26Llr>2AcxD3>O`O(c6a3Vu?V>`_B8K|h8RW@oPo&~GggAzs z1S2a!G@FR%juKO{Yc*c~OdBPQHGiYUP81Pp2tF6BDJZ?Mu_1f|WCwbc%~e_-j3!fz z70YI8w%Q)4;@O?7nkENX#YS{Aqq)<838MO;Jr0#ZijQy(| zLJ8IGZq6pPXW6Yw>^%`+89~#^Ef0HLHdIfvuUhUh8ywEpXjLTdKMt z1vS#J_qP#HTt>d{okB|xqZ@s3_=PN0aPCj{`kigQRFyaeq7LD z=>!s~fn{I`MTQ&|iYU6f`{P$nzWnYhvzX4&^Gi#E+dRY8FP2GiIX35DL~A|J1$!y1 z=6hq+iNuDqv8u!+K221W=SQUmfJ2NKd(OZ~+Y`tX zok39p0Ib_&sb)P05toBXQdrtNxF3W?@LMA1Gj?Tb{I$1g%8){S4^4?g@t@V1ZaNLMtyv*r~)2OqPb2HB}d- zk)(S@vl}hKcBIgqw%1w3&C5#9q!Ew?m7UY(m7Pw|)D1rg)mW-(8P>dt(1&$Y1ny=A z1UA4=?fmXVow)1erHi<7@rxp{ube8%eq!RAM+mMj-BOJtk!$mUYmkqT1klwX=?$}DtZ9MP=0yv4%uIJq><35bRw$*0R`M4Ur>DSz<|`B!Yjf1Us`&D4H_#e$>h&y^Na7^qFtE( zRDCH4O(s|77HHLaGK*c*%9M=P<8Sh3H5Y3gXd9w~QU0MAC3*&Ie@pdqeQ_Zc2Qf6~ zcGGX8&70)AB)|B}5M`L9C9{o31Bys3I+~>=*E#Fwz9C}g?b(>-EBux*aA*mS@Err4 zs{@I^2FzYqqhvyk15_yqa-5%*i-t2f8@7SkBjAyAhkvjbaiTeBM5iH5KGz_dF7Y_a?H`loRW1K%SY~RG8i@JSg17d zM7ROKiWx^PjW(dyv!4uB_{!soi%{nrV$*TYRH0GCAlVE{qRp3(?c~hN2V@pNZi2n~ za6tJY3{~X$ZpgEv1BI6Yapij+P|{wcs@L=Ukl{I2D|~HMSf^9sSR$&m9KPlX8~lV! zR8cg=+FdNcBtZ(nq4tC&>Inr-s|R+zFot_p_C^&sx<=G(zz~qLsX~b^A52&|J3}bU z9ViG3(29FQ-CYTF8Ai@UT;z5=U~d8qa%u%b1A4`<(@?b_9Gt#5lEKIxUPX z(tKj0t(tM1VL0~@5`;RR#)o^Y#xMJg4<{G<)%~)&!fbt|%T^{IS8WRGN$ZH70z5W= z2qSYbZxQTJIuQ_M)W<9`4c1>cCz}M;Wj{^h(y?Q+)XaYd7>=WA*cApZpnA)Y)JihK zNT=hj?BFZshz8MOd2UBg>pD0z=8=F-2*=ZAA&2G2EhZ3-VTK1;GB2@?94cm^vP=Lx>`N^3~LZ}Saej%aZ%gWWsXbsEo^Q%xCcBD{*%qyoU*|8-M zoZd0r&YIbS?v;;EeM7Db_^;D~)mWc5ZJeCJ^fH6*^DBe> zGMEt_4*3jj^Z1wMd`|B*;aIh2?E&n(t8%~{3#|Os4mR5T<14(}PEG z+W_|Kz$&_eLKROl;Y|Z(9nFk5<)v8|y=vR+kqRj2A)Sig+(*j@9=MOqhVnr0Gfb%! zRz5pW!f+t{9*CNX<6_ve4<4#5kHlV?h3}~oxOIu~F#J!b z+qm~bon`hpK)OnaaYSYyOX#!15CJHFCK~9>N-}`2SfI*(pFs!zU4$^#`ZBQqX=Id;KU*(Om;XvA=#G7>jM^uP)n2mTw z7sn#QKcI6UmI}ShQ)Zu|6pC`U_D(bsAelW-hn%LMCR+;4K3pm%QUgZeM!_m9u)4G{ zHj}kQdR zoQRWB`vuO>!u0I4yRbeq^%vSk>!{y$M$BrnM06HyR)s1e*>YcEVPn?=)EJ-iIsDwVkEZRF+K1 zx(rx{&EeI3jP-~hx{Vc0>iVYw#T0?+86MS(YgaF=A{aW+sG=!{hO115V)cC8>m`J% zN7SomFk+*W%J35Mi{R%ziOpsE^Iv>>R_?#T^1a1QxyA;lYW>D&?wk0^T`98_PNXOZ zUbF(q6x6zKf?ESon~@nvdA42?UO*)Zv>EXb&~mz+_%@$sMiUjo@)`O-uSIQGSSb#_ zWqm}1ckEu&#SH2MWT;(zomd!p^1a1=6emiKb7AlgaOlf*^H#uyq;)4!cMFp_qZqFihHH zF{;q?@e8>oc6VKi%Cs*tumwA(!e2^sz#YeknxDTw4GAk6uJ!2AqhLorIPz5!9S%;^ z4N!1qS9rO4?#xbc^b%@Y^SwguMQuR``G*)ZLR2IIg$D=Lt{5n+?O4dV!hy3-Et;2n z9Q&|WNZ_AZdEps7d2VwUg@%vcu<6Z)KOi)lifw#CSz z#);U=9Rvm(pFL)D9g)5E=Pm+chcJ;K;)CVYDLxjDA${~VmKmSIbcIs=p$*Dcfli7m zAAb0u4g_C5^a(4l2|_?_ErZ@YgC2Z0DuJu;*Jut_?@tairXs3mB@lX#0Oa58s3guL z6wKKB(Bg11>5G&b#8WS;yY=(~K4L`+&kZ_ThpF8BCZJ79z#;5oFyejx!!tiAz`454 zl*I6kQ$s(6vE_B#=hCT0zVg+NKmPC|LJ<_lWr?Dp5Y(G6w=hm!2hut_-nKeWH(>!7 zGQf!KrvnxEKQaPhc7ni7u77GuENnOq!Ko?SjbOCW-f8&jblYR`)FWDn76j)Yt4YLW zq(*Ci$u8B3GiVJ+J7RDsa15q9!w??brY-f<4qj#B|NP{~@4xx}KX&2za(Vp%U57#N z$+vV$`>%s9e)#_TufBNp)tA5sumGIOsBe;i#D`$}MbO=-4Qb9JpPEw{J~LbsQ`LSE z@pKU)y=oYkj?-JXGA876+*40R z9gAAxY#{Jd|5&zIJPTa`^Gz`+HG>KH0M;;t2d4u`iM>r8FisqbV_u0hSIqoJibdB| zvKDkwJYs}JUxZb38Bem@YJtFeKcnK_;U}KH!Bs;JX|tJDF96Q4aeAsiKvt9&LeJtM zgg#%Fht^jFa2h^mN~19kf8hy#V26n^qGGSbUxr=?w)+&ZGH>sfKjQK#I0aAM&BB&^0}2=|E6crjz15r>_4QZP*HHk? zcH$S2kvWFqCZHQkgy5XyT>Bor|9Z*|O>WV?b2Eg76#3|Dakb)7WpM?x4r<_tmyaXm z1I{=O>uWhIGLEa>$ehSLVRQTwep7~ZL!Oqm&VHd=(G-LaTcj{dDHg4)gUFpReBc3o zvOLW))97pN9P6f`>W0Wn8e2@B>0luBT8$m7CVJ&9SJN#;-G;XUGN{DWYpJ>cX2S>i zFTX{BRz#`rdwzULvvX#{p!E>`s8+oyyxq_EjI{m7U;7i6tp>8teT|eTz+@OSn0bj( zik`E&#{pG9xGgf!1gkR>=SAd4AU&6(pic7HmS`3n8?q6QZuur@i5iHvPrb?st8)rC z!%a@%G)9g@I%%uV#1jz2cz$XaGD8j=!iygai6L3~!+jH?CteaqpuB*Wl;fM`5HT*V z>no37X*i{~Hb-?;bGn{B7UJDiHNqZ9I|`j(crh-#x`Ah3efRVrCU~L4V*DYd*z7kB z&x$*;GAZ zG75<}+}zo+IIBI4+)Gd^zD|>x<9^yD-q22AiHkVG_VTs@j`Bt7DPt-hHy&N5aw7+C_2jP8OkvRMT|d_zgTijUr?^$U z#cOR7TMCQD_p1C`tX{;In{5)d_8V`MG@*C7S=eggU{&AZq7a&qmx}1i1W@`>Syv^8 z3h8)7s8A)JYs6P`f&-|#opZ4hcFz{3Clnu|WR7DZ7a)90al~==2t#hrxHMOIx1xb) zf^yw4p(;l~$@5^+J(6%X2SAZTv)F*<7>tR-Ef#kL&5b__J@Yi32OoT1trr1;wyT_2 z8L_{eYqzjbvu4~XJZK-Bh{d5k-)Lf-Y@QR6qG=|DQF}{isH`Q@o^#wiC50X{j~3~D z?|Bhy1Z8m5i=9G!f&n_^BPhMCB*zO{M$qYC2B#*;h6CeBsi!~%O#FFL=D<7{HIszm z>Tt^Z%p*y3Cl=9n@k%eAnnWUk15U{`Y;%ml6 zqp!2+Fbta&Zwc7a{E-+;7?gZP44qOmUguWNdUNC2_=)&jf*ovAtf9|eQ-;jWQ z$fK^WQ8uMvCDM9V79|4mOUbG83RyZ?P6A*&X(%=>935%dgg@g3O(9Te%uiDaB9~jV z#LC}LxZfa89P-sn!>aePDv3WZKGS=BbTC~48VF*uV-K4J zW-l&44SK1g9pHSEvFGAy#7-T_DlCdy_PTc*_Bcl8X94c{SB8ABF#nM z94gbk%ti?FWP>~4rYu-bBI=oC#qB1kjv7nKgrVAmLK`29+ZIcfTTkH3pPH0mI6#m% z0Aaw~STu-0e@`|O==0*o48uS24@Of;vg#45WQrz|A?HWx1u3?U2BSlUMKcS{fB_^8 zSg%ffx6g4+54MuVwpVDm4Wx-LJYyOgMtCDEI0)tctil#{mD6&8yt{FbU`J8^g zB+zIkslTKr^lK4l=(kC<;-`ievN94#h6n7IW3Io{65L!GnfE^N5Is8D6$1|?w#J~0 z{M#wcFrmo1+Yf07kqwirDW%9aLghAK(fsrFyH>}Ox5?FTs=#4oCyqv%YT5ajx{HF+ z&~k;7bBJ<%Y)_DS=MM8+OLn93z}?-fEwdw%A}!Stxhx#6$zfJxkb3w!-@_ac;c=bd zo%)Q!fNgHua@KCmB%UBiBP$xo;S^(?J*E7sR|F<9>TR}<`VFv<&1rkOIqjcr{$Xq5 z7$yQNvtaKirbfZoi=O(f|r3unX%89(0^s~yClM@e9?iIj0iW-pso zRsI$6m-ZgiN4fZ!V203 zwy5Kz8TRDSH)wMI`4EC1YDYP>*i->81P+tw==7AfOCn>$KQIdLbZKen9S^^Jf}2D- z2odE~u*qOXaY6-rdJJwLiSAQi%|`f{iHS7d#u3OSk3h(_<5Bg`&%S<~lzFySK#zY& zP~D^Og-LmO{<&&9P4gJhmJor}0A(J++U;`TW6hVHOQNggiLDB3FWJx-uS3d9xlCAY ziyQ_N2%)u0*&$QO=}R+WtiaYpSbFvz zaij>Qd~nI$tzeD@1w{W0k~uL9#8lWDFj2Ee7kw8VY1T@D39>=IcShAoViB_YE=*}5 zT~-cmCe?%rLht^U$og>;I)*?I+NYEj@tuT4bp~LbW<}A&{tcRF4khtz%AA7m5$F+6 zCzOiI@oYw#OvE+l0b31PL_J#ojeg?_z|{wAz*1HDgDnkC2O1Nz7AzE;OqTQ{g#|Lr zZ+Qv18Zban01KM~;|=Fu^8N_Q;PkG+;2^TVH6UADNHaKDnoH`H2`uOC3TRG%Dbp^7 zqQSV89$h#ecLyYLtGJUX2Phu7iIK#@qIx~sa-^jY`2j}3VI>8U^;iz%bBCib zwl9lXXf^ijYPcp?LB*3K65?EEx}LV4(eC16+VYp!TL#PwyGoT+m$sbUfe=D#&FjUBuD|Pi=?g=m&sj67MGecZ!9iacHvlDvSf-_T+npCG+`7q zf|H>GsFUT($`*uVt1eh1|AJCwwA3M<`EvRr&2@mi(8R7-O-QrKM2vK>m85EnyNmcA zml&B5nMW366x%;W^)?x1vmE`Gt#r}V57u^xOSXNIU*zEB%|vo+evh^*}n#d`ciA&5n zCBsK?6zH0hP~vQ!&T5Q`9*4#3E0S(9I`kQ1yDaz0J59Y(8hpxJlC-=+0+y=I=jQ94 zzXr)U$vVqXqCzW4c`-u?VV>Ms*h2(Sbut;xII?g;c`BAgv(O_6{g+Gcs6d2@pV~8w zmPS)A;3f0Im3lV$O$liMG~$HB)^NuZ36YOB)`E-YIW!9~W4RTe4>Z+h;42~Fu5+KDqc-4o&+rq}(X?VyvD zh~c_TCa%<)G_WqcMh?UM!%wtC3F3qvxGAJsCIcRwB9;Q`{Wo8KjXQ8~9U#o-#BT{s z{%8|29;OF_0$WKlk~KE#zm&A$WRL{{@$?2OXd{)?;S6Fk+DbjXSYuO}W3LGnjwE74 zszQ>l(J0M9x*Yh|5WIjWY~@r-u%WrW3PzDTckalv6r*G*^zcqi2gJec-CHOBl+WCvy0L3k3u#p+zRx;%kj>dNSanMTxF1?#fh93Wu86gl19 z)kucn;ES9mY5>7g8x}1M#M6W~tR~A-mtL*YI6n)W@cQdwqKV3t4TxB;gqw%Xscuqr zV}0N(OB>TwmBqpvTquiEz)px;QE6+L9=pGWEHBQaIGK>a0JD|u;^49l|0isK(Ec>~ zg8iDX;L>^;LJ}E@oIqKV#6W=edHdeqWz*9kh{kqxH`)+-&@YM05H;K}L!_n!;MM@?OZ-~Iz>9D)(aYEz;{2--ugEeJ2@9VxWEoiy5S8 zNzf?3mBn>qceBtyL8$qMn-;j3kCZ!8)bq6!7(3$lwAgn73J292%qF-SORf$nboMTx z6dMNFmknj$;Pn#nu7-%<(3W^hj-T_;aEQmaqf81zbm;J20|^6ln+fmXWLfG9fat3+ z((rp6g^0wsT}2KYPjNqirMqS@h~$Lh1!I)X^=io$b^>`Z24RWpOr%f+5NB{TTrG<% z6}UW*aZWN;!&~3C(twShN#rz(o1|RdJAH*~7;pl^B=EL#m3BD8cGhJU52Bfw`~-K+ z2H~ZYA6kK>n)41h-4+b+6-V|bQ9cxHwHmoHsR|1+1+oYzh|u%IW(e278{b6COE=d9 z=8}jF`M%e_d<1XNv-FrzxXb!9GIqWBp<$Il0q1hGjgyRsz=DgmI}I#yR{=R71XcD} z3J)o6S{4AtK8nC4*U`Abs{Uc@)<2gwnAMa)>(u6Uc}@?R`rSY^PtJ1WGXvP& z2{K}Lr?h`n5x<%xqztbnI4z*VpI{v>7ZTZBHYAfQCTf`SxpR*5^E;3_k3h`WFDk-o z4+?^AZG$M-nC`|^>~D?>f20S}hZ~SRNXAGaehf-7!gcDC0WRY%EWVO<%gu&~t@V)G zalFRlyld;>ZfHK(T3-*p=U|Vc)F~p$Ihvbry zrW=?DQIZauFL6z=IQ_@ttEBIhOl#&Kvrz3T>wRf zc$@(i+*!ptXLAWU>3Z4Iq7EUgL=Xy3Q%9-BcrtDy-dz474;fm3LyRcX>cb28k=K3K zf+Yk1#rG31II;v6JQ2EQhk@^2(yx;8t7NNvwK&0I1;ky#crLfa5OWXT zsZ+=$qmb^gJ}_g@Aa)j>k8uo%GfG^YMY1a(z!OclNxOl$$SZ7^o^(~=z}}oQGxh7a zwDf#yt#A0b`DmDj8ald*OKPi|uStd6FPc zeE0LLsP&OIwI-wCuC0*V=20Rn^V=dClw|8(mDxuR8iCkC?e79@?C#l4(tk|`NYoGq308)pL&tnI*mdPq-XC1uh25(gG#CD%o<_Ic=F=>PKX#(BY)>}02joB4T2*saIo;6#3b2hu1n6A zB{@2+Wf%nqA2h`VxnhD|b?uTaZS2C$fRRfXx+E~}^9sF!8EDC{%P4?@JKmMf)azz% zE;!g^a|8kF6a25=! zqO7QeB8W42YUl*PND`2wF+r%QZO|nhCZNfvfh$>IgOlEow~w-+L@TyByw`!DKm#0- zOyMmnH|mnKQ5?s0R^tAkYXO%BHc$w0vu!ID0?4AsB9``tJk(AvK|3Ak{=SAcU9gMT zgDL2~EIf6jR$jyo=1wn^Kr~*kd&|%oTZ|26h65lco+3Wvyj6+Fz55{B-(-r&7m}IsXiHi$-VMY1%wAGXq7A%`A2a@^VsURqT5@|Pe8Ot$Uvna^U`*6hDPP) zAh`;d7kZD!Gj$XISMOrP&f2xKd3Uv^LB}WPpEMPg1trQhELU_`X zFciB)tOc5PB)NmNOEJ6%!IJcUQjz579z|R6WYKUiG!9vs7G@UK5j?Yt7~w>W4KEZu z9BORK5O=0xaAwaDLdtru;bGq2;Ls3>uRRGy2C0IAh`is&ut$qXP9jp=7vcHV7X73I z?M7qq>|&|CdHFVzZjIyUnGLiw_#eO#jLWG1TcZiK;YkkireNTLUgh^7IOtxJ3_KnZ((JF-)M&1IM@IozG z=8u)Z$rM4Mlt6>-*fhC%Rz{ZcDL5Q`2jM&LqID$7NpChrDdd(ww|!jvhH@Gelh;*< z$Xpa;8g~&%N}n1K6KQP~F6#_=3+L&j zbSb!dl-Js-kw`P82pZ5#S{7%4f{G#6Yy)z(%e~jY6O&s!W*vjYLEPiVkBxD#1(%-O z!1rF4)jKoW-fy&~QJhPgY~BPX>3Yl*GjDh+qQ$#e*Ib=>^Ob=fVd-^+(Tlc8hb{(U z3^7olW%6{vVxUZ>S5X0bD=X_e2X zG<(zyChkaRQ-ihR)0&8?dT3~T9Zn)H%1HD1hE;Dc<@|MY;U;+uLW;#hz=V@hj1qk5 zW>JR`{^mXS7}Nvr!g%4{+UtRAq)+<1^u06iE2hj*#yLkwM6#j%Xyz66z<;zc;9WFhB`s4qhe8 zrpALnIk^}}c7cf`5BPXvr)B;KPWLhF4z5j_h6d+>9CH3b+_%r}loId191wZYUJ&rlnunOmV*x;lj(lYsuQzx zq(@E3@IW|R)~(L<&AK!VJ0E%?VcsxitvU;hhIsA5o&3zk2>g_5fOv8!?~)sVJ1V5P z)qDF0!P+vq5~HGMy+e1HG5+(XbPfy+TVi-EB;#KjJpy@cd0w2`N3~}2)J2IQzk1yI!bdeZ_dM8eR@S_X&%1<~UI0J9U*3cvqkahY) z!73G^1*Y3cLla?3!&<^hjFpl312m85o}3CRu%gQ{CL}{i&IPiFx>My%PHY!47^A`h z5*Psy5J#sKOS8wPh-elrGA&m&D)4QsJq3I!bSV_Z4s zy>mTNhS5|{3PdhjSz3?fsw(SN^R;3ZnQQ?&hW4Uj6E^ME?mJgRKN%dgUs6p(;>-nPE|MH1co0yIlv#xa1t@ zbe&|GEDDz27bI`sQ1c3Q$^H_xspY zLEtxX8yDm%`ZtaH%z}=?CQ&006NG!8;GBzR03RnL;VF4y1f3vJu4YCmc-Dh@`ij^D zv5_SdW}?EIJx!IX(9jAMNm*&eHQ^vC*LYVpZIX5ffCze&uDK+P^5#(W6P3?L@Xob+ z3Uax+ngk?Dk14yE;}Ih7OHj_saUWzjTPhicG{+s#!;AqQTurQjQ&}1WJ3Ix? zq_?@A6y*%-oeo@U0qCjakeAIEM+q`74@%oEP8YMg6Ta;BT9h@JCEuIb+GvI(ASuPm zz=zkdjk$@;mG(s8MKnqcC_Lm}mk=(aLD@QjHlPEN7)ZPUQ3`XwQP;xd(G!*v&NJk~#pt8>qk)2IQkaNjfXB%g!XhUdVfAasH zhOJMfY=83XJ18<{)yp@h>7A)D=-B(>HvII@qEg%DN{M?QRl&lc-3#v@j)sk&zW!^V zzztadN{mc{6>Cr6jsv3}cCO#~Kul+8JGkaO52$nmd6?>uNbS8rE5+Y&s!H!f8&g!t z#CF?!e3|PJZ!||4viqstWS&yd=q2VV*+}yVb82bQ5j?Dx^lr(Zg?YfvluO#Kh!<*Q zc*#Z#9{hUM#P93s*3i*uw}Z1U-XUICX>a9@ffmaHg*OK-OGNJU4K-M012nUl13MH} zT<6h%Xw9ouNvzSKl*$RIAJ}Vyir0d-Wr}dctRC8=7R;t5L72oO*$7PnNdq8`Ak4}& zyBuAAdM62l98#(gfp2PK=)#zmsjXLxuX#PFo8l`T8NvuNfS%yWT<{Fh_zP>7b8qtduXmRB;T=_?YMax)wQRQ%{DGsDdx3Ni^$_fvSoG-3cZGX(I& zb0I-Z(21?Py@Z4t!V9zZGMSCkR0>SP^519B)Nvby;3smLAz_`~f0(mT(4dmuNB|Ky zZ;9TDY8mj^u3|^}<{F;%Czy@1fID@fVZNcvRl5VLl6YvxRU`%~=u4D7clpfLMmY!v zkX$tRiyyY7w{znbW*Gm989ri{^Qinrc#u!edx!5_SSh-6=-9u|Wb(+OU;S3%3Guc_ zJM5})wt8u^Uky8`TdplIDeiYU{J8^Pr6a_uMWunpc6Dz3@Z`f>f7uV`8+Xn6_Iz^J z%nkU4avOKyk8frME*<6EgdOZ#aN_Ozn(rpAq|VU$GHPz4oZF_U@ReYFsyQ{DnjJ9H z=;oG4Tdk1lQg`K~0lKl&-uDP%gBx}rmoBt)%9Z79=r!s`C#EtUse4-EK3wirqk(X1 zH53sk4d#Y({|Yzr!iB1U6xDdfF3KA)F}XB=B91HsT+R8cog`gq2No%fB8Up7Me@k5 ziHg@m57Ce+ZIif=SMh>pV3KP$LyTmUj!Q+~M@iJjk(H~`IxRMAaXQ2?nX?3MJFi3s zZ`U=La{(GJGn42&FBH+ms4ijRiWx+Qgbkej*=QCe)EHO9CPc!|JBZg1LZrp<1Y{^T z&68u7_<^r0SN;+sJor9dGi*Dolp)cj`0is;CSHQOQt4lkxA`YREitNdO!Qvo@cg??-Z|@=`fpT>PkMiQ; z0SH?w0I!OsWCd0Vv%RYDRqtz`ZDz2$s`ORwYoDcb7n4Ujd#`bQTqvXns`%Z?o zxUu5u`yRTs${tnY2&o*lv*oDaTUfH7~X7iPG%w3<&~6HFE2V z{>pMgHxmvf_V?t7xVX>AZ z@de5P5~rk-D;;Sn53!}JLS7V=wL3WB?A~#6wCLYRHuXY8k-HOUa)a(&x3R;~J|eN? zoulcRA*R}3De{%6?BMT+%bin|Vi~(+p+>8EJNCNY3L?`VP_e$2TSyeLTWtS5Sw!Cp5;5Ycy`X z;#Kww#k?ACQ}$s9u?t5G1WEdP!EDK3Zd#}>HuJ}uiO>*rcxCgbGt=|P&Fnl?PT+J? zrgPQoeF7Sr(G^C*cxFVxSUih&0VKRJN6niMGU{Sxk zHZJ)HQ`_l)T`d_0;_IO2?A%QJz%n5oFE6g=L{XZg-Opr~o$$20E1j&>U#wq5j7#6* zBT^2;_`sfRD=CM&%=KXhE0Q-^hv<4}@u~ZezN{ww~i3PPvV2tRU_^rz5zx7%ofMYQ<4y7dXE85DJ?m zNBB1w&=nxLe(PDLi)`Wvi@66cQA|Lv(=N|<{2OQ;E?3ank6ttK5!ZpEnc=Qu99+UZ z01}E}f)tqJtko8-Vtqvg(mZV=o!?$^ZV<0Q?!NA}#cthzyC*OmjyI+AO0em)R({?@ zb#4Ww?{0fnYyZJy7C$KRdF^k|>|D=>oVE(LOd7xqnuy?J3u$!u@q*Il1;bI|T4;p; zgyIf8+|wsl){S-M)=DNL>1rF|v121~>~$3Do$1-#itXW7#`l1i}?rh^81%HrX3Og5~ws<8Jr! zpT1njWnJSjsH3iEg18bV{kNnS!;lNhLw@lI0!!z)$GJa(xQ9L=oVXb@+i02d4mKA# zGeq;@(E+3}0U(RUcAOF?j%eBZU|sY=x}BZb4B%+1PC&5$guI-CY6p|4lmv+fd`ajv zzF{y-)PZ)PGyq;_4NViLnysUYM@*qg4}O&QIdYNtVf!+({*Xdi#0tJM;ofLYeE_rU zW$y{XQVGgIG2W9+>VolG<#=%@d+h=HQt-^M#4Eek-HDgTVhogfvIJYh6Vo|L096EBgdq=toJ0FOSEf2>^ww5suvJn z-8{ks2rA5)+lK|WCg?BPG!?r>N%9wJZh=u8Qjcx6^X1x4&z}7F%nl_RN%LvwY4JiG z>$ED=>KWQ+4raiQ5nJ${1*QVXfK5OE-$#jK}ha)2F=(28W$g{9q10@$xK2LFDx)x$84yb7Kccs#TIRFRcqF@;i;vVrEK!b85 z1=S&3!wzYC?Zng$pP2x`r;i$+nP~e64TkVvFyB%y66i<3xa64dh?icAMOoL=1VwT; ztd}aWs)6AamLewL^g$F`Uvk{9Dk0m5_~xlH&nRa@U*mD>h{z;om#+Ae-I*5~2gvyF z+IP4!3wku>ehhzW%m@BPA_ciFy6YCATufR`{l^6~j&|v!Tu*N;m^l_0HhbKNG0ZNZBQ{C#wEFAdv>rIP>`xrt}Q``pftt z9K(IzAk-Qgu@IKeVM=J2NHF5QglHeaMvP-R19@l5kI5d=UgBPKii46)hHYUvkTNae zWWp@nW*lAW4lpzn{zZ_^06@B6i!~h&8o%)5dfG*wj6(u8QArcM5y;Oz;eAVJDjX-I z9YJnDnI6M`A9Zh;G55}8c#N&ea>7IY;!o_CIBAB0EM3T>VCd0r< zo+I9GA<VpzsJZaa#3u(Fb)%RaI ztG8(~yr@$6b}>SXoFy?rxGJ%PpeK1nPxrY zmZBv6CPizpy9shE*8I>l?p-?)UrlH1pui3?dl~4uvPY7tk}K22%QMK_DPfE4Z^}M; z0gP{W4-6?pmqZgl0W{eqxZ;Kyn{a@hoY|xOWw|C7AY6vc_L5Crgk%K-sfXxJESfPh z8&g3^h2jqZXa(04iqTTZJ%OXP099rLTTL^$-r8Ir<{WU$KY5JypSlKpX6s#n>ggR!ztmhDBqbuMI#%5Y?%ofu~85> zyJD2g%y>TE#&JP~5&L~+QnC3J4Jz~F7sE!5O@>HypCj@8nxrEX)`hneGAfcRUv*Xh zq~Pp;qrM0WNzp|Sh6O83R@lJ`Lsqot=K z28iOkMnvcAoM(;$bUSNw1YSpy21zzCJ+VM--z*ukw2#CfQ`y z(x9ajrS9eTfwmC~$-%(s1h<2MU)zb6$dJ_RG$+?|gi8X;Nkhwl0crRGJ)kZO=nOQF z&NVxzj|EAJmX?wMoq^$wp#~{IP|{}kaQkJpWEeknBYdH_1P{xS2nH5HVa}E%=}9i$ zy@ADMaTVdk3wIOUB+8>(WM`V9?BagjlkH67S z=qes0;wchD8Z3yc9bXEnz)lG9C#H_b84KB*%X|`KMLZs zkLlqC4M-3NE%*`Q9Hx(08?j;f5$G-`4GhodNT`fG-U#2&2n-6(7d9mz>Abxx#N+^^ zMU3eZT0(_g2Z1qgkBiA^9w}Vk-S^eUZ5v3Zo<~L6^_pi5zgsy#z!1WEPmKJ zM0jwC@K{Y>aRrjE`%=wM-~_Lz5qCR?_Aa55CDM?idR~%R#fh@JX-T_i_rT3pQDjpp ztxu!yBPw;unqZPbLj?<22T!*VBj}J_;Z-f=1g1IYA*@DuFi7tPe+0*)M>^T1D- zWyNHk*SR(+hX~Ru;Kmo^PUzy~tpnwZ%aUnlDphB)wPuS!woC>LGS7r{f{nf+!fEh)2@>#812+x=NS;eLh5iWyC%1AkeRa?lS*YgTxr2(0^m<~W9_Zjzx zi&Z$)lh#qcEqk~kcBe5vEE>#}K3`c|iZVq24xV6gW?ofDh)#PWrqR&rgB7!X14(#O zQ0zSu`)Mrqp^Eql7bg%{TWi1EnXcOAG8N}DKMCw{nexdCSQp`V5GyTuzL_bG*D13} z8o`CG{V1u(@4!fY1`>%g4UlVwK&tf)T1Gx8PDm}#W(MO9lqBVp7+mMHR2-%Z8u7X+ zGZAkm0uv*rV_Ok8Nf6WJLdV*ot9`7&rPiHufCC*IC&zSX1S9gm%`*yV4H%415mDT7 z;6yiTSBv9bp;Z`#EqD@$<7B|uS&BUe3xau^mmcv_H2O1Os4$d~FDj!t3x}{X%0)&p zjud8_054MbHH2vsr&XWz{KZ9SIyQ=nJY?=kq9z>qAv6?fNJpVD^9FHuQ&bq6OOO26 z-%GX5q0kr8J?6OKk=+W_C_`%3Qcw`zQV#?3ZA+C(!i&WyW#sqB*+PLO)(C6FQFRrD zHicsbx#J5G1g|0jU)S5_k$!+jqC8Wa;7kUZqmD)YmBEaa<5*IjG$w9L8{P&QEmU;A zE}k{1oOCAk$@GkMlSD~jkqPp0%O1xPQ}}3bpbBP(*lKOL7fF!^m@gyNM2d-QWFu7^ zo`-a=+AAXAV-KuSjVBJEYlMA!(X>HhV(lVgqI+PZ7w6xEncSlh9{hnj5g@u8QeMYK zf{6tyJ-@?AN3g8A&VuYqHDU-*foD1zc_HgwQMvJ%U0wA^YYKiZ1aAd>fv>F$^;(d& zT^AMbd04|W6RH)iF6Y@Rb>y-xor5kXh}VX98RFEi@lkBVR}g2(KX=E;e8pDA${?Hx zS;=*ClB~H?IC-p@=FMV&C4`zmFJPh3WV0mp$<0F~Z!B$;XEPOrjEBu9#9CS^ddlh$ zOx@>Vn9WO{FDR^Go7XHX{ud0@jCjlWB4reBio$%4Kt6eFRWy-MgDG3WbKgSvy|5Vy z4>-E!G1*YBJnTV*w0VvTbhLCtF4@gDIz@~D`1sgk?eZm`~8UjWzGkHoM1lCeG=xHR zoDN`il^6yc*)~aG2BIx!+ge$WP#?%C`V06WCnQWbD0u`g8w=dPz_mRcqRTBXI$&FI z_E5Oz?U5jad{44bX8|lV?%JlaxhQXxdbllXvU4`Efe@j<{Uc9{6Vqx2wq*D);M98( zV2rj3w6)N2+7T}}=bCFh3R zjL-{r_umaL-yUqpU~&cEihX4Gd<`I_D^=vaH(NkGur}(6*c0e33^M`3oit1;YMZn} z>@eY)TR?b{q&{>xOLfeo_|J)3X}4Y-++vbhYHeOmP48f4$H#YO<{B9vy+PMG=DVDl zJu7zk2JNTi^VZ`NZ95JgOp}b0ec(Qn6ZlTsZj~p(_#|imn?6zsl#!yIIQ5PnT7c&v z32jdn2m7`lV_MkxuHeI_shG6dsk0;xr`#6?32ipjPym(o<|g4ZpY6?zqI(Xim97aJFP^U3kb)m&>&DxK94BLn(i z1#SjhvUHI3#9ZI$rzRSSCA`s8$eye_kyIE#^$_z-p=H>Hkc>zS1Ky4$3j;wFm`!H= zsVo%bgo0yi zzs!e)T?bOA2M8r*#nHVLnApHgK*jP^;Ihc+?S{C@3LRngC3P_6W-$LZ_-i(l4+@EK z{{uR_nW<#MowX}BLdkEkjIiz8Dyk7!a?{$~`MYwxZ#&W$t4JtjNX^L^;y>Iv#;DlD@xv5LT0nx0SXEG9;jT(a59W--xepe+2DCY2BDl#oHD7284A?21 zk;qpm`g5|t6Mpj zXqIYT5uT@DRXDzD3N2Jty+lhrF5iVM^_XmoF6?p-K3%^+7%&SJQs}7zvnmmg_6q6Pa=3?D0EuEt_8( z7}1apZG-;VxOkejGaTvO)$w=kIt_?pCXkq%hTDWuPeM`n;8h=qmH||M@i;u+`>)OK zpCcgzN5f5Mx0miglz;>H6fVU3I#i;fipdP8Kh+ilRHJf+}v9jc&fbI4Sy6KlN{7H11 z5^0)S%z6$-s_yXR8hyUkjaIw!Rrbam(`2(&)LvK_FRrfpmh#dd@!pS0SDW*AL)j8d9ZUd5XiE-y0_G0O}no70n1XJXa}9}(W!7PdFS zI{6B1Vliq&Oh^u1k_~^nTtiN43BD*f11=MDGY9EpOmb6@DJeC$ z!;cX^p&X_?K>ny$!up^f2IFZXzMv~3wp70@nuX?UhXEOJ?kDsvA^XLN8K^w&;$YSp z27|%st#x86@ZAw!&WJE@8f}X?)gU=cz@Kp@`l34?b_agQ4*$abVLSbbiC_e4y?H@Y z4w)aC46*ZZm~h~;DjJ&kG|D~BK%!Y7ueUZr9u!_Zt}Uybx_vqe*jQQfYd{-ZpM<>g zsUWPyh%;-b{jw42td&&6$!xfDH~Y=@$@5qWD>zmt^J%nGgK{Ix3g-cQ%1^&_fBSC! z`|c+X7q!`c{mH{vF*S*&2M>2j;~+j4r-#tT4sQUKTY-1VsxEE^?skKFVSm?WEXs)@&UdAFp-85^<7*K-4`~vzu&}*G%!~W|zGYEkvt+&sP z&}?y(PPRB?|HKL?y>M16EW_dCDVnuTIuCc|I& z&A0crpW>HKC*5sRuY^?Cgd;d^#W&uBfMEjZ8TStqUJ9i*8esC6r2KaVM}i^%nYL+ z?i4_jpev({@6z*5Ym8N01a?r;(d2ck#zt!43$QEr^y9qKSd8B9O`L*q1y=;bT2Q=) zhfOOy+&S#06zuh^S_?)obn z2a{meLh$Z9zH*FZn#XzHba>ZU)ijpl)5ff7G_re+PiMtNgTM&I~uU~7ivGVVkN1~cZ{@qU9k;8dWfK87ZBu5?lI6;9KtP(SF;h-qI8!8Kgf3* zQ1axn#Sf@3+A058=R7dj~vDg zf>LBf2ZU-he9X_4!Xo^;VSy0IH?57O*gpU7wY~pt?EikfVSnrJbVh{+k_l7B#M;bD zgpdX0W!lHaYD&n0K6vNq`F}q^qXlVmH2F_Wakn0}5qkf+NbL;Or4OXIDZRZ6fe4R; zbxMg#gW|S4Y5fh-eHn!pjS$xpWk}5~ge++zk3#bgWuhuw^x@!tlP;QRZKR7~du-!u z{6SEFPx&c8M+UL6hlnxgx-dVo(?)2*XHg65zfoz+AHsSTdnj_iyocu22J~})tI*(8 zYruZeI`G$3HBxEVljf*$Eqv>_E4ewSP~D}^22GjF&pgJ=>GU{pHLEaM7Zt5mZzGuUr%58Qx>W3-V~Y*_}N_eS>uuZbbN zcvAzyLAub$VeCZY;Js2Sk{ZENpuCdyU=)S*7q)+oL=@$1BRm1f#Y_tqt5PeHItDt( zJ)AzAPVPy{(=a)kz}~t+bE`hqBHqBnJqw@;OZ`s{}6@_N5@k+ z00`lS7r^sj_{$-V7iK^@y)dxch7RP*?qMHFkRpY671C1=1P3Pza{C)`2-X;yEB`)& zeYi9oLLlB<7`}M=7m2R|&*ptH^ex0$3cgHuttT>&=$2_NJ z{KRxtl_6k3Dl#v}xb+feDO(}9zHVV>R{Y64HnIqr$)4rPD2$XZCI4WDzPoaS!c6o$ z7i#?d%db8^_|p$RJv;dBFW)}<=E;v={AsT41vl`VPRCZ~N3}_0;&JQjbpz?7D%vXD zx5H-msf9Q?qw#8;reTjs?QlMWJ0W<=B=&qDVsUG;jf&wg9sc|v3QrQpU>l#57Nfe| z(r#v<{~h4hUHs3y0M+^eA#AL_ArW|%`QdXoM*BWmw7tMUJP>||`LaGK9 z!nd@AH!!99QK`5xj}9SbL-qh6Uv>2W$DkHt3zo_R!yu#*z4{D}=xqQ2(jcjzm*3ru zN(7U8B0_zme0t(Vla@hgNQ7~hm>HO#%PMMPmT{|i4ZCrqhNIfo5$V4X2?)7{ykEhRB3$=9eBdRnH+NaQKO>rd0FRc8boNF) zDm3($w{OUHgj)Qxh5J?q;U^d_dp&4nw0*DsMe?$=;+=77m?BbrCrQUw!|`-_y1Tjg zs{f)--)%Tyi$|0cVlWlw zA?I6SG2<%?*#L5a?3)mJa6S)Rl?nwDgzDi=ShcoSacu7cnDkzA5LF`xn|R4~Hf1bN zXh49pgP7_*yzh`ucNOm?#aDu?W`b;W$R3q-wjl}e;5RB2?3)9V8Ho3S`W>8{BKVGH z@oH571%R$RZb_a*h%}{B(Hwf`5g;}}hAXODFQ+GTKLG;@gF1_nVO?OUcq-R{n#My;A?@eP zDvaap3mk;uvSN=tsPfq@WN(0nHq2D#Lg6o#2RKegM%FiK!v?UtoXZeSk3H`8WpA>( zi|M9>XT}2m3qB+|b)ch{isT&fuWNL5_T$Ym1QVkClL1hc5r8k{Hg~zWPvm(+YC)C4 zv;~83`(J1s;d~a?B!L!rue-b7aTA1Mg~G4pWm0zaGRULy3WZ=7f~3l%_gL(G1&fTt z{qnVblu6Brz>|zeGle^j!J{D$e$U(=i`}~SL+rjP0xrJ9-c0ApPwB1c*J*A4kvgLd zM}$`KHs1(8(@luL!?F|yosADpAA$%KGtNrMIP%a3vGv@4bU|JC8b~ZX5-aDIGIC5ZdCjzA1H;jG zY?~toV0`EfqgTJ*k3|Y&XW2I%{DR79G;{8xtdZ6$4oODc>+#Q?q$%a%X0vkj3E_Fn z5x9a?Q)WguAOd0}b#d1_B`UTi5oHm_BjoW@7&Q=nPdaV>lgiBqo5w6?fE z;>|VYs2kZBS~>#Bg8sT2JJ2+#Ff+|mv4sf_$*O3H*oGbEjC`1R4DNx&F<+)Sjqm{M zb^l~`!n65@JAc-4VknLcb0-3rfB<~n9zJ;R;17bt3IP3ACfDu0$nN2c6sWSCnOUvb zMr<}=k8WF5uJr~p_y-mMte1@HDx=>x)|z0#N?qP(kj|EjW6g10Fu(^X6Tz;Y9*lYi zgt|+qU~a&N=dT}ZJ%7D(`26+O1N@(dy=*GOp!o*Opv?TzvDM#W;uv;jTP|bXPhY`Y zRWDRpbK7+Ov>^*~v5#Bg?JU|IXk}o9d1HMD#A34%bR0Qm%!$)^{s7445yAqZSkTB0 zL|tHgxdwbiAq7x=8nuxw&CwJ=_56)AP%nmu46)}gc7tB{a6LSa?Q<>UJ>p+RLwzg1 zrz4m%@h~=qt9|H)Voi^AcY5QR&FcW*$Sl%jFn@(52IkMniMW|dFU4V?4%>$-Y8+rf zzN!`Zee)sKH5RU^AckIq?4UDQzRF%bhpsIl%F>tDiBN2^lG^RrvOuO|KJ$L?v6Z0n zdm~~OpyrPC*#?Wx(j*I5n7zLoUA*moC2aY=`--ZBttIwn3AV|qQpU34D8w3trOvAKC)*$j+x`Cb-s_6Eq= z$S)_|>G24e#EJxg?Y~|FO~ZbFz1AML?{D)934qknEhArr$c*^5-$N(10N;QPh_EVU z3;<_wOCUT_&dPRheP_a{McAC4ssD*D1chSug?L9At=5En&Pf zKqrkk{{MbwJ7dQj-p$DD>oprpPGAfD*MRN)-dU2^*hxlu`O`lc_00!aXpfNRT(91k zWe_5*3{lge2WdpV7V-3-XgfRD__sV+1P^ADU5FF)h=~!%*r+kFD7Hs@u0rOXrqVH0 z0ZDX4EqqTlJ6AM8+YlrpDa{LdJB&FUy-G!+Z{}{FkW*vWu;X12I9$g;e-8$uO}{#|K}gve*S$R;HDtOy~g&&&PH>y_RBj3Kyz#B;m*znVe13k z!v1%=*|aAiG`Ds>-nzfNeZTqegXY%95AWm6);k@=g2v=dpbxfwmA)1X;kSIOcP{_d zk;A`R{{MbUAp9HmUAh0i_|uc`|KqEl-W6CD?f>S^wv&R;Y~J75*=}xcZS8!}Y(BVu zyZ_%6^e=B`d#kzC*t*}?dhk0DeHwPrj^hO#Z}m_~GERjxB)s&q6;WBBoSK3cG?mHv z@0NeJjCK5k%{Ct(&va|d8hF0ch-I4_&5ir=#LueaRE}pju#FB1ZjyAW@l@gYBKaMYjVLng;+AhRS=_xLnnv*qZw9bmj)%jUSdD;L}_rks~2@!)h- zp~sx=OvWZR8G1%gXoc`FWGTPw+ChsxaJ;8ug!0Z|S{EDIEyu;Hoh0NIr5Sb0%K1G? ztK#9{O#?bG535VHmtNfnskvtiCWnU?Z>Ex)&>9jzYe$MYB5zF3g|$mKi^ER91@SXH z8w*E`DGWwuTu2OD@IrtLypY95NrosR1krMABmWmQnhF26=#Qz_Bj77Fjb7yC(`EdLGgKhBt`&&D={QnA|zN6RQ z#0YL&(Idq8cgz2&2HV}RO&0wlU6&`j0T)sKZuuScdfUwZ76??*e+qr?aDX?a|Ih`< z8*b_UJ6wbXO;xV{Tu!Y8m9P1D5&egr2dj{Nn%f`mY(MyT`{9Ev(EkTJWDUQHP3GU6 z{}=C1hM+9B0g)AiH31Dh$$4QmByt=%uk(&r1XCmXR+PmhDXn^~z^Re6Ln2Z{j;9B# zx!6%<;Q5m(3A8$kU#VT7qXIpWl=@vk)E4C0Z7U_2jN*lQ)Q6xprREzFrvp1S9TuQE zaTw4G*y--?mR+rK1?97+>IMEi4&5F}Kd_p!!NLpbnS40u#@n&8!T1RjdgJMyl;mA2 z;yCEKqN>EAb=>*>hi6~ik(eT7v_8~$4L3D3cE^)I%l`%-@{#+3A}-29=-Tkqzb7wa zeU6Ct2GaMAcTFJl3D-4A6dUe1(9kwl;B0^x*)z27PuI}VdQ@~hz>Qv)qH<}*Dvkk8 z+SFX3TlwX?;-<^7&fUH%v*&VNlU&>u`xPNjN&gi;-`OZ`&i_A#74Vk-zq19nq@n8d zM>a6HpLQ>)cav8)UVj_|-LC&lApGWKtJi3I%o`4s7Q7^EE&E>ptTq*+yR&VjN2EOuH*b&wS( z4oKjgwMNh6#_@<(FC8I4h)Nj<;lQmHE*`0cm!jQF0;tRl28QD<8ixRi5EqCT@MWHz zu8KVv0tQE^!I35~NlZ4#m0lpD_Ugy5>E8eh|F%Ud_kV8x-IN=BB;bN!DsN&9T)6+Y zA4Usca|gTr{>PvKIRAgRbN^QV`*lzfAu~|g&Lz0l*9*iev*@U35%K4B^&wp9sd6wI^xv>R;1ZpgmDEGkE zblO^5CUZ$ch_=UB<36sM6ori$ka1W^71-1~9%zE9cH%_re)LC;&(J3{R1U&DG_NtK zd>Wt}#`Cn)Q0)jKB!nn*-Dl6xxD^RU03sKcPZeebSex6M21vO-b zEF-szt^rU1L1ibqyHY3^>N%`YY`!O}OE7BRjPV?I#Y0cdBUd+9p^Ud%WE+zaT#Wl* zRBnD?w|dW&vEF*oz0Ijussu&rOWVylvd;H^--N?5(5u*p#A~KUwu<(r z6vfHx@x*P!d8)BS5E@VDx2@$%^|iMA^Q^azY{51b!t;*j>L}Y_ zR7#LA&os;wXt>A;Qp?&ryiJ7e${l5O43XiKY1~m*L5dl~2ulGHyWcHeV4QJ*YT9hg z!nGxT*aQ)`W7t?Uo4bo9sX?(00SXjiAeJcPjN~A&S}jab)PY?}vf9v?!W18j-fc5Q zAbCu@bc`dSu>N@2&Sh-u#?wtt-&Zc!YR-FHD zmQqf?LC=fiKOFe;m{&e_{=0pD`(wy|_nWu!-x~n>4XWJAf5Pu? zFavYTsyC!@3CNXo~A3S}uOm5ZXrKc`q}Q%_*IQlj)40-0NBQp4VECQU{$ zH;I*!LCLRAqPTjoNdaRsyF8etZ=QC>`w#Yc)9AtI1+|w6v=6)botK@6$RfHZTj9Cq zMy7O%J`quxwf6%e_M+5jypLzAsvU_&Dq2NZb6`>B(NLMtRk-OKHtPdvy&+dX6n469 zG9QeI*8DlIaq{W)q3Uo$keMpFlVVrg|5VftP~gCFo*>5{)VEJ-FS@ur8Hq4($v323 z$l#E%

i;t&qGSck2a5OvGqGY-SGh18P83TGtb6O9hy%4(GxVsQ7>qE@hl`j(-Y44)Y(`#TaWr}~v#GI>Y*n+biMia`ENFOf zBf_oCB3eNH_u4Ef^?#Cs&EB}%J)CqJa(~MkXqKtUjnDt@Ka}{-TmR1l!}s;=>h)*x z@VD#z=Ij4p=ivvp{y%RA_3PDMy#AKl8d?j&0GbWWxO}}vOQmkS{yPs51$4XqB{061 zpVwLcHV~lk7G&V&>;K^6TmP^3vfOixUbX&jvF&4DH(vkyI}-nW%l{(?-`khP>#rB_ zy~VbVW4`(NBLT=Q{g3c_pI@$8|KDc+Z{NRN|M$7-sqMwVFAJ z|GM9|KI9=zZS+-uD|*tyt5(PSpIL`#(%#v;9t>D_4-@<_a^*duBd;V*Ee4O z`^*A*d;W7B*uHI<%h&(iBm%(Tw@pg^A@?B{)7K-ehoh`9~{|Dd(p#Qh$zwaNfuD|}!1mAEtH(vjphda0Vf8P+;H>`H``hVLW&R)O8?*9Py zdE7An^MkGCt^9w(g?z)}*IoZN-~Df}{yPu0Z_oeVa6xZa?dtXaxsM$CuO@Fn0dBtk z?@RvITmFB;#e9R}*I)lPrvNu!|E-6&{QnIW^9`z8z5ciI{~LhypQg(7*Z)`C|F`o0 zuZBNYum7$5|En#=Z_v?o*Z<9T|E>K08!YR!yS#e+Z{`1M1M{D-;Pu!4%_+dG{Qpmg R7`H>dg}^NY{^cR?{{z8OAMyYI diff --git a/src/vendormodules/tarjar-2.4.2.tm b/src/vendormodules/tarjar-2.4.2.tm deleted file mode 100644 index c2c8464e6a2f257f32e9e4cc6ed438836126c073..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 118784 zcmeFaX?I)4u{P?jS8L@D+)rBsY?6w=Nt2B@@|C9(zww}DE5|u6#lr;xAc+tJ7!0Cl zhUd56=c%EGy*D^WvYg})iA55-cXxGFb#+yBRdr+5nf$FYY1xmhwTEk4AH3tw=Ela8 zM~^-zHa;liQ~t>>Hy>?0dAPZ;x%J@j2b&uYH_^O!^p4@E?QTBB)IZqRsD1eF|7D|w z{_FnbaNOxlyOY7m%=lw%)*ap)C!qi1hYzdt-+K7u@x~Jn8lOo2tq(RIKiDAs-wRFt zm(%}_(fUr~|ICMj&ZzjVGwJq+#rNaAVZYeg*m$&7eE!py#kYfQe>Cl{72E&kyYF|3 z@u-*`_KO$YVSlnbElvkVgQ8U&&Sod=^>zM5PFb5B-D%uuw0?yT`z@Z&Cnw`+zg_&; z@AQfla_egGQE@sM%=(4$^`ze`j>o+@=CVH+_NT>sIv5=kC-X_aMF`PLQM@=DOpD{e z!Qrgf>!U?~e?BZa)1p)CjmNX;Y|=R?_Q#WAj44lwmHp0i)}P#;9(RVA{r&y<=xETN ze70%>wSd6G!K?mc3KVr_?624xj5?D+f2!m4*A9x=WV}Bu&?&{w(O_15_L3Yca6t6zP%z&ek7oVR3=;e>}tk9Z+Ye z-|(sS4B{2t@$oUbL3>OSm}wWj_CG!8bdNd*{im%@IhVnB^i+_AzKF}obS4-r2FeLG zX_*e75;!}>a4_oc_xrv3MSs)_-`b!>_pmeRbb-rarLkIcMm>Ntnso*vVy<71o-GwW zVH*930zaINF=vw0rrY>Mv7L=Gn+#jOB*VP){e5MQe$nZ@ z>R`qPXhK%utOH>?m};ln?N6rz4lay~{=hGzUS}dKQ8?CT1VUN<^bI zsZeN>>AZW$=LeJiiA-7`1fv(KVj&-#^v7&CAMJOJ2auZ+<#>|b$Hc6a3pl#) z*WKB;H-?xTj9&Gpv%vwluw8s3%uZU5ihKS2{XuttG42(o9ZZw_%7q4a$aV7>#`*q9CGW>XnpdN`gBdp3?DERmopk9$BFhJ=s@&&doZ8b=Ug(|I40 z{1rBsmQd`M!O2O#XUfkM)BIWGZ)bD_vW>y&K;5wT322Z-jTX~>zxa!6GI&|h1u=L; z60A|qQ)abmcFOh52OmFq%u#=p+1$C)aQ5qsN&92SS;|@poDswr1UzRHL|#md&k)`Ql@16g}T=hYZW0_C2rpmh*Ib|p$# zN)PTVjy$Kz6p+ZG7Ync;`XKSfkOV7KN@nwu)@%S}0np5qKPZDB2eHTYM_r6H7!8gG zzsO4p2W6Y?HW&}!o)!E3Q>qr|pxvJK!T$4+^fh&94aH42lwxyjYon%{6UbqT4x1X7 z3SjpJ)K@@%5L0!c?(jZ&WiW#}3gOCa5Nq)S8V2@ypkvYjG%^+9g!t&}L7L7)%1-8B zUM_8EfIjiUx}s8q!?0wT-pSCk{FVKtonne?)?|ur(3+*kniv zBch0p`ALt^35#>12Z$73V+~DhwS=fx(iu*tu>l6s=zs6ec4ycW(0O6j24UEb$RuneG7TJ$x9DEdR#RLWJvaf9m4 z{8%(Y?6R|CX~rjYBQ?_*r+8_E35hNglzQ1dq+uga$RAD>zr`AsUiBWchOYLtm~OIph>AAF zdyormpt`^Y9=Z^ts;g4j?Ceo%<;D)R6U3u_DT*)q6S0V;YKB2U*DYT3( zfQ0@wrK~xBR(zf=KZ@LKs6nFxAi4Q$r}*O^iw!iG^k?(Qs5rm42QrK0A0LK9E@Vj2HoaebRv7PN>~(|Fr9ThdsB|k}eziFUI>~e0%~G3B04ci8eIyPO*sk zGnl1>$y+~%rUV-iJkt*EKf7Oi&Ni)9@e^L)MhcgLbSYvWb_=xR-TerOJe;L{VOcAE ze8iuqf6{L1rtLW1_v29?sxN;PUQXcu^_aQ&%(h_;+nG$DYj6$Dj!(b<0t+7`^bbse zCc-CcwavgL-Odbrbv}m!RXSwrWR)4Mw{=hv9~^c^2ECwgzauY-G;6mHJ5wktwA=SP z*a+|30rPEu7s-Qnw{5KQZUChRZ(LCM!OvY2gn>ir`-dRv3lQn!yoaKh{|#sf?;_c@ z>oP3}Nl}VLSdA#XA-Z(IhCOZwck3=a6cD+)vtz0=0+UWRU2`=p!vsk?&Z4GGt|DiaKDvcyZbHk1p&>dlERW$}AL|e*G`3RlY2lqNHW2YB z?~Ne<>7AzjEIU~b->gq(*g?coOILAJrJm2Rlo`$mSq1JZUt(s=vF*k z+9CVpfK-|fJFqkN`mhL~eu!y_NnpdJMtTOU07{sDuov*10VuXTJ=LZfs(;)yhTOe| z_qi^(HLGuurtAn>8rBi~wZzbTD!M;f%(!cdk?}LVopk>Ejov@8Y-n)!RP;sR=e4yp z**ze2V5r$trSsuR6no(@IJ621!KV3G{5E_dCbTFsq)Nu(f4J0Bc1?GZBM3fAA zXt=dfM=9Z6FhXYy}4!@D7(bD_A2S@?L*-O00_w;KNdd$lwwE z1ky%5VRU(kT__d|G1@=I^r;>JM))FUN=`sAm{1-cLkH`?6Lu`dA`R_~qg% z6MGEK6(x+~p=6is&ACf(p-|fttCf&pp25RP{SGsS5E~cEVu>x&dfkU@h9AqR9S4%_ zEE7r4^t=5D7O!p)x@_C+bm8jA*;L2w_sV6S2dY443b-T0_b`*XiZ*C7K^z>Lin>;e{Er4&+g54??&lTHw+DE6As&d8-vRQ@*N*cUV)sP4i4;*vuiQcO_?Bfk9&|+ltDonH%G%i z{&6WY^<3j&>xdG0!*<)M7|*%1-Tv{bXJ3Bzl{sNECLtV`w#IJr0;@l76BTr<&*7Nf zf3ORdQ?Z;bk7bt=YtqNE%9rqMl&ch&aE}M4qW6||)@~ac`?jWwfpk@+A;Cu2!YSV) z(v+bgRSTdvLqo$x5^*l4pOm$M@~|IZ%TZ*(8Hr^A8wA4DPRRkN}SIcS$RAn>QUfr>PKxl9LoWB3071l&hwSz)vn47{optl4!4d z+HQ;bpr$rhJ8aEi#c~9GV6*Z_IO0lPOjKSr5(Vu9{=fm`{P{(-HNL6zT!$BS<{#C2 zBdYj)L#eq|$QBi}l(piEbmt1w$HoZ8(w&ogIB+4#gaS$?m)T%_6FMxA)5z~K95tNs z-g^i9hj%BkoI?H0VUT_ZJ@A}Ww=Oy}x zC}86KCbNu>D1}58@RtE}B!AO?UPYY>pZkm9AjwH(iVJWL1DX*CP+?4qbhiay$oSW! zA*GV)HbOP1H`rKGLgV)yoKS;VBBvaVH(bB|y2@StRXfwS=-nkc4WW_-W=d*F^HLK^ zC=`Tju=3<<;kWQry5(~Z)c0Y>h;c{ViYl5|FuJL8md$g0d?B6<@qnj}+i%?~9~h;i zB6))%Q}X z5sWY&w&q8*1|L35OVu|hm>w1&#@F<0)Wr%KmzH3{JW+lL!csJg0mhx-T;Z9)?OR5Q z(T|#9v9#TVzwC%+7z0J@FF5hWh@ROgTK0YM;eWM0JZ^p1d-36)+8=(`{_v+Aw^y4s zagG#KOwL+3NS|UiKZnH$ivnirYybz{MHwo-ArezJC_d|>x#1?h7JO~FWP{f@E|^5XeTohM8YLc)Y4@vO4Hyr^C8X~euna? zjy2U4lOX}@4iDLq2cO+rDw+aFwtu=!;)c@p6jnAkOhIn#&|+$--Bj$J932R}Mj4@e zh1{V>`j-sax=Dvg7UvEk(WvujeYo9e{j$^gaC)&*Kkh=Bm)&q|$WLPi|5E3G;Tb$& zf&M0Qu?QWA14eF;c{HXkur=RZI47F~=&}>1aV^*tBn@5y>myJAPMF~l{1gJ4dX&Zh zc{b_iA|fNQbNZrL>oDb+AHXW^;T)ewD>_|74A@BnJa6uDf)Rn^3`j_e*z4(ex5j>m z{h|yX4G0d$&q9RhBEakf`3d^o1b^v{!BO?^WEZkyPP>IG!n+tL=XI;M&)*GQo9vus2re z)vjO>UftmhFd1bd?FA=&Rg}tdu3b65?H)n2UxqWH!!e)Yt%A8Y<#Pra`j*#t(H+8v zzAVuNq0KTBw*ImBXyCt)vrvRxBC>EUVY~?S!7O`CV@3NATZ2NC7RUjX9FA8%L0ESy1d57As8%*R;{gC7zmrpC zbI=L_u88(wzx9kUH12G`c`xO0L4 z(g>eS#aHbyg8anoTl`PaG{|>~Cfn=?ia8^FBWIbkO(Qlkh0CK@v?F?ydHew05}aw= zW8R+(W}III&Os~w$AKgM4geed4}#xmv4=2Y?K6v=J zvgUT%?f6=8u95^R&!*LqusUc@ws5QB4juGG0-lS=gK5R1I0Pj0&U^ujY1M(A8l@ZF z+Gcx=3KQL`$-k9=&>++#*)&4S08Ms5b4&(kas+E$_S8sMRJxNf5N`}s67!MR_Z$?N zz%GM8K`M*_f|P{1&r%u%-Cr0$W+!Me53TZMoPxU1L7l0CD_$bTE5cFV$~^T~cgAj# zz7pZ9v}y_{Awa+^WNsV!qG($n%vZn-m`w z_;d9_i6w~R>%benjw@s1B3=Fv8a*!K282mRQii4@#Pq>OCBP|!oe39Pr}roPhy8(q zQe&hx*ET=7i=#^Y3sWebJ^x0$)d-NW+>1WXT~vto;7*g1NLV&AOTdscAkk{?i;EC& z^gG9lrKcP4bbx>W*?CUoWK|A+C9C0#iAWaz&w*{D=Gkd=3Ge`MchWiCJ=7VT^Qgd4 z+Suz%2i<~g7*1kM#M69?TqfqWaCg)d&wXKpbSmtrn(L$f7|Hy=ktfZrrkv4rkR{mp zSpK)U)xrNi?rh3;k2_nP2l9VD-F)<@c&W=#xGw!iFoNq^z{a8n#bUba%#ObdprbId6w&Jf5qZrFbvxhV z7R`{N{Xrkc+$uP)0pMEz;zS}|%!TP7Z37y*l|F23ZXkY2VA^R{_p_H9#mo8D!;Ot% z3IF4-TR7C*=IrdH9eh2KDd%fLN2(R7$#Te;>EDhK1T9YY*G6+;JEv+&B0=hFAXj}s z`1jZ_{d%WZdii=|V@bu6A{xQONbJFaI!2B~h^`oSXB|D8O2%EZ1nNe2#^@CrYE0+I#@EI&8!M*yTQWvv-7gyA#;A-#s&}dmRf5WN#72P_SIwCT z_)4HnCDy+_MiM2XQNToj&*u#LZOSVP=3b$iNo%0ec>=m)B)H&S)+)I)<4=-_kDb-k zVR>)8P;E9P4x92ru9MCl1sd_|iW8Dw@)O!`3MiBhwsvzwbYxipstn8O(=|vD z&~!P_4Ev!fKe{V6^+(N)s{3U#**2S*6oX?w-!5SWao4Qr$~RJXQz2%WJ8Cm!(`IRZ zZ3f!abQm^YX_ailF#KdY-l2*HCC!jTHzBp8805z7h-N9aL)x%={e!_s9IEDGrF^pF z+O<3Q10^!rZMO{)o5Ea9g`H;MClw5^jx$8V&qAPF7fYIK_Vnq~!VYY3Y^>>bIG@mn zLt&Y=;9A{z^Aj9(6pfAQs8Hwdwz316XN+`CPh-T|dB?7)1L zltp!b22Ttkx)5;Hg`-ui+7^&K?N43-k!rz^N@^4T~ua#0$&SS4Mql(Q-G&YOCNstp#p+m zK6IojqKO?~ZY9CqeZwB&KkAShQ9qdOYU)O?G)lPhp@6}^+d)H^LXr7%cVLjn%oWad zn+IWx4eRtp%w~gj@Ehf??84C9%E)^9knUh`CPb01eBg zMzAH5E<`0F55ykDXNZ#n9C0Fy39cCJk0wd4-A~Ax=JSG2?2MCFbB%kk}L(2LX<^MeabF<_?@w%IA);ti+8{r&r6Zx zNf9P@(Bm4HN$JSM_(CA_~bA_}wT`-kx<3@v$2bk{1aJ#;h=E|+p!+ll3)$z9qbGsXv}wxhkcSvtb&Da_@r`>m%^I{opjF7S#CBM zBtO1`&s#P`3>gl5+&)JY0YArKC;Wu-Dg<)K0cbMQdi>*z7$=j81k`sq5-}G%_4@s) zd}(6^{3>!es_Y$bD)V3!Vfedt6vs!UW8OtD`~k`F^F6ptkds6__(>`{Y`uoEP3N;# zE7-EXP?iBH^bE)LwviA_j#K}AMWHH@5qWd>aTxeFhET6zvc9oH)JaB?mQ2u`VFq89 zv)qwgjdO4bsT5Y@j2li&MV@fQyCGxgpgrSXp(7XGuSPqQ1GWQkrXqJtt!_GHEoH5@zV%Y2_#997Qi?Yq`YWT{g<2>K>1qPNO@3$n+beX zQaMM-)>6i2OTH~H1{JhEv`8G;buDoj`m7~XD-c=ig1?0zTj6tYm-SzBE!Z$EH7P_n z(j;f@k3MzEqvbHba+E;calIr`_H21C(9|;2MbpP^3w9TDR?(P>-}B={?Dwk7SNu_Z z7ImDtV-m3O$M^k_i8ipvfn^?{d;I|FAbOhUhwJ2V1TQjI1@xFp2qTI%P$r8LvloND zB_RgqSL_7hSALT+Ni7rs&=KXN&m}z~+NLLn-lDBRIcKzHB@Ad-JjXMBn4=sIaSu?K z%Vobp(+VMVQJa7rf<2&|6qT`CAfcNbPvJ2*VK6r#xvHzE!jP-3YF%tY6r<5GzzVtM zoIw8ai?6gE&alau}WJWd#XLq3lvcvrm69@8zw%sS#Z zY+|BCvNn`{(k+`O@g+rbNrXi07SjrkDmyj=tvS#+G~b>bbI%S6F1=8;YdbtD#xt)$ zi!Pf=!*f+_=T?0D+nWj(TWWnH*yb=ciK=IikL36N=r(SqV6q*;VMgVcM8;$74z-{iJc zLV1!qdSfuV7c#Js%jjw51ET5(yti@REIqAA$OXM3H*`2h0E^VXfm@+8O2I@>iSLM| z0@Iw)WYZCTa-3HgAw;u^F1eVZi>D-+g4q0Mli(~@%V4RijOIfwu*^r7vSJ<9la%`f z2r3~YQj}BOgJ2A>Y@+=)(6ZrX=g3nqKf`XYyNi^~TsToaEScJt7$i%H14icXbAOqdxMa&i zi}R+`=;$^GV%QC*z-IFHmr}sy6lFE}g5+{|l}~K*!~MK9g3#9J1c3T)@pbYBim?U1 zB)h>vmw+}V$>*k51F(897RtIwhy_Z%p zqnyznSbdY(-x8CNgW=p(<6O&6lh|g~9AZzXeCnXi9?v9#;RZKi+2`2=x1`vr=EhP2QzE2~{tmCI%gj&Q*)R+2-#8 zCqjGRU@vb1!omIiku(tou0f=HmBB3x=V_>3yR&=NhAxMSklhX92}(>fJz;dF)&O zs>LGe1~AB!F)#35WDX9P;t~!ES3K$&2ERviujMSQGzra6{3DK!vRenk@gB3IS&(MP zM2QysO^HHgh(X#oy!qEg&pky&Mhl^`X_g`M0)%Ao3@ic+Fe;W?sQLiTjy2`@7C-rZ zXWitJsYN8;B^MlbUKjZi<`aHgGt=}JKU~ebF3DDXQU7JWP*{+_O>{NrQ5Q>)nGv z3p@V$tUFtu4NlfS*;qS-+Xb@FsyM@(O4X*)-skWly5Q9=PajeJNs5+cN0Bv1bdz0t zo^UrmjY_0Vv&^SeM2RF*SIkm!@@e7e<@a~~VBzvhJnueUD99UWS0&|#)8!{^!Z4O> z?v*vjHzL!Bw&QAOv80F98lG;xRr%^0Aam#C$czPc;h#%|QXD5^PQmbWHahiq^ZLEg1;Wg8neViH6%VpJ|=; z)TUZ4BVoA;#3i!KImmxHzWo)qY09JI`ewwkc?#KGa==*9V`Pyo>uNc!y)G`YW>w9i)CLXzhl^wZu zN~^&TaGMfNNkx55MJJ1d3nGeS$=ssEbAocO9~CWjHfR)Px95HOIs2`>dQDqbx!lk# zN(okn7F*8)VxDS6*1$z9{XW<~qnko9I+AN)%pDM#vfH<|hmmAI1mzcV0yy>SAi>$1Y~djc#xObc7}7TCc|;$ z{)~{61EeG3)1W3;4LAQ{LyHpVB)nyfbHPHO^c;~dC(ak4Eh>Wmcz45Oc*1mw^DlX4 z3r$jHeE?)=s|aRE7zK(fPF2BtrF5S}KRx#_)+B&6)Y$+~jMTH^Q5Ww?a3TUeJcN!4 zK@dX%zOtqJ`RQWO&MFnmZDwlnDxPJf=zvmCJPS8jAY4O`oxMlQBsJot7&S6r^pY8$ zOq{@4@ntp{o_6{k+V8;`Yi4sk5iycq!WDt5W+@=UTevaQ|LNNvM1D()tQ14OGztwOCn85X0$ zUflCjL+OiBqfy^5!gp26G^pyTwiT&y)eGgIr>okRbdRf=o0}paCA2p&7Z*6iqE)9W zvzstulmDuStjKs@n~9+DuQVtc>ueJ%ZaK2wGRvegDqSiZGW{~Ft-u(GujGNSI78yKExrWP%UirX1aR$fg;rdhIy6TPdw~rv6eqQ>EE<#;w>vmkmKSwPFfCqv#vv~E z?F#_C)A~O-B6ni>oamCyssPmuP6TFCcDZKA%p@5bCq;l%*C#vWg>ZN-kb9m&aBzJ^ zBQIvNa6)N4phdHA?T0{;`pykxtMF;O0JJ;@;W|9-v!=#iDp7Ad0y#if=%HNHG&;jg zXQQ!{I$03<8OOEyg9`-YGU?4+72ck(`t$9tM-> zNRvs0vq3}5Y4SEiTYBVIwR*x9AYO~Kb}fzw1vtVUT1A~UeAQT&v!vQgHi}X z=tDQ!OEWxJVON$PMaD2SMCfO%7*HPyWDoJjw}q0}o5E$u#X5 zhfC(NR=hy!2y8Vu{#EQFHNb@AeVhXyk0HC9+GH#!9+R`R#Jnt*7#1RDi2vcw`F!!0 zOq7^sYkn@|H* z6u;Ix)9hj`Qxx;y69R#gLF{2wb-7HTakxPu}t=G^41jd+b|46|RaF&DUAd zpWYAcJ%h~$c9bRqI}=HJ;=>e2*=14)#Iv{&>0q^bIC6$TX@@;2?vkjWpO8W#B2k-V zYnA85yqG9}8uwnz0VOO9TzRf=s)EJU2$LHujTn2hTxpRb^ZR&=Rs315-dm6I!daV8#cs>{tg{CdJu@RT@+X93$DNyMz5*vP&~X zA9xqHz%t?o7gyrn03psB=$d43i)taZujp7oC0)1^l{FUG4vD(RBTe}ZLF!B6qs;$f zhbPD-=Pk*C5zLk|Z!ZU_f%tyZ;1OpFzcuj8opPb0MCRhlLbzrLhA?4EhVqV9#Vr+F z@fm!?v~DE~Pl-K5<2>{tlp#a$9a9E0Aj1-wTu%)1($!X3?IEs^p1~y#Iuj1S(JQA{ zB)EwiMh0s#^8XZT*a?0be?b6B*?tig1tu;C&v(_mQ_`NWIXf=$Q7@aV0wQrdR}ZEg zVI2J>jv}JkV(dk+TVN3QzHGNKk)NF(P&16b=G=Nw98dErAc+CZX-7$;KvThsZ1hO` zL5>O-k|Dabl%Q50>P6aEb+CD$JV?A)dp+wQQvv?r>xqPYs!9a4QKz$D+WE+*#jzt& z2-N;?KE-8watTp3*t^71=vc+HEji0Mmxm1`{TE$Hq~-)T5lxM<%J0nN>ai{(?xfxi z4j$eS%%-$xfYH+luJiDeD$&|;O_NkQJHb6CGgN~V#SA58_pttsU@8h((6tmTyD#Ss5szMQ5HMs4RsgE)t<8EK_@}f;r z?G-IjDAzY^pPbsYFAcmLmWu$IsvEvzCfjjlSk|@GEjeo@^Y;x)B0_|HoLx}vOpGh# zd3`_7lJ8Pv@C{Zu7ey>7>4$tUJn^N-qKuWkqRglWu^T}4E+9%Ek?tz+G!|kh41axO z=xDkaKq*i8vak6D?@h5}`!l)*>qKtDYQ7eyQykVXURu}{ zm!pYcBVvFBVWSMrLourJ+m&~oLWFW$yohLKSWhZY45Qdcb#*U8h!8IPkP#@AZXj%7 z7T~6VL&&f3oHuCp`zIOkbwjZ#hM3sO{%|~=tgtrr%4%`1*nG6Hx?236KjDTW1NbLF zbNIf(+-zJ$fKK%(?)SpB7esSq%8~Z$rb2Um$;x!th!md@q&S!n`YvPHU*Ya{$$|<8h|wM{c^xg} zY@u0Pwu>w6X_mV6v%o6gD#@)U)C|3@>7>D>K?WgeK$PBhU^fYI+>0hVtHv<4Ceuk5 z6)of^ic_g2Dy|64l>m0R<9^qH9|`Ej@3``qy-~8do{VH!)#O=_>D}5Z9IDP-sZ;!R z)N2QipFr4P8B2PqRe`{*_edJ)ia+Zd3@ib_;Sdokst&v2CMSI}r?uuaH*4{YpO^Hc7fy@sRjC1 z{16S7TYTa?1J2=;q#{kMlO4 zE}`JPbJ=rM0Wv-3)kPqC$UU%>{Fi)(IY`7ua4h(0R(`@ssNA?4?BnFsyt`ZyM3-=^ zrWH`|#&yg%Mh}@KBg?!XwXRYCPr`^pYMhT%QExm>anUP9=OtV1n3-r7uJp(}VH;KWTFA2+=v zE}T+9GB)R@4)gq8vCrT5X|QMP-3!8Se9GcWZf&k+b*kij{Ih7JMjXmWF2s>q9S z=wV~=n2!KJ;pWZtflh(-(%CnDrn3cZ%SzcbXjDg?i z8~qw9`Wx;8L3&^A_RSYtTt!u}9VWjc(~%c(<{AWx1Qa?~+1a5mL~NnKNTJOoPEENg zH26DRdNI>e^M5V$#~mK^`w}z z8CGT|Kpr8+Gcu2PB@)zyLD(7!Z`#^VLnER?YpA|(ykWmZvM`p(Vbxs~J@r<5J}G93 zg+a$@ZQgH05Ah=0We(wNVJ&?B!s38?gYK*X6}!wVXg5;QRUZxMWDsbpLL-gK)O!lH zXMHHJoPCRz5g=)&sdMGnap&it{N&{p_)Udm{F0vv@{*1N4cPD^`%6THg0R8`s7D@H zd)1*yZf&_6maAJPTtdVCJ`R?wFKEFipTFvVYS-&H9V7_;;ourGAZs5chqVs_XjnlA zA8VdNq+GO`=isx8^{_sWrB(B4x*7V2!9Bpq;38zCVoJ$v$!5o1rqI(9t;fFe5ecev zv@EyWyTpz|r^iScmb78by+tqDA5(|W%XHkrjp{Y;qcAQ_8>x)Y>G7r?rrHi+vCohj zz+59(nR3-~xcODN&>Y=9JO0c<{7qhq+YH7PN^{0tK)%e#!PhSl96FaoII?}tO<{0z zXgT>A!ay%pzMy$4N7e!v{Ds{X8UTv}gw7M`bj8f4M0sQ`IB1PN2|x*?d4ENKg|f?A0L352zH z0Amk-(L&O-Ks1O?ZhtWz1Wj1hA|x&wCP3N<@e%e0-VL-?JcEC8FrChkm?U9k%aqIryodM{YR4TeCwE#+roHhy0! zDamu#!?n4h20;7cO;nMm$XD0VTAS$Ojdj)Ju!m6m3I74f??6XQmE(MWFW)vr`14tF z=2bE#e8j#XT2P#Z5^ItB)gHp%!Otjk==3-dG>zVEzei zd{I$=EOrSunf-=5jVT0>>I2Y$>s8?lv^oV_yS($-HuA&{G85FM0UN zttSZaA=Z~Hh~#&byN%-i6upbg|goqD{!Rus?nC4JNGK<$9=2Xc{wGOc){ zWh0WJ(aG!FZ0^$_lTb-b*~UOH40-IwR}`8TED(nOBR2-JrkC`vr}?2H+*uEB&EYLO zC*Q_l3Gnd^JgT@ACAvb%jwo^!m#k2(h$ggT#~EefCk1Vn~K8fi{xxu4Ab)bzt3x(2lHSu=KB)GMve z;}+qxVlT2R+POMXi*qTGb`MK1*mPHCc3*ZBw{$Q4B(eCR|9oeEJDZWLXpVG*UO#;* zvuWDgn(`L|_Xfi>H=8RucrS`I6g%Vr(xJgB(jz)8{}nvmdSAeA=R+0-vw8+`8Ed^$rbu#H z-T_@<``V=wqRNQRg`vz$n;eCGN;h^t|FUDX5-CIDTGI+~EE)s%w&z*DGN}?N&>Poo z8blG26!EX^3yvHKHC5M-TuX`L7OkhT`Gzc`G>~c=x*b1?12iUbPuRB#mM_Ck0&S#%^CBz#@#9F1gd3pnQ;i* zQp;c;rn(V@(8C0i_%rUc(oUN}wbV@+?u%v^3*RPdl+6Ve0h_0J-q7t#w(w6wlEq6= z1^$q*<36(B@ogG19eIWdIC}rk5IammhD`lLl&b6C83oz9tl_M#g(|B}43`-g4hnxt zJWvb=ih@YqqAivQDn+ZFtUc^#jvIN<>&|I7iRY(zOT!cp9<|AJbgg?fD5D z4*fD__1kb8u%I8_=orWEI7x1?5~iat($lBuOj(BCSkx47&cHkgc4saN#iIm>YRh!> zt7YJaSk2f0qW3n6&C>0c%wf@R=FHS64ei@Y>})eu16R(z1O&yw+YE1Rvve|1XnXgH z3JM%Tuiu7ZeEMevYOEBw`jufuJRT}*wMvc zl!^A$ktB)Q5{=1b1vTU{BQs|h+q=|VmPRQP3$sdEy=qTOOV}cvv-wqIX=!D`WEJbN z^aMU+*1cLS;svmpaQ@5SWYvPN<7l8)7i~8fQs0t4kSd^lRiyee_67bveqnfom(8Q5 z^;QCUb0vg^PX;5X9Wpm`h28Ex?+3-p$Q&4->P;OK_qaP;t53_daYhMvY$<Oq7Yq5tzC1QX-794-dqA?_cpz>|J=z$%2wy=*U|qdXDOP@Ie2RQRod1uopy zI$^gD|BkN~8o{80vyeDvEyLP3uhHJ!oEaITL)SOlv zB2j|;HfersQfrs4?GR^}iZEiFpzZQF29{mrGUld_&(eDWH2X!E=X8Kt6|Q;7VNTew zOPz*WH<(036AdR8zoSiE|LAeu@nnr>vjvi^CAfp>s1|w|= z-vNJ|kYpC8HNO;xi}K^%@__ zrcKF?T@7_HWN4Cvg@g#IeuBCD6p2c9H=kP#C4rWRfVh!{V?LbQpzKo#%V|5ZSi-cW zmI0*7=716AOu8jCK?4U0L_-{PX*Sm#Lq@BNq%2nw1lJ+}!-O64a*!RMgqW8vO6x96 z7qh!teA(acP}SrWao)|w+GY{;BXj!2HIK)kkIF+iJuJ2waqnX9&E6+Zrp^??NP}v$aL9Fo_&59Y7tX zIV4K^{;(6PCvd7N@5CB2A5ENyEj~U>&4@Reqk!xc18y=;dC}x0<|=mpq!Z@U;-mw5 z_*%5Pr7kSy0e@JkXuBbvy_N7KJ2CT%zg{)*2TI)r20H2YaPmAsN&bw|-pgG>tr$-k za@iv6PT$ai)op<8KufWM!HR1xThOd0yoLwD8UsqJRFIavw`96)ANEc$?Qlx|zKak0twHg3sg5 z9xaFX3xdT=aQ+m2q0{EXpYN-!TW*&rcKoU4=^!fKIzl zkqy6yVcT3IU=pwK2^&GDwd&3iN^NK^aQR9t5P4I@Fa6+upTkPWg@?kNsMCuY%&c_Y z$ut58ppwl<1d&*8$=k|j3F_IeIuzn>Zr$m4!qzwmx!WX5rJ~Bt9(r&o;-JdPnCJ!i1z7}*eypyEO4=uAB-xzU+67W z$SACTDpeZrG#3^+0qOP9ZoeA!@GjpDlO#mqwZDt#!vmx@2AhChdOa%m@c6^jKG`YG z*Y25f?d9~IITP?3+O6F~@|QUSNF1uMk^US^sQ&h2Rfox@#F2C?6V?W0Wg%)q{(B`7 zpKF1%=jP>0EVc?kwAYF_jDzvF#onx^&+gL7gwu#`}aPD8d?l9~zV~R3Q#?H%2EbbbyP0k|=5!di-)K0rDb@Pf6Mh!!C z&(tK+fys*3WRJ^eRVGiu7}4h(NW~~;DKSmR%CFM*EG}vZCdN^o3w>i>(FOe_X6m>p z!D?7AXjwK+FUF(>Ev+sEIK`4r$|vfay=2r=iy~SP_O;JHu}~ak*(sbuW^>7@nnEJb zC%v-QmxL>*Z_7-&lIsu2B+ws>k~)FsnOw8Atqw>>7k^&9jB||1%2GVYwp!i;*_8nT2a675qufLo*+$^lcE>S@>L+3V!mF&L^KiJ9Y$6#XkHp{47V zZFVk&dZ~fnnEH<)Z660Xa9Uts9IH<2o8ntl8hz%q+cU+3b($MYeqO%$NsLSIp4^uj zO{HKchaG;|$>qk4jb+yP0OXA`N+ifq;p!#5G@63 zRw$(yh(vA-)}lT_;1E{LOs;5zXO2e}9HEc-Vmn;L({bw z4@Q&cJAn}FMhT0Hj96z9NyFxIPOPeZSXBsEiBSMVvobfrQ02Yi!~G9KuNV0MCBo(Q z;`JVHo|6+oen1ZiSvk615JYK?7C>zm`0=#6FN3T!k5=RQOni3~ z6UfbjBiaZkr?MKSW?Xmj3a8_8=gAAiIMb=ocbhvf22IFM9&e2#Lgj?a)lYam6pT1nh)wGidq@q$Z zVqAr&{#&wiA+KO!cN26XHN3i8ocmYUkT51x5I5nHg_Z;iVsUXJh6X-5*oCel2xQaH zk4xaV0a^)U_zS&}E@$6dh6t?HsGZONnq0bJ>HyQ3w1j8}ektHJ0c2=*mXc!J5+VS& z7Y+)-r#Ob}99%qQ#d@YGpuNwLukgeEWoCmBRk6Sod}b=V$(-g8Zq>`46NRM~RC_`m zHoH`U@wZxdaf*6vfSnXPr??EP3fNZwMPVnp@HsB73DjQVH8%Pe2VA-+Bl0q2)h@9H z1?T)&t_ZjAhGiuJEBT{n7ydbbMMRRLP&a*3TpFzX6+BhYGUXl-XshlBVLHF+t`?_Z zN#_y!ixy4Is!@^rg*sN?=7yGIi|zbQ_l!@fM}@Wuf)VvQu2VT?|tg@P%71Aiup1Rx{_<8Po0mXI{m_-)O> zr5(`=6<8hD zied}2)qqzxmr-H?jeu2gwMYrjaMc^CaEnu$<5D(qbwI?$!o;kR}yOK@AZ+tr?lED4g1_+JTh_s#7szgEz z^3FxXf#IZ8Oi)EKprM3BqK!zNVBI@Fq61>QZ zgAphW*r-LIrU+*T@60dab|80pn4ZR4u~&2YrDqXA+)u}duu=Y-rq}WKRdia{g}{-j zI*C9FAKei-Jsi(*v*uw3a*~K;)F3fIQR`a{(_q1?psPk^a>Z89LW$L zoqfcEo4Dgu6eczbY=i1-Sq9WCO5T|10I$C+x@F1-wRiB|4EOZ{d9fh$3Kx{ityL9V zDm7vo5hkRPgccIj2+bpJVqv?4Bin$wRt+Z*PZq5Z52IQ*6GF+m!#M*-(FMMC-j@wp zuR!D&;>IH*iO06xj@;qp`wr_?Ga01pAe5*FFV`S!iJs%kOyZImIiwDS z{`Qb)tk)EZ?}ea#Bv&`_Hwn1F^}={VQ%jZlkOP1xt~rDZ-D!OF{g=MY+ccRARI7Nq z3L#$1k_sU@pt(w%_##Gw$2#5uMMbsUe(}|J&v!fX*%;B(IO=P*+u;w5c1ym{qkUDl zIZ`kceW={qTD<~FhYSO7w0!(O0OxgZ1$DGx3V<9=E<4GwsMMtkta6c!PoWA38kS=e zQmMi@txGxlg4$x7W8LVw2iuSju<2QWr*NN5xOpJ@6r-W(eP}r%rIli=qO;bW4?nfi z`&K`;9@n;Is60;xab!nUE>LmJ3ze=XD2zD1P$SB6Sf(wKrN=iz7#n zq}lNE)39*u(04f=mqYwIzWhX(Q7GG#r>e5@vYmq8LD`0s3Kes0dCNv-zII>np2m^o zf&}|N!wqvn^tghZlO~}P$LaBzeYJC^0oSa2@bi*&p5wCyj~L40V{-3h;$q5dRM`Dc z4wi6Zw)iSl;uA&c3IHhV(TtMoQRn(tXV(?1^UDldP}6$-*KWv{+%*eOPHeKHn_$yJ zQqIe%kh*LEfFw5MB+xuO8;xM2AcLk8V)UiU7*+PIH9yuf^ESMVSFx+kM}b>=G(Ng0 zQqD^xgNd4+JFVjs-wvK+dqw-+9F`e(5Ga+2juASAY_l8gxsTa)&!+({sE*>MPdq6$ zzub>fg+S9C$1vN^^3YQ<47t-U=gjS5av~ z3Tw=cv!GyKFUfWpHaK$Bbi{aKq?kf%pimWl!$#>M#5NcoBIx7#9C7losmYp)by~^R z>2#eHg?2>^o2<=VTW)%`1CVwOhs<^H@RxR-O)81f$MmGzq$I3t&X}5BTHi%dBOyfG z3GRl)W^N~2qF~bK(~^0!@i+`|jX?i&T7q6MI=t)zOu*4n(8Lq}+|gZ|FXg`W+}mSl z71maHe#z$eg)%QfDoc7BEN*ImM#E@YxlZ^7E}q4&0M<)39L7(Sp?$inu`8NK1Qz1i&NnIJAt)&lLXnAdJ0kzN zqA0mH(PJMZf}Do>v5L^n%L(vp&{|fBj5I_Fy1oao7mHZPC>G&TCzbF@wN{1n%HH{3 zQb|C!pQtZt8%!KB2vp(OP>pA;%7;NClwN$8`v zUk|n&Nt76Oy5IOJCc;qrmU)4!CSm;}bvbl*fec)45pc|`FDqGrqjsA?7sn`EFE7;j^&*t zx%knZDW|P!CrP$y=w9Cm#+sQQs9eS(0PsNq5@{>3QpcTxL06!yN!n>ufurADWi}CU z>D$tjrBHBs1<0U$-@9){1byxfswl$Tq_Tq zFI3A(6ah#miFy^9RBwdv;73Khg%HUfJKOQCb9fKfPsJJ{wcQuur63gFK@;VB{76$- z3wG@`)`=~{N?W#Xn79qv0}8xQ`w4FqE97QXJYdG*oI~zPg+9V13oYTb96F&`0ncN3 zq&dZrP^1zE;YVPa=(c4=d?ILE%?9Nf`V}nbYx=Ki3KHED+sc^YCyn3n{ivk!^^4G5 z1+jb_vY|Dgk-8<~g}w~QhvnLy-z_FkpOel=)=4RdbBKnWZ3IX~BA zXKido^kr-fP;zMbW^QhJU$v;?!v>1l4fkk2V4=cU1a7H{E}{Xfp}Z2v;e9vAaNsPS zQE9%2uu)Avtxpk8L^bSbr4zy5Lh{r|H$)0M0RHpZ#NrFrAsE};kZ9hut;>3OR7*I% zSx-DZiK`(0OTSOHmAluFGz}zg;U)!zF|Kuwji&-(2N>o$0gu42Vpz1uN9qvVW@8|X z7#rZ7pt&bT8TZjR2=Q*n;Y><#==#Jw9g)K3E)4JGp~wD`rm6*-Uo#&Pjk)qsLK>Bch@k)l3|YH~k#QChvJZ=!rI%>b0%gIyh#CMi zrBI`mnU3ZDv!e<^$xowrHbi`TOYjc$UoJzV{mOs|*@Q7Tv@LqU-0Xt=z#4mU@)^l; z9b`SvPG`~yC&-KRwLouWnNkTQC7BpG;dww=220ipPhMK?&&!z-egwsd$H`TO(3gd8 zbxa9PI6_c&)QQd4crQEdj&`~$pK}L#u^b!AzlrTd_B;ge`_57%nBgn;Xe@QCz%1 z-;t!=bNEL4HPG2L?z=ihlzkK|@}=2G*w*!hu&mHhUWf@sq|RMG@)An}2}orbk(mcp zhoCJSv2LCPI&n4DmWP}kPK5$S>*_2*MEZWQlGr!+BKa$+Az3TVWLA=Fm3xLRaWn0M z)|nL3K5}2veodcA!9lJGeN9~rdM!C4ULpupAL1XN=IQ1S^{LM&JDM$Uo0Y8JWF@m>FWjtqQ&QcT4`l+~@d>UI zVp3n&Nm4%+g6j7nV2GOwUm1RWfyEJ~cOk!F^yo5j)!ym|nQW4)pb(n6gy4X5X^{%n z1lPsuZ{8ok2yy=6-tRW*rKCPLV(9k?UmLC4>zzqlaV zbQoV_fm)Yz83T4bHWO}2;(sk_g3tm2I`bhgs}vQ&uzor3)h>eKRLPWIQ=1luyW&>j zl2KWE+bl^069KM%ly$S{V;(oBl#KSG%myxI2p}Z)6c$`ce8`ik99}TX#xHq-;&m{C zcN`-G`i-%|m#>Q%wynd?l4j^{wIo_w)*}mcX^b=Z+JZ0O#arQqE%4|<%=LNH&>H#Rn(MNe0xBwsPUwK7RE3)5~EknP8>o_+b?2cJ>P2g?w)zKw3Y?w8#X32Iw^=+IcC`5s ztEc8YOL_5ev8){~v;LgLw8P)1sWtQ_A=rxx_{>p93?cG4Wmdwn2fz*r*2ePNTa z^3P`lzGWt*%9drtE|OBD*6%Xn?*^mp0InP_hwRuEu{E9bQ~G&v=qj-X)Q z8Z#2kLIC_doloyxWe!9hiz{(OGRIHE7r!_ipbj{Y?GHXHUT*)_`u8tOWlp%f><0C1 zs3u5#m?3z6CvKnwUwEz*(ALzquqJTqb(Sd$K4bO`z@ZND2zIi4@dft!? zW3keeD6xq+_*WQgy&xTcUL%S6%wWD8UR@RoU{yFP zFy@uT5$O)!CE1Ltm$CJipr>xQBxZpJ5I1}~vT5U+5$^wGIi4XgWmz;LrA}~=Da)S3 zF`ohw!7v)oW)UOYcsQt4GPN^}QCTm~>(uBd@dXotLU~JN<$XRoK zz!!@OzQePmPdA1|I$RH{5bBAov6Emj0Xsx^$@0ry5JssB>w_G40SCaB@E}XFDY;hG zA3bDt9E2>8{^->TGcod__8z~RJlBCFGHFpaSM-9%*XrcUZ+^TKn(v;o#WlM6@!3y* z+Wq>6Z@>Ji)S>J&$DJ;ckjB$^)L5Ez`g$^2q84n^$lz7A{=j^mc=n6!I&qCQw!{E zxF3h*qcla)-U+=R;7;@$=6zxX$-En^gb3AZ3atfU2}k|Os6X@=7=#KB_PX(}P|-=k z;k^66{REqSV+a=n`U;}Ka6T4M3`BvO9r}NRnd&%E~+xrFuC(#2RcOmk{FgdvzbRKNoOaH$2 z@#95(4qku!xWsN865sAVeprHo9G_1Q3C_Kr2EX7gCtPdzFf~coNu&6w-!DAf;?vEi z1<)(|9UMtw&IQY#&Hdxk%|PSBIOF)+$w@bv>C$tC>Z43UL?~bM9#8o6qz;8koyqaS z*YK;BgkAEpn9Do6sdYKdh7GeMG$r?10n?4(hAf$a(jJUElLEe5y7L0u!FU}_?k z2Z>d*ToB~eDIP!E8|cQum-)fHwus4P!~oKvJ2-b2VGZ6wN^GZiu!Z)v>ty2!VmJo* zR_I)&*qfm4T0BaqBgW!y9i-^T)z4PmU0LSw*-gQ_4pk#8hbOIh9W=6f4o~Je5edsp zI5o_Ri!h4vH<=dSxz5zsE>180HlFTp)?i)ciCamN1rXn{INU|A(GpFPAe++HE)q;} zD+$5iCw7)>2&O(RHP879FHQl2USz)VlGf%cM*6+3+J<~wTz|+RpvWEHXF|Uuaag*( z`m7sj$01NDDt^%K*5KOUNlgzaidg5D>2?ZJjfQuhyo)8SVZpe@9vL?9E4fz515wSv zw;n8ZMiw|FgF|j{(4s3kBBH58EMKWCA}Is@7SVhoZLBc<`G2o$|95NW_p2@Y*+fbL zUT8hFt@LDG)d-;r3c2GtwymbbEEt0~L7)HkBXpW+o8#$!YSqfsVha^EUgy%zSY5_I z8LQIM%NQuQGAkNM_R0HBRv!bG<;PYv{h_g#8?mYY3K#RBjaCdJ$SK4jNSV80bUCE~~0fFms-+PTkDPphZC^zVT@N zvD#vfi~aco{owFdOtY=Ezb1AMp(O=h!FepFw{ZdR5fr^RpqJc<#ZlnNVZGe7VjW$J zTZX?peweFyjpA!DFIjj5bvzivj%j5K7&NWYo28k-J%q~{QN_hOS%x@8Z4|gq?iakf zi5>F>736UBVUZ*03|YeWOT9=56fbmiD*Yij4Zd(3s(9M57;kIEGoW0Y)Cd49^&$nL zV1wK*jt3{x`%=5On4V4HWfmv1XvLDn3RU&ed>&sBh)0dOIk>i&ku~TFzkxW00 z42Uk^S%o)YpGApyp5VIy6}}QUp3tz*3+_tKUi|Ro5AB5CNK5pHGDmPetPCD}42D)c z8*y)IYpdK|N?oYK5W~XHPe;Gh&e5u3!W!;>zyYun)R|#14a_=|MIKPcmMRmPcL@A`^&d4zIpcJ7k{d}d%*=YI6Hm0~uUjY@SJRio zU&kGv-S7j~mqTYVULD|c?6GhqPN$IZ#WOcKO#mb2OPhVvfWu2Hsz7Al#2tfud|V<% zeZQsE%trql=+{;JuS|e?dx03Xt-mFyvR2;ZbA4sYi19xAC=fG`!m&%TFqD4v+L_R3Douy zlyB(^Pf!@Z4~iwwe!K@Y8@dNX?y{Q)I0Uw|cx{#fsqLNAc;Y5*t3!y`1=QJ*;0nm9%uxM zrtkA=9a){QlAm{QC-SiP34YA|eHdwUg)jd_YB6=BV78njiJyu*_8m(44ExK);cRx& zUSB^Q91WN+fMkL7O>8Njpr*jD@DWyP6x&=EyOHceiQU^z|j)&}O z-648L-vSgN)JPa0lo9o`m(fJ3{6#ElDcDYrJE!idT_{OBb`JK2O^^`ER3xH9V=<0# z0pOI8dg^n4e1IiA=}4_qC_Lg(i05l5CeH(AY^KaBmXWx+IZr{$d48{G2&uFpuNcr` zLls)+W2jF$#8EPIb3AlOCG*Agq;hu6N!$gut`L)2XAyGEQpKnn3Np|b;#;f`8vM+hTDv!IO$=BpK-YwIlq3b^z zf_<5Z`wAsDnQ~8rlE;m~W$xLuh0SqoXVE#p0WNMo!xrSDw%gxvK@|B5*qwM<)baj4f!&r0 z#iZVjzVGG~5=&VdbO|KUeT?%(+KRqs_oZSw%q0L$*n{+KfxWwFpmd*uYp5 zR|7_P`1N{lJU`~S{Nsmz)^_3~mQJ~@fGo_k__TQZ=+UE3!saE*h#OeHe}p@6`DZ3j zvghVfwXRyBE9C-RYmNQk9FdO!aeBG0QVV0~B!!wwO?j4J(9ll;ro1Us41i$S&34E8 zyTqhxn%Iv()0eLwZM=N_aPQ^ojYs&82e|CUIDoyf0DOGe9K_j|zsKYNrumA?T=Uac za6L7%7gpTQoPOI9WMAy8MhN?(1D5I)fWkb1b0RA5Qcy%_F+)z2Nd>!Ln8LE!1s&4J zWC3(jaB8_VB3!XaQ^Of|QQFYi47DftH!80kjrLfHf`4%cjKD8fivjY43ci@EY`=`|5jb2!1B^;`bQ0AX!qWp3r)b^1* zxsl73rV-s0_9^$Tgn>`xoQrQzY(T+p4vJ4p{o-3hm?PfT^?%}@Z*=DfXBf?Rk00(F zN;V)i;D?R)&`PDpjs_v;nNAFS2aE8R)=!4`kv;*~d)_2pL)4r4wYbY?RMiPtO0NYGzw zdFv8mpSrmiFn9l0Jb3WSvtSiphHzOw1vV;ADb0EuyODV>Vl6~xLzcsYLL!(7 zY@jXDj4dnMCcoq-?INkiz(=}e=D)EyFJ)NFN983T*fgZM^cDOGW$~M%1PQqTiE&?c zk(KiA?;md27D(W3Ci-5l7!aw@3*$Dxt%LnD)ppo+4cBo7j1crQS1R>OnQ(_4fz6Q^?Xikzjwvm5R~!I3kLzxUxKS@)Y`%-hJa z)2cml*MJM8kBBk3%i`q+ztzVLam7PxYwh9M)_UWYcM8tt#>V4^4?ie2K2QeopIe)o z_DxZ2ZajRl@nCD~!RF%+HaDI;Msu`(44S~;GS+*T&P|8-=SZLZ-JSpUrhwnJ zeDl-H@zqc7WB_!sX#HLlK791S=H{b^k8juiyF&k^ z{cLS)J^Gz&zAcytav5DQ?!wS6v`h!e5fmGUGvQTRh+7J!t#R1&$?xv`?#|Z6=0

;-T0W@ZazZw@6Lp8;QRll z720mDZLU3#Z~U-9PFCoIhxZE^YJLj7?HGIzWd zN_3*Ej!zR_IYPgcqTS}$Zp&3gh^3PlFrE-BEB07upC#esKFScK#46`WVa1LGWbG>kCse2avHs-IqpJQFgg_ExG_nD>F@6Rr@Hmp1+77BvOhAsblNU(A^7j^TtVyG$NyRw zsFnXz+TP(bZY=*dA3UJ_e=GmrArTgIRZIU$b*Tj}U-Rol@}G7d$Sj}DttSt+9zEH5 z{AdI6{}KMZmH*d7?^`v?@3DrWD|ak$D=1cEYhm{Q1tt zyZQeA1pfHj{r{a2;F6B&>5n2%i2Cba^4?7z-I)G32D+vHO)&iCZR_bj?v3At;cs9q z(*IP;H~sJ7!;Q_y@cwLVeXzN;_3**1{`clYy}_Fri*E{vgqa}kx66QEc)MpPkisK{CT6oCI1(E_*j-}_-nWGKLBJC}U3 zb3MypkdrPVv8gmVKc0VOi5xrnisVn&;gpq)a>j}WfcJO;xMb1(lIUZl%{h$JNsebp zjlc24Y>vB_aG0lwQV7sQ*%nl+!(d1%m-`)I-9ZL)YEB!)T!IWS_L5k*L!(rUTSW$5MY^nmC_?8t20{or($?0QG88-K+#1G$ptn^1;6w>n-l~K}t5NRA z4+GiYJHOvVh%4AD??e*j;#WpR`%y}x<2@kcZ6w;MH$@m4-!QsY`yfmskY48x4n~ax z#4$Rp?Isbvw}T3?1`F|dcTuLDY6+5O7r~4R@ zpa=+p8l(Y*-S6&P0M0<5hIZSq3|cAhHbu(g1U?q6KJKbX>`=Tzzyg&Rs3nRy6FCiJ z?sktlxH{ROp|eNoj?kIHA`DEQ?6Qa)*brWx?Kx^QP`aTs7;$Z{T^J@&a)+5FC|t#( za1N=%iP%8KLh0>D#n{2utO0T9TcfGBHf)#_BEC!pIi5bXy8X!`e@9d8xQeEgm#WYF zEp8L_@06c_a<{78J5vsPo7UA>bN;_xDhm7tBQMhbkPt>QPd=M!|7|_kdIJ6Lfdq!# zp8vi9vTyjxt^OzbeXZK2vWe_Ti44&Rp?s_VU8Vo2p0cZo88){>Z!+BonvtSb&?@TE zF3P4cqdh1$rbWeeLDl%zR4Z-j5iM70l>UZb=2n~3q^X-}lR?dmYNgb;@f(Avu3oHD z!B|gj7^dr+r=6if{SGe#-5no^Spw?=H7MpdqC=>oSeb}7#PJ_{;koBpVswf<5m=h~ z`c8p-ub_46))({2hH5&pVcBwEQ{AIsGGVCVrgK^@*z`=a`L*uBAo0w6505_FG+l3Ae9b1ktfoo{q z(7W{l9+t|p^eJ-(`T;d)D81{6wH0eisKXf&g0z;~bay&GVcro1mzbtG#BRs#4|@~T zs0#C{BiHruwBD5djLX<7wC8+a0-LjwHLK?+Hs_}f!$|S3>71=SacvPs1k5U23CFOP z(w{lh3%XuB3rPvX-9%FB!thhoX!}lGMO4XNvN9q8aJ0)p9LK+?nJotSp*Nr zKd;ZC*8ZnBSl^%Y`+L(~OK#Y>p;ehTzw!D1gU63}FmxOLnd9--`0Hx=v%K@$jeK+Z zKYF-zOaHe+`ZeEPOn)ms3}a+#?ZIYCYvNwB*Sy({>HqMtM!IQn<~c{Tmteh0X@{J*vT-WSg; zrvI(|_r7TGTaI%b`rq1rza@o!-LbEt|8JxJ-P(V@F4bf2i|K!B|3xhQ`~G$n{ePSF ze{27}FOI9Fzs4iHGZ1d9|8L&rf4?*2U(r!L{Vo4{9q}+%ynmg?H>UpsT=aJ9|G5ro z-@47^^nW*nfI$D+`p=u2DE3!zw*Ko|llEF2+_?Ua$IRW9 z|FPR1{*B82c&^%Q;h$@*oqvZ$m&GZws{|}`8*KPdg&1m^1t*=l2HOiZDjrnHoQLl-&_Lx{~K-p55a^n>g3T77!8489|8bSYKln! diff --git a/src/vfs/_vfscommon.vfs/modules/modpod-0.1.4.tm b/src/vfs/_vfscommon.vfs/modules/modpod-0.1.4.tm deleted file mode 100644 index 64e1bd9d..00000000 --- a/src/vfs/_vfscommon.vfs/modules/modpod-0.1.4.tm +++ /dev/null @@ -1,673 +0,0 @@ -# -*- tcl -*- -# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix 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) 2024 -# -# @@ Meta Begin -# Application modpod 0.1.4 -# Meta platform tcl -# Meta license -# @@ Meta End - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# doctools header -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -#*** !doctools -#[manpage_begin modpod_module_modpod 0 0.1.4] -#[copyright "2024"] -#[titledesc {Module API}] [comment {-- Name section and table of contents description --}] -#[moddesc {-}] [comment {-- Description at end of page heading --}] -#[require modpod] -#[keywords module] -#[description] -#[para] - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - -#*** !doctools -#[section Overview] -#[para] overview of modpod -#[subsection Concepts] -#[para] - - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Requirements -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - -#*** !doctools -#[subsection dependencies] -#[para] packages used by modpod -#[list_begin itemized] - -package require Tcl 8.6- -package require struct::set ;#review -package require punk::lib -package require punk::args -#*** !doctools -#[item] [package {Tcl 8.6-}] - -# #package require frobz -# #*** !doctools -# #[item] [package {frobz}] - -#*** !doctools -#[list_end] - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - -#*** !doctools -#[section API] - - -#changes -#0.1.4 - when mounting with vfs::zip (because zipfs not available) - mount relative to executable folder instead of module dir -# (given just a module name it's easier to find exepath than look at package ifneeded script to get module path) - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# Base namespace -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -namespace eval modpod { - namespace export {[a-z]*}; # Convention: export all lowercase - - variable connected - if {![info exists connected(to)]} { - set connected(to) list - } - variable modpodscript - set modpodscript [info script] - if {[string tolower [file extension $modpodscript]] eq ".tcl"} { - set connected(self) [file dirname $modpodscript] - } else { - #expecting a .tm - set connected(self) $modpodscript - } - variable loadables [info sharedlibextension] - variable sourceables {.tcl .tk} ;# .tm ? - - #*** !doctools - #[subsection {Namespace modpod}] - #[para] Core API functions for modpod - #[list_begin definitions] - - - - #old tar connect mechanism - review - not needed? - proc connect {args} { - puts stderr "modpod::connect--->>$args" - set argd [punk::args::parse $args withdef { - @id -id ::modpod::connect - -type -default "" - @values -min 1 -max 1 - path -type string -minsize 1 -help "path to .tm file or toplevel .tcl script within #modpod-- folder (unwrapped modpod)" - }] - catch { - punk::lib::showdict $argd ;#heavy dependencies - } - set opt_path [dict get $argd values path] - variable connected - set original_connectpath $opt_path - set modpodpath [modpod::system::normalize $opt_path] ;# - - if {$modpodpath in $connected(to)} { - return [dict create ok ALREADY_CONNECTED] - } - lappend connected(to) $modpodpath - - set connected(connectpath,$opt_path) $original_connectpath - set is_sourced [expr {[file normalize $modpodpath] eq [file normalize [info script]]}] - - set connected(location,$modpodpath) [file dirname $modpodpath] - set connected(startdata,$modpodpath) -1 - set connected(type,$modpodpath) [dict get $argd opts -type] - set connected(fh,$modpodpath) "" - - if {[string range [file tail $modpodpath] 0 7] eq "#modpod-"} { - set connected(type,$modpodpath) "unwrapped" - lassign [::split [file tail [file dirname $modpodpath]] -] connected(package,$modpodpath) connected(version,$modpodpath) - set this_pkg_tm_folder [file dirname [file dirname $modpodpath]] - - } else { - #connect to .tm but may still be unwrapped version available - lassign [::split [file rootname [file tail $modpodpath]] -] connected(package,$modpodpath) connected(version,$modpodpath) - set this_pkg_tm_folder [file dirname $modpodpath] - if {$connected(type,$modpodpath) ne "unwrapped"} { - #Not directly connected to unwrapped version - but may still be redirected there - set unwrappedFolder [file join $connected(location,$modpodpath) #modpod-$connected(package,$modpodpath)-$connected(version,$modpodpath)] - if {[file exists $unwrappedFolder]} { - #folder with exact version-match must exist for redirect to 'unwrapped' - set con(type,$modpodpath) "modpod-redirecting" - } - } - - } - set unwrapped_tm_file [file join $this_pkg_tm_folder] "[set connected(package,$modpodpath)]-[set connected(version,$modpodpath)].tm" - set connected(tmfile,$modpodpath) - set tail_segments [list] - set lcase_tmfile_segments [string tolower [file split $this_pkg_tm_folder]] - set lcase_modulepaths [string tolower [tcl::tm::list]] - foreach lc_mpath $lcase_modulepaths { - set mpath_segments [file split $lc_mpath] - if {[llength [struct::set intersect $lcase_tmfile_segments $mpath_segments]] == [llength $mpath_segments]} { - set tail_segments [lrange [file split $this_pkg_tm_folder] [llength $mpath_segments] end] - break - } - } - if {[llength $tail_segments]} { - set connected(fullpackage,$modpodpath) [join [concat $tail_segments [set connected(package,$modpodpath)]] ::] ;#full name of package as used in package require - } else { - set connected(fullpackage,$modpodpath) [set connected(package,$modpodpath)] - } - - switch -exact -- $connected(type,$modpodpath) { - "modpod-redirecting" { - #redirect to the unwrapped version - set loadscript_name [file join $unwrappedFolder #modpod-loadscript-$con(package,$modpod).tcl] - - } - "unwrapped" { - if {[info commands ::thread::id] ne ""} { - set from [pid],[thread::id] - } else { - set from [pid] - } - #::modpod::Puts stderr "$from-> Package $connected(package,$modpodpath)-$connected(version,$modpodpath) is using unwrapped version: $modpodpath" - return [list ok ""] - } - default { - #autodetect .tm - zip/tar ? - #todo - use vfs ? - - #connect to tarball - start at 1st header - set connected(startdata,$modpodpath) 0 - set fh [open $modpodpath r] - set connected(fh,$modpodpath) $fh - fconfigure $fh -encoding iso8859-1 -translation binary -eofchar {} - - if {$connected(startdata,$modpodpath) >= 0} { - #verify we have a valid tar header - if {![catch {::modpod::system::tar::readHeader [read $fh 512]}]} { - seek $fh $connected(startdata,$modpodpath) start - return [list ok $fh] - } else { - #error "cannot verify tar header" - #try zipfs - if {[info commands tcl::zipfs::mount] ne ""} { - - } - } - } - lpop connected(to) end - set connected(startdata,$modpodpath) -1 - unset connected(fh,$modpodpath) - catch {close $fh} - return [dict create err {Does not appear to be a valid modpod}] - } - } - } - proc disconnect {{modpod ""}} { - variable connected - if {![llength $connected(to)]} { - return 0 - } - if {$modpod eq ""} { - puts stderr "modpod::disconnect WARNING: modpod not explicitly specified. Disconnecting last connected: [lindex $connected(to) end]" - set modpod [lindex $connected(to) end] - } - - if {[set posn [lsearch $connected(to) $modpod]] == -1} { - puts stderr "modpod::disconnect WARNING: disconnect called when not connected: $modpod" - return 0 - } - if {[string length $connected(fh,$modpod)]} { - close $connected(fh,$modpod) - } - array unset connected *,$modpod - set connected(to) [lreplace $connected(to) $posn $posn] - return 1 - } - proc get {args} { - set argd [punk::args::parse $args withdef { - @id -id ::modpod::get - -from -default "" -help "path to pod" - @values -min 1 -max 1 - filename - }] - set frompod [dict get $argd opts -from] - set filename [dict get $argd values filename] - - variable connected - #//review - set modpod [::modpod::system::connect_if_not $frompod] - set fh $connected(fh,$modpod) - if {$connected(type,$modpod) eq "unwrapped"} { - #for unwrapped connection - $connected(location) already points to the #modpod-pkg-ver folder - if {[string range $filename 0 0 eq "/"]} { - #absolute path (?) - set path [file join $connected(location,$modpod) .. [string trim $filename /]] - } else { - #relative path - use #modpod-xxx as base - set path [file join $connected(location,$modpod) $filename] - } - set fd [open $path r] - #utf-8? - #fconfigure $fd -encoding iso8859-1 -translation binary - return [list ok [lindex [list [read $fd] [close $fd]] 0]] - } else { - #read from vfs - puts stderr "get $filename from wrapped pod '$frompod' not implemented" - } - } - - - #*** !doctools - #[list_end] [comment {--- end definitions namespace modpod ---}] -} -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# Secondary API namespace -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -namespace eval modpod::lib { - namespace export {[a-z]*}; # Convention: export all lowercase - namespace path [namespace parent] - #*** !doctools - #[subsection {Namespace modpod::lib}] - #[para] Secondary functions that are part of the API - #[list_begin definitions] - - #proc utility1 {p1 args} { - # #*** !doctools - # #[call lib::[fun utility1] [arg p1] [opt {?option value...?}]] - # #[para]Description of utility1 - # return 1 - #} - - proc is_valid_tm_version {versionpart} { - #Needs to be suitable for use with Tcl's 'package vcompare' - if {![catch [list package vcompare $versionparts $versionparts]]} { - return 1 - } else { - return 0 - } - } - - #zipfile is a pure zip at this point - ie no script/exe header - proc make_zip_modpod {args} { - set argd [punk::args::parse $args withdef { - @id -id ::modpod::lib::make_zip_modpod - -offsettype -default "archive" -choices {archive file} -help\ - "Whether zip offsets are relative to start of file or start of zip-data within the file. - 'archive' relative offsets are easier to work with (for writing/updating) in tools such as 7zip,peazip, - but other tools may be easier with 'file' relative offsets. (e.g info-zip,pkzip) - info-zip's 'zip -A' can sometimes convert archive-relative to file-relative. - -offsettype archive is equivalent to plain 'cat prefixfile zipfile > modulefile'" - @values -min 2 -max 2 - zipfile -type path -minsize 1 -help "path to plain zip file with subfolder #modpod-packagename-version containing .tm, data files and/or binaries" - outfile -type path -minsize 1 -help "path to output file. Name should be of the form packagename-version.tm" - }] - set zipfile [dict get $argd values zipfile] - set outfile [dict get $argd values outfile] - set opt_offsettype [dict get $argd opts -offsettype] - - - set mount_stub [string map [list %offsettype% $opt_offsettype] { - #zip file with Tcl loader prepended. Requires either builtin zipfs, or vfs::zip to mount while zipped. - #Alternatively unzip so that extracted #modpod-package-version folder is in same folder as .tm file. - #generated using: modpod::lib::make_zip_modpod -offsettype %offsettype% - if {[catch {file normalize [info script]} modfile]} { - error "modpod zip stub error. Unable to determine module path. (possible safe interp restrictions?)" - } - if {$modfile eq "" || ![file exists $modfile]} { - error "modpod zip stub error. Unable to determine module path" - } - set moddir [file dirname $modfile] - set exedir [file dirname [file normalize [info nameofexecutable]]] - set mod_and_ver [file rootname [file tail $modfile]] - lassign [split $mod_and_ver -] moduletail version - - #determine module namespace so we can mount appropriately - proc intersect {A B} { - if {[llength $A] == 0} {return {}} - if {[llength $B] == 0} {return {}} - if {[llength $B] > [llength $A]} { - set res $A - set A $B - set B $res - } - set res {} - foreach x $A {set ($x) {}} - foreach x $B { - if {[info exists ($x)]} { - lappend res $x - } - } - return $res - } - set lcase_tmfile_segments [string tolower [file split $moddir]] - set lcase_modulepaths [string tolower [tcl::tm::list]] - foreach lc_mpath $lcase_modulepaths { - set mpath_segments [file split $lc_mpath] - if {[llength [intersect $lcase_tmfile_segments $mpath_segments]] == [llength $mpath_segments]} { - set tail_segments [lrange [file split $moddir] [llength $mpath_segments] end] ;#use properly cased tail - break - } - } - if {[llength $tail_segments]} { - set fullpackage [join [concat $tail_segments $moduletail] ::] ;#full name of package as used in package require - set mount_at #modpod/[file join {*}$tail_segments]/#mounted-modpod-$mod_and_ver - } else { - set fullpackage $moduletail - set mount_at #modpod/#mounted-modpod-$mod_and_ver - } - - if {[info commands tcl::zipfs::mount] ne ""} { - #argument order changed to be consistent with vfs::zip::Mount etc - #early versions: zipfs::Mount mountpoint zipname - #since 2023-09: zipfs::Mount zipname mountpoint - #don't use 'file exists' when testing mountpoints. (some versions at least give massive delays on windows platform for non-existance) - #This is presumably related to // being interpreted as a network path - set mountpoints [dict keys [tcl::zipfs::mount]] - if {"//zipfs:/$mount_at" ni $mountpoints} { - #despite API change tcl::zipfs package version was unfortunately not updated - so we don't know argument order without trying it - if {[catch { - #tcl::zipfs::mount $modfile //zipfs:/#mounted-modpod-$mod_and_ver ;#extremely slow if this is a wrong guess (artifact of aforementioned file exists issue ?) - #puts "tcl::zipfs::mount $modfile $mount_at" - tcl::zipfs::mount $modfile $mount_at - } errM]} { - #try old api - if {![catch {tcl::zipfs::mount //zipfs:/$mount_at $modfile}]} { - puts stderr "modpod stub>>> tcl::zipfs::mount failed.\nbut old api: tcl::zipfs::mount succeeded\n tcl::zipfs::mount //zipfs://$mount_at $modfile" - puts stderr "Consider upgrading tcl runtime to one with fixed zipfs API" - } - } - if {![file exists //zipfs:/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm]} { - puts stderr "modpod stub>>> mount at //zipfs:/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm failed\n zipfs mounts: [zipfs mount]" - #tcl::zipfs::unmount //zipfs:/$mount_at - error "Unable to find $mod_and_ver.tm in $modfile for module $fullpackage" - } - } - # #modpod-$mod_and_ver subdirectory always present in the archive so it can be conveniently extracted and run in that form - source //zipfs:/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm - } else { - #fallback to slower vfs::zip - #NB. We don't create the intermediate dirs - but the mount still works - - if {![file exists $exedir/$mount_at]} { - if {[catch {package require vfs::zip} errM]} { - set msg "Unable to load vfs::zip package to mount module $mod_and_ver (and zipfs not available either)" - append msg \n "If neither zipfs or vfs::zip are available - the module can still be loaded by manually unzipping the file $modfile in place." - append msg \n "The unzipped data will all be contained in a folder named #modpod-$mod_and_ver in the same parent folder as $modfile" - error $msg - } else { - set fd [vfs::zip::Mount $modfile $exedir/$mount_at] - if {![file exists $exedir/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm]} { - vfs::zip::Unmount $fd $exedir/$mount_at - error "Unable to find $mod_and_ver.tm in $modfile for module $fullpackage" - } - } - } - source $exedir/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm - } - #zipped data follows - }] - #todo - test if supplied zipfile has #modpod-loadcript.tcl or some other script/executable before even creating? - append mount_stub \x1A - modpod::system::make_mountable_zip $zipfile $outfile $mount_stub $opt_offsettype - - } - - #*** !doctools - #[list_end] [comment {--- end definitions namespace modpod::lib ---}] -} -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -#*** !doctools -#[section Internal] -namespace eval modpod::system { - #*** !doctools - #[subsection {Namespace modpod::system}] - #[para] Internal functions that are not part of the API - - #deflate,store only supported - - #zipfile here is plain zip - no script/exe prefix part. - proc make_mountable_zip {zipfile outfile mount_stub {offsettype "archive"}} { - set inzip [open $zipfile r] - fconfigure $inzip -encoding iso8859-1 -translation binary - set out [open $outfile w+] - fconfigure $out -encoding iso8859-1 -translation binary - puts -nonewline $out $mount_stub - set stuboffset [tell $out] - lappend report "stub size: $stuboffset" - fcopy $inzip $out - close $inzip - - set size [tell $out] - lappend report "modpod::system::make_mountable_zip" - lappend report "tmfile : [file tail $outfile]" - lappend report "output size : $size" - lappend report "offsettype : $offsettype" - - if {$offsettype eq "file"} { - #make zip offsets relative to start of whole file including prepended script. - #same offset structure as Tcl's older 'zipfs mkimg' as at 2024-10 - #2025 - zipfs mkimg fixed to use 'archive' offset. - #not editable by 7z,nanazip,peazip - - #we aren't adding any new files/folders so we can edit the offsets in place - - #Now seek in $out to find the end of directory signature: - #The structure itself is 24 bytes Long, followed by a maximum of 64Kbytes text - if {$size < 65559} { - set tailsearch_start 0 - } else { - set tailsearch_start [expr {$size - 65559}] - } - seek $out $tailsearch_start - set data [read $out] - #EOCD - End of Central Directory record - #PK\5\6 - set start_of_end [string last "\x50\x4b\x05\x06" $data] - #set start_of_end [expr {$start_of_end + $seek}] - #incr start_of_end $seek - set filerelative_eocd_posn [expr {$start_of_end + $tailsearch_start}] - - lappend report "kitfile-relative START-OF-EOCD: $filerelative_eocd_posn" - - seek $out $filerelative_eocd_posn - set end_of_ctrl_dir [read $out] - binary scan $end_of_ctrl_dir issssiis eocd(signature) eocd(disknbr) eocd(ctrldirdisk) \ - eocd(numondisk) eocd(totalnum) eocd(dirsize) eocd(diroffset) eocd(comment_len) - - lappend report "End of central directory: [array get eocd]" - seek $out [expr {$filerelative_eocd_posn+16}] - - #adjust offset of start of central directory by the length of our sfx stub - puts -nonewline $out [binary format i [expr {$eocd(diroffset) + $stuboffset}]] - flush $out - - seek $out $filerelative_eocd_posn - set end_of_ctrl_dir [read $out] - binary scan $end_of_ctrl_dir issssiis eocd(signature) eocd(disknbr) eocd(ctrldirdisk) \ - eocd(numondisk) eocd(totalnum) eocd(dirsize) eocd(diroffset) eocd(comment_len) - - # 0x06054b50 - end of central dir signature - puts stderr "$end_of_ctrl_dir" - puts stderr "comment_len: $eocd(comment_len)" - puts stderr "eocd sig: $eocd(signature) [punk::lib::dec2hex $eocd(signature)]" - lappend report "New dir offset: $eocd(diroffset)" - lappend report "Adjusting $eocd(totalnum) zip file items." - catch { - punk::lib::showdict -roottype list -chan stderr $report ;#heavy dependencies - } - - seek $out $eocd(diroffset) - for {set i 0} {$i <$eocd(totalnum)} {incr i} { - set current_file [tell $out] - set fileheader [read $out 46] - puts -------------- - puts [ansistring VIEW -lf 1 $fileheader] - puts -------------- - #binary scan $fileheader is2sss2ii2s3ssii x(sig) x(version) x(flags) x(method) \ - # x(date) x(crc32) x(sizes) x(lengths) x(diskno) x(iattr) x(eattr) x(offset) - - binary scan $fileheader ic4sss2ii2s3ssii x(sig) x(version) x(flags) x(method) \ - x(date) x(crc32) x(sizes) x(lengths) x(diskno) x(iattr) x(eattr) x(offset) - set ::last_header $fileheader - - puts "sig: $x(sig) (hex: [punk::lib::dec2hex $x(sig)])" - puts "ver: $x(version)" - puts "method: $x(method)" - - #PK\1\2 - #33639248 dec = 0x02014b50 - central directory file header signature - if { $x(sig) != 33639248 } { - error "modpod::system::make_mountable_zip Bad file header signature at item $i: dec:$x(sig) hex:[punk::lib::dec2hex $x(sig)]" - } - - foreach size $x(lengths) var {filename extrafield comment} { - if { $size > 0 } { - set x($var) [read $out $size] - } else { - set x($var) "" - } - } - set next_file [tell $out] - lappend report "file $i: $x(offset) $x(sizes) $x(filename)" - - seek $out [expr {$current_file+42}] - puts -nonewline $out [binary format i [expr {$x(offset)+$stuboffset}]] - - #verify: - flush $out - seek $out $current_file - set fileheader [read $out 46] - lappend report "old $x(offset) + $stuboffset" - binary scan $fileheader is2sss2ii2s3ssii x(sig) x(version) x(flags) x(method) \ - x(date) x(crc32) x(sizes) x(lengths) x(diskno) x(iattr) x(eattr) x(offset) - lappend report "new $x(offset)" - - seek $out $next_file - } - } - - close $out - #pdict/showdict reuire punk & textlib - ie lots of dependencies - #don't fall over just because of that - catch { - punk::lib::showdict -roottype list -chan stderr $report - } - #puts [join $report \n] - return - } - - proc connect_if_not {{podpath ""}} { - upvar ::modpod::connected connected - set podpath [::modpod::system::normalize $podpath] - set docon 0 - if {![llength $connected(to)]} { - if {![string length $podpath]} { - error "modpod::system::connect_if_not - Not connected to a modpod file, and no podpath specified" - } else { - set docon 1 - } - } else { - if {![string length $podpath]} { - set podpath [lindex $connected(to) end] - puts stderr "modpod::system::connect_if_not WARNING: using last connected modpod:$podpath for operation\n -podpath not explicitly specified during operation: [info level -1]" - } else { - if {$podpath ni $connected(to)} { - set docon 1 - } - } - } - if {$docon} { - if {[lindex [modpod::connect $podpath]] 0] ne "ok"} { - error "modpod::system::connect_if_not error. file $podpath does not seem to be a valid modpod" - } else { - return $podpath - } - } - #we were already connected - return $podpath - } - - proc myversion {} { - upvar ::modpod::connected connected - set script [info script] - if {![string length $script]} { - error "No result from \[info script\] - modpod::system::myversion should only be called from within a loading modpod" - } - set fname [file tail [file rootname [file normalize $script]]] - set scriptdir [file dirname $script] - - if {![string match "#modpod-*" $fname]} { - lassign [lrange [split $fname -] end-1 end] _pkgname version - } else { - lassign [scan [file tail [file rootname $script]] {#modpod-loadscript-%[a-z]-%s}] _pkgname version - if {![string length $version]} { - #try again on the name of the containing folder - lassign [scan [file tail $scriptdir] {#modpod-%[a-z]-%s}] _pkgname version - #todo - proper walk up the directory tree - if {![string length $version]} { - #try again on the grandparent folder (this is a standard depth for sourced .tcl files in a modpod) - lassign [scan [file tail [file dirname $scriptdir]] {#modpod-%[a-z]-%s}] _pkgname version - } - } - } - - #tarjar::Log debug "'myversion' determined version for [info script]: $version" - return $version - } - - proc myname {} { - upvar ::modpod::connected connected - set script [info script] - if {![string length $script]} { - error "No result from \[info script\] - modpod::system::myname should only be called from within a loading modpod" - } - return $connected(fullpackage,$script) - } - proc myfullname {} { - upvar ::modpod::connected connected - set script [info script] - #set script [::tarjar::normalize $script] - set script [file normalize $script] - if {![string length $script]} { - error "No result from \[info script\] - modpod::system::myfullname should only be called from within a loading tarjar" - } - return $::tarjar::connected(fullpackage,$script) - } - proc normalize {path} { - #newer versions of Tcl don't do tilde sub - - #Tcl's 'file normalize' seems to do some unfortunate tilde substitution on windows.. (at least for relative paths) - # we take the assumption here that if Tcl's tilde substitution is required - it should be done before the path is provided to this function. - set matilda "<_tarjar_tilde_placeholder_>" ;#token that is *unlikely* to occur in the wild, and is somewhat self describing in case it somehow ..escapes.. - set path [string map [list ~ $matilda] $path] ;#give our tildes to matilda to look after - set path [file normalize $path] - #set path [string tolower $path] ;#must do this after file normalize - return [string map [list $matilda ~] $path] ;#get our tildes back. -} -} -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready -package provide modpod [namespace eval modpod { - variable pkg modpod - variable version - set version 0.1.4 -}] -return - -#*** !doctools -#[manpage_end] - diff --git a/src/vfs/_vfscommon.vfs/modules/modpod-0.1.5.tm b/src/vfs/_vfscommon.vfs/modules/modpod-0.1.5.tm new file mode 100644 index 00000000..63875951 --- /dev/null +++ b/src/vfs/_vfscommon.vfs/modules/modpod-0.1.5.tm @@ -0,0 +1,677 @@ +# -*- tcl -*- +# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix 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) 2024 +# +# @@ Meta Begin +# Application modpod 0.1.5 +# Meta platform tcl +# Meta license +# @@ Meta End + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# doctools header +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[manpage_begin modpod_module_modpod 0 0.1.5] +#[copyright "2024"] +#[titledesc {Module API}] [comment {-- Name section and table of contents description --}] +#[moddesc {-}] [comment {-- Description at end of page heading --}] +#[require modpod] +#[keywords module] +#[description] +#[para] - + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section Overview] +#[para] overview of modpod +#[subsection Concepts] +#[para] - + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[subsection dependencies] +#[para] packages used by modpod +#[list_begin itemized] + +package require Tcl 8.6- +package require struct::set ;#review +package require punk::lib +package require punk::args +#*** !doctools +#[item] [package {Tcl 8.6-}] + +# #package require frobz +# #*** !doctools +# #[item] [package {frobz}] + +#*** !doctools +#[list_end] + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section API] + + +#changes +#0.1.5 - Reduce pollution of global namespace with procs,variables +#0.1.4 - when mounting with vfs::zip (because zipfs not available) - mount relative to executable folder instead of module dir +# (given just a module name it's easier to find exepath than look at package ifneeded script to get module path) + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# Base namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +namespace eval modpod { + namespace export {[a-z]*}; # Convention: export all lowercase + + variable connected + if {![info exists connected(to)]} { + set connected(to) list + } + variable modpodscript + set modpodscript [info script] + if {[string tolower [file extension $modpodscript]] eq ".tcl"} { + set connected(self) [file dirname $modpodscript] + } else { + #expecting a .tm + set connected(self) $modpodscript + } + variable loadables [info sharedlibextension] + variable sourceables {.tcl .tk} ;# .tm ? + + #*** !doctools + #[subsection {Namespace modpod}] + #[para] Core API functions for modpod + #[list_begin definitions] + + + + #old tar connect mechanism - review - not needed? + proc connect {args} { + puts stderr "modpod::connect--->>$args" + set argd [punk::args::parse $args withdef { + @id -id ::modpod::connect + -type -default "" + @values -min 1 -max 1 + path -type string -minsize 1 -help "path to .tm file or toplevel .tcl script within #modpod-- folder (unwrapped modpod)" + }] + catch { + punk::lib::showdict $argd ;#heavy dependencies + } + set opt_path [dict get $argd values path] + variable connected + set original_connectpath $opt_path + set modpodpath [modpod::system::normalize $opt_path] ;# + + if {$modpodpath in $connected(to)} { + return [dict create ok ALREADY_CONNECTED] + } + lappend connected(to) $modpodpath + + set connected(connectpath,$opt_path) $original_connectpath + set is_sourced [expr {[file normalize $modpodpath] eq [file normalize [info script]]}] + + set connected(location,$modpodpath) [file dirname $modpodpath] + set connected(startdata,$modpodpath) -1 + set connected(type,$modpodpath) [dict get $argd opts -type] + set connected(fh,$modpodpath) "" + + if {[string range [file tail $modpodpath] 0 7] eq "#modpod-"} { + set connected(type,$modpodpath) "unwrapped" + lassign [::split [file tail [file dirname $modpodpath]] -] connected(package,$modpodpath) connected(version,$modpodpath) + set this_pkg_tm_folder [file dirname [file dirname $modpodpath]] + + } else { + #connect to .tm but may still be unwrapped version available + lassign [::split [file rootname [file tail $modpodpath]] -] connected(package,$modpodpath) connected(version,$modpodpath) + set this_pkg_tm_folder [file dirname $modpodpath] + if {$connected(type,$modpodpath) ne "unwrapped"} { + #Not directly connected to unwrapped version - but may still be redirected there + set unwrappedFolder [file join $connected(location,$modpodpath) #modpod-$connected(package,$modpodpath)-$connected(version,$modpodpath)] + if {[file exists $unwrappedFolder]} { + #folder with exact version-match must exist for redirect to 'unwrapped' + set con(type,$modpodpath) "modpod-redirecting" + } + } + + } + set unwrapped_tm_file [file join $this_pkg_tm_folder] "[set connected(package,$modpodpath)]-[set connected(version,$modpodpath)].tm" + set connected(tmfile,$modpodpath) + set tail_segments [list] + set lcase_tmfile_segments [string tolower [file split $this_pkg_tm_folder]] + set lcase_modulepaths [string tolower [tcl::tm::list]] + foreach lc_mpath $lcase_modulepaths { + set mpath_segments [file split $lc_mpath] + if {[llength [struct::set intersect $lcase_tmfile_segments $mpath_segments]] == [llength $mpath_segments]} { + set tail_segments [lrange [file split $this_pkg_tm_folder] [llength $mpath_segments] end] + break + } + } + if {[llength $tail_segments]} { + set connected(fullpackage,$modpodpath) [join [concat $tail_segments [set connected(package,$modpodpath)]] ::] ;#full name of package as used in package require + } else { + set connected(fullpackage,$modpodpath) [set connected(package,$modpodpath)] + } + + switch -exact -- $connected(type,$modpodpath) { + "modpod-redirecting" { + #redirect to the unwrapped version + set loadscript_name [file join $unwrappedFolder #modpod-loadscript-$con(package,$modpod).tcl] + + } + "unwrapped" { + if {[info commands ::thread::id] ne ""} { + set from [pid],[thread::id] + } else { + set from [pid] + } + #::modpod::Puts stderr "$from-> Package $connected(package,$modpodpath)-$connected(version,$modpodpath) is using unwrapped version: $modpodpath" + return [list ok ""] + } + default { + #autodetect .tm - zip/tar ? + #todo - use vfs ? + + #connect to tarball - start at 1st header + set connected(startdata,$modpodpath) 0 + set fh [open $modpodpath r] + set connected(fh,$modpodpath) $fh + fconfigure $fh -encoding iso8859-1 -translation binary -eofchar {} + + if {$connected(startdata,$modpodpath) >= 0} { + #verify we have a valid tar header + if {![catch {::modpod::system::tar::readHeader [read $fh 512]}]} { + seek $fh $connected(startdata,$modpodpath) start + return [list ok $fh] + } else { + #error "cannot verify tar header" + #try zipfs + if {[info commands tcl::zipfs::mount] ne ""} { + + } + } + } + lpop connected(to) end + set connected(startdata,$modpodpath) -1 + unset connected(fh,$modpodpath) + catch {close $fh} + return [dict create err {Does not appear to be a valid modpod}] + } + } + } + proc disconnect {{modpod ""}} { + variable connected + if {![llength $connected(to)]} { + return 0 + } + if {$modpod eq ""} { + puts stderr "modpod::disconnect WARNING: modpod not explicitly specified. Disconnecting last connected: [lindex $connected(to) end]" + set modpod [lindex $connected(to) end] + } + + if {[set posn [lsearch $connected(to) $modpod]] == -1} { + puts stderr "modpod::disconnect WARNING: disconnect called when not connected: $modpod" + return 0 + } + if {[string length $connected(fh,$modpod)]} { + close $connected(fh,$modpod) + } + array unset connected *,$modpod + set connected(to) [lreplace $connected(to) $posn $posn] + return 1 + } + proc get {args} { + set argd [punk::args::parse $args withdef { + @id -id ::modpod::get + -from -default "" -help "path to pod" + @values -min 1 -max 1 + filename + }] + set frompod [dict get $argd opts -from] + set filename [dict get $argd values filename] + + variable connected + #//review + set modpod [::modpod::system::connect_if_not $frompod] + set fh $connected(fh,$modpod) + if {$connected(type,$modpod) eq "unwrapped"} { + #for unwrapped connection - $connected(location) already points to the #modpod-pkg-ver folder + if {[string range $filename 0 0 eq "/"]} { + #absolute path (?) + set path [file join $connected(location,$modpod) .. [string trim $filename /]] + } else { + #relative path - use #modpod-xxx as base + set path [file join $connected(location,$modpod) $filename] + } + set fd [open $path r] + #utf-8? + #fconfigure $fd -encoding iso8859-1 -translation binary + return [list ok [lindex [list [read $fd] [close $fd]] 0]] + } else { + #read from vfs + puts stderr "get $filename from wrapped pod '$frompod' not implemented" + } + } + + + #*** !doctools + #[list_end] [comment {--- end definitions namespace modpod ---}] +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# Secondary API namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +namespace eval modpod::lib { + namespace export {[a-z]*}; # Convention: export all lowercase + namespace path [namespace parent] + #*** !doctools + #[subsection {Namespace modpod::lib}] + #[para] Secondary functions that are part of the API + #[list_begin definitions] + + #proc utility1 {p1 args} { + # #*** !doctools + # #[call lib::[fun utility1] [arg p1] [opt {?option value...?}]] + # #[para]Description of utility1 + # return 1 + #} + + proc is_valid_tm_version {versionpart} { + #Needs to be suitable for use with Tcl's 'package vcompare' + if {![catch [list package vcompare $versionparts $versionparts]]} { + return 1 + } else { + return 0 + } + } + + #zipfile is a pure zip at this point - ie no script/exe header + proc make_zip_modpod {args} { + set argd [punk::args::parse $args withdef { + @id -id ::modpod::lib::make_zip_modpod + -offsettype -default "archive" -choices {archive file} -help\ + "Whether zip offsets are relative to start of file or start of zip-data within the file. + 'archive' relative offsets are easier to work with (for writing/updating) in tools such as 7zip,peazip, + but other tools may be easier with 'file' relative offsets. (e.g info-zip,pkzip) + info-zip's 'zip -A' can sometimes convert archive-relative to file-relative. + -offsettype archive is equivalent to plain 'cat prefixfile zipfile > modulefile'" + @values -min 2 -max 2 + zipfile -type path -minsize 1 -help "path to plain zip file with subfolder #modpod-packagename-version containing .tm, data files and/or binaries" + outfile -type path -minsize 1 -help "path to output file. Name should be of the form packagename-version.tm" + }] + set zipfile [dict get $argd values zipfile] + set outfile [dict get $argd values outfile] + set opt_offsettype [dict get $argd opts -offsettype] + + + #mount_stub should not pollute global namespace. + set mount_stub [string map [list %offsettype% $opt_offsettype] { + #zip file with Tcl loader prepended. Requires either builtin zipfs, or vfs::zip to mount while zipped. + #Alternatively unzip so that extracted #modpod-package-version folder is in same folder as .tm file. + #generated using: modpod::lib::make_zip_modpod -offsettype %offsettype% + if {[catch {file normalize [info script]}]} { + error "modpod zip stub error. Unable to determine module path. (possible safe interp restrictions?)" + } + apply {{modfile} { + if {$modfile eq "" || ![file exists $modfile]} { + error "modpod zip stub error. Unable to determine module path" + } + set moddir [file dirname $modfile] + set exedir [file dirname [file normalize [info nameofexecutable]]] + set mod_and_ver [file rootname [file tail $modfile]] + lassign [split $mod_and_ver -] moduletail version + set do_intersect {{A B} { + if {[llength $A] == 0} {return {}} + if {[llength $B] == 0} {return {}} + if {[llength $B] > [llength $A]} { + set res $A + set A $B + set B $res + } + set res {} + foreach x $A {set ($x) {}} + foreach x $B { + if {[info exists ($x)]} { + lappend res $x + } + } + return $res + }} + #determine module namespace so we can mount appropriately + set lcase_tmfile_segments [string tolower [file split $moddir]] + set lcase_modulepaths [string tolower [tcl::tm::list]] + foreach lc_mpath $lcase_modulepaths { + set mpath_segments [file split $lc_mpath] + if {[llength [apply $do_intersect $lcase_tmfile_segments $mpath_segments]] == [llength $mpath_segments]} { + set tail_segments [lrange [file split $moddir] [llength $mpath_segments] end] ;#use properly cased tail + break + } + } + if {[llength $tail_segments]} { + set fullpackage [join [concat $tail_segments $moduletail] ::] ;#full name of package as used in package require + set mount_at #modpod/[file join {*}$tail_segments]/#mounted-modpod-$mod_and_ver + } else { + set fullpackage $moduletail + set mount_at #modpod/#mounted-modpod-$mod_and_ver + } + + if {[info commands tcl::zipfs::mount] ne ""} { + #argument order changed to be consistent with vfs::zip::Mount etc + #early versions: zipfs::Mount mountpoint zipname + #since 2023-09: zipfs::Mount zipname mountpoint + #don't use 'file exists' when testing mountpoints. (some versions at least give massive delays on windows platform for non-existance) + #This is presumably related to // being interpreted as a network path + set mountpoints [dict keys [tcl::zipfs::mount]] + if {"//zipfs:/$mount_at" ni $mountpoints} { + #despite API change tcl::zipfs package version was unfortunately not updated - so we don't know argument order without trying it + if {[catch { + #tcl::zipfs::mount $modfile //zipfs:/#mounted-modpod-$mod_and_ver ;#extremely slow if this is a wrong guess (artifact of aforementioned file exists issue ?) + #puts "tcl::zipfs::mount $modfile $mount_at" + tcl::zipfs::mount $modfile $mount_at + } errM]} { + #try old api + if {![catch {tcl::zipfs::mount //zipfs:/$mount_at $modfile}]} { + puts stderr "modpod stub>>> tcl::zipfs::mount failed.\nbut old api: tcl::zipfs::mount succeeded\n tcl::zipfs::mount //zipfs://$mount_at $modfile" + puts stderr "Consider upgrading tcl runtime to one with fixed zipfs API" + } + } + if {![file exists //zipfs:/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm]} { + puts stderr "modpod stub>>> mount at //zipfs:/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm failed\n zipfs mounts: [zipfs mount]" + #tcl::zipfs::unmount //zipfs:/$mount_at + error "Unable to find $mod_and_ver.tm in $modfile for module $fullpackage" + } + } + # #modpod-$mod_and_ver subdirectory always present in the archive so it can be conveniently extracted and run in that form + uplevel 1 [list source //zipfs:/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm] + } else { + #fallback to slower vfs::zip + #NB. We don't create the intermediate dirs - but the mount still works + + if {![file exists $exedir/$mount_at]} { + if {[catch {package require vfs::zip} errM]} { + set msg "Unable to load vfs::zip package to mount module $mod_and_ver (and zipfs not available either)" + append msg \n "If neither zipfs or vfs::zip are available - the module can still be loaded by manually unzipping the file $modfile in place." + append msg \n "The unzipped data will all be contained in a folder named #modpod-$mod_and_ver in the same parent folder as $modfile" + error $msg + } else { + set fd [vfs::zip::Mount $modfile $exedir/$mount_at] + if {![file exists $exedir/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm]} { + vfs::zip::Unmount $fd $exedir/$mount_at + error "Unable to find $mod_and_ver.tm in $modfile for module $fullpackage" + } + } + } + uplevel 1 [list source $exedir/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm] + } + }} [file normalize [info script]] + + #zipped data follows + }] + #todo - test if supplied zipfile has #modpod-loadcript.tcl or some other script/executable before even creating? + append mount_stub \x1A + modpod::system::make_mountable_zip $zipfile $outfile $mount_stub $opt_offsettype + + } + + #*** !doctools + #[list_end] [comment {--- end definitions namespace modpod::lib ---}] +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[section Internal] +namespace eval modpod::system { + #*** !doctools + #[subsection {Namespace modpod::system}] + #[para] Internal functions that are not part of the API + + #deflate,store only supported + + #zipfile here is plain zip - no script/exe prefix part. + proc make_mountable_zip {zipfile outfile mount_stub {offsettype "archive"}} { + set inzip [open $zipfile r] + fconfigure $inzip -encoding iso8859-1 -translation binary + set out [open $outfile w+] + fconfigure $out -encoding iso8859-1 -translation binary + puts -nonewline $out $mount_stub + set stuboffset [tell $out] + lappend report "stub size: $stuboffset" + fcopy $inzip $out + close $inzip + + set size [tell $out] + lappend report "modpod::system::make_mountable_zip" + lappend report "tmfile : [file tail $outfile]" + lappend report "output size : $size" + lappend report "offsettype : $offsettype" + + if {$offsettype eq "file"} { + #make zip offsets relative to start of whole file including prepended script. + #same offset structure as Tcl's older 'zipfs mkimg' as at 2024-10 + #2025 - zipfs mkimg fixed to use 'archive' offset. + #not editable by 7z,nanazip,peazip + + #we aren't adding any new files/folders so we can edit the offsets in place + + #Now seek in $out to find the end of directory signature: + #The structure itself is 24 bytes Long, followed by a maximum of 64Kbytes text + if {$size < 65559} { + set tailsearch_start 0 + } else { + set tailsearch_start [expr {$size - 65559}] + } + seek $out $tailsearch_start + set data [read $out] + #EOCD - End of Central Directory record + #PK\5\6 + set start_of_end [string last "\x50\x4b\x05\x06" $data] + #set start_of_end [expr {$start_of_end + $seek}] + #incr start_of_end $seek + set filerelative_eocd_posn [expr {$start_of_end + $tailsearch_start}] + + lappend report "kitfile-relative START-OF-EOCD: $filerelative_eocd_posn" + + seek $out $filerelative_eocd_posn + set end_of_ctrl_dir [read $out] + binary scan $end_of_ctrl_dir issssiis eocd(signature) eocd(disknbr) eocd(ctrldirdisk) \ + eocd(numondisk) eocd(totalnum) eocd(dirsize) eocd(diroffset) eocd(comment_len) + + lappend report "End of central directory: [array get eocd]" + seek $out [expr {$filerelative_eocd_posn+16}] + + #adjust offset of start of central directory by the length of our sfx stub + puts -nonewline $out [binary format i [expr {$eocd(diroffset) + $stuboffset}]] + flush $out + + seek $out $filerelative_eocd_posn + set end_of_ctrl_dir [read $out] + binary scan $end_of_ctrl_dir issssiis eocd(signature) eocd(disknbr) eocd(ctrldirdisk) \ + eocd(numondisk) eocd(totalnum) eocd(dirsize) eocd(diroffset) eocd(comment_len) + + # 0x06054b50 - end of central dir signature + puts stderr "$end_of_ctrl_dir" + puts stderr "comment_len: $eocd(comment_len)" + puts stderr "eocd sig: $eocd(signature) [punk::lib::dec2hex $eocd(signature)]" + lappend report "New dir offset: $eocd(diroffset)" + lappend report "Adjusting $eocd(totalnum) zip file items." + catch { + punk::lib::showdict -roottype list -chan stderr $report ;#heavy dependencies + } + + seek $out $eocd(diroffset) + for {set i 0} {$i <$eocd(totalnum)} {incr i} { + set current_file [tell $out] + set fileheader [read $out 46] + puts -------------- + puts [ansistring VIEW -lf 1 $fileheader] + puts -------------- + #binary scan $fileheader is2sss2ii2s3ssii x(sig) x(version) x(flags) x(method) \ + # x(date) x(crc32) x(sizes) x(lengths) x(diskno) x(iattr) x(eattr) x(offset) + + binary scan $fileheader ic4sss2ii2s3ssii x(sig) x(version) x(flags) x(method) \ + x(date) x(crc32) x(sizes) x(lengths) x(diskno) x(iattr) x(eattr) x(offset) + set ::last_header $fileheader + + puts "sig: $x(sig) (hex: [punk::lib::dec2hex $x(sig)])" + puts "ver: $x(version)" + puts "method: $x(method)" + + #PK\1\2 + #33639248 dec = 0x02014b50 - central directory file header signature + if { $x(sig) != 33639248 } { + error "modpod::system::make_mountable_zip Bad file header signature at item $i: dec:$x(sig) hex:[punk::lib::dec2hex $x(sig)]" + } + + foreach size $x(lengths) var {filename extrafield comment} { + if { $size > 0 } { + set x($var) [read $out $size] + } else { + set x($var) "" + } + } + set next_file [tell $out] + lappend report "file $i: $x(offset) $x(sizes) $x(filename)" + + seek $out [expr {$current_file+42}] + puts -nonewline $out [binary format i [expr {$x(offset)+$stuboffset}]] + + #verify: + flush $out + seek $out $current_file + set fileheader [read $out 46] + lappend report "old $x(offset) + $stuboffset" + binary scan $fileheader is2sss2ii2s3ssii x(sig) x(version) x(flags) x(method) \ + x(date) x(crc32) x(sizes) x(lengths) x(diskno) x(iattr) x(eattr) x(offset) + lappend report "new $x(offset)" + + seek $out $next_file + } + } + + close $out + #pdict/showdict reuire punk & textlib - ie lots of dependencies + #don't fall over just because of that + catch { + punk::lib::showdict -roottype list -chan stderr $report + } + #puts [join $report \n] + return + } + + proc connect_if_not {{podpath ""}} { + upvar ::modpod::connected connected + set podpath [::modpod::system::normalize $podpath] + set docon 0 + if {![llength $connected(to)]} { + if {![string length $podpath]} { + error "modpod::system::connect_if_not - Not connected to a modpod file, and no podpath specified" + } else { + set docon 1 + } + } else { + if {![string length $podpath]} { + set podpath [lindex $connected(to) end] + puts stderr "modpod::system::connect_if_not WARNING: using last connected modpod:$podpath for operation\n -podpath not explicitly specified during operation: [info level -1]" + } else { + if {$podpath ni $connected(to)} { + set docon 1 + } + } + } + if {$docon} { + if {[lindex [modpod::connect $podpath]] 0] ne "ok"} { + error "modpod::system::connect_if_not error. file $podpath does not seem to be a valid modpod" + } else { + return $podpath + } + } + #we were already connected + return $podpath + } + + proc myversion {} { + upvar ::modpod::connected connected + set script [info script] + if {![string length $script]} { + error "No result from \[info script\] - modpod::system::myversion should only be called from within a loading modpod" + } + set fname [file tail [file rootname [file normalize $script]]] + set scriptdir [file dirname $script] + + if {![string match "#modpod-*" $fname]} { + lassign [lrange [split $fname -] end-1 end] _pkgname version + } else { + lassign [scan [file tail [file rootname $script]] {#modpod-loadscript-%[a-z]-%s}] _pkgname version + if {![string length $version]} { + #try again on the name of the containing folder + lassign [scan [file tail $scriptdir] {#modpod-%[a-z]-%s}] _pkgname version + #todo - proper walk up the directory tree + if {![string length $version]} { + #try again on the grandparent folder (this is a standard depth for sourced .tcl files in a modpod) + lassign [scan [file tail [file dirname $scriptdir]] {#modpod-%[a-z]-%s}] _pkgname version + } + } + } + + #tarjar::Log debug "'myversion' determined version for [info script]: $version" + return $version + } + + proc myname {} { + upvar ::modpod::connected connected + set script [info script] + if {![string length $script]} { + error "No result from \[info script\] - modpod::system::myname should only be called from within a loading modpod" + } + return $connected(fullpackage,$script) + } + proc myfullname {} { + upvar ::modpod::connected connected + set script [info script] + #set script [::tarjar::normalize $script] + set script [file normalize $script] + if {![string length $script]} { + error "No result from \[info script\] - modpod::system::myfullname should only be called from within a loading tarjar" + } + return $::tarjar::connected(fullpackage,$script) + } + proc normalize {path} { + #newer versions of Tcl don't do tilde sub + + #Tcl's 'file normalize' seems to do some unfortunate tilde substitution on windows.. (at least for relative paths) + # we take the assumption here that if Tcl's tilde substitution is required - it should be done before the path is provided to this function. + set matilda "<_tarjar_tilde_placeholder_>" ;#token that is *unlikely* to occur in the wild, and is somewhat self describing in case it somehow ..escapes.. + set path [string map [list ~ $matilda] $path] ;#give our tildes to matilda to look after + set path [file normalize $path] + #set path [string tolower $path] ;#must do this after file normalize + return [string map [list $matilda ~] $path] ;#get our tildes back. +} +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Ready +package provide modpod [namespace eval modpod { + variable pkg modpod + variable version + set version 0.1.5 +}] +return + +#*** !doctools +#[manpage_end] + diff --git a/src/vfs/_vfscommon.vfs/modules/modpodtest-0.1.1.tm b/src/vfs/_vfscommon.vfs/modules/modpodtest-0.1.1.tm new file mode 100644 index 0000000000000000000000000000000000000000..be64f8636784b318c482acf3fe743e6f4c4042be GIT binary patch literal 9410 zcmcgx30MFBY}9qg5#=bw{gKQE`L++(`ln34Hzf|IZ&EpTNw$=brUF?>)3fIv<;P z5(N@Tq$G-wFp(%&AVpG&5RyuyP?8E#E+mCcXbSnYN}?obM8X<)6`_(y8HpUhUJ*S6 zQA!joqIoUR62S(6ioszC z3kx$U60`^>7U(n2O~nlvYS347;*HpktUO0aziL zx-hDSkP2thfhGkEM3|4fj71l_j?G}Hl$47B1#J0Y$ioAJ&Q`34r_*Z6~%@R6-oiwnGvEr>C?#JH*2gX4|A7Ewx)fclRG z%}_jEY-by5->lNH$Ge$&dV<;7b z%di+^Ybe+d?eSUID0YjEH7u5DwAV@uGjIpqtyim|YWTL*D|L+`O+99-e`Xk4u8oD) zx3J_e#N%NL z@m|C>07?Xno8>eJC<|CF#7su}NU7#pMr~u$2G>kD9I4?)&T5CV+Qd5~>MIiF469&0 zDRhKTU^az2p|+72oRNq~DFmYVoYi#zmZY)KKoAa*QDy%-b=n&UW+TVqp@5Rfpu^IL ztx`(&GVsKueK|1_w5HNC5ju@bY7&IF-qJcru6p$pX?g)}gN)j}K#F+ZZFcX1q zAt@!|Xao#AMj{tdF*H(02?j6_C^yhoIVE>wdlUgC*c;a@I1;mV*a)3hB?JBx2Q3PO zsJ-v(3<1EpsTnME9C!{DLO?v37)lw%@?Aq7sF!T4U!XS#f%>8-5)=+KOpxYbmFw)R zP9?$ z0+H9rUC0?)MWU~ar2!Gl|Vp}FlCqp*o66(E|NFqTVpw*2J`gqv|4j? zzx7P>#>kEVU!@Q$2_efIVcMaDx|RU?0sKSSsX<>Pfg7P3d~qSSe2^i%(5le<8+A-| zGu$wYxOE$}Z0v`I{teTP|CnZaE>H_Z+UT<3z-a$357z`9BF6?z-BY0Th3fno*0S^T zz(yrkYh*;97Ar(EKWQA4h@e5SX`*F1crFAS3pI&N6-GoGQ?>TsIobu}K!MB^x6 z16ZVXwI1CDbBybg{p!5l83~r~m6=Jdh+QDe8VcrCHB)IkCJCd4{M3Zs}ECWDo z9FPI~!P%?c3Q+{3WJdj@Qbi#=OOo*9I{SWC8r9Hcy+e z@U2a3=%A1V>UzV}frthyX6J?KQEijKpB9<4-Ght~unb!P;A*>1T z;lJ-R)ClA>0C3~bv)5$*)}L8&IGnZ|`+iTR-=9h!{LqTSdDe!*apstEv`tLi%ka(7 z(Z$Kt$+f`{TeP3c=ztXirlI@ap_3}((@^PIt(ek1a` zS@0!6F7|a?>5^NItx|GLxY3GR)5S|}d7tcku}T#9Xjj?I@pDs??)==QTpVDPGCiwC*yb})*UqQzdzmbD>lvGx?3wADH?nj4 zZ3)Y}kBqan?{((nA&bMUw-YNyuN&n!Y`C~`(7b6DKZHygk@nE!*>=y^{q0>}%}KuA zspinF4q^7b<*uac;)qxC<7Tz}efh^AOOL>Q4!zqhIPU6LwJB=>6?FWfY9u^|=0Z z#~ZizZtL{r%%20>W!>%i{e%T;mS>$lx~gsH_^N@jm;AJs4~3nj+54R2PYd`yebz=; z-@Ed+pGAnRpY?FZ<);Bo z_c?S+lF@x|LG`Ge-+Giy>Q>sb>Vm@t52qyCWivmoywt_IvhVevv$cb>#&@jy@v{mm zqHJ?zPEx)9ntfYsH|;CV`WQB%SE*HR|HnV2`uzTlQ{8|cXRXfu(2cO~Xc9HhdttrL ztnd-V*Yjhz^NSa`riGrle8;2r$JViAM~5%RjZ0+QdS=G_b+Yq7cV^lAv68?}iri

522ysaeGk3QYpIU*=jl4N~;!y9mogQ~f z*qMD~<&=XfR&R_ok2}7##M5K9IJ9E*we?kxF0R8xJm9}I$E<~7npa;BMQ0KeeKzFGZ_a^s-^vM7T#=Kl#_1}^UJ=tvE{=nycgySPCe4oYqY<3 z^S*#Q+xx}sKHiS;9e+^jCQC2yYE^#k?`J>XO)SYOx-_bKkw0CxvPjWCTe)M&c=HSE zRk;CM%I0$1mYaUFnfvka54CUJd~wW_;Lq&pu=onsGAHe({R6inXA~y1>n}YrI<3s+ zJ#g#GQS>^;?bex)*7Tm;BmeB?${p+C4vrR_o%vMWhuHLFSLxY-7gnTax3PX*ay`4G zXKwzy3w@m@lec0Amk^mAd&GNx8U5VWbJ>Db74Fq*-b}h@&YyVTr=i~7wK-`E7rx!l z&+6srcipESvi)#4An^Np8+`_u-Av0OUwMsmTXUH4FZ^C!EuhCPDh@8s8Bp#z!|iI% zX?YzM3x=BwbDkWx6VF}!Zw zK3kl0@QNf~xY;@U%I&N=zuN8jKU7^iyYqHJK;_ZJ9T>~j>Ep&8pS0o|Mf(e!%2i(C z%6DrE`@MCWF+J5LVB^CRT?S0?n4Nt7tG)hYhk*OjBi`f^kEr!yFK4C<+rryTcL=g9 zpxZco#p8X`Z*KR%n2|m5GOT8QcjMuN5Q8w zGN|x)+fDKBA1AEmq|_v=K6f&4Z<~Ind!O7Uo_ZtT{_)`}_IPgK@Lh zo!B>95$-qTWs0C8%p*9)H^zN`mf5Z4M|OndM_utA=)0Cm?O43w-krG_ujiyZI5l(f z7)SpTe~<1STwu2N^`9p>J-F1f{ zMD{wIoR^-JX|p;;<#_qqudBO^j=ULl>)o~k=LTAjzw`8mtH1f@5wlh0$=CDDuK3(I znDKI$@0ZttXB>{a-C@|{y)$1NYwv0mVETG!-^#64AKsVm8(Yv{aKdb@aBtDR=Y2z_ zAM(w!d))R>?XE@rW`u}+BfIzcyn4i>LtQ#}_UXl!CNH>FlPRfL5mz?Ua!8Wno~wh? zrAO1c?EJRA^UnUs-Iu-nquOJ?XF`s9@Q>Hl6gd`Tp3QtzF~E25!sCTKgUfQ4&M!)P z`0?E9PHF49E{z>hyyE>)R zPgZ!^U5E`0+V!F99ka}(OH8gOom-o`uu$(~EU35)1mvUB;Ailss4=O-5> z^$PayJn?*X&GwHOt|d=pBL~mjB=lW6aF4ykot4l3{Ge(bU36{7{!b`yF!yq;$<)#V z?JC@YUoOm>IcK;3=?^I%uEu!CFRl0C`(ETt?iO`a_F>8+|0S|ivjc;UI@I+&SMI$m z-tUn8`gZv>hd(4*xm&$BU2T0eHpIN*^X-3iOTV(V%ZrE1=Svckt2b|y6+X*l`XfQv zQj1yVT#k7w$7T7Z?^^UK=hcRa(eJ(OC)u@WeeuK032SS&zMx{P>fe~J3m44YpK&|; zL<}){+~z@7?rhp{oj2&hyGzr!llophy>x@c#VEnz)msvF@}K&DnG-hZ{*6!9g7!pl zL)TQiKJe`oW&ix$dBYR_kR0_CthkvSXI`GRv(o1sf5o1-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) Julian Noble 2003-2023 +# +# @@ Meta Begin +# Application overtype 1.7.1 +# Meta platform tcl +# Meta license BSD +# @@ Meta End + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# doctools header +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[manpage_begin overtype_module_overtype 0 1.7.1] +#[copyright "2024"] +#[titledesc {overtype text layout - ansi aware}] [comment {-- Name section and table of contents description --}] +#[moddesc {overtype text layout}] [comment {-- Description at end of page heading --}] +#[require overtype] +#[keywords module text ansi] +#[description] +#[para] - + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section Overview] +#[para] overview of overtype +#[subsection Concepts] +#[para] - + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[subsection dependencies] +#[para] packages used by overtype +#[list_begin itemized] + +package require Tcl 8.6- +package require textutil +package require punk::lib ;#required for lines_as_list +package require punk::ansi ;#required to detect, split, strip and calculate lengths +package require punk::char ;#box drawing - and also unicode character width determination for proper layout of text with double-column-width chars +package require punk::assertion +#*** !doctools +#[item] [package {Tcl 8.6}] +#[item] [package textutil] +#[item] [package punk::ansi] +#[para] - required to detect, split, strip and calculate lengths of text possibly containing ansi codes +#[item] [package punk::char] +#[para] - box drawing - and also unicode character width determination for proper layout of text with double-column-width chars + +# #package require frobz +# #*** !doctools +# #[item] [package {frobz}] + +#*** !doctools +#[list_end] + +#PERFORMANCE notes +#overtype is very performance sensitive - used in ansi output all over the place ie needs to be optimised +#NOTE use of tcl::dict::for tcl::string::range etc instead of ensemble versions. This is for the many tcl 8.6/8.7 interps which don't compile ensemble commands when in safe interps +#similar for tcl::namespace::eval - but this is at least on some versions of Tcl - faster even in a normal interp. Review to see if that holds for Tcl 9. +#for string map: when there are exactly 2 elements - it is faster to use a literal which has a special case optimisation in the c code +#ie use tcl::string::map {\n ""} ... instead of tcl::string::map [list \n ""] ... +#note that we can use unicode (e.g \uFF31) and other escapes such as \t within these curly braces - we don't have to use double quotes +#generally using 'list' is preferred for the map as less error prone. +#can also use: tcl::string::map "token $var" .. but be careful regarding quoting and whitespace in var. This should be used sparingly if at all. + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[section API] + + +#Julian Noble - 2003 +#Released under standard 'BSD license' conditions. +# +#todo - ellipsis truncation indicator for center,right + +#v1.4 2023-07 - naive ansi color handling - todo - fix tcl::string::range +# - need to extract and replace ansi codes? + +tcl::namespace::eval overtype { + namespace import ::punk::assertion::assert + punk::assertion::active true + + namespace path ::punk::lib + + namespace export * + variable default_ellipsis_horizontal "..." ;#fallback + variable default_ellipsis_vertical "..." + tcl::namespace::eval priv { + proc _init {} { + upvar ::overtype::default_ellipsis_horizontal e_h + upvar ::overtype::default_ellipsis_vertical e_v + set e_h [format %c 0x2026] ;#Unicode Horizontal Ellipsis + set e_v [format %c 0x22EE] + #The unicode ellipsis looks more natural than triple-dash which is centred vertically whereas ellipsis is at floorline of text + #Also - unicode ellipsis has semantic meaning that other processors can interpret + #unicode does also provide a midline horizontal ellipsis 0x22EF + + #set e [format %c 0x2504] ;#punk::char::charshort boxd_ltdshhz - Box Drawings Light Triple Dash Horizontal + #if {![catch {package require punk::char}]} { + # set e [punk::char::charshort boxd_ltdshhz] + #} + } + } + priv::_init +} +proc overtype::about {} { + return "Simple text formatting. Author JMN. BSD-License" +} + +tcl::namespace::eval overtype { + variable grapheme_widths [tcl::dict::create] + + variable escape_terminals + #single "final byte" in the range 0x40–0x7E (ASCII @A–Z[\]^_`a–z{|}~). + tcl::dict::set escape_terminals CSI [list @ \\ ^ _ ` | ~ 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 "\{" "\}"] + #tcl::dict::set escape_terminals CSI [list J K m n A B C D E F G s u] ;#basic + tcl::dict::set escape_terminals OSC [list \007 \033\\] ;#note mix of 1 and 2-byte terminals + + #self-contained 2 byte ansi escape sequences - review more? + variable ansi_2byte_codes_dict + set ansi_2byte_codes_dict [tcl::dict::create\ + "reset_terminal" "\u001bc"\ + "save_cursor_posn" "\u001b7"\ + "restore_cursor_posn" "\u001b8"\ + "cursor_up_one" "\u001bM"\ + "NEL - Next Line" "\u001bE"\ + "IND - Down one line" "\u001bD"\ + "HTS - Set Tab Stop" "\u001bH"\ + ] + + #debatable whether strip should reveal the somethinghidden - some terminals don't hide it anyway. + # "PM - Privacy Message" "\u001b^somethinghidden\033\\"\ +} + + + + +proc overtype::string_columns {text} { + if {[punk::ansi::ta::detect $text]} { + #error "error string_columns is for calculating character length of string - ansi codes must be stripped/rendered first e.g with punk::ansi::ansistrip. Alternatively try punk::ansi::printing_length" + set text [punk::ansi::ansistrip $text] + } + return [punk::char::ansifreestring_width $text] +} + +#todo - consider a way to merge overtype::left/centre/right +#These have similar algorithms/requirements - and should be refactored to be argument-wrappers over a function called something like overtype::renderblock +#overtype::renderblock could render the input to a defined (possibly overflowing in x or y) rectangle overlapping the underlay. +#(i.e not even necessariy having it's top left within the underlay) +tcl::namespace::eval overtype::priv { +} + +#could return larger than renderwidth +proc _get_row_append_column {row} { + #obsolete? + upvar outputlines outputlines + set idx [expr {$row -1}] + if {$row <= 1 || $row > [llength $outputlines]} { + return 1 + } else { + upvar opt_expand_right expand_right + upvar renderwidth renderwidth + set existinglen [punk::ansi::printing_length [lindex $outputlines $idx]] + set endpos [expr {$existinglen +1}] + if {$expand_right} { + return $endpos + } else { + if {$endpos > $renderwidth} { + return [expr {$renderwidth + 1}] + } else { + return $endpos + } + } + } +} + +tcl::namespace::eval overtype { + #*** !doctools + #[subsection {Namespace overtype}] + #[para] Core API functions for overtype + #[list_begin definitions] + + + + #tcl::string::range should generally be avoided for both undertext and overtext which contain ansi escapes and other cursor affecting chars such as \b and \r + #render onto an already-rendered (ansi already processed) 'underlay' string, a possibly ansi-laden 'overlay' string. + #The underlay and overlay can be multiline blocks of text of varying line lengths. + #The overlay may just be an ansi-colourised block - or may contain ansi cursor movements and cursor save/restore calls - in which case the apparent length and width of the overlay can't be determined as if it was a block of text. + #This is a single-shot rendering of strings - ie there is no way to chain another call containing a cursor-restore to previously rendered output and have it know about any cursor-saves in the first call. + # a cursor start position other than top-left is a possible addition to consider. + #see editbuf in punk::repl for a more stateful ansi-processor. Both systems use loops over overtype::renderline + proc renderspace {args} { + #*** !doctools + #[call [fun overtype::renderspace] [arg args] ] + #[para] usage: ?-transparent [lb]0|1[rb]? ?-expand_right [lb]1|0[rb]? ?-ellipsis [lb]1|0[rb]? ?-ellipsistext ...? undertext overtext + + # @c overtype starting at left (overstrike) + # @c can/should we use something like this?: 'format "%-*s" $len $overtext + variable default_ellipsis_horizontal + + if {[llength $args] < 2} { + error {usage: ?-width ? ?-startcolumn ? ?-transparent [0|1|]? ?-expand_right [1|0]? ?-ellipsis [1|0]? ?-ellipsistext ...? undertext overtext} + } + set optargs [lrange $args 0 end-2] + if {[llength $optargs] % 2 == 0} { + set overblock [lindex $args end] + set underblock [lindex $args end-1] + #lassign [lrange $args end-1 end] underblock overblock + set argsflags [lrange $args 0 end-2] + } else { + set optargs [lrange $args 0 end-1] + if {[llength $optargs] %2 == 0} { + set overblock [lindex $args end] + set underblock "" + set argsflags [lrange $args 0 end-1] + } else { + error "renderspace expects opt-val pairs followed by: or just " + } + } + set opts [tcl::dict::create\ + -bias ignored\ + -width \uFFEF\ + -height \uFFEF\ + -startcolumn 1\ + -ellipsis 0\ + -ellipsistext $default_ellipsis_horizontal\ + -ellipsiswhitespace 0\ + -expand_right 0\ + -appendlines 1\ + -transparent 0\ + -exposed1 \uFFFD\ + -exposed2 \uFFFD\ + -experimental 0\ + -cp437 0\ + -looplimit \uFFEF\ + -crm_mode 0\ + -reverse_mode 0\ + -insert_mode 0\ + -wrap 0\ + -info 0\ + -console {stdin stdout stderr}\ + ] + #expand_right is perhaps consistent with the idea of the page_size being allowed to grow horizontally.. + # it does not necessarily mean the viewport grows. (which further implies need for horizontal scrolling) + # - it does need to be within some concept of terminal width - as columns must be addressable by ansi sequences. + # - This implies the -width option value must grow if it is tied to the concept of renderspace terminal width! REVIEW. + # - further implication is that if expand_right grows the virtual renderspace terminal width - + # then some sort of reflow/rerender needs to be done for preceeding lines? + # possibly not - as expand_right is distinct from a normal terminal-width change event, + # expand_right being primarily to support other operations such as textblock::table + + #todo - viewport width/height as separate concept to terminal width/height? + #-ellipsis args not used if -wrap is true + foreach {k v} $argsflags { + switch -- $k { + -looplimit - -width - -height - -startcolumn - -bias - -ellipsis - -ellipsistext - -ellipsiswhitespace + - -transparent - -exposed1 - -exposed2 - -experimental + - -expand_right - -appendlines + - -reverse_mode - -crm_mode - -insert_mode + - -cp437 + - -info - -console { + tcl::dict::set opts $k $v + } + -wrap - -autowrap_mode { + #temp alias -autowrap_mode for consistency with renderline + #todo - + tcl::dict::set opts -wrap $v + } + default { + error "overtype::renderspace unknown option '$k'. Known options: [tcl::dict::keys $opts]" + } + } + } + #set opts [tcl::dict::merge $defaults $argsflags] + # -- --- --- --- --- --- + #review - expand_left for RTL text? + set opt_expand_right [tcl::dict::get $opts -expand_right] + #for repl - standard output line indicator is a dash - todo, add a different indicator for a continued line. + set opt_width [tcl::dict::get $opts -width] + set opt_height [tcl::dict::get $opts -height] + set opt_startcolumn [tcl::dict::get $opts -startcolumn] + set opt_appendlines [tcl::dict::get $opts -appendlines] + set opt_transparent [tcl::dict::get $opts -transparent] + set opt_ellipsistext [tcl::dict::get $opts -ellipsistext] + set opt_ellipsiswhitespace [tcl::dict::get $opts -ellipsiswhitespace] + set opt_exposed1 [tcl::dict::get $opts -exposed1] ;#widechar_exposed_left - todo + set opt_exposed2 [tcl::dict::get $opts -exposed2] ;#widechar_exposed_right - todo + # -- --- --- --- --- --- + set opt_crm_mode [tcl::dict::get $opts -crm_mode] + set opt_reverse_mode [tcl::dict::get $opts -reverse_mode] + set opt_insert_mode [tcl::dict::get $opts -insert_mode] + ##### + # review -wrap should map onto DECAWM terminal mode - the wrap 2 idea may not fit in with this?. + set opt_autowrap_mode [tcl::dict::get $opts -wrap] + #??? wrap 1 is hard wrap cutting word at exact column, or 1 column early for 2w-glyph, wrap 2 is for language-based word-wrap algorithm (todo) + ##### + # -- --- --- --- --- --- + set opt_cp437 [tcl::dict::get $opts -cp437] + set opt_info [tcl::dict::get $opts -info] + + + + # ---------------------------- + # -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 + } + } + } + # ---------------------------- + + set underblock [tcl::string::map {\r\n \n} $underblock] + set overblock [tcl::string::map {\r\n \n} $overblock] + + + #set underlines [split $underblock \n] + + #underblock is a 'rendered' block - so width height make sense + #only non-cursor affecting and non-width occupying ANSI codes should be present. + #ie SGR codes and perhaps things such as PM - although generally those should have been pushed to the application already + #renderwidth & renderheight were originally used with reference to rendering into a 'column' of output e.g a table column - before cursor row/col was implemented. + + if {$opt_width eq "\uFFEF" || $opt_height eq "\uFFEF"} { + lassign [blocksize $underblock] _w renderwidth _h renderheight + if {$opt_width ne "\uFFEF"} { + set renderwidth $opt_width + } + if {$opt_height ne "\uFFEF"} { + set renderheight $opt_height + } + } else { + set renderwidth $opt_width + set renderheight $opt_height + } + #initial state for renderspace 'terminal' reset + set initial_state [dict create\ + renderwidth $renderwidth\ + renderheight $renderheight\ + crm_mode $opt_crm_mode\ + reverse_mode $opt_reverse_mode\ + insert_mode $opt_insert_mode\ + autowrap_mode $opt_autowrap_mode\ + cp437 $opt_cp437\ + ] + #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 + + # -- --- --- --- + #REVIEW - do we need ansi resets in the underblock? + if {$underblock eq ""} { + set underlines [lrepeat $renderheight ""] + } else { + set underblock [textblock::join_basic -- $underblock] ;#ensure properly rendered - ansi per-line resets & replays + 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] + #} + # -- --- --- --- + + #todo - reconsider the 'line' as the natural chunking mechanism for the overlay. + #In practice an overlay ANSI stream can be a single line with ansi moves/restores etc - or even have no moves or newlines, just relying on wrapping at the output renderwidth + #In such cases - we process the whole shebazzle for the first output line - only reducing by the applied amount at the head each time, reprocessing the long tail each time. + #(in cases where there are interline moves or cursor jumps anyway) + #This works - but doesn't seem efficient. + #On the other hand.. maybe it depends on the data. For simpler files it's more efficient than splitting first + + #a hack until we work out how to avoid infinite loops... + # + set looplimit [tcl::dict::get $opts -looplimit] + if {$looplimit eq "\uFFEF"} { + #looping for each char is worst case (all newlines?) - anything over that is an indication of something broken? + #do we need any margin above the length? (telnet mapscii.me test) + set looplimit [expr {[tcl::string::length $overblock] + 10}] + } + + #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 $overblock] + } + 1 { + set inputchunks [punk::ansi::ta::split_codes $overblock] + } + 2 { + + #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 { + #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 + } + if {[llength $lflines]} { + lset lflines end [tcl::string::range [lindex $lflines end] 0 end-1] + } + #set inputchunks $lflines[unset lflines] + set inputchunks [lindex [list $lflines [unset lflines]] 0] + + } + 4 { + set inputchunks [list] + foreach ln [split $overblock \n] { + lappend inputchunks $ln\n + } + if {[llength $inputchunks]} { + lset inputchunks end [tcl::string::range [lindex $inputchunks end] 0 end-1] + } + } + } + + + + + set replay_codes_underlay [tcl::dict::create 1 ""] + #lappend replay_codes_overlay "" + set replay_codes_overlay "[punk::ansi::a]" + set unapplied "" + set cursor_saved_position [tcl::dict::create] + set cursor_saved_attributes "" + + + 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] + + set loop 0 + #while {$overidx < [llength $inputchunks]} { } + + while {[llength $inputchunks]} { + #set overtext [lindex $inputchunks $overidx]; lset inputchunks $overidx "" + set overtext [lpop inputchunks 0] + if {![tcl::string::length $overtext]} { + incr loop + continue + } + #puts "----->[ansistring VIEW -lf 1 -vt 1 -nul 1 $overtext]<----" + set undertext [lindex $outputlines [expr {$row -1}]] + set renderedrow $row + + #renderline pads each underaly line to width with spaces and should track where end of data is + + + #set overtext [tcl::string::cat [lindex $replay_codes_overlay $overidx] $overtext] + set overtext $replay_codes_overlay$overtext + 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\ + -cp437 $opt_cp437\ + -info 1\ + -crm_mode [tcl::dict::get $vtstate crm_mode]\ + -insert_mode [tcl::dict::get $vtstate insert_mode]\ + -autowrap_mode [tcl::dict::get $vtstate autowrap_mode]\ + -reverse_mode [tcl::dict::get $vtstate reverse_mode]\ + -cursor_restore_attributes $cursor_saved_attributes\ + -transparent $opt_transparent\ + -width [tcl::dict::get $vtstate renderwidth]\ + -exposed1 $opt_exposed1\ + -exposed2 $opt_exposed2\ + -expand_right $opt_expand_right\ + -cursor_column $col\ + -cursor_row $row\ + ] + set rinfo [renderline {*}$renderopts $undertext $overtext] + + set instruction [tcl::dict::get $rinfo instruction] + tcl::dict::set vtstate crm_mode [tcl::dict::get $rinfo crm_mode] + tcl::dict::set vtstate insert_mode [tcl::dict::get $rinfo insert_mode] + tcl::dict::set vtstate autowrap_mode [tcl::dict::get $rinfo autowrap_mode] ;# + tcl::dict::set vtstate reverse_mode [tcl::dict::get $rinfo reverse_mode] + #how to support reverse_mode in rendered linelist? we need to examine all pt/code blocks and flip each SGR stack? + # - review - the answer is probably that we don't need to - it is set/reset only during application of overtext + + #Note carefully the difference betw overflow_right and unapplied. + #overflow_right may need to be included in next run before the unapplied data + #overflow_right most commonly has data when in insert_mode + set rendered [tcl::dict::get $rinfo result] + set overflow_right [tcl::dict::get $rinfo overflow_right] + set overflow_right_column [tcl::dict::get $rinfo overflow_right_column] + set unapplied [tcl::dict::get $rinfo unapplied] + set unapplied_list [tcl::dict::get $rinfo unapplied_list] + set post_render_col [tcl::dict::get $rinfo cursor_column] + set post_render_row [tcl::dict::get $rinfo cursor_row] + set c_saved_pos [tcl::dict::get $rinfo cursor_saved_position] + set c_saved_attributes [tcl::dict::get $rinfo cursor_saved_attributes] + 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] + 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] + set replay_codes_overlay [tcl::dict::get $rinfo replay_codes_overlay] + if {0 && [tcl::dict::get $vtstate reverse_mode]} { + #test branch - todo - prune + puts stderr "---->[ansistring VIEW $replay_codes_overlay] rendered: $rendered" + #review + #JMN3 + set existing_reverse_state 0 + #split_codes_single is single esc sequence - but could have multiple sgr codes within one esc sequence + #e.g \x1b\[0;31;7m has a reset,colour red and reverse + set codeinfo [punk::ansi::codetype::sgr_merge [list $replay_codes_overlay] -info 1] + set codestate_reverse [dict get $codeinfo codestate reverse] + switch -- $codestate_reverse { + 7 { + set existing_reverse_state 1 + } + 27 { + set existing_reverse_state 0 + } + "" { + } + } + if {$existing_reverse_state == 0} { + set rflip [a+ reverse] + } else { + #reverse of reverse + set rflip [a+ noreverse] + } + #note that mergeresult can have multiple esc (due to unmergeables or non sgr codes) + set replay_codes_overlay [punk::ansi::codetype::sgr_merge [list [dict get $codeinfo mergeresult] $rflip]] + puts stderr "---->[ansistring VIEW $replay_codes_overlay] rendered: $rendered" + } + + + + #-- todo - detect looping properly + if {$row > 1 && $overtext ne "" && $unapplied eq $overtext && $post_render_row == $row && $instruction eq ""} { + puts stderr "overtype::renderspace loop?" + puts [ansistring VIEW $rinfo] + break + } + #-- + + if {[tcl::dict::size $c_saved_pos] >= 1} { + set cursor_saved_position $c_saved_pos + set cursor_saved_attributes $c_saved_attributes + } + + + set overflow_handled 0 + + + + set nextprefix "" + + + #todo - handle potential insertion mode as above for cursor restore? + #keeping separate branches for debugging - review and merge as appropriate when stable + set instruction_type [lindex $instruction 0] ;#some instructions have params + tcl::dict::incr instruction_stats $instruction_type + switch -- $instruction_type { + reset { + #reset the 'renderspace terminal' (not underlying terminal) + set row 1 + set col 1 + 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 + if {![llength $unapplied_list]} { + if {$overflow_right ne ""} { + incr row + } + } else { + puts stderr "renderspace end of input line - has unapplied: [ansistring VIEW $unapplied] (review)" + } + set col $opt_startcolumn + } + up { + + #renderline knows it's own line number, and knows not to go above row l + #it knows that a move whilst 1-beyond the width conflicts with the linefeed and reduces the move by one accordingly. + #row returned should be correct. + #column may be the overflow column - as it likes to report that to the caller. + + #Note that an ansi up sequence after last column going up to a previous line and also beyond the last column, will result in the next grapheme going onto the following line. + #this seems correct - as the column remains beyond the right margin so subsequent chars wrap (?) review + #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 + } + down { + if {$data_mode == 0} { + #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]}] + if {$diff > 0} { + lappend outputlines {*}[lrepeat $diff ""] + } + lappend outputlines "" + } + } + set row $post_render_row + set col $post_render_col + } else { + if {$post_render_row > [llength $outputlines]} { + if {$opt_appendlines} { + set diff [expr {$post_render_row - [llength $outputlines]}] + if {$diff > 0} { + lappend outputlines {*}[lrepeat $diff ""] + } + lappend outputlines "" + } + } + 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 + } + + } + } + 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] + #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 + set replay_codes_overlay [tcl::dict::get $rinfo replay_codes_overlay]$cursor_saved_attributes + #set replay_codes_overlay $cursor_saved_attributes + set cursor_saved_position [tcl::dict::create] + set cursor_saved_attributes "" + } else { + #TODO + #?restore without save? + #should move to home position and reset ansi SGR? + #puts stderr "overtype::renderspace cursor_restore without save data available" + } + #If we were inserting prior to hitting the cursor_restore - there could be overflow_right data - generally the overtype functions aren't for inserting - but ansi can enable it + #if we were already in overflow when cursor_restore was hit - it shouldn't have been processed as an action - just stored. + if {!$overflow_handled && $overflow_right ne ""} { + #wrap before restore? - possible effect on saved cursor position + #this overflow data has previously been rendered so has no cursor movements or further save/restore operations etc + #we can just insert another call to renderline to solve this.. ? + #It would perhaps be more properly handled as a queue of instructions from our initial renderline call + #we don't need to worry about overflow next call (?)- but we should carry forward our gx and ansi stacks + + puts stdout ">>>[a+ red bold]overflow_right during restore_cursor[a]" + + set sub_info [overtype::renderline\ + -info 1\ + -width [tcl::dict::get $vtstate renderwidth]\ + -insert_mode [tcl::dict::get $vtstate insert_mode]\ + -autowrap_mode [tcl::dict::get $vtstate autowrap_mode]\ + -expand_right [tcl::dict::get $opts -expand_right]\ + ""\ + $overflow_right\ + ] + set foldline [tcl::dict::get $sub_info result] + tcl::dict::set vtstate insert_mode [tcl::dict::get $sub_info insert_mode] ;#probably not needed..? + tcl::dict::set vtstate autowrap_mode [tcl::dict::get $sub_info autowrap_mode] ;#nor this.. + linsert outputlines $renderedrow $foldline + #review - row & col set by restore - but not if there was no save.. + } + set overflow_handled 1 + + } + move { + ######## + if {$post_render_row > [llength $outputlines]} { + #Ansi moves need to create new lines ? + #if {$opt_appendlines} { + # set diff [expr {$post_render_row - [llength $outputlines]}] + # if {$diff > 0} { + # lappend outputlines {*}[lrepeat $diff ""] + # } + # set row $post_render_row + #} else { + set row [llength $outputlines] + #} + } else { + set row $post_render_row + } + ####### + set col $post_render_col + #overflow + unapplied? + } + clear_and_move { + #e.g 2J + if {$post_render_row > [llength $outputlines]} { + set row [llength $outputlines] + } else { + set row $post_render_row + } + set 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 \000 $renderwidth]\x1b\[0m + if 0 { + + 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"} { + incr numcells 1 + } else { + incr numcells [grapheme_width_cached $grapheme] + } + } + } + + } + } + } + #replays/resets each line + lappend clearedlines \x1b\[0m$replay_codes_overlay[string repeat \000 $numcells]\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] + + } + lf_start { + #raw newlines + # ---------------------- + #test with fruit.ans + #test - treating as newline below... + #append rendered $overflow_right + #set overflow_right "" + set row $renderedrow + incr row + if {$row > [llength $outputlines]} { + lappend outputlines "" + } + set col $opt_startcolumn + # ---------------------- + } + lf_mid { + + set edit_mode 0 + if {$edit_mode} { + set inputchunks [linsert $inputchunks 0 $overflow_right$unapplied] + set overflow_right "" + set unapplied "" + set row $post_render_row + #set col $post_render_col + set col $opt_startcolumn + if {$row > [llength $outputlines]} { + lappend outputlines {*}[lrepeat 1 ""] + } + } 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] + set overflow_right "" + set 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 + } + } + set overflow_right [join $remaining_overflow ""] + } + } + } + } + set row $post_render_row + set col $opt_startcolumn + if {$row > [llength $outputlines]} { + lappend outputlines {*}[lrepeat 1 ""] + } + } 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 ""] + } + } + } + } + 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 + } + + 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 ""] + } + set col $opt_startcolumn + + } + newlines_above { + #we get a newlines_above instruction when received at column 1 + #In some cases we want to treat that as request to insert a new blank line above, and move our row 1 down (staying with the data) + #in other cases - we want to treat at column 1 the same as any other + + 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 + if {$insert_lines_above > 0} { + set row $renderedrow + set outputlines [linsert $outputlines $renderedrow-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 + #? set row $post_render_row #can renderline tell us? + } + } + 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 + # + + + set overflow_right "" + set row $renderedrow + #only add newline if we're at the bottom + if {$row > [llength $outputlines]} { + 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]}] + if {$diff > 0} { + lappend outputlines {*}[lrepeat $diff ""] + } + 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 + } + } + } + } + wrapmoveforward { + #doesn't seem to be used by fruit.ans testfile + #used by dzds.ans + #note that cursor_forward may move deep into the next line - or even span multiple lines !TODO + set c $renderwidth + set r $post_render_row + if {$post_render_col > $renderwidth} { + set i $c + while {$i <= $post_render_col} { + if {$c == $renderwidth+1} { + incr r + if {$opt_appendlines} { + if {$r < [llength $outputlines]} { + lappend outputlines "" + } + } + set c $opt_startcolumn + } else { + incr c + } + incr i + } + set col $c + } else { + #why are we getting this instruction then? + puts stderr "wrapmoveforward - test" + set r [expr {$post_render_row +1}] + set c $post_render_col + } + set row $r + set col $c + } + wrapmovebackward { + set c $renderwidth + set r $post_render_row + if {$post_render_col < 1} { + set c 1 + set i $c + while {$i >= $post_render_col} { + if {$c == 0} { + if {$r > 1} { + incr r -1 + set c $renderwidth + } else { + #leave r at 1 set c 1 + #testfile besthpav.ans first line top left border alignment + set c 1 + break + } + } else { + incr c -1 + } + incr i -1 + } + set col $c + } else { + puts stderr "Wrapmovebackward - but postrendercol >= 1???" + } + set row $r + set col $c + } + overflow { + #normal single-width grapheme overflow + #puts "----normal overflow --- [ansistring VIEWSTYLE -lf 1 -nul 1 -vt 1 $rendered]" + set row $post_render_row ;#renderline will not advance row when reporting overflow char + if {[tcl::dict::get $vtstate autowrap_mode]} { + incr row + set col $opt_startcolumn ;#whether wrap or not - next data is at column 1 ?? + } else { + set col $post_render_col + #set unapplied "" ;#this seems wrong? + #set unapplied [tcl::string::range $unapplied 1 end] + #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' + set idx 0 + set next_grapheme_index -1 + foreach u $unapplied_list { + if {![punk::ansi::ta::detect $u]} { + set next_grapheme_index $idx + break + } + incr idx + } + assert {$next_grapheme_index >= 0} + #drop the overflow grapheme - keeping all codes in place. + set unapplied [join [lreplace $unapplied_list $next_grapheme_index $next_grapheme_index] ""] + #we need to run the reduced unapplied on the same line - further graphemes will just overflow again, but codes or control chars could trigger jumps to other lines + + set overflow_handled 1 + #handled by dropping overflow if any + } + } + overflow_splitchar { + set row $post_render_row ;#renderline will not advance row when reporting overflow char + + #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 + if {[tcl::dict::get $vtstate autowrap_mode]} { + if {$renderwidth < 2} { + #edge case of rendering to a single column output - any 2w char will just cause a loop if we don't substitute with something, or drop the character + set idx 0 + set triggering_grapheme_index -1 + foreach u $unapplied_list { + if {![punk::ansi::ta::detect $u]} { + set triggering_grapheme_index $idx + break + } + incr idx + } + set unapplied [join [lreplace $unapplied_list $triggering_grapheme_index $triggering_grapheme_index $opt_exposed1] ""] + } else { + set col $opt_startcolumn + incr row + } + } else { + set overflow_handled 1 + #handled by dropping entire overflow if any + if {$renderwidth < 2} { + set idx 0 + set triggering_grapheme_index -1 + foreach u $unapplied_list { + if {![punk::ansi::ta::detect $u]} { + set triggering_grapheme_index $idx + break + } + incr idx + } + set unapplied [join [lreplace $unapplied_list $triggering_grapheme_index $triggering_grapheme_index $opt_exposed1] ""] + } + } + + } + vt { + + #can vt add a line like a linefeed can? + set row $post_render_row + set col $post_render_col + } + set_window_title { + set newtitle [lindex $instruction 1] + puts stderr "overtype::renderspace set_window_title [ansistring VIEW $newtitle] instruction '$instruction'" + # + } + reset_colour_palette { + puts stderr "overtype::renderspace instruction '$instruction' unimplemented" + } + default { + puts stderr "overtype::renderspace unhandled renderline instruction '$instruction'" + } + + } + + + if {!$opt_expand_right && ![tcl::dict::get $vtstate autowrap_mode]} { + #not allowed to overflow column or wrap therefore we get overflow data to truncate + if {[tcl::dict::get $opts -ellipsis]} { + set show_ellipsis 1 + if {!$opt_ellipsiswhitespace} { + #we don't want ellipsis if only whitespace was lost + set lostdata "" + if {$overflow_right ne ""} { + append lostdata $overflow_right + } + if {$unapplied ne ""} { + append lostdata $unapplied + } + if {[tcl::string::trim $lostdata] eq ""} { + set show_ellipsis 0 + } + #set lostdata [tcl::string::range $overtext end-[expr {$overflowlength-1}] end] + if {[tcl::string::trim [punk::ansi::ansistrip $lostdata]] eq ""} { + set show_ellipsis 0 + } + } + if {$show_ellipsis} { + set rendered [overtype::right $rendered $opt_ellipsistext] + } + set overflow_handled 1 + } else { + #no wrap - no ellipsis - silently truncate + set overflow_handled 1 + } + } + + + + if {$renderedrow <= [llength $outputlines]} { + lset outputlines [expr {$renderedrow-1}] $rendered + } else { + if {$opt_appendlines} { + lappend outputlines $rendered + } else { + #? + lset outputlines [expr {$renderedrow-1}] $rendered + } + } + + if {!$overflow_handled} { + append nextprefix $overflow_right + } + + append nextprefix $unapplied + + 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] + } + } + } + + if {$nextprefix ne ""} { + set inputchunks [linsert $inputchunks 0 $nextprefix] + } + + + incr overidx + incr loop + if {$loop >= $looplimit} { + puts stderr "overtype::renderspace looplimit reached ($looplimit)" + lappend outputlines "[a+ red bold] - looplimit $looplimit reached[a]" + set Y [a+ yellow bold] + set RST [a] + set sep_header ----DEBUG----- + 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" + tcl::dict::for {k v} $rinfo { + append debugmsg "${Y}$k [ansistring VIEW -lf 1 -vt 1 $v]$RST" \n + } + append debugmsg "${Y}[string repeat - [string length $sep_header]]$RST" \n + + puts stdout $debugmsg + #todo - config regarding error dumps rather than just dumping in working dir + set fd [open [pwd]/error_overtype.txt w] + puts $fd $debugmsg + close $fd + error $debugmsg + break + } + } + + set result [join $outputlines \n] + if {!$opt_info} { + return $result + } else { + #emit to debug window like basictelnet does? make debug configurable as syslog or even a telnet server to allow on 2nd window? + #append result \n$instruction_stats\n + set inforesult [dict create\ + result $result\ + last_instruction $instruction\ + instruction_stats $instruction_stats\ + ] + if {$opt_info == 2} { + return [pdict -channel none inforesult] + } else { + return $inforesult + } + } + } + + #todo - left-right ellipsis ? + proc centre {args} { + variable default_ellipsis_horizontal + if {[llength $args] < 2} { + error {usage: ?-transparent [0|1]? ?-bias [left|right]? ?-overflow [1|0]? undertext overtext} + } + + foreach {underblock overblock} [lrange $args end-1 end] break + + #todo - vertical vs horizontal overflow for blocks + set opts [tcl::dict::create\ + -bias left\ + -ellipsis 0\ + -ellipsistext $default_ellipsis_horizontal\ + -ellipsiswhitespace 0\ + -overflow 0\ + -transparent 0\ + -exposed1 \uFFFD\ + -exposed2 \uFFFD\ + ] + set argsflags [lrange $args 0 end-2] + foreach {k v} $argsflags { + switch -- $k { + -bias - -ellipsis - -ellipsistext - -ellipsiswhitespace - -overflow - -transparent - -exposed1 - -exposed2 { + tcl::dict::set opts $k $v + } + default { + set known_opts [tcl::dict::keys $opts] + error "overtype::centre unknown option '$k'. Known options: $known_opts" + } + } + } + #set opts [tcl::dict::merge $defaults $argsflags] + # -- --- --- --- --- --- + set opt_transparent [tcl::dict::get $opts -transparent] + set opt_ellipsis [tcl::dict::get $opts -ellipsis] + set opt_ellipsistext [tcl::dict::get $opts -ellipsistext] + set opt_ellipsiswhitespace [tcl::dict::get $opts -ellipsiswhitespace] + set opt_exposed1 [tcl::dict::get $opts -exposed1] + set opt_exposed2 [tcl::dict::get $opts -exposed2] + # -- --- --- --- --- --- + + + set underblock [tcl::string::map {\r\n \n} $underblock] + set overblock [tcl::string::map {\r\n \n} $overblock] + + set underlines [split $underblock \n] + #set renderwidth [tcl::mathfunc::max {*}[lmap v $underlines {punk::ansi::printing_length $v}]] + lassign [blocksize $underblock] _w renderwidth _h renderheight + set overlines [split $overblock \n] + lassign [blocksize $overblock] _w overblock_width _h overblock_height + set under_exposed_max [expr {$renderwidth - $overblock_width}] + if {$under_exposed_max > 0} { + #background block is wider + if {$under_exposed_max % 2 == 0} { + #even left/right exposure + set left_exposed [expr {$under_exposed_max / 2}] + } else { + set beforehalf [expr {$under_exposed_max / 2}] ;#1 less than half due to integer division + if {[tcl::string::tolower [tcl::dict::get $opts -bias]] eq "left"} { + set left_exposed $beforehalf + } else { + #bias to the right + set left_exposed [expr {$beforehalf + 1}] + } + } + } else { + set left_exposed 0 + } + + set outputlines [list] + if {[punk::ansi::ta::detect_sgr [lindex $overlines 0]]} { + set replay_codes "[punk::ansi::a]" + } else { + set replay_codes "" + } + set replay_codes_underlay "" + set replay_codes_overlay "" + foreach undertext $underlines overtext $overlines { + set overtext_datalen [punk::ansi::printing_length $overtext] + set ulen [punk::ansi::printing_length $undertext] + if {$ulen < $renderwidth} { + set udiff [expr {$renderwidth - $ulen}] + set undertext "$undertext[string repeat { } $udiff]" + } + set undertext $replay_codes_underlay$undertext + set overtext $replay_codes_overlay$overtext + + set overflowlength [expr {$overtext_datalen - $renderwidth}] + #review - right-to-left langs should elide on left! - extra option required + + if {$overflowlength > 0} { + #overlay line wider or equal + #review - we still expand_right for centred for now.. possibly should do something like -expand_leftright with ellipsis each end? + set rinfo [renderline -info 1 -insert_mode 0 -transparent $opt_transparent -expand_right [tcl::dict::get $opts -overflow] -exposed1 $opt_exposed1 -exposed2 $opt_exposed2 $undertext $overtext] + set rendered [tcl::dict::get $rinfo result] + set overflow_right [tcl::dict::get $rinfo overflow_right] + set unapplied [tcl::dict::get $rinfo unapplied] + #todo - get replay_codes from overflow_right instead of wherever it was truncated? + + #overlay line data is wider - trim if overflow not specified in opts - and overtype an ellipsis at right if it was specified + if {![tcl::dict::get $opts -overflow]} { + #lappend outputlines [tcl::string::range $overtext 0 [expr {$renderwidth - 1}]] + #set overtext [tcl::string::range $overtext 0 $renderwidth-1 ] + if {$opt_ellipsis} { + set show_ellipsis 1 + if {!$opt_ellipsiswhitespace} { + #we don't want ellipsis if only whitespace was lost + #don't use tcl::string::range on ANSI data + #set lostdata [tcl::string::range $overtext end-[expr {$overflowlength-1}] end] + set lostdata "" + if {$overflow_right ne ""} { + append lostdata $overflow_right + } + if {$unapplied ne ""} { + append lostdata $unapplied + } + if {[tcl::string::trim $lostdata] eq ""} { + set show_ellipsis 0 + } + } + if {$show_ellipsis} { + set rendered [overtype::right $rendered $opt_ellipsistext] + } + } + } + lappend outputlines $rendered + #lappend outputlines [renderline -insert_mode 0 -transparent $opt_transparent $undertext $overtext] + } else { + #background block is wider than or equal to data for this line + #lappend outputlines [renderline -insert_mode 0 -startcolumn [expr {$left_exposed + 1}] -transparent $opt_transparent -exposed1 $opt_exposed1 -exposed2 $opt_exposed2 $undertext $overtext] + set rinfo [renderline -info 1 -insert_mode 0 -startcolumn [expr {$left_exposed + 1}] -transparent $opt_transparent -exposed1 $opt_exposed1 -exposed2 $opt_exposed2 $undertext $overtext] + lappend outputlines [tcl::dict::get $rinfo result] + } + set replay_codes_underlay [tcl::dict::get $rinfo replay_codes_underlay] + set replay_codes_overlay [tcl::dict::get $rinfo replay_codes_overlay] + } + return [join $outputlines \n] + } + + #overtype::right is for a rendered ragged underblock and a rendered ragged overblock + #ie we can determine the block width for bost by examining the lines and picking the longest. + # + proc right {args} { + #NOT the same as align-right - which should be done to the overblock first if required + variable default_ellipsis_horizontal + # @d !todo - implement overflow, length checks etc + + if {[llength $args] < 2} { + error {usage: ?-overflow [1|0]? ?-transparent 0|? undertext overtext} + } + foreach {underblock overblock} [lrange $args end-1 end] break + + set opts [tcl::dict::create\ + -bias ignored\ + -ellipsis 0\ + -ellipsistext $default_ellipsis_horizontal\ + -ellipsiswhitespace 0\ + -overflow 0\ + -transparent 0\ + -exposed1 \uFFFD\ + -exposed2 \uFFFD\ + -align "left"\ + ] + set argsflags [lrange $args 0 end-2] + tcl::dict::for {k v} $argsflags { + switch -- $k { + -bias - -ellipsis - -ellipsistext - -ellipsiswhitespace - -overflow - -transparent - -exposed1 - -exposed2 - -align { + tcl::dict::set opts $k $v + } + default { + set known_opts [tcl::dict::keys $opts] + error "overtype::centre unknown option '$k'. Known options: $known_opts" + } + } + } + #set opts [tcl::dict::merge $defaults $argsflags] + # -- --- --- --- --- --- + set opt_transparent [tcl::dict::get $opts -transparent] + set opt_ellipsis [tcl::dict::get $opts -ellipsis] + set opt_ellipsistext [tcl::dict::get $opts -ellipsistext] + set opt_ellipsiswhitespace [tcl::dict::get $opts -ellipsiswhitespace] + set opt_overflow [tcl::dict::get $opts -overflow] + set opt_exposed1 [tcl::dict::get $opts -exposed1] + set opt_exposed2 [tcl::dict::get $opts -exposed2] + set opt_align [tcl::dict::get $opts -align] + # -- --- --- --- --- --- + + set underblock [tcl::string::map {\r\n \n} $underblock] + set overblock [tcl::string::map {\r\n \n} $overblock] + + set underlines [split $underblock \n] + lassign [blocksize $underblock] _w renderwidth _h renderheight + set overlines [split $overblock \n] + #set overblock_width [tcl::mathfunc::max {*}[lmap v $overlines {punk::ansi::printing_length $v}]] + lassign [blocksize $overblock] _w overblock_width _h overblock_height + set under_exposed_max [expr {max(0,$renderwidth - $overblock_width)}] + set left_exposed $under_exposed_max + + + + set outputlines [list] + if {[punk::ansi::ta::detect_sgr [lindex $overlines 0]]} { + set replay_codes "[punk::ansi::a]" + } else { + set replay_codes "" + } + set replay_codes_underlay "" + set replay_codes_overlay "" + foreach undertext $underlines overtext $overlines { + set overtext_datalen [punk::ansi::printing_length $overtext] + set ulen [punk::ansi::printing_length $undertext] + if {$ulen < $renderwidth} { + set udiff [expr {$renderwidth - $ulen}] + #puts xxx + append undertext [string repeat { } $udiff] + } + if {$overtext_datalen < $overblock_width} { + set odiff [expr {$overblock_width - $overtext_datalen}] + switch -- $opt_align { + left { + set startoffset 0 + } + right { + set startoffset $odiff + } + default { + set half [expr {$odiff / 2}] + #set lhs [string repeat { } $half] + #set righthalf [expr {$odiff - $half}] ;#remainder - may be one more - so we are biased left + #set rhs [string repeat { } $righthalf] + set startoffset $half + } + } + } else { + set startoffset 0 ;#negative? + } + + set undertext $replay_codes_underlay$undertext + set overtext $replay_codes_overlay$overtext + + set overflowlength [expr {$overtext_datalen - $renderwidth}] + if {$overflowlength > 0} { + #raw overtext wider than undertext column + set rinfo [renderline\ + -info 1\ + -insert_mode 0\ + -transparent $opt_transparent\ + -exposed1 $opt_exposed1 -exposed2 $opt_exposed2\ + -overflow $opt_overflow\ + -startcolumn [expr {1 + $startoffset}]\ + $undertext $overtext] + set replay_codes [tcl::dict::get $rinfo replay_codes] + set rendered [tcl::dict::get $rinfo result] + if {!$opt_overflow} { + if {$opt_ellipsis} { + set show_ellipsis 1 + if {!$opt_ellipsiswhitespace} { + #we don't want ellipsis if only whitespace was lost + set lostdata [tcl::string::range $overtext end-[expr {$overflowlength-1}] end] + if {[tcl::string::trim $lostdata] eq ""} { + set show_ellipsis 0 + } + } + if {$show_ellipsis} { + set ellipsis $replay_codes$opt_ellipsistext + #todo - overflow on left if allign = right?? + set rendered [overtype::right $rendered $ellipsis] + } + } + } + lappend outputlines $rendered + } else { + #padded overtext + #lappend outputlines [renderline -insert_mode 0 -transparent $opt_transparent -startcolumn [expr {$left_exposed + 1}] $undertext $overtext] + #Note - we still need overflow(exapnd_right) here - as although the overtext is short - it may oveflow due to the startoffset + set rinfo [renderline -info 1 -insert_mode 0 -transparent $opt_transparent -expand_right $opt_overflow -startcolumn [expr {$left_exposed + 1 + $startoffset}] $undertext $overtext] + lappend outputlines [tcl::dict::get $rinfo result] + } + set replay_codes [tcl::dict::get $rinfo replay_codes] + set replay_codes_underlay [tcl::dict::get $rinfo replay_codes_underlay] + set replay_codes_overlay [tcl::dict::get $rinfo replay_codes_overlay] + } + + return [join $outputlines \n] + } + + proc left {args} { + overtype::block -blockalign left {*}$args + } + #overtype a (possibly ragged) underblock with a (possibly ragged) overblock + proc block {args} { + variable default_ellipsis_horizontal + # @d !todo - implement overflow, length checks etc + + if {[llength $args] < 2} { + error {usage: ?-blockalign left|centre|right? ?-textalign left|centre|right? ?-overflow [1|0]? ?-transparent 0|? undertext overtext} + } + #foreach {underblock overblock} [lrange $args end-1 end] break + lassign [lrange $args end-1 end] underblock overblock + + set opts [tcl::dict::create\ + -ellipsis 0\ + -ellipsistext $default_ellipsis_horizontal\ + -ellipsiswhitespace 0\ + -overflow 0\ + -transparent 0\ + -exposed1 \uFFFD\ + -exposed2 \uFFFD\ + -textalign "left"\ + -textvertical "top"\ + -blockalign "left"\ + -blockalignbias left\ + -blockvertical "top"\ + ] + set argsflags [lrange $args 0 end-2] + tcl::dict::for {k v} $argsflags { + switch -- $k { + -blockalignbias - -ellipsis - -ellipsistext - -ellipsiswhitespace - -overflow - -transparent - -exposed1 - -exposed2 - -textalign - -blockalign - -blockvertical { + tcl::dict::set opts $k $v + } + default { + error "overtype::block unknown option '$k'. Known options: [tcl::dict::keys $opts]" + } + } + } + # -- --- --- --- --- --- + set opt_transparent [tcl::dict::get $opts -transparent] + set opt_ellipsis [tcl::dict::get $opts -ellipsis] + set opt_ellipsistext [tcl::dict::get $opts -ellipsistext] + set opt_ellipsiswhitespace [tcl::dict::get $opts -ellipsiswhitespace] + set opt_overflow [tcl::dict::get $opts -overflow] + set opt_exposed1 [tcl::dict::get $opts -exposed1] + set opt_exposed2 [tcl::dict::get $opts -exposed2] + set opt_textalign [tcl::dict::get $opts -textalign] + set opt_blockalign [tcl::dict::get $opts -blockalign] + if {$opt_blockalign eq "center"} { + set opt_blockalign "centre" + } + # -- --- --- --- --- --- + + set underblock [tcl::string::map {\r\n \n} $underblock] + set overblock [tcl::string::map {\r\n \n} $overblock] + + set underlines [split $underblock \n] + lassign [blocksize $underblock] _w renderwidth _h renderheight + set overlines [split $overblock \n] + #set overblock_width [tcl::mathfunc::max {*}[lmap v $overlines {punk::ansi::printing_length $v}]] + lassign [blocksize $overblock] _w overblock_width _h overblock_height + set under_exposed_max [expr {max(0,$renderwidth - $overblock_width)}] + + switch -- $opt_blockalign { + left { + set left_exposed 0 + } + right { + set left_exposed $under_exposed_max + } + centre { + if {$under_exposed_max > 0} { + #background block is wider + if {$under_exposed_max % 2 == 0} { + #even left/right exposure + set left_exposed [expr {$under_exposed_max / 2}] + } else { + set beforehalf [expr {$under_exposed_max / 2}] ;#1 less than half due to integer division + if {[tcl::string::tolower [tcl::dict::get $opts -blockalignbias]] eq "left"} { + set left_exposed $beforehalf + } else { + #bias to the right + set left_exposed [expr {$beforehalf + 1}] + } + } + } else { + set left_exposed 0 + } + } + default { + set left_exposed 0 + } + } + + + + set outputlines [list] + if {[punk::ansi::ta::detect_sgr [lindex $overlines 0]]} { + set replay_codes "[punk::ansi::a]" + } else { + set replay_codes "" + } + set replay_codes_underlay "" + set replay_codes_overlay "" + foreach undertext $underlines overtext $overlines { + set overtext_datalen [punk::ansi::printing_length $overtext] + set ulen [punk::ansi::printing_length $undertext] + if {$ulen < $renderwidth} { + set udiff [expr {$renderwidth - $ulen}] + #puts xxx + append undertext [string repeat { } $udiff] + } + if {$overtext_datalen < $overblock_width} { + set odiff [expr {$overblock_width - $overtext_datalen}] + switch -- $opt_textalign { + left { + set startoffset 0 + } + right { + set startoffset $odiff + } + default { + set half [expr {$odiff / 2}] + #set lhs [string repeat { } $half] + #set righthalf [expr {$odiff - $half}] ;#remainder - may be one more - so we are biased left + #set rhs [string repeat { } $righthalf] + set startoffset $half + } + } + } else { + set startoffset 0 ;#negative? + } + + set undertext $replay_codes_underlay$undertext + set overtext $replay_codes_overlay$overtext + + set overflowlength [expr {$overtext_datalen - $renderwidth}] + if {$overflowlength > 0} { + #raw overtext wider than undertext column + set rinfo [renderline -info 1 -insert_mode 0 -transparent $opt_transparent -exposed1 $opt_exposed1 -exposed2 $opt_exposed2 -expand_right $opt_overflow -startcolumn [expr {1 + $startoffset}] $undertext $overtext] + set replay_codes [tcl::dict::get $rinfo replay_codes] + set rendered [tcl::dict::get $rinfo result] + set overflow_right [tcl::dict::get $rinfo overflow_right] + set unapplied [tcl::dict::get $rinfo unapplied] + if {!$opt_overflow} { + if {$opt_ellipsis} { + set show_ellipsis 1 + if {!$opt_ellipsiswhitespace} { + #we don't want ellipsis if only whitespace was lost + #don't use tcl::string::range on ANSI data + #set lostdata [tcl::string::range $overtext end-[expr {$overflowlength-1}] end] + set lostdata "" + if {$overflow_right ne ""} { + append lostdata $overflow_right + } + if {$unapplied ne ""} { + append lostdata $unapplied + } + if {[tcl::string::trim $lostdata] eq ""} { + set show_ellipsis 0 + } + } + if {$show_ellipsis} { + set rendered [overtype::block -blockalign right $rendered $opt_ellipsistext] + } + } + + #if {$opt_ellipsis} { + # set show_ellipsis 1 + # if {!$opt_ellipsiswhitespace} { + # #we don't want ellipsis if only whitespace was lost + # set lostdata [tcl::string::range $overtext end-[expr {$overflowlength-1}] end] + # if {[tcl::string::trim $lostdata] eq ""} { + # set show_ellipsis 0 + # } + # } + # if {$show_ellipsis} { + # set ellipsis [tcl::string::cat $replay_codes $opt_ellipsistext] + # #todo - overflow on left if allign = right?? + # set rendered [overtype::right $rendered $ellipsis] + # } + #} + } + lappend outputlines $rendered + } else { + #padded overtext + #lappend outputlines [renderline -insert_mode 0 -transparent $opt_transparent -startcolumn [expr {$left_exposed + 1}] $undertext $overtext] + #Note - we still need expand_right here - as although the overtext is short - it may oveflow due to the startoffset + set rinfo [renderline -info 1 -insert_mode 0 -transparent $opt_transparent -expand_right $opt_overflow -startcolumn [expr {$left_exposed + 1 + $startoffset}] $undertext $overtext] + #puts stderr "--> [ansistring VIEW -lf 1 -nul 1 $rinfo] <--" + set overflow_right [tcl::dict::get $rinfo overflow_right] + set unapplied [tcl::dict::get $rinfo unapplied] + lappend outputlines [tcl::dict::get $rinfo result] + } + set replay_codes [tcl::dict::get $rinfo replay_codes] + set replay_codes_underlay [tcl::dict::get $rinfo replay_codes_underlay] + set replay_codes_overlay [tcl::dict::get $rinfo replay_codes_overlay] + } + + return [join $outputlines \n] + } + + variable optimise_ptruns 10 ;# can be set to zero to disable the ptruns branches + + # ## ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### + # renderline written from a left-right line orientation perspective as a first-shot at getting something useful. + # ultimately right-to-left, top-to-bottom and bottom-to-top are probably needed. + # ## ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### + # + # + #-returnextra enables returning of overflow and length + #review - use punk::ansi::ta::detect to short-circuit processing and do simpler string calcs as an optimisation? + #review - DECSWL/DECDWL double width line codes - very difficult/impossible to align and compose with other elements + #(could render it by faking it with sixels and a lot of work - find/make a sixel font and ensure it's exactly 2 cols per char? + # This would probably be impractical to support for different fonts) + #todo - review transparency issues with single/double width characters + #bidi - need a base direction and concept of directional runs for RTL vs LTR - may be best handled at another layer? + proc renderline {args} { + #*** !doctools + #[call [fun overtype::renderline] [arg args] ] + #[para] renderline is the core engine for overtype string processing (frames & textblocks), and the raw mode commandline repl for the Tcl Punk Shell + #[para] It is also a central part of an ansi (micro) virtual terminal-emulator of sorts + #[para] This system does a half decent job at rendering 90's ANSI art to manipulable colour text blocks that can be joined & framed for layout display within a unix or windows terminal + #[para] Renderline helps maintain ANSI text styling reset/replay codes so that the styling of one block doesn't affect another. + #[para] Calling on the punk::ansi library - it can coalesce codes to keep the size down. + #[para] It is a giant mess of doing exactly what common wisdom says not to do... lots at once. + #[para] renderline is part of the Unicode and ANSI aware Overtype system which 'renders' a block of text onto a static underlay + #[para] The underlay is generally expected to be an ordered set of lines or a rectangular text block analogous to a terminal screen - but it can also be ragged in line length, or just blank. + #[para] The overlay couuld be similar - in which case it may often be used to overwrite a column or section of the underlay. + #[para] The overlay could however be a sequence of ANSI-laden text that jumps all over the place. + # + #[para] renderline itself only deals with a single line - or sometimes a single character. It is generally called from a loop that does further terminal-like or textblock processing. + #[para] By suppyling the -info 1 option - it can return various fields indicating the state of the render. + #[para] The main 3 are the result, overflow_right, and unapplied. + #[para] Renderline handles cursor movements from either keystrokes or ANSI sequences but for a full system the aforementioned loop will need to be in place to manage the set of lines under manipulation. + + #puts stderr "renderline '$args'" + variable optimise_ptruns + + if {[llength $args] < 2} { + error {usage: ?-info 0|1? ?-startcolumn ? ?-cursor_column ? ?-cursor_row |""? ?-transparent [0|1|]? ?-expand_right [1|0]? undertext overtext} + } + set under [lindex $args end-1] + set over [lindex $args end] + #lassign [lrange $args end-1 end] under over + if {[string last \n $under] >= 0} { + error "overtype::renderline not allowed to contain newlines in undertext" + } + #if {[string first \n $over] >=0 || [string first \n $under] >= 0} { + # error "overtype::renderline not allowed to contain newlines" + #} + + #generally faster to create a new dict in the proc than to use a namespace variable to create dict once and link to variable (2024 8.6/8.7) + set opts [tcl::dict::create\ + -etabs 0\ + -width \uFFEF\ + -expand_right 0\ + -transparent 0\ + -startcolumn 1\ + -cursor_column 1\ + -cursor_row ""\ + -insert_mode 1\ + -crm_mode 0\ + -autowrap_mode 1\ + -reverse_mode 0\ + -info 0\ + -exposed1 \uFFFD\ + -exposed2 \uFFFD\ + -cursor_restore_attributes ""\ + -cp437 0\ + -experimental {}\ + ] + #-cursor_restore_attributes only - for replay stack - position and actual setting/restoring handled by throwback to caller + + #cursor_row, when numeric will allow detection of certain row moves that are still within our row - allowing us to avoid an early return + #An empty string for cursor_row tells us we have no info about our own row context, and to return with an unapplied string if any row move occurs + + #exposed1 and exposed2 for first and second col of underying 2wide char which is truncated by transparency, currsor movements to 2nd charcol, or overflow/expand_right + #todo - return info about such grapheme 'cuts' in -info structure and/or create option to raise an error + + 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 + - -crm_mode - -insert_mode - -autowrap_mode - -reverse_mode + - -info - -exposed1 - -exposed2 - -cursor_restore_attributes { + tcl::dict::set opts $k $v + } + default { + error "overtype::renderline unknown option '$k'. Known options: [tcl::dict::keys $opts]" + } + } + } + # -- --- --- --- --- --- --- --- --- --- --- --- + set opt_width [tcl::dict::get $opts -width] + set opt_etabs [tcl::dict::get $opts -etabs] + set opt_expand_right [tcl::dict::get $opts -expand_right] + set opt_colstart [tcl::dict::get $opts -startcolumn] ;#lhs limit for overlay - an offset to cursor_column - first visible column is 1. 0 or < 0 are before the start of the underlay + set opt_colcursor [tcl::dict::get $opts -cursor_column];#start cursor column relative to overlay + set opt_row_context [tcl::dict::get $opts -cursor_row] + if {[string length $opt_row_context]} { + if {![tcl::string::is integer -strict $opt_row_context] || $opt_row_context <1 } { + error "overtype::renderline -cursor_row must be empty for unspecified/unknown or a non-zero positive integer. received: '$opt_row_context'" + } + } + # -- --- --- --- --- --- --- --- --- --- --- --- + #The _mode flags correspond to terminal modes that can be set/reset via escape sequences (e.g DECAWM wraparound mode) + set opt_insert_mode [tcl::dict::get $opts -insert_mode];#should usually be 1 for each new line in editor mode but must be initialised to 1 externally (review) + #default is for overtype + # -- --- --- --- --- --- --- --- --- --- --- --- + set opt_autowrap_mode [tcl::dict::get $opts -autowrap_mode] ;#DECAWM - char or movement can go beyond leftmost/rightmost col to prev/next line + set opt_reverse_mode [tcl::dict::get $opts -reverse_mode] ;#DECSNM + set opt_crm_mode [tcl::dict::get $opts -crm_mode];# CRM - show control character mode + # -- --- --- --- --- --- --- --- --- --- --- --- + set temp_cursor_saved [tcl::dict::get $opts -cursor_restore_attributes] + + set cp437_glyphs [tcl::dict::get $opts -cp437] + set cp437_map [tcl::dict::create] + if {$cp437_glyphs} { + set cp437_map [set ::punk::ansi::cp437_map] + #for cp437 images we need to map these *after* splitting ansi + #some old files might use newline for its glyph.. but we can't easily support that. + #Not sure how old files did it.. maybe cr lf in sequence was newline and any lone cr or lf were displayed as glyphs? + tcl::dict::unset cp437_map \n + } + + set opt_transparent [tcl::dict::get $opts -transparent] + if {$opt_transparent eq "0"} { + set do_transparency 0 + } else { + set do_transparency 1 + if {$opt_transparent eq "1"} { + set opt_transparent {[\s]} + } + } + # -- --- --- --- --- --- --- --- --- --- --- --- + set opt_returnextra [tcl::dict::get $opts -info] + # -- --- --- --- --- --- --- --- --- --- --- --- + set opt_exposed1 [tcl::dict::get $opts -exposed1] + set opt_exposed2 [tcl::dict::get $opts -exposed2] + # -- --- --- --- --- --- --- --- --- --- --- --- + + if {$opt_row_context eq ""} { + set cursor_row 1 + } else { + set cursor_row $opt_row_context + } + + set insert_mode $opt_insert_mode ;#default 1 + set autowrap_mode $opt_autowrap_mode ;#default 1 + set crm_mode $opt_crm_mode ;#default 0 (Show Control Character mode) + set reverse_mode $opt_reverse_mode + + #----- + # + if {[info exists punk::console::tabwidth]} { + #punk console is updated if punk::console::set_tabstop_width is used or rep is started/restarted + #It is way too slow to test the current width by querying the terminal here - so it could conceivably get out of sync + #todo - we also need to handle the new threaded repl where console config is in a different thread. + # - also - concept of sub-regions being mini-consoles with their own settings - 'id' for console, or use in/out channels as id? + set tw $::punk::console::tabwidth + } else { + set tw 8 + } + + set overdata $over + if {!$cp437_glyphs} { + #REVIEW! tabify will give different answers for an ANSI colourised string vs plain text + if {!$opt_etabs} { + if {[string first \t $under] >= 0} { + #set under [textutil::tabify::untabify2 $under] + set under [textutil::tabify::untabifyLine $under $tw] + } + if {[string first \t $over] >= 0} { + #set overdata [textutil::tabify::untabify2 $over] + set overdata [textutil::tabify::untabifyLine $over $tw] + } + } + } + #------- + + #ta_detect ansi and do simpler processing? + + #we repeat tests for grapheme width in different loops - rather than create another datastructure to store widths based on column, + #we'll use the grapheme_width_cached function as a lookup table of all graphemes encountered - as there will often be repeats in different positions anyway. + + # -- --- --- --- --- --- --- --- + if {$under ne ""} { + if {[punk::ansi::ta::detect $under]} { + set undermap [punk::ansi::ta::split_codes_single $under] + } else { + #single plaintext part + set undermap [list $under] + } + } else { + set undermap [list] + } + set understacks [list] + set understacks_gx [list] + set pm_list [list] + + set i_u -1 ;#underlay may legitimately be empty + set undercols [list] + set u_codestack [list] + #u_gx_stack probably isn't really a stack - I don't know if g0 g1 can stack or not - for now we support only g0 anyway + set u_gx_stack [list] ;#separate stack for g0 (g1 g2 g3?) graphics on and off (DEC special graphics) + #set pt_underchars "" ;#for string_columns length calculation for expand_right 0 truncation + set remainder [list] ;#for returnextra + foreach {pt code} $undermap { + #pt = plain text + #append pt_underchars $pt + if {$pt ne ""} { + if {$cp437_glyphs} { + set pt [tcl::string::map $cp437_map $pt] + } + set is_ptrun 0 + if {$optimise_ptruns && [tcl::string::length $pt] >= $optimise_ptruns} { + set p1 [tcl::string::index $pt 0] + set hex [format %x [scan $p1 %c]] ;#punk::char::char_hex + set re [tcl::string::cat {^[} \\U$hex {]+$}] + set is_ptrun [regexp $re $pt] + } + if {$is_ptrun} { + #switch -- $p1 { + # " " - - - _ - ! - @ - # - $ - % - ^ - & - * - = - + - : - . - , - / - | - ? - + # 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 { + # set width 1 + # } + # default { + # if {$p1 eq "\u0000"} { + # #use null as empty cell representation - review + # #use of this will probably collide with some application at some point + # #consider an option to set the empty cell character + # set width 1 + # } else { + # set width [grapheme_width_cached $p1] ;# when zero??? + # } + # } + #} + set width [grapheme_width_cached $p1] ;# when zero??? + set ptlen [string length $pt] + if {$width <= 1} { + #review - 0 and 1? + incr i_u $ptlen + lappend understacks {*}[lrepeat $ptlen $u_codestack] + lappend understacks_gx {*}[lrepeat $ptlen $u_gx_stack] + lappend undercols {*}[lrepeat $ptlen $p1] + } else { + incr i_u $ptlen ;#2nd col empty str - so same as above + set 2ptlen [expr {$ptlen * 2}] + lappend understacks {*}[lrepeat $2ptlen $u_codestack] + lappend understacks_gx {*}[lrepeat $2ptlen $u_gx_stack] + set l [concat {*}[lrepeat $ptlen [list $p1 ""]]] + lappend undercols {*}$l + unset l + } + + } else { + foreach grapheme [punk::char::grapheme_split $pt] { + #an ugly but easy hack to serve *some* common case ascii quickly with byte-compiled literal switch - feels dirty. + #.. but even 0.5uS per char (grapheme_width_cached) adds up quickly when stitching lots of lines together. + #todo - test decimal value instead, compare performance + 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 { + set width 1 + } + default { + if {$grapheme eq "\u0000"} { + #use null as empty cell representation - review + #use of this will probably collide with some application at some point + #consider an option to set the empty cell character + set width 1 + } else { + #zero width still acts as 1 below??? review what should happen + set width [grapheme_width_cached $grapheme] + #we still want most controls and other zero-length codepoints such as \u200d (zero width joiner) to stay zero-length + #we substitute lone ESC that weren't captured within ANSI context as a debugging aid to see malformed ANSI + #todo - default to off and add a flag (?) to enable this substitution + set sub_stray_escapes 0 + if {$sub_stray_escapes && $width == 0} { + if {$grapheme eq "\x1b"} { + set gvis [ansistring VIEW $grapheme] ;#can only use with graphemes that have a single replacement char.. + set grapheme $gvis + set width 1 + } + } + } + } + } + + #set width [grapheme_width_cached $grapheme] + incr i_u + lappend understacks $u_codestack + lappend understacks_gx $u_gx_stack + + lappend undercols $grapheme + if {$width > 1} { + #presumably there are no triple-column or wider unicode chars.. until the aliens arrive.(?) + #but what about emoji combinations etc - can they be wider than 2? + #todo - if -etabs enabled - then we treat \t as the width determined by our elastic tabstop + incr i_u + lappend understacks $u_codestack + lappend understacks_gx $u_gx_stack + lappend undercols "" + } + } + + } + } + #underlay should already have been rendered and not have non-sgr codes - but let's retain the check for them and not stack them if other codes are here + + #only stack SGR (graphics rendition) codes - not title sets, cursor moves etc + #keep any remaining PMs in place + if {$code ne ""} { + set c1c2 [tcl::string::range $code 0 1] + + set leadernorm [tcl::string::range [tcl::string::map [list\ + \x1b\[ 7CSI\ + \x9b 8CSI\ + \x1b\( 7GFX\ + \x1b^ 7PMX\ + \x1bX 7SOS\ + ] $c1c2] 0 3];# leadernorm is 1st 2 chars mapped to normalised indicator - or is original 2 chars + + switch -- $leadernorm { + 7CSI - 8CSI { + #need to exclude certain leaders after the lb e.g < for SGR 1006 mouse + #REVIEW - what else could end in m but be mistaken as a normal SGR code here? + set maybemouse "" + if {[tcl::string::index $c1c2 0] eq "\x1b"} { + set maybemouse [tcl::string::index $code 2] + } + + if {$maybemouse ne "<" && [tcl::string::index $code end] eq "m"} { + if {[punk::ansi::codetype::is_sgr_reset $code]} { + set u_codestack [list "\x1b\[m"] + } elseif {[punk::ansi::codetype::has_sgr_leadingreset $code]} { + set u_codestack [list $code] + } else { + #basic simplification first.. straight dups + set dup_posns [lsearch -all -exact $u_codestack $code] ;#-exact because of square-bracket glob chars + set u_codestack [lremove $u_codestack {*}$dup_posns] + lappend u_codestack $code + } + } + } + 7GFX { + switch -- [tcl::string::index $code 2] { + "0" { + set u_gx_stack [list gx0_on] ;#we'd better use a placeholder - or debugging will probably get into a big mess + } + B { + set u_gx_stack [list] + } + } + } + 7PMX - 7SOS { + #we can have PMs or SOS (start of string) in the underlay - though mostly the PMs should have been processed.. + #attach the PM/SOS (entire ANSI sequence) to the previous grapheme! + #It should not affect the size - but terminal display may get thrown out if terminal doesn't support them. + + #note that there may in theory already be ANSI stored - we don't assume it was a pure grapheme string + set graphemeplus [lindex $undercols end] + if {$graphemeplus ne "\0"} { + append graphemeplus $code + } else { + set graphemeplus $code + } + lset undercols end $graphemeplus + #The grapheme_width_cached function will be called on this later - and doesn't account for ansi. + #we need to manually cache the item with it's proper width + variable grapheme_widths + #stripped and plus version keys pointing to same length + dict set grapheme_widths $graphemeplus [grapheme_width_cached [::punk::ansi::ansistrip $graphemeplus]] + + } + default { + + } + + } + + #if {[punk::ansi::codetype::is_sgr_reset $code]} { + # #set u_codestack [list] + #} elseif {[punk::ansi::codetype::has_sgr_leadingreset $code]} { + #} elseif {[punk::ansi::codetype::is_sgr $code]} { + #} else { + # #leave SGR stack as is + # if {[punk::ansi::codetype::is_gx_open $code]} { + # } elseif {[punk::ansi::codetype::is_gx_close $code]} { + # } + #} + } + #consider also if there are other codes that should be stacked..? + } + + #NULL empty cell indicator + if {$opt_width ne "\uFFEF"} { + if {[llength $understacks]} { + set cs $u_codestack + set gs $u_gx_stack + } else { + set cs [list] + set gs [list] + } + if {[llength $undercols]< $opt_width} { + set diff [expr {$opt_width- [llength $undercols]}] + if {$diff > 0} { + #set undercols [list {*}$undercols {*}[lrepeat $diff "\u0000"]] ;#2024 - much slower + lappend undercols {*}[lrepeat $diff "\u0000"] + lappend understacks {*}[lrepeat $diff $cs] + lappend understacks_gx {*}[lrepeat $diff $gs] + } + } + } + + if {$opt_width ne "\uFFEF"} { + set renderwidth $opt_width + } else { + set renderwidth [llength $undercols] + } + + + if 0 { + # ----------------- + # if we aren't extending understacks & understacks_gx each time we incr idx above the undercols length.. this doesn't really serve a purpose + # Review. + # ----------------- + #replay code for last overlay position in input line + # whether or not we get that far - we need to return it for possible replay on next line + if {[llength $understacks]} { + lappend understacks $u_codestack + lappend understacks_gx $u_gx_stack + } else { + #in case overlay onto emptystring as underlay + lappend understacks [list] + lappend understacks_gx [list] + } + # ----------------- + } + + #trailing codes in effect for underlay + if {[llength $u_codestack]} { + #set replay_codes_underlay [join $u_codestack ""] + set replay_codes_underlay [punk::ansi::codetype::sgr_merge_list {*}$u_codestack] + } else { + set replay_codes_underlay "" + } + + + # -- --- --- --- --- --- --- --- + #### + #if opt_colstart - we need to build a space (or any singlewidth char ?) padding on the left containing the right number of columns. + #this will be processed as transparent - and handle doublewidth underlay characters appropriately + set startpadding [string repeat " " [expr {$opt_colstart -1}]] + #overdata with left padding spaces based on col-start under will show through for left-padding portion regardless of -transparency + if {$startpadding ne "" || $overdata ne ""} { + if {[punk::ansi::ta::detect $overdata]} { + set overmap [punk::ansi::ta::split_codes_single $startpadding$overdata] + } else { + #single plaintext part + set overmap [list $startpadding$overdata] + } + } else { + set overmap [list] + } + #### + + + #todo - detect plain ascii no-ansi input line (aside from leading ansi reset) + #will that allow some optimisations? + + #todo - detect repeated transparent char in overlay + #regexp {^(.)\1+$} ;#backtracking regexp - relatively slow. + # - try set c [string index $data 0]; regexp [string map [list %c% $c] {^[%c%]+$}] $data + #we should be able to optimize to pass through the underlay?? + + #??? + set colcursor $opt_colstart + #TODO - make a little virtual column object + #we need to refer to column1 or columnmin? or columnmax without calculating offsets due to to startcolumn + #need to lock-down what start column means from perspective of ANSI codes moving around - the offset perspective is unclear and a mess. + + + #set re_diacritics {[\u0300-\u036f]+|[\u1ab0-\u1aff]+|[\u1dc0-\u1dff]+|[\u20d0-\u20ff]+|[\ufe20-\ufe2f]+} + #as at 2024-02 punk::char::grapheme_split uses these - not aware of more complex graphemes + + set overstacks [list] + set overstacks_gx [list] + + set o_codestack [list]; #SGR codestack (not other codes such as movement,insert key etc) + set o_gxstack [list] + set pt_overchars "" + set i_o 0 + set overlay_grapheme_control_list [list] ;#tag each with g, sgr or other. 'other' are things like cursor-movement or insert-mode or codes we don't recognise/use + #experiment + set overlay_grapheme_control_stacks [list] + foreach {pt code} $overmap { + if {$pt ne ""} { + #todo - wrap in test for empty pt (we used split_codes_single - and it may be common for sgr sequences to be unmerged and so have empty pts between) + if {$cp437_glyphs} { + set pt [tcl::string::map $cp437_map $pt] + } + append pt_overchars $pt + #will get empty pt between adjacent codes + if {!$crm_mode} { + + set is_ptrun 0 + if {$optimise_ptruns && [tcl::string::length $pt] >= $optimise_ptruns} { + set p1 [tcl::string::index $pt 0] + set re [tcl::string::cat {^[} \\U[format %x [scan $p1 %c]] {]+$}] + set is_ptrun [regexp $re $pt] + + #leading only? we would have to check for graphemes at the trailing boundary? + #set re [tcl::string::cat {^[} \\U[format %x [scan $p1 %c]] {]+}] + #set is_ptrun [regexp -indices $re $pt runrange] + #if {$is_ptrun && 1} { + #} + } + if {$is_ptrun} { + #review - in theory a run over a certain length won't be part of some grapheme combo (graphemes can be long e.g 44?, but not as runs(?)) + #could be edge cases for runs at line end? (should be ok as we include trailing \n in our data) + set len [string length $pt] + set g_element [list g $p1] + + #lappend overstacks {*}[lrepeat $len $o_codestack] + #lappend overstacks_gx {*}[lrepeat $len $o_gxstack] + #incr i_o $len + #lappend overlay_grapheme_control_list {*}[lrepeat $len [list g $p1]] + #lappend overlay_grapheme_control_stacks {*}[lrepeat $len $o_codestack] + + set pi 0 + incr i_o $len + while {$pi < $len} { + lappend overstacks $o_codestack + lappend overstacks_gx $o_gxstack + lappend overlay_grapheme_control_list $g_element + lappend overlay_grapheme_control_stacks $o_codestack + incr pi + } + } else { + foreach grapheme [punk::char::grapheme_split $pt] { + lappend overstacks $o_codestack + lappend overstacks_gx $o_gxstack + incr i_o + lappend overlay_grapheme_control_list [list g $grapheme] + lappend overlay_grapheme_control_stacks $o_codestack + } + } + } else { + set tsbegin [clock micros] + foreach grapheme_original [punk::char::grapheme_split $pt] { + set pt_crm [ansistring VIEW -nul 1 -lf 2 -vt 2 -ff 2 $grapheme_original] + #puts stderr "ptlen [string length $pt] graphemelen[string length $grapheme_original] pt_crmlen[string length $pt_crm] $pt_crm" + foreach grapheme [punk::char::grapheme_split $pt_crm] { + if {$grapheme eq "\n"} { + lappend overlay_grapheme_control_stacks $o_codestack + lappend overlay_grapheme_control_list [list crmcontrol "\x1b\[00001E"] + } else { + lappend overstacks $o_codestack + lappend overstacks_gx $o_gxstack + incr i_o + lappend overlay_grapheme_control_list [list g $grapheme] + lappend overlay_grapheme_control_stacks $o_codestack + } + } + } + set elapsed [expr {[clock micros] - $tsbegin}] + puts stderr "ptlen [string length $pt] elapsedus:$elapsed" + } + } + + #only stack SGR (graphics rendition) codes - not title sets, cursor moves etc + #order of if-else based on assumptions: + # that pure resets are fairly common - more so than leading resets with other info + # that non-sgr codes are not that common, so ok to check for resets before verifying it is actually SGR at all. + if {$code ne ""} { + #we need to immediately set crm_mode here if \x1b\[3h received + if {$code eq "\x1b\[3h"} { + set crm_mode 1 + } elseif {$code eq "\x1b\[3l"} { + set crm_mode 0 + } + #else crm_mode could be set either way from options + if {$crm_mode && $code ne "\x1b\[00001E"} { + #treat the code as type 'g' like above - only allow through codes to reset mode REVIEW for now just \x1b\[3l ? + #we need to somehow convert further \n in the graphical rep to an instruction for newline that will bypass further crm_mode processing or we would loop. + set code_as_pt [ansistring VIEW -nul 1 -lf 1 -vt 1 -ff 1 $code] + #split using standard split for first foreach loop - grapheme based split when processing 2nd foreach loop + set chars [split $code_as_pt ""] + set codeparts [list] ;#list of 2-el lists each element {crmcontrol } or {g } + foreach c $chars { + if {$c eq "\n"} { + #use CNL (cursor next line) \x1b\[00001E ;#leading zeroes ok for this processor - used as debugging aid to distinguish + lappend codeparts [list crmcontrol "\x1b\[00001E"] + } else { + if {[llength $codeparts] > 0 && [lindex $codeparts end 0] eq "g"} { + set existing [lindex $codeparts end 1] + lset codeparts end [list g [string cat $existing $c]] + } else { + lappend codeparts [list g $c] + } + } + } + + set partidx 0 + foreach record $codeparts { + lassign $record rtype rval + switch -exact -- $rtype { + g { + append pt_overchars $rval + foreach grapheme [punk::char::grapheme_split $rval] { + lappend overstacks $o_codestack + lappend overstacks_gx $o_gxstack + incr i_o + lappend overlay_grapheme_control_list [list g $grapheme] + lappend overlay_grapheme_control_stacks $o_codestack + } + } + crmcontrol { + #leave o_codestack + lappend overlay_grapheme_control_stacks $o_codestack + lappend overlay_grapheme_control_list [list crmcontrol $rval] + } + } + } + } else { + lappend overlay_grapheme_control_stacks $o_codestack + #there will always be an empty code at end due to foreach on 2 vars with odd-sized list ending with pt (overmap coming from perlish split) + if {[punk::ansi::codetype::is_sgr_reset $code]} { + set o_codestack [list "\x1b\[m"] ;#reset better than empty list - fixes some ansi art issues + lappend overlay_grapheme_control_list [list sgr $code] + } elseif {[punk::ansi::codetype::has_sgr_leadingreset $code]} { + set o_codestack [list $code] + lappend overlay_grapheme_control_list [list sgr $code] + } elseif {[priv::is_sgr $code]} { + #basic simplification first - remove straight dupes + set dup_posns [lsearch -all -exact $o_codestack $code] ;#must be -exact because of square-bracket glob chars + set o_codestack [lremove $o_codestack {*}$dup_posns] + lappend o_codestack $code + lappend overlay_grapheme_control_list [list sgr $code] + } elseif {[regexp {\x1b7|\x1b\[s} $code]} { + #experiment + #cursor_save - for the replays review. + #jmn + #set temp_cursor_saved [punk::ansi::codetype::sgr_merge_list {*}$o_codestack] + lappend overlay_grapheme_control_list [list other $code] + } elseif {[regexp {\x1b8|\x1b\[u} $code]} { + #experiment + #cursor_restore - for the replays + set o_codestack [list $temp_cursor_saved] + lappend overlay_grapheme_control_list [list other $code] + } else { + #review + if {[punk::ansi::codetype::is_gx_open $code]} { + set o_gxstack [list "gx0_on"] + lappend overlay_grapheme_control_list [list gx0 gx0_on] ;#don't store code - will complicate debugging if we spit it out and jump character sets + } elseif {[punk::ansi::codetype::is_gx_close $code]} { + set o_gxstack [list] + lappend overlay_grapheme_control_list [list gx0 gx0_off] ;#don't store code - will complicate debugging if we spit it out and jump character sets + } else { + lappend overlay_grapheme_control_list [list other $code] + } + } + } + } + + } + #replay code for last overlay position in input line - should take account of possible trailing sgr code after last grapheme + set max_overlay_grapheme_index [expr {$i_o -1}] + lappend overstacks $o_codestack + lappend overstacks_gx $o_gxstack + + #set replay_codes_overlay [join $o_codestack ""] + set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}$o_codestack] + + #if {[tcl::dict::exists $overstacks $max_overlay_grapheme_index]} { + # set replay_codes_overlay [join [tcl::dict::get $overstacks $max_overlay_grapheme_index] ""] + #} else { + # set replay_codes_overlay "" + #} + # -- --- --- --- --- --- --- --- + + + #potential problem - combinining diacritics directly following control chars like \r \b + + # -- --- --- + #we need to initialise overflow_idx before any potential row-movements - as they need to perform a loop break and force in_excess to 1 + if {$opt_expand_right} { + #expand_right true means we can have lines as long as we want, but either way there can be excess data that needs to be thrown back to the calling loop. + #we currently only support horizontal expansion to the right (review regarding RTL text!) + set overflow_idx -1 + } else { + #expand_right zero - we can't grow beyond our column width - so we get ellipsis or truncation + if {$opt_width ne "\uFFEF"} { + set overflow_idx [expr {$opt_width}] + } else { + #review - this is also the cursor position when adding a char at end of line? + set overflow_idx [expr {[llength $undercols]}] ;#index at which we would be *in* overflow a row move may still override it + } + } + # -- --- --- + + set outcols $undercols ;#leave undercols as is, outcols can potentially be appended to. + + set unapplied "" ;#if we break for move row (but not for /v ?) + set unapplied_list [list] + + set insert_lines_above 0 ;#return key + set insert_lines_below 0 + set instruction "" + + # -- --- --- + #cursor_save_dec, cursor_restore_dec etc + set cursor_restore_required 0 + set cursor_saved_attributes "" + set cursor_saved_position "" + # -- --- --- + + #set idx 0 ;# line index (cursor - 1) + #set idx [expr {$opt_colstart + $opt_colcursor} -1] + + #idx is the per column output index + set idx [expr {$opt_colcursor -1}] ;#don't use opt_colstart here - we have padded and won't start emitting until idx reaches opt_colstart-1 + #cursor_column is usually one above idx - but we have opt_colstart which is like a margin - todo: remove cursor_column from the following loop and calculate it's offset when breaking or at end. + #(for now we are incrementing/decrementing both in sync - which is a bit silly) + set cursor_column $opt_colcursor + + #idx_over is the per grapheme overlay index + set idx_over -1 + + + #movements only occur within the overlay range. + #an underlay is however not necessary.. e.g + #renderline -expand_right 1 "" data + + #set re_mode {\x1b\[\?([0-9]*)(h|l)} ;#e.g DECAWM + #set re_col_move {\x1b\[([0-9]*)(C|D|G)$} + #set re_row_move {\x1b\[([0-9]*)(A|B)$} + #set re_both_move {\x1b\[([0-9]*)(?:;){0,1}([0-9]*)H$} ;# or "f" ? + #set re_vt_sequence {\x1b\[([0-9]*)(?:;){0,1}([0-9]*)~$} + #set re_cursor_save {\x1b\[s$} ;#note probable incompatibility with DECSLRM (set left right margin)! + #set re_cursor_restore {\x1b\[u$} + #set re_cursor_save_dec {\x1b7$} + #set re_cursor_restore_dec {\x1b8$} + #set re_other_single {\x1b(D|M|E)$} + #set re_decstbm {\x1b\[([0-9]*)(?:;){0,1}([0-9]*)r$} ;#DECSTBM set top and bottom margins + + #puts "-->$overlay_grapheme_control_list<--" + #puts "-->overflow_idx: $overflow_idx" + for {set gci 0} {$gci < [llength $overlay_grapheme_control_list]} {incr gci} { + set gc [lindex $overlay_grapheme_control_list $gci] + lassign $gc type item + + #emit plaintext chars first using existing SGR codes from under/over stack as appropriate + #then check if the following code is a cursor movement within the line and adjust index if so + #foreach ch $overlay_graphemes {} + switch -- $type { + g { + set ch $item + #crm_mode affects both graphic and control + if {0 && $crm_mode} { + set chars [ansistring VIEW -nul 1 -lf 2 -vt 2 -ff 2 $ch] + set chars [string map [list \n "\x1b\[00001E"] $chars] + if {[llength [split $chars ""]] > 1} { + priv::render_unapplied $overlay_grapheme_control_list $gci + #prefix the unapplied controls with the string version of this control + set unapplied_list [linsert $unapplied_list 0 {*}[split $chars ""]] + set unapplied [join $unapplied_list ""] + #incr idx_over + break + } else { + set ch $chars + } + } + incr idx_over; #idx_over (until unapplied reached anyway) is per *grapheme* in the overlay - not per col. + if {($idx < ($opt_colstart -1))} { + incr idx [grapheme_width_cached $ch] + continue + } + #set within_undercols [expr {$idx <= [llength $undercols]-1}] ;#within our active data width + set within_undercols [expr {$idx <= $renderwidth-1}] + + #https://www.enigma.com/resources/blog/the-secret-world-of-newline-characters + #\x85 NEL in the c1 control set is treated by some terminal emulators (e.g Hyper) as a newline, + #on some it's invisble but doesn't change the line, on some it's a visible glyph of width 1. + #This is hard to process in any standard manner - but I think the Hyper behaviour of doing what it was intended is perhaps most reasonable + #We will map it to the same behaviour as lf here for now... but we need also to consider the equivalent ANSI sequence: \x1bE + + set chtest [tcl::string::map [list \n \x85 \b \r \v \x7f ] $ch] + #puts --->chtest:$chtest + #specials - each shoud have it's own test of what to do if it happens after overflow_idx reached + switch -- $chtest { + "" { + set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] + if {$idx == 0} { + #puts "---a at col 1" + #linefeed at column 1 + #leave the overflow_idx ;#? review + set instruction lf_start ;#specific instruction for newline at column 1 + priv::render_unapplied $overlay_grapheme_control_list $gci + break + } elseif {$overflow_idx != -1 && $idx == $overflow_idx} { + #linefeed after final column + #puts "---c at overflow_idx=$overflow_idx" + incr cursor_row + set overflow_idx $idx ;#override overflow_idx even if it was set to -1 due to expand_right = 1 + set instruction lf_overflow ;#only special treatment is to give it it's own instruction in case caller needs to handle differently + priv::render_unapplied $overlay_grapheme_control_list $gci + break + } else { + #linefeed occurred in middle or at end of text + #puts "---mid-or-end-text-linefeed idx:$idx overflow_idx:$overflow_idx" + if {$insert_mode == 0} { + incr cursor_row + if {$idx == -1 || $overflow_idx > $idx} { + #don't set overflow_idx higher if it's already set lower and we're adding graphemes to overflow + set overflow_idx $idx ;#override overflow_idx even if it was set to -1 due to expand_right = 1 + } + set instruction lf_mid + priv::render_unapplied $overlay_grapheme_control_list $gci + break + } else { + incr cursor_row + #don't adjust the overflow_idx + priv::render_unapplied $overlay_grapheme_control_list $gci + set instruction lf_mid + break ;# could have overdata following the \n - don't keep processing + } + } + + } + "" { + #will we want/need to use raw for keypresses in terminal? (terminal with LNM in standard reset mode means enter= this is the usual config for terminals) + #So far we are assuming the caller has translated to and handle above.. REVIEW. + + #consider also the old space-carriagereturn softwrap convention used in some terminals. + #In the context of rendering to a block of text - this works similarly in that the space gets eaten so programs emitting space-cr at the terminal width col will pretty much get what they expect. + set idx [expr {$opt_colstart -1}] + set cursor_column $opt_colstart ;#? + } + "" { + #literal backspace char - not necessarily from keyboard + #review - backspace effect on double-width chars - we are taking a column-editing perspective in overtype + #(important for -transparent option - hence replacement chars for half-exposed etc) + #review - overstrike support as per nroff/less (generally considered an old technology replaced by unicode mechanisms and/or ansi SGR) + if {$idx > ($opt_colstart -1)} { + incr idx -1 + incr cursor_column -1 + } else { + set flag 0 + if $flag { + #review - conflicting requirements? Need a different sequence for destructive interactive backspace? + priv::render_unapplied $overlay_grapheme_control_list $gci + set instruction backspace_at_start + break + } + } + } + "" { + #literal del character - some terminals send just this for what is generally expected to be a destructive backspace + #We instead treat this as a pure delete at current cursor position - it is up to the repl or terminal to remap backspace key to a sequence that has the desired effect. + priv::render_delchar $idx + } + "" { + #end processing this overline. rest of line is remainder. cursor for column as is. + #REVIEW - this theoretically depends on terminal's vertical tabulation setting (name?) + #e.g it could be configured to jump down 6 rows. + #On the other hand I've seen indications that some modern terminal emulators treat it pretty much as a linefeed. + #todo? + incr cursor_row + set overflow_idx $idx + #idx_over has already been incremented as this is both a movement-control and in some sense a grapheme + priv::render_unapplied $overlay_grapheme_control_list $gci + set instruction vt + break + } + default { + if {$overflow_idx != -1} { + #review - how to check arbitrary length item such as tab is going to overflow .. before we get to overflow_idx? + #call grapheme_width_cached on each ch, or look for tab specifically as it's currently the only known reason to have a grapheme width > 2? + #we need to decide what a tab spanning the overflow_idx means and how it affects wrap etc etc + if {$idx == $overflow_idx-1} { + set owidth [grapheme_width_cached $ch] + if {$owidth == 2} { + #review split 2w overflow? + #we don't want to make the decision here to split a 2w into replacement characters at end of line and beginning of next line + #better to consider the overlay char as unable to be applied to the line + #render empty column(?) - and reduce overlay grapheme index by one so that the current ch goes into unapplied + #throwing back to caller with instruction complicates its job - but is necessary to avoid making decsions for it here. + priv::render_addchar $idx "" [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode + #change the overflow_idx + set overflow_idx $idx + incr idx + incr idx_over -1 ;#set overlay grapheme index back one so that sgr stack from previous overlay grapheme used + priv::render_unapplied $overlay_grapheme_control_list [expr {$gci-1}] ;#note $gci-1 instead of just gci + #throw back to caller's loop - add instruction to caller as this is not the usual case + #caller may for example choose to render a single replacement char to this line and omit the grapheme, or wrap it to the next line + set instruction overflow_splitchar + break + } elseif {$owidth > 2} { + #? tab? + #TODO! + puts stderr "overtype::renderline long overtext grapheme '[ansistring VIEW -lf 1 -vt 1 $ch]' not handled" + #tab of some length dependent on tabstops/elastic tabstop settings? + } + } elseif {$idx >= $overflow_idx} { + #REVIEW + set next_gc [lindex $overlay_grapheme_control_list $gci+1] ;#next grapheme or control + lassign $next_gc next_type next_item + if {$autowrap_mode || $next_type ne "g"} { + set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci-1]] + #set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] + #don't incr idx beyond the overflow_idx + #idx_over already incremented - decrement so current overlay grapheme stacks go to unapplied + incr idx_over -1 + #priv::render_unapplied $overlay_grapheme_control_list [expr {$gci-1}] ;#back one index here too + priv::render_this_unapplied $overlay_grapheme_control_list $gci ;# + set instruction overflow + break + } else { + #no point throwing back to caller for each grapheme that is overflowing + #without this branch - renderline would be called with overtext reducing only by one grapheme per call + #processing a potentially long overtext each time (ie - very slow) + set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] + #JMN4 + + } + } + } else { + #review. + #overflow_idx = -1 + #This corresponds to expand_right being true (at least until overflow_idx is in some cases forced to a value when throwing back to calling loop) + } + + if {($do_transparency && [regexp $opt_transparent $ch])} { + #pre opt_colstart is effectively transparent (we have applied padding of required number of columns to left of overlay) + if {$idx > [llength $outcols]-1} { + lappend outcols " " + #tcl::dict::set understacks $idx [list] ;#review - use idx-1 codestack? + #lset understacks $idx [list] ;#will get index $i out of range error + lappend understacks [list] ;#REVIEW + incr idx + incr cursor_column + } else { + #todo - punk::char::char_width + set g [lindex $outcols $idx] + #JMN + set uwidth [grapheme_width_cached $g] + if {[lindex $outcols $idx] eq ""} { + #2nd col of 2-wide char in underlay + incr idx + incr cursor_column + } elseif {$uwidth == 0} { + #e.g control char ? combining diacritic ? + incr idx + incr cursor_column + } elseif {$uwidth == 1} { + set owidth [grapheme_width_cached $ch] + incr idx + incr cursor_column + if {$owidth > 1} { + incr idx + incr cursor_column + } + } elseif {$uwidth > 1} { + if {[grapheme_width_cached $ch] == 1} { + if {!$insert_mode} { + #normal singlewide transparent overlay onto double-wide underlay + set next_pt_overchar [tcl::string::index $pt_overchars $idx_over+1] ;#lookahead of next plain-text char in overlay + if {$next_pt_overchar eq ""} { + #special-case trailing transparent - no next_pt_overchar + incr idx + incr cursor_column + } else { + if {[regexp $opt_transparent $next_pt_overchar]} { + incr idx + incr cursor_column + } else { + #next overlay char is not transparent.. first-half of underlying 2wide char is exposed + #priv::render_addchar $idx $opt_exposed1 [tcl::dict::get $overstacks $idx_over] [tcl::dict::get $overstacks_gx $idx_over] $insert_mode + priv::render_addchar $idx $opt_exposed1 [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode + incr idx + incr cursor_column + } + } + } else { + #? todo - decide what transparency even means for insert mode + incr idx + incr cursor_column + } + } else { + #2wide transparency over 2wide in underlay - review + incr idx + incr cursor_column + } + } + } + } else { + + set idxchar [lindex $outcols $idx] + #non-transparent char in overlay or empty cell + if {$idxchar eq "\u0000"} { + #empty/erased cell indicator + set uwidth 1 + } else { + set uwidth [grapheme_width_cached $idxchar] + } + if {$within_undercols} { + if {$idxchar eq ""} { + #2nd col of 2wide char in underlay + if {!$insert_mode} { + priv::render_addchar $idx $ch [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] 0 + #JMN - this has to expose if our startposn chopped an underlay - but not if we already overwrote the first half of the widechar underlay grapheme + #e.g renderline \uFF21\uFF21--- a\uFF23\uFF23 + #vs + # renderline -startcolumn 2 \uFF21---- \uFF23 + if {[lindex $outcols $idx-1] != ""} { + #verified it's an empty following a filled - so it's a legit underlay remnant (REVIEW - when would it not be??) + #reset previous to an exposed 1st-half - but leave understacks code as is + priv::render_addchar [expr {$idx-1}] $opt_exposed1 [lindex $understacks $idx-1] [lindex $understacks_gx $idx-1] 0 + } + incr idx + } else { + set prevcolinfo [lindex $outcols $idx-1] + #for insert mode - first replace the empty 2ndhalf char with exposed2 before shifting it right + #REVIEW - this leaves a replacement character permanently in our columns.. but it is consistent regarding length (?) + #The alternative is to disallow insertion at a column cursor that is at 2nd half of 2wide char + #perhaps by inserting after the char - this may be worthwhile - but may cause other surprises + #It is perhaps best avoided at another level and try to make renderline do exactly as it's told + #the advantage of this 2w splitting method is that the inserted character ends up in exactly the column we expect. + priv::render_addchar $idx $opt_exposed2 [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] 0 ;#replace not insert + priv::render_addchar $idx $ch [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] 1 ;#insert - same index + if {$prevcolinfo ne ""} { + #we've split the 2wide - it may already have been rendered as an exposed1 - but not for example if our startcolumn was current idx + priv::render_addchar [expr {$idx-1}] $opt_exposed1 [lindex $understacks $idx-1] [lindex $understacks_gx $idx-1] 0 ;#replace not insert + } ;# else?? + incr idx + } + if {$cursor_column < [llength $outcols] || $overflow_idx == -1} { + incr cursor_column + } + } elseif {$uwidth == 0} { + #what if this is some other c0/c1 control we haven't handled specifically? + + #by emitting a preceding empty-string column - we associate whatever this char is with the preceeding non-zero-length character and any existing zero-lengths that follow it + #e.g combining diacritic - increment before over char REVIEW + #arguably the previous overchar should have done this - ie lookahead for combiners? + #if we can get a proper grapheme_split function - this should be easier to tidy up. + priv::render_addchar $idx "" [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode + incr idx + priv::render_addchar $idx $ch [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode + incr idx + incr cursor_column 2 + + if {$cursor_column > [llength $outcols] && $overflow_idx != -1} { + set cursor_column [llength $outcols] + } + } elseif {$uwidth == 1} { + #includes null empty cells + set owidth [grapheme_width_cached $ch] + if {$owidth == 1} { + priv::render_addchar $idx $ch [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode + incr idx + } else { + priv::render_addchar $idx $ch [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode + incr idx + priv::render_addchar $idx "" [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode + #if next column in underlay empty - we've overwritten first half of underlying 2wide grapheme + #replace with rhs exposure in case there are no more overlay graphemes coming - use underlay's stack + if {([llength $outcols] >= $idx +2) && [lindex $outcols $idx+1] eq ""} { + priv::render_addchar [expr {$idx+1}] $opt_exposed2 [lindex $understacks $idx+1] [lindex $understacks_gx $idx+1] $insert_mode + } + incr idx + } + if {($cursor_column < [llength $outcols]) || $overflow_idx == -1} { + incr cursor_column + } + } elseif {$uwidth > 1} { + set owidth [grapheme_width_cached $ch] + if {$owidth == 1} { + #1wide over 2wide in underlay + if {!$insert_mode} { + priv::render_addchar $idx $ch [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode + incr idx + incr cursor_column + priv::render_addchar $idx $opt_exposed2 [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode + #don't incr idx - we are just putting a broken-indication in the underlay - which may get overwritten by next overlay char + } else { + #insert mode just pushes all to right - no exposition char here + priv::render_addchar $idx $ch [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode + incr idx + incr cursor_column + } + } else { + #2wide over 2wide + priv::render_addchar $idx $ch [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode + incr idx 2 + incr cursor_column 2 + } + + if {$cursor_column > [llength $outcols] && $overflow_idx != -1} { + set cursor_column [llength $outcols] + } + } + } else { + priv::render_addchar $idx $ch [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode + incr idx + incr cursor_column + } + } + } + } ;# end switch + + + } + other - crmcontrol { + if {$crm_mode && $type ne "crmcontrol" && $item ne "\x1b\[00001E"} { + if {$item eq "\x1b\[3l"} { + set crm_mode 0 + } else { + #When our initial overlay split was done - we weren't in crm_mode - so there are codes that weren't mapped to unicode control character representations + #set within_undercols [expr {$idx <= $renderwidth-1}] + #set chars [ansistring VIEW -nul 1 -lf 2 -vt 2 -ff 2 $item] + set chars [ansistring VIEW -nul 1 -lf 1 -vt 1 -ff 1 $item] + priv::render_unapplied $overlay_grapheme_control_list $gci + #prefix the unapplied controls with the string version of this control + set unapplied_list [linsert $unapplied_list 0 {*}[split $chars ""]] + set unapplied [join $unapplied_list ""] + + break + } + } + + #todo - consider CSI s DECSLRM vs ansi.sys \x1b\[s - we need \x1b\[s for oldschool ansi art - but may have to enable only for that. + #we should possibly therefore reverse this mapping so that x1b7 x1b8 are the primary codes for save/restore? + set code [tcl::string::map [list \x1b7 \x1b\[s \x1b8 \x1b\[u ] $item] + #since this element isn't a grapheme - advance idx_over to next grapheme overlay when about to fill 'unapplied' + + + #remap of DEC cursor_save/cursor_restore from ESC sequence to equivalent CSI + #probably not ideal - consider putting cursor_save/cursor_restore in functions so they can be called from the appropriate switch branch instead of using this mapping + #review - cost/benefit of function calls within these switch-arms instead of inline code? + + set c1 [tcl::string::index $code 0] + set c1c2c3 [tcl::string::range $code 0 2] + #set re_ST_open {(?:\033P|\u0090|\033X|\u0098|\033\^|\u009e|\033_|\u009f)} + #tcl 8.7 - faster to use inline list than to store it in a local var outside of loop. + #(somewhat surprising) + set leadernorm [tcl::string::range [tcl::string::map [list\ + \x1b\[< 1006\ + \x1b\[ 7CSI\ + \x1bY 7MAP\ + \x1bP 7DCS\ + \x90 8DCS\ + \x9b 8CSI\ + \x1b\] 7OSC\ + \x9d 8OSC\ + \x1b 7ESC\ + ] $c1c2c3] 0 3] ;#leadernorm is 1st 1,2 or 3 chars mapped to 4char normalised indicator - or is original first chars (1,2 or 3 len) + + #we leave the tail of the code unmapped for now + switch -- $leadernorm { + 1006 { + #https://invisible-island.net/xterm/ctlseqs/ctlseqs.html + #SGR (1006) CSI < followed by colon separated encoded-button-value,px,py ordinates and final M for button press m for button release + set codenorm [tcl::string::cat $leadernorm [tcl::string::range $code 3 end]] + } + 7CSI - 7OSC { + #set codenorm [tcl::string::cat $leadernorm [tcl::string::range $code 2 end]] + set codenorm $leadernorm[tcl::string::range $code 2 end] + } + 7DCS { + #ESC P + #Device Control String https://invisible-island.net/xterm/ctlseqs/ctlseqs.html#h4-Controls-beginning-with-ESC:ESC-F.C74 + set codenorm [tcl::string::cat $leadernorm [tcl::string::range $code 2 end]] + } + 8DCS { + #8-bit Device Control String + set codenorm [tcl::string::cat $leadernorm [tcl::string::range $code 1 end]] + } + 7MAP { + #map to another type of code to share implementation branch + set codenorm $leadernorm[tcl::string::range $code 1 end] + } + 7ESC { + #set codenorm [tcl::string::cat $leadernorm [tcl::string::range $code 1 end]] + set codenorm $leadernorm[tcl::string::range $code 1 end] + } + 8CSI - 8OSC { + set codenorm [tcl::string::cat $leadernorm [tcl::string::range $code 1 end]] + } + default { + puts stderr "Sequence detected as ANSI, but not handled in leadernorm switch. code: [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + #we haven't made a mapping for this + #could in theory be 1,2 or 3 in len + #although we shouldn't be getting here if the regexp for ansi codes is kept in sync with our switch branches + set codenorm $code + } + } + + switch -- $leadernorm { + 7MAP { + switch -- [lindex $codenorm 4] { + Y { + #vt52 movement. we expect 2 chars representing position (limited range) + set params [tcl::string::range $codenorm 5 end] + if {[tcl::string::length $params] != 2} { + #shouldn't really get here or need this branch if ansi splitting was done correctly + puts stderr "overtype::renderline ESC Y recognised as vt52 move, but incorrect parameters length ([string length $params] vs expected 2) [ansistring VIEW -lf 1 -vt 1 -nul 1 $code] not implemented codenorm:[ansistring VIEW -lf 1 -vt 1 -nul 1 $codenorm]" + } + set line [tcl::string::index $params 5] + set column [tcl::string::index $params 1] + set r [expr {[scan $line %c] -31}] + set c [expr {[scan $column %c] -31}] + + #MAP to: + #CSI n;m H - CUP - Cursor Position + set leadernorm 7CSI + set codenorm "$leadernorm${r}\;${c}H" + } + } + } + } + + #we've mapped 7 and 8bit escapes to values we can handle as literals in switch statements to take advantange of jump tables. + switch -- $leadernorm { + 1006 { + #TODO + # + switch -- [tcl::string::index $codenorm end] { + M { + puts stderr "mousedown $codenorm" + } + m { + puts stderr "mouseup $codenorm" + } + } + + } + {7CSI} - {8CSI} { + set param [tcl::string::range $codenorm 4 end-1] + #puts stdout "--> CSI [tcl::string::index $leadernorm 0] bit param:$param" + set code_end [tcl::string::index $codenorm end] ;#used for e.g h|l set/unset mode + + switch -exact -- $code_end { + A { + #Row move - up + set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] + #todo + lassign [split $param {;}] num modifierkey + if {$modifierkey ne ""} { + puts stderr "modifierkey:$modifierkey" + } + + if {$num eq ""} {set num 1} + incr cursor_row -$num + + if {$cursor_row < 1} { + set cursor_row 1 + } + + #ensure rest of *overlay* is emitted to remainder + incr idx_over + priv::render_unapplied $overlay_grapheme_control_list $gci + set instruction up + #retain cursor_column + break + } + B { + #CUD - Cursor Down + #Row move - down + lassign [split $param {;}] num modifierkey + set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] + #move down + if {$modifierkey ne ""} { + puts stderr "modifierkey:$modifierkey" + } + if {$num eq ""} {set num 1} + incr cursor_row $num + + + incr idx_over ;#idx_over hasn't encountered a grapheme and hasn't advanced yet + priv::render_unapplied $overlay_grapheme_control_list $gci + set instruction down + #retain cursor_column + break + } + C { + #CUF - Cursor Forward + #Col move + #puts stdout "->forward" + #todo - consider right-to-left cursor mode (e.g Hebrew).. some day. + #cursor forward + #right-arrow/move forward + lassign [split $param {;}] num modifierkey + if {$modifierkey ne ""} { + puts stderr "modifierkey:$modifierkey" + } + if {$num eq ""} {set num 1} + + #todo - retrict to moving 1 position past datalen? restrict to column width? + #should ideally wrap to next line when interactive and not on last row + #(some ansi art seems to expect this behaviour) + #This presumably depends on the terminal's wrap mode + #e.g DECAWM autowrap mode + # CSI ? 7 h - set: autowrap (also tput smam) + # CSI ? 7 l - reset: no autowrap (also tput rmam) + set version 2 + if {$version eq "2"} { + set max [llength $outcols] + if {$overflow_idx == -1} { + incr max + } + if {$cursor_column == $max+1} { + #move_forward while in overflow + incr cursor_column -1 + } + + if {($cursor_column + $num) <= $max} { + incr idx $num + incr cursor_column $num + } else { + if {$autowrap_mode} { + set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] + #jmn + if {$idx == $overflow_idx} { + incr num + } + + #horizontal movement beyond line extent needs to wrap - throw back to caller + #we may have both overflow_right and unapplied data + #(can have overflow_right if we were in insert_mode and processed chars prior to this movement) + #leave row as is - caller will need to determine how many rows the column-movement has consumed + incr cursor_column $num ;#give our caller the necessary info as columns from start of row + #incr idx_over + #should be gci following last one applied + priv::render_unapplied $overlay_grapheme_control_list $gci + set instruction wrapmoveforward + break + } else { + set cursor_column $max + set idx [expr {$cursor_column -1}] + } + } + } else { + #review - dead branch + if {!$expand_right || ($cursor_column + $num) <= [llength $outcols+1]} { + incr idx $num + incr cursor_column $num + } else { + if {!$insert_mode} { + #block editing style with arrow keys + #overtype mode + set idxstart $idx + set idxend [llength $outcols] + set moveend [expr {$idxend - $idxstart}] + if {$moveend < 0} {set moveend 0} ;#sanity? + #puts "idxstart:$idxstart idxend:$idxend outcols[llength $outcols] undercols:[llength $undercols]" + incr idx $moveend + incr cursor_column $moveend + #if {[tcl::dict::exists $understacks $idx]} { + # set stackinfo [tcl::dict::get $understacks $idx] ;#use understack at end - which may or may not have already been replaced by stack from overtext + #} else { + # set stackinfo [list] + #} + if {$idx < [llength $understacks]} { + set stackinfo [lindex $understacks $idx] ;#use understack at end - which may or may not have already been replaced by stack from overtext + } else { + set stackinfo [list] + } + if {$idx < [llength $understacks_gx]} { + #set gxstackinfo [tcl::dict::get $understacks_gx $idx] + set gxstackinfo [lindex $understacks_gx $idx] + } else { + set gxstackinfo [list] + } + #pad outcols + set movemore [expr {$num - $moveend}] + #assert movemore always at least 1 or we wouldn't be in this branch + for {set m 1} {$m <= $movemore} {incr m} { + incr idx + incr cursor_column + priv::render_addchar $idx " " $stackinfo $gxstackinfo $insert_mode + } + } else { + #normal - insert + incr idx $num + incr cursor_column $num + if {$idx > [llength $outcols]} { + set idx [llength $outcols];#allow one beyond - for adding character at end of line + set cursor_column [expr {[llength $outcols]+1}] + } + } + } + } + } + D { + #Col move + #puts stdout "<-back" + #cursor back + #left-arrow/move-back when ltr mode + lassign [split $param {;}] num modifierkey + if {$modifierkey ne ""} { + puts stderr "modifierkey:$modifierkey" + } + if {$num eq ""} {set num 1} + + set version 2 + if {$version eq "2"} { + #todo - startcolumn offset! + if {$cursor_column - $num >= 1} { + incr idx -$num + incr cursor_column -$num + } else { + if {!$autowrap_mode} { + set cursor_column 1 + set idx 0 + } else { + set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] + incr cursor_column -$num + priv::render_unapplied $overlay_grapheme_control_list $gci + set instruction wrapmovebackward + break + } + } + } else { + incr idx -$num + incr cursor_column -$num + if {$idx < $opt_colstart-1} { + #wrap to previous line and position cursor at end of data + set idx [expr {$opt_colstart-1}] + set cursor_column $opt_colstart + } + } + } + E { + #CNL - Cursor Next Line + if {$param eq ""} { + set downmove 1 + } else { + set downmove [expr {$param}] + } + puts stderr "renderline CNL down-by-$downmove" + set cursor_column 1 + set cursor_row [expr {$cursor_row + $downmove}] + set idx [expr {$cursor_column -1}] + set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] + incr idx_over + priv::render_unapplied $overlay_grapheme_control_list $gci + set instruction move + break + + } + F { + #CPL - Cursor Previous Line + if {$param eq ""} { + set upmove 1 + } else { + set upmove [expr {$param}] + } + puts stderr "renderline CPL up-by-$upmove" + set cursor_column 1 + set cursor_row [expr {$cursor_row -$upmove}] + if {$cursor_row < 1} { + set cursor_row 1 + } + set idx [expr {$cursor_column - 1}] + set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] + incr idx_over + priv::render_unapplied $overlay_grapheme_control_list $gci + set instruction move + break + + } + G { + #CHA - Cursor Horizontal Absolute (move to absolute column no) + if {$param eq ""} { + set targetcol 1 + } else { + set targetcol $param + if {![string is integer -strict $targetcol]} { + puts stderr "renderline CHA (Cursor Horizontal Absolute) error. Unrecognised parameter '$param'" + } + set targetcol [expr {$param}] + set max [llength $outcols] + if {$overflow_idx == -1} { + incr max + } + if {$targetcol > $max} { + puts stderr "renderline CHA (Cursor Horizontal Absolute) error. Param '$param' > max: $max" + set targetcol $max + } + } + #adjust to colstart - as column 1 is within overlay + #??? REVIEW + set idx [expr {($targetcol -1) + $opt_colstart -1}] + + set cursor_column $targetcol + #puts stderr "renderline absolute col move ESC G (TEST)" + } + H - f { + #CSI n;m H - CUP - Cursor Position + + #CSI n;m f - HVP - Horizontal Vertical Position REVIEW - same as CUP with differences (what?) in some terminal modes + # - 'counts as effector format function (like CR or LF) rather than an editor function (like CUD or CNL)' + # - REVIEW + #see Annex A at: https://www.ecma-international.org/wp-content/uploads/ECMA-48_5th_edition_june_1991.pdf + + #test e.g ansicat face_2.ans + #$re_both_move + lassign [split $param {;}] paramrow paramcol + #missing defaults to 1 + #CSI ;5H = CSI 1;5H -> row 1 col 5 + #CSI 17;H = CSI 17H = CSI 17;1H -> row 17 col 1 + + if {$paramcol eq ""} {set paramcol 1} + if {$paramrow eq ""} {set paramrow 1} + if {![string is integer -strict $paramcol] || ![string is integer -strict $paramrow]} { + puts stderr "renderline CUP (CSI H) unrecognised param $param" + #ignore? + } else { + set max [llength $outcols] + if {$overflow_idx == -1} { + incr max + } + if {$paramcol > $max} { + set target_column $max + } else { + set target_column [expr {$paramcol}] + } + + + if {$paramrow < 1} { + puts stderr "renderline CUP (CSI H) bad row target 0. Assuming 1" + set target_row 1 + } else { + set target_row [expr {$paramrow}] + } + if {$target_row == $cursor_row} { + #col move only - no need for break and move + #puts stderr "renderline CUP col move only to col $target_column param:$param" + set cursor_column $target_column + set idx [expr {$cursor_column -1}] + } else { + set cursor_row $target_row + set cursor_column $target_column + set idx [expr {$cursor_column -1}] + set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] + incr idx_over + priv::render_unapplied $overlay_grapheme_control_list $gci + set instruction move + break + } + } + } + J { + set modegroup [tcl::string::index $codenorm 4] ;#e.g ? + switch -exact -- $modegroup { + ? { + #CSI ? Pn J - selective erase + puts stderr "overtype::renderline ED - SELECTIVE ERASE IN DISPLAY (UNIMPLEMENTED) [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + } + default { + puts stderr "overtype::renderline ED - ERASE IN DISPLAY (TESTING) [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + if {$param eq ""} {set param 0} + switch -exact -- $param { + 0 { + #clear from cursor to end of screen + } + 1 { + #clear from cursor to beginning of screen + } + 2 { + #clear entire screen + #ansi.sys - move cursor to upper left REVIEW + set cursor_row 1 + set cursor_column 1 + set idx [expr {$cursor_column -1}] + set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] + incr idx_over + if {[llength $outcols]} { + priv::render_erasechar 0 [llength $outcols] + } + priv::render_unapplied $overlay_grapheme_control_list $gci + set instruction clear_and_move + break + } + 3 { + #clear entire screen. presumably cursor doesn't move - otherwise it would be same as 2J ? + + } + default { + } + } + + } + } + } + K { + #see DECECM regarding background colour + set modegroup [tcl::string::index $codenorm 4] ;#e.g ? + switch -exact -- $modegroup { + ? { + puts stderr "overtype::renderline DECSEL - SELECTIVE ERASE IN LINE (UNIMPLEMENTED) [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + set param [string range $param 1 end] ;#chop qmark + if {$param eq ""} {set param 0} + switch -exact -- $param { + 0 { + #clear from cursor to end of line - depending on DECSCA + } + 1 { + #clear from cursor to beginning of line - depending on DECSCA + + } + 2 { + #clear entire line - depending on DECSCA + } + default { + puts stderr "overtype::renderline DECSEL - SELECTIVE ERASE IN LINE PARAM '$param' unrecognised [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + } + } + + } + default { + puts stderr "overtype::renderline EL - ERASE IN LINE (TESTING) [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + if {$param eq ""} {set param 0} + switch -exact -- $param { + 0 { + #clear from cursor to end of line + } + 1 { + #clear from cursor to beginning of line + + } + 2 { + #clear entire line + } + default { + puts stderr "overtype::renderline EL - ERASE IN LINE PARAM '$param' unrecognised [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + } + } + } + } + } + L { + puts stderr "overtype::renderline IL - Insert Line - not implemented [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + } + 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]" + + } + T { + #CSI Pn T - SD Pan Up (empty lines introduced at top) + #CSI Pn+T - kitty extension (lines at top come from scrollback buffer) + #Pn new lines appear at top of the display, Pn old lines disappear at the bottom of the display + if {$param eq "" || $param eq "0"} {set param 1} + if {[string index $param end] eq "+"} { + puts stderr "overtype::renderline CSI Pn + T - kitty Pan Up - not implemented [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + } else { + puts stderr "overtype::renderline CSI Pn T - SD Pan Up - not implemented [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + } + } + X { + puts stderr "overtype::renderline X ECH ERASE CHARACTER - $param" + #ECH - erase character + if {$param eq "" || $param eq "0"} {set param 1}; #param=count of chars to erase + priv::render_erasechar $idx $param + #cursor position doesn't change. + } + q { + set code_secondlast [tcl::string::index $codenorm end-1] + switch -exact -- $code_secondlast { + {"} { + #DECSCA - Select Character Protection Attribute + #(for use with selective erase: DECSED and DECSEL) + set param [tcl::string::range $codenorm 4 end-2] + if {$param eq ""} {set param 0} + #TODO - store like SGR in stacks - replays? + switch -exact -- $param { + 0 - 2 { + #canerase + puts stderr "overtype::renderline - DECSCA canerase not implemented - [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + } + 1 { + #cannoterase + puts stderr "overtype::renderline - DECSCA cannoterase not implemented - [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + } + default { + puts stderr "overtype::renderline DECSCA param '$param' not understood [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + } + } + + } + default { + puts stderr "overtype::renderline - CSI ... q not implemented - [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + } + } + + } + r { + #$re_decstbm + #https://www.vt100.net/docs/vt510-rm/DECSTBM.html + #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 + + incr idx_over + priv::render_unapplied $overlay_grapheme_control_list $gci + set instruction move ;#own instruction? decstbm? + break + } + s { + #code conflict between ansi emulation and DECSLRM - REVIEW + #ANSISYSSC (when no parameters) - like other terminals - essentially treat same as DECSC + # todo - when parameters - support DECSLRM instead + + if {$param ne ""} { + #DECSLRM - should only be recognised if DECLRMM is set (vertical split screen mode) + lassign [split $param {;}] margin_left margin_right + puts stderr "overtype DECSLRM not yet supported - got [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + if {$margin_left eq ""} { + set margin_left 1 + } + set columns_per_page 80 ;#todo - set to 'page width (DECSCPP set columns per page)' - could be 132 or?? + if {$margin_right eq ""} { + set margin_right $columns_per_page + } + puts stderr "DECSLRM margin left: $margin_left margin right: $margin_right" + if {![string is integer -strict $margin_left] || $margin_left < 0} { + puts stderr "DECSLRM invalid margin_left" + } + if {![string is integer -strict $margin_right] || $margin_right < 0} { + puts stderr "DECSLRM invalid margin_right" + } + set scrolling_region_size [expr {$margin_right - $margin_left}] + if {$scrolling_region_size < 2 || $scrolling_region_size > $columns_per_page} { + puts stderr "DECSLRM region size '$scrolling_regsion_size' must be between 1 and $columns_per_page" + } + #todo + + + } else { + #DECSC + #//notes on expected behaviour: + #DECSC - saves following items in terminal's memory + #cursor position + #character attributes set by the SGR command + #character sets (G0,G1,G2 or G3) currently in GL and GR + #Wrap flag (autowrap or no autowrap) + #State of origin mode (DECOM) + #selective erase attribute + #any single shift 2 (SS2) or single shift 3(SSD) functions sent + + #$re_cursor_save + #cursor save could come after last column + if {$overflow_idx != -1 && $idx == $overflow_idx} { + #bartman2.ans test file - fixes misalignment at bottom of dialog bubble + #incr cursor_row + #set cursor_column 1 + #bwings1.ans test file - breaks if we actually incr cursor (has repeated saves) + set cursor_saved_position [list row [expr {$cursor_row+1}] column 1] + } else { + set cursor_saved_position [list row $cursor_row column $cursor_column] + } + #there may be overlay stackable codes emitted that aren't in the understacks because they come between the last emmited character and the cursor_save control. + #we need the SGR and gx overlay codes prior to the cursor_save + + #a real terminal would not be able to know the state of the underlay.. so we should probably ignore it. + #set sgr_stack [lindex $understacks $idx] + #set gx_stack [lindex $understacks_gx $idx] ;#not actually a stack - just a boolean state (for now?) + + set sgr_stack [list] + set gx_stack [list] + + #we shouldn't need to scan for intermediate cursor save/restores - as restores would throw-back to the calling loop - so our overlay 'line' is since those. + #The overlay_grapheme_control_list had leading resets from previous lines - so we go back to the beginning not just the first grapheme. + + foreach gc [lrange $overlay_grapheme_control_list 0 $gci-1] { + lassign $gc type code + #types g other sgr gx0 + switch -- $type { + gx0 { + #code is actually a stand-in for the graphics on/off code - not the raw code + #It is either gx0_on or gx0_off + set gx_stack [list $code] + } + sgr { + #code is the raw code + if {[punk::ansi::codetype::is_sgr_reset $code]} { + #jmn + set sgr_stack [list "\x1b\[m"] + } elseif {[punk::ansi::codetype::has_sgr_leadingreset $code]} { + set sgr_stack [list $code] + lappend overlay_grapheme_control_list [list sgr $code] + } elseif {[priv::is_sgr $code]} { + #often we don't get resets - and codes just pile up. + #as a first step to simplifying - at least remove earlier straight up dupes + set dup_posns [lsearch -all -exact $sgr_stack $code] ;#needs -exact - codes have square-brackets (glob chars) + set sgr_stack [lremove $sgr_stack {*}$dup_posns] + lappend sgr_stack $code + } + } + } + } + set cursor_saved_attributes "" + switch -- [lindex $gx_stack 0] { + gx0_on { + append cursor_saved_attributes "\x1b(0" + } + gx0_off { + append cursor_saved_attributes "\x1b(B" + } + } + #append cursor_saved_attributes [join $sgr_stack ""] + append cursor_saved_attributes [punk::ansi::codetype::sgr_merge_list {*}$sgr_stack] + + #as there is apparently only one cursor storage element we don't need to throw back to the calling loop for a save. + + #don't incr index - or the save will cause cursor to move to the right + #carry on + } + } + u { + #ANSISYSRC save cursor (when no parameters) (DECSC) + + #$re_cursor_restore + #we are going to jump somewhere.. for now we will assume another line, and process accordingly. + #The caller has the cursor_saved_position/cursor_saved_attributes if any (?review - if we always pass it back it, we could save some calls for moves in same line) + #don't set overflow at this point. The existing underlay to the right must be preserved. + #we only want to jump and render the unapplied at the new location. + + #lset overstacks $idx_over [list] + #set replay_codes_overlay "" + + #if {$cursor_saved_attributes ne ""} { + # set replay_codes_overlay $cursor_saved_attributes ;#empty - or last save if it happend in this input chunk + #} else { + #jj + #set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] + set replay_codes_overlay "" + #} + + #like priv::render_unapplied - but without the overlay's ansi reset or gx stacks from before the restore code + incr idx_over + + set unapplied "" + set unapplied_list [list] + foreach gc [lrange $overlay_grapheme_control_list $gci+1 end] { + lassign $gc type item + if {$type eq "gx0"} { + if {$item eq "gx0_on"} { + lappend unapplied_list "\x1b(0" + } elseif {$item eq "gx0_off"} { + lappend unapplied_list "\x1b(B" + } + } else { + lappend unapplied_list $item + } + #incr idx_over + } + set unapplied [join $unapplied_list ""] + #if the save occured within this line - that's ok - it's in the return value list and caller can prepend for the next loop. + set instruction restore_cursor + break + } + "{" { + + puts stderr "renderline warning - CSI.. - unimplemented [ansistring VIEW -lf 1 -nul 1 $code]" + } + "}" { + set code_secondlast [tcl::string::index $codenorm end-1] + switch -exact -- $code_secondlast { + ' { + puts stderr "renderline warning - DECIC - Insert Column - CSI...' - unimplemented [ansistring VIEW -lf 1 -nul 1 $code]" + } + default { + puts stderr "renderline warning - CSI.. - unimplemented [ansistring VIEW -lf 1 -nul 1 $code]" + } + } + } + ~ { + set code_secondlast [tcl::string::index $codenorm end-1] ;#used for e.g CSI x '~ + switch -exact -- $code_secondlast { + ' { + #DECDC - editing sequence - Delete Column + puts stderr "renderline warning - DECDC - unimplemented" + } + default { + #$re_vt_sequence + lassign [split $param {;}] key mod + + #Note that f1 to f4 show as ESCOP|Q|R|S (VT220?) but f5+ show as ESC\[15~ + # + #e.g esc \[2~ insert esc \[2;2~ shift-insert + #mod - subtract 1, and then use bitmask + #shift = 1, (left)Alt = 2, control=4, meta=8 (meta seems to do nothing on many terminals on windows? Intercepted by windows?) + #puts stderr "vt key:$key mod:$mod code:[ansistring VIEW $code]" + if {$key eq "1"} { + #home + } elseif {$key eq "2"} { + #Insert + if {$mod eq ""} { + #no modifier key + set insert_mode [expr {!$insert_mode}] + #rather than set the cursor - we return the insert mode state so the caller can decide + } + } elseif {$key eq "3"} { + #Delete - presumably this shifts other chars in the line, with empty cells coming in from the end + switch -- $mod { + "" { + priv::render_delchar $idx + } + "5" { + #ctrl-del - delete to end of word (pwsh) - possibly word on next line if current line empty(?) + } + } + } elseif {$key eq "4"} { + #End + } elseif {$key eq "5"} { + #pgup + } elseif {$key eq "6"} { + #pgDn + } elseif {$key eq "7"} { + #Home + #?? + set idx [expr {$opt_colstart -1}] + set cursor_column 1 + } elseif {$key eq "8"} { + #End + } elseif {$key eq "11"} { + #F1 - or ESCOP or e.g shift F1 ESC\[1;2P + } elseif {$key eq "12"} { + #F2 - or ESCOQ + } elseif {$key eq "13"} { + #F3 - or ESCOR + } elseif {$key eq "14"} { + #F4 - or ESCOS + } elseif {$key eq "15"} { + #F5 or shift F5 ESC\[15;2~ + } elseif {$key eq "17"} { + #F6 + } elseif {$key eq "18"} { + #F7 + } elseif {$key eq "19"} { + #F8 + } elseif {$key eq "20"} { + #F9 + } elseif {$key eq "21"} { + #F10 + } elseif {$key eq "23"} { + #F11 + } elseif {$key eq "24"} { + #F12 + } + + } + } + + } + h - l { + #set mode unset mode + #we are matching only last char to get to this arm - but are there other sequences ending in h|l we need to handle? + + #$re_mode if first after CSI is "?" + #some docs mention ESC=h|l - not seen on windows terminals.. review + #e.g https://www2.math.upenn.edu/~kazdan/210/computer/ansi.html + set modegroup [tcl::string::index $codenorm 4] ;#e.g ? = + switch -exact -- $modegroup { + ? { + set smparams [tcl::string::range $codenorm 5 end-1] ;#params between ? and h|l + #one or more modes can be set + set smparam_list [split $smparams {;}] + foreach num $smparam_list { + switch -- $num { + "" { + #ignore empties e.g extra/trailing semicolon in params + } + 5 { + #DECSNM - reverse video + #How we simulate this to render within a block of text is an open question. + #track all SGR stacks and constantly flip based on the current SGR reverse state? + #It is the job of the calling loop to do this - so at this stage we'll just set the states + + if {$code_end eq "h"} { + #set (enable) + set reverse_mode 1 + } else { + #reset (disable) + set reverse_mode 0 + } + + } + 7 { + #DECAWM autowrap + if {$code_end eq "h"} { + #set (enable) + set autowrap_mode 1 + if {$opt_width ne "\uFFEF"} { + set overflow_idx $opt_width + } else { + #review - this is also the cursor position when adding a char at end of line? + set overflow_idx [expr {[llength $undercols]}] ;#index at which we would be *in* overflow a row move may still override it + } + #review - can idx ever be beyond overflow_idx limit when we change e.g with a width setting and cursor movements? + # presume not usually - but sanity check with warning for now. + if {$idx >= $overflow_idx} { + puts stderr "renderline warning - idx '$idx' >= overflow_idx '$overflow_idx' - unexpected" + } + } else { + #reset (disable) + set autowrap_mode 0 + #REVIEW! + set overflow_idx -1 + } + } + 25 { + if {$code_end eq "h"} { + #visible cursor + + } else { + #invisible cursor + + } + } + 117 { + #DECECM - Erase Color Mode + #https://invisible-island.net/ncurses/ncurses.faq.html + #The Erase color selection controls the background color used when text is erased or new + #text is scrolled on to the screen. Screen background causes newly erased areas or + #scrolled text to be written using color index zero, the screen background. This is VT + #and DECterm compatible. Text background causes erased areas or scrolled text to be + #written using the current text background color. This is PC console compatible and is + #the factory default. + + #see also: https://unix.stackexchange.com/questions/251726/clear-to-end-of-line-uses-the-wrong-background-color-in-screen + } + } + } + } + = { + set num [tcl::string::range $codenorm 5 end-1] ;#param between = and h|l + puts stderr "overtype::renderline CSI=...h|l code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code] not implemented" + } + default { + #e.g CSI 4 h + set num [tcl::string::range $codenorm 4 end-1] ;#param before h|l + switch -exact -- $num { + 3 { + puts stderr "CRM MODE $code_end" + #CRM - Show control character mode + # 'No control functions are executed except LF,FF and VT which are represented in the CRM FONT before a CRLF(new line) is executed' + # + #use ansistring VIEW -nul 1 -lf 2 -ff 2 -vt 2 + #https://vt100.net/docs/vt510-rm/CRM.html + #NOTE - vt100 CRM always does auto-wrap at right margin. + #disabling auto-wrap in set-up or by sequence is disabled. + #We should default to turning off auto-wrap when crm_mode enabled.. but + #displaying truncated (on rhs) crm can still be very useful - and we have optimisation in overflow to avoid excess renderline calls (per grapheme) + #we therefore could reasonably put in an exception to allow auto_wrap to be disabled after crm_mode is engaged, + #although this would be potentially an annoying difference to some.. REVIEW + if {$code_end eq "h"} { + set crm_mode 1 + set autowrap_mode 1 + if {$opt_width ne "\uFFEF"} { + set overflow_idx $opt_width + } else { + #review - this is also the cursor position when adding a char at end of line? + set overflow_idx [expr {[llength $undercols]}] ;#index at which we would be *in* overflow a row move may still override it + } + } else { + set crm_mode 0 + } + } + 4 { + #IRM - Insert/Replace Mode + if {$code_end eq "h"} { + #CSI 4 h + set insert_mode 1 + } else { + #CSI 4 l + #replace mode + set insert_mode 0 + } + } + default { + puts stderr "overtype::renderline CSI...h|l code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code] not implemented" + } + } + } + } + } + | { + switch -- [tcl::string::index $codenorm end-1] { + {$} { + #CSI ... $ | DECSCPP set columns per page- (recommended in vt510 docs as preferable to DECCOLM) + #real terminals generally only supported 80/132 + #some other virtuals support any where from 2 to 65,536? + #we will allow arbitrary widths >= 2 .. to some as yet undetermined limit. + #CSI $ | + #empty or 0 param is 80 for compatibility - other numbers > 2 accepted + set page_width -1 ;#flag as unset + if {$param eq ""} { + set page_width 80 + } elseif {[string is integer -strict $param] && $param >=2} { + set page_width [expr {$param}] ;#we should allow leading zeros in the number - but lets normalize using expr + } else { + puts stderr "overtype::renderline unacceptable DECSPP value '$param'" + } + + if {$page_width > 2} { + puts stderr "overtype::renderline DECSCPP - not implemented - but selected width '$page_width' looks ok" + #if cursor already beyond new page_width - will move to right colum - otherwise no cursor movement + + } + + } + default { + puts stderr "overtype::renderline unrecognised CSI code ending in pipe (|) [ansistring VIEW -lf 1 -vt 1 -nul 1 $code] not implemented" + } + } + } + default { + puts stderr "overtype::renderline CSI code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code] not implemented" + } + } + } + 7ESC { + # + #re_other_single {\x1b(D|M|E)$} + #also vt52 Y.. + #also PM \x1b^...(ST) + switch -- [tcl::string::index $codenorm 4] { + c { + #RIS - reset terminal to initial state - where 'terminal' in this case is the renderspace - not the underlying terminal! + puts stderr "renderline reset" + priv::render_unapplied $overlay_grapheme_control_list $gci + set instruction reset + break + } + D { + #\x84 + #index (IND) + #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_unapplied $overlay_grapheme_control_list $gci + set instruction down + #retain cursor_column + break + } + E { + #\x85 + #review - is behaviour different to lf? + #todo - possibly(?) same logic as handling above. i.e return instruction depends on where column_cursor is at the time we get NEL + #leave implementation until logic for is set in stone... still under review + #It's arguable NEL is a pure cursor movement as opposed to the semantic meaning of crlf or lf in a file. + # + #Next Line (NEL) "Move the cursor to the left margin on the next line. If the cursor is at the bottom margin, scroll the page up" + puts stderr "overtype::renderline ESC E unimplemented" + + } + H { + #\x88 + #Tab Set + puts stderr "overtype::renderline ESC H tab set unimplemented" + } + M { + #\x8D + #Reverse Index (RI) + #vt102-docs: "Moves cursor up one line in same column. If cursor is at top margin, screen performs a scroll-down" + puts stderr "overtype::renderline ESC M not fully implemented" + + set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] + #move up + incr cursor_row -1 + if {$cursor_row < 1} { + set cursor_row 1 + } + #ensure rest of *overlay* is emitted to remainder + priv::render_unapplied $overlay_grapheme_control_list $gci + set instruction up ;#need instruction for scroll-down? + #retain cursor_column + break + } + N { + #\x8e - affects next character only + puts stderr "overtype::renderline single shift select G2 command UNIMPLEMENTED. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + } + O { + #\x8f - affects next character only + puts stderr "overtype::renderline single shift select G3 command UNIMPLEMENTED. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + } + P { + #\x90 + #DCS - shouldn't get here - handled in 7DCS branch + #similarly \] OSC (\x9d) and \\ (\x9c) ST + } + V { + #\x96 + + } + W { + #\x97 + } + X { + #\x98 + #SOS + if {[string index $code end] eq "\007"} { + set sos_content [string range $code 2 end-1] ;#ST is \007 + } else { + set sos_content [string range $code 2 end-2] ;#ST is \x1b\\ + } + #return in some useful form to the caller + #TODO! + lappend sos_list [list string $sos_content row $cursor_row column $cursor_column] + puts stderr "overtype::renderline ESCX SOS UNIMPLEMENTED. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + } + ^ { + #puts stderr "renderline PM" + #Privacy Message. + if {[string index $code end] eq "\007"} { + set pm_content [string range $code 2 end-1] ;#ST is \007 + } else { + set pm_content [string range $code 2 end-2] ;#ST is \x1b\\ + } + #We don't want to render it - but we need to make it available to the application + #see the textblock library in punk, for the exception we make here for single backspace. + #It is unlikely to be encountered as a useful PM - so we hack to pass it through as a fix + #for spacing issues on old terminals which miscalculate the single-width 'Symbols for Legacy Computing' + if {$pm_content eq "\b"} { + #puts stderr "renderline PM sole backspace special handling for \U1FB00 - \U1FBFF" + #esc^\b\007 or esc^\besc\\ + #HACKY pass-through - targeting terminals that both mis-space legacy symbols *and* don't support PMs + #The result is repair of the extra space. If the terminal is a modern one and does support PM - the \b should be hidden anyway. + #If the terminal has the space problem AND does support PMs - then this just won't fix it. + #The fix relies on the symbol-supplier to cooperate by appending esc^\b\esc\\ to the problematic symbols. + + #priv::render_addchar $idx $code [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode + #idx has been incremented after last grapheme added + priv::render_append_to_char [expr {$idx -1}] $code + } + #lappend to a dict element in the result for application-specific processing + lappend pm_list $pm_content + } + _ { + #APC Application Program Command + #just warn for now.. + puts stderr "overtype::renderline ESC_ APC command UNIMPLEMENTED. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + } + default { + puts stderr "overtype::renderline ESC code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code] not implemented codenorm:[ansistring VIEW -lf 1 -vt 1 -nul 1 $codenorm]" + } + } + + } + 7DCS - 8DCS { + puts stderr "overtype::renderline DCS - DEVICE CONTROL STRING command UNIMPLEMENTED. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + #ST (string terminator) \x9c or \x1b\\ + if {[tcl::string::index $codenorm end] eq "\x9c"} { + set code_content [tcl::string::range $codenorm 4 end-1] ;#ST is 8-bit 0x9c + } else { + set code_content [tcl::string::range $codenorm 4 end-2] ;#ST is \x1b\\ + } + + } + 7OSC - 8OSC { + # OSCs are terminated with ST of either \007 or \x1b\\ - we allow either whether code was 7 or 8 bit + if {[tcl::string::index $codenorm end] eq "\007"} { + set code_content [tcl::string::range $codenorm 4 end-1] ;#ST is \007 + } else { + set code_content [tcl::string::range $codenorm 4 end-2] ;#ST is \x1b\\ + } + set first_colon [tcl::string::first {;} $code_content] + if {$first_colon == -1} { + #there probably should always be a colon - but we'll try to make sense of it without + set osc_code $code_content ;#e.g \x1b\]104\007 vs \x1b\]104\;\007 + } else { + set osc_code [tcl::string::range $code_content 0 $first_colon-1] + } + switch -exact -- $osc_code { + 2 { + set newtitle [tcl::string::range $code_content 2 end] + priv::render_unapplied $overlay_grapheme_control_list $gci + set instruction [list set_window_title $newtitle] + break + } + 4 { + #OSC 4 - set colour palette + #can take multiple params + #e.g \x1b\]4\;1\;red\;2\;green\x1b\\ + set params [tcl::string::range $code_content 2 end] ;#strip 4 and first semicolon + set cmap [dict create] + foreach {cnum spec} [split $params {;}] { + if {$cnum >= 0 && $cnum <= 255} { + #todo - parse spec from names like 'red' to RGB + #todo - accept rgb:ab/cd/ef as well as rgb:/a/b/c (as alias for aa/bb/cc) + #also - what about rgb:abcd/defg/hijk and 12-bit abc/def/ghi ? + dict set cmap $cnum $spec + } else { + #todo - log + puts stderr "overtype::renderline OSC 4 set colour palette - bad color number: $cnum must be from 0 to 255. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + } + } + + puts stderr "overtype::renderline OSC 4 set colour palette unimplemented. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + + + } + 10 - 11 - 12 - 13 - 14 - 15 - 16 - 17 { + #OSC 10 through 17 - so called 'dynamic colours' + #can take multiple params - each successive parameter changes the next colour in the list + #- e.g if code started at 11 - next param is for 12. 17 takes only one param because there are no more + #10 change text foreground colour + #11 change text background colour + #12 change text cursor colour + #13 change mouse foreground colour + #14 change mouse background colour + #15 change tektronix foreground colour + #16 change tektronix background colour + #17 change highlight colour + set params [tcl::string::range $code_content 2 end] + + puts stderr "overtype::renderline OSC $osc_code set dynamic colours unimplemented. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + + + } + 18 { + #why is this not considered one of the dynamic colours above? + #https://www.xfree86.org/current/ctlseqs.html + #tektronix cursor color + puts stderr "overtype::renderline OSC 18 - set tektronix cursor color unimplemented. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + } + 99 { + #kitty desktop notifications + #https://sw.kovidgoyal.net/kitty/desktop-notifications/ + # 99 ; metadata ; payload + puts stderr "overtype::renderline OSC 99 kitty desktop notification unimplemented. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + } + 104 { + #reset colour palette + #we want to do it for the current rendering context only (vvt) - not just pass through to underlying vt + puts stderr "overtype::renderline OSC 104 reset colour palette unimplemented. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + priv::render_unapplied $overlay_grapheme_control_list $gci + set instruction [list reset_colour_palette] + break + } + 1337 { + #iterm2 graphics and file transfer + puts stderr "overtype::renderline OSC 1337 iterm2 graphics/file_transfer unimplemented. 1st 100 chars of code [ansistring VIEW -lf 1 -vt 1 -nul 1 [string range $code 0 99]]" + } + 5113 { + puts stderr "overtype::renderline OSC 5113 kitty file transfer unimplemented. 1st 100 chars of code [ansistring VIEW -lf 1 -vt 1 -nul 1 [string range $code 0 99]]" + } + default { + puts stderr "overtype::renderline OSC - UNIMPLEMENTED. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + } + } + + } + default { + } + } + + + } + default { + #don't need to handle sgr or gx0 types + #we have our sgr gx0 codes already in stacks for each overlay grapheme + } + } + } + + #-------- + if {$opt_expand_right == 0} { + #need to truncate to the width of the original undertext + #review - string_width vs printing_length here. undertext requirement to be already rendered therefore punk::char::string_width ok? + #set num_under_columns [punk::char::string_width $pt_underchars] ;#plaintext underchars + } + if {$overflow_idx == -1} { + #overflow was initially unlimited and hasn't been overridden + } else { + + } + #-------- + + + #coalesce and replay codestacks for outcols grapheme list + set outstring "" ;#output prior to overflow + set overflow_right "" ;#remainder after overflow point reached + set i 0 + set cstack [list] + set prevstack [list] + set prev_g0 [list] + #note overflow_idx may already have been set lower if we had a row move above due to \v or ANSI moves + set in_overflow 0 ;#used to stop char-width scanning once in overflow + if {$overflow_idx == 0} { + #how does caller avoid an infinite loop if they have autowrap on and keep throwing graphemes to the next line? REVIEW + set in_overflow 1 + } + set trailing_nulls 0 + foreach ch [lreverse $outcols] { + if {$ch eq "\u0000"} { + incr trailing_nulls + } else { + break + } + } + if {$trailing_nulls} { + set first_tail_null_posn [expr {[llength $outcols] - $trailing_nulls}] + } else { + set first_tail_null_posn -1 + } + + #puts stderr "first_tail_null_posn: $first_tail_null_posn" + #puts stderr "colview: [ansistring VIEW $outcols]" + + foreach ch $outcols { + #puts "---- [ansistring VIEW $ch]" + + set gxleader "" + if {$i < [llength $understacks_gx]} { + #set g0 [tcl::dict::get $understacks_gx $i] + set g0 [lindex $understacks_gx $i] + if {$g0 ne $prev_g0} { + if {$g0 eq [list "gx0_on"]} { + set gxleader "\x1b(0" + } else { + set gxleader "\x1b(B" + } + } + set prev_g0 $g0 + } else { + set prev_g0 [list] + } + + set sgrleader "" + if {$i < [llength $understacks]} { + #set cstack [tcl::dict::get $understacks $i] + set cstack [lindex $understacks $i] + if {$cstack ne $prevstack} { + if {[llength $prevstack] && ![llength $cstack]} { + #This reset is important e.g testfile fruit.ans - we get overhang on rhs without it. But why is cstack empty? + append sgrleader \033\[m + } else { + append sgrleader [punk::ansi::codetype::sgr_merge_list {*}$cstack] + } + } + set prevstack $cstack + } else { + set prevstack [list] + } + + + + if {$in_overflow} { + if {$i == $overflow_idx} { + set 0 [lindex $understacks_gx $i] + set gxleader "" + if {$g0 eq [list "gx0_on"]} { + set gxleader "\x1b(0" + } elseif {$g0 eq [list "gx0_off"]} { + set gxleader "\x1b(B" + } + append overflow_right $gxleader + set cstack [lindex $understacks $i] + set sgrleader "" + #whether cstack is same or differs from previous char's stack - we must have an output at the start of the overflow_right + #if {[llength $prevstack] && ![llength $cstack]} { + # append sgrleader \033\[m + #} + append sgrleader [punk::ansi::codetype::sgr_merge_list {*}$cstack] + append overflow_right $sgrleader + append overflow_right $ch + } else { + append overflow_right $gxleader + append overflow_right $sgrleader + append overflow_right $ch + } + } else { + if {$overflow_idx != -1 && $i+1 == $overflow_idx} { + #one before overflow + #will be in overflow in next iteration + set in_overflow 1 + if {[grapheme_width_cached $ch]> 1} { + #we overflowed with second-half of a double-width char - replace first-half with user-supplied exposition char (should be 1 wide) + set ch $opt_exposed1 + } + } + append outstring $gxleader + append outstring $sgrleader + if {$ch eq "\u0000"} { + if {$cp437_glyphs} { + #map all nulls including at tail to space + append outstring " " + } else { + if {$trailing_nulls && $i < $first_tail_null_posn} { + append outstring " " ;#map inner nulls to space + } else { + append outstring \u0000 + } + } + } else { + append outstring $ch + } + } + incr i + } + #flower.ans good test for null handling - reverse line building + #review - presence of overflow_right doesn't indicate line's trailing nulls should remain. + #The cells could have been erased? + #if {!$cp437_glyphs} { + # #if {![ansistring length $overflow_right]} { + # # set outstring [tcl::string::trimright $outstring "\u0000"] + # #} + # set outstring [tcl::string::trimright $outstring "\u0000"] + # set outstring [tcl::string::map {\u0000 " "} $outstring] + #} + + + #REVIEW + #set overflow_right [tcl::string::trimright $overflow_right "\u0000"] + #set overflow_right [tcl::string::map {\u0000 " "} $overflow_right] + + set replay_codes "" + if {[llength $understacks] > 0} { + if {$overflow_idx == -1} { + #set tail_idx [tcl::dict::size $understacks] + set tail_idx [llength $understacks] + } else { + set tail_idx [llength $undercols] + } + if {$tail_idx-1 < [llength $understacks]} { + #set replay_codes [join [lindex $understacks $tail_idx-1] ""] ;#tail replay codes + set replay_codes [punk::ansi::codetype::sgr_merge_list {*}[lindex $understacks $tail_idx-1]] ;#tail replay codes + } + if {$tail_idx-1 < [llength $understacks_gx]} { + set gx0 [lindex $understacks_gx $tail_idx-1] + if {$gx0 eq [list "gx0_on"]} { + #if it was on, turn gx0 off at the point we stop processing overlay + append outstring "\x1b(B" + } + } + } + if {[string length $overflow_right]} { + #puts stderr "remainder:$overflow_right" + } + #pdict $understacks + + if {[punk::ansi::ta::detect_sgr $outstring]} { + append outstring [punk::ansi::a] ;#without this - we would get for example, trailing backgrounds after rightmost column + + #close off any open gx? + #probably should - and overflow_right reopen? + } + + if {$opt_returnextra} { + #replay_codes is the codestack at the boundary - used for ellipsis colouring to match elided text - review + #replay_codes_underlay is the set of codes in effect at the very end of the original underlay + + #review + #replay_codes_overlay is the set of codes in effect at the very end of the original overlay (even if not all overlay was applied) + #todo - replay_codes for gx0 mode + + #overflow_idx may change during ansi & character processing + if {$overflow_idx == -1} { + set overflow_right_column "" + } else { + set overflow_right_column [expr {$overflow_idx+1}] + } + set result [tcl::dict::create\ + result $outstring\ + visualwidth [punk::ansi::printing_length $outstring]\ + instruction $instruction\ + stringlen [string length $outstring]\ + overflow_right_column $overflow_right_column\ + overflow_right $overflow_right\ + unapplied $unapplied\ + unapplied_list $unapplied_list\ + insert_mode $insert_mode\ + autowrap_mode $autowrap_mode\ + crm_mode $crm_mode\ + reverse_mode $reverse_mode\ + insert_lines_above $insert_lines_above\ + insert_lines_below $insert_lines_below\ + cursor_saved_position $cursor_saved_position\ + cursor_saved_attributes $cursor_saved_attributes\ + cursor_column $cursor_column\ + cursor_row $cursor_row\ + expand_right $opt_expand_right\ + replay_codes $replay_codes\ + replay_codes_underlay $replay_codes_underlay\ + replay_codes_overlay $replay_codes_overlay\ + pm_list $pm_list\ + ] + if {$opt_returnextra == 1} { + #puts stderr "renderline: $result" + return $result + } else { + #human/debug - map special chars to visual glyphs + set viewop VIEW + switch -- $opt_returnextra { + 2 { + #codes and character data + set viewop VIEWCODES ;#ansi colorisation of codes - green for SGR, blue/blue reverse for cursor_save/cursor_restore, cyan for movements, orange for others + } + 3 { + set viewop VIEWSTYLE ;#ansi colorise the characters within the output with preceding codes, stacking codes only within each dict value - may not be same SGR effect as the effect in-situ. + } + } + tcl::dict::set result result [ansistring $viewop -lf 1 -vt 1 [tcl::dict::get $result result]] + tcl::dict::set result overflow_right [ansistring VIEW -lf 1 -vt 1 [tcl::dict::get $result overflow_right]] + tcl::dict::set result unapplied [ansistring VIEW -lf 1 -vt 1 [tcl::dict::get $result unapplied]] + tcl::dict::set result unapplied_list [ansistring VIEW -lf 1 -vt 1 [tcl::dict::get $result unapplied_list]] + tcl::dict::set result replay_codes [ansistring $viewop -lf 1 -vt 1 [tcl::dict::get $result replay_codes]] + tcl::dict::set result replay_codes_underlay [ansistring $viewop -lf 1 -vt 1 [tcl::dict::get $result replay_codes_underlay]] + tcl::dict::set result replay_codes_overlay [ansistring $viewop -lf 1 -vt 1 [tcl::dict::get $result replay_codes_overlay]] + tcl::dict::set result cursor_saved_attributes [ansistring $viewop -lf 1 -vt 1 [tcl::dict::get $result cursor_saved_attributes]] + return $result + } + } else { + #puts stderr "renderline returning: result $outstring instruction $instruction unapplied $unapplied overflow_right $overflow_right" + return $outstring + } + #return [join $out ""] + } + + #*** !doctools + #[list_end] [comment {--- end definitions namespace overtype ---}] +} + +tcl::namespace::eval overtype::piper { + proc overcentre {args} { + if {[llength $args] < 2} { + error {usage: ?-bias left|right? ?-transparent [0|1|]? ?-exposed1 ? ?-exposed2 ? ?-overflow [1|0]? overtext pipelinedata} + } + lassign [lrange $args end-1 end] over under + set argsflags [lrange $args 0 end-2] + tailcall overtype::centre {*}$argsflags $under $over + } + proc overleft {args} { + if {[llength $args] < 2} { + error {usage: ?-startcolumn ? ?-transparent [0|1|]? ?-exposed1 ? ?-exposed2 ? ?-overflow [1|0]? overtext pipelinedata} + } + lassign [lrange $args end-1 end] over under + set argsflags [lrange $args 0 end-2] + tailcall overtype::left {*}$argsflags $under $over + } +} + + +# -- --- --- --- --- --- --- --- --- --- --- +proc overtype::transparentline {args} { + foreach {under over} [lrange $args end-1 end] break + set argsflags [lrange $args 0 end-2] + set defaults [tcl::dict::create\ + -transparent 1\ + -exposed 1 " "\ + -exposed 2 " "\ + ] + set newargs [tcl::dict::merge $defaults $argsflags] + tailcall overtype::renderline {*}$newargs $under $over +} +#renderline may not make sense as it is in the long run for blocks of text - but is handy in the single-line-handling form anyway. +# We are trying to handle ansi codes in a block of text which is acting like a mini-terminal in some sense. +#We can process standard cursor moves such as \b \r - but no way to respond to other cursor movements e.g moving to other lines. +# +tcl::namespace::eval overtype::piper { + proc renderline {args} { + if {[llength $args] < 2} { + error {usage: ?-start ? ?-transparent [0|1|]? ?-overflow [1|0]? overtext pipelinedata} + } + foreach {over under} [lrange $args end-1 end] break + set argsflags [lrange $args 0 end-2] + tailcall overtype::renderline {*}$argsflags $under $over + } +} +interp alias "" piper_renderline "" overtype::piper::renderline + +#intended primarily for single grapheme - but will work for multiple +#WARNING: query CAN contain ansi or newlines - but if cache was not already set manually,the answer will be incorrect! +#We deliberately allow this for PM/SOS attached within a column +#(a cache of ansifreestring_width calls - as these are quite regex heavy) +proc overtype::grapheme_width_cached {ch} { + variable grapheme_widths + if {[tcl::dict::exists $grapheme_widths $ch]} { + return [tcl::dict::get $grapheme_widths $ch] + } + set width [punk::char::ansifreestring_width $ch] + tcl::dict::set grapheme_widths $ch $width + return $width +} + + + +proc overtype::test_renderline {} { + set t \uFF5E ;#2-wide tilde + set u \uFF3F ;#2-wide underscore + set missing \uFFFD + return [list $t $u A${t}B] +} + +#maintenance warning +#same as textblock::size - but we don't want that circular dependency +#block width and height can be tricky. e.g \v handled differently on different terminal emulators and can affect both +proc overtype::blocksize {textblock} { + if {$textblock eq ""} { + return [tcl::dict::create width 0 height 1] ;#no such thing as zero-height block - for consistency with non-empty strings having no line-endings + } + if {[tcl::string::first \t $textblock] >= 0} { + if {[info exists punk::console::tabwidth]} { + set tw $::punk::console::tabwidth + } else { + set tw 8 + } + set textblock [textutil::tabify::untabify2 $textblock $tw] + } + #ansistrip on entire block in one go rather than line by line - result should be the same - review - make tests + if {[punk::ansi::ta::detect $textblock]} { + set textblock [punk::ansi::ansistrip $textblock] + } + if {[tcl::string::last \n $textblock] >= 0} { + set num_le [expr {[tcl::string::length $textblock]-[tcl::string::length [tcl::string::map {\n {}} $textblock]]}] ;#faster than splitting into single-char list + set width [tcl::mathfunc::max {*}[lmap v [split $textblock \n] {::punk::char::ansifreestring_width $v}]] + } else { + set num_le 0 + set width [punk::char::ansifreestring_width $textblock] + } + #our concept of block-height is likely to be different to other line-counting mechanisms + set height [expr {$num_le + 1}] ;# one line if no le - 2 if there is one trailing le even if no data follows le + + return [tcl::dict::create width $width height $height] ;#maintain order in 'image processing' standard width then height - caller may use lassign [dict values [blocksize ]] width height +} + +tcl::namespace::eval overtype::priv { + variable cache_is_sgr [tcl::dict::create] + + #we are likely to be asking the same question of the same ansi codes repeatedly + #caching the answer saves some regex expense - possibly a few uS to lookup vs under 1uS + #todo - test if still worthwhile after a large cache is built up. (limit cache size?) + proc is_sgr {code} { + variable cache_is_sgr + if {[tcl::dict::exists $cache_is_sgr $code]} { + return [tcl::dict::get $cache_is_sgr $code] + } + set answer [punk::ansi::codetype::is_sgr $code] + tcl::dict::set cache_is_sgr $code $answer + return $answer + } + # better named render_to_unapplied? + proc render_unapplied {overlay_grapheme_control_list gci} { + upvar idx_over idx_over + upvar unapplied unapplied + upvar unapplied_list unapplied_list ;#maintaining as a list allows caller to utilize it without having to re-split + upvar overstacks overstacks + upvar overstacks_gx overstacks_gx + upvar overlay_grapheme_control_stacks og_stacks + + #set unapplied [join [lrange $overlay_grapheme_control_list $gci+1 end]] + set unapplied "" + set unapplied_list [list] + #append unapplied [join [lindex $overstacks $idx_over] ""] + #append unapplied [punk::ansi::codetype::sgr_merge_list {*}[lindex $overstacks $idx_over]] + set sgr_merged [punk::ansi::codetype::sgr_merge_list {*}[lindex $og_stacks $gci]] + if {$sgr_merged ne ""} { + lappend unapplied_list $sgr_merged + } + switch -- [lindex $overstacks_gx $idx_over] { + "gx0_on" { + lappend unapplied_list "\x1b(0" + } + "gx0_off" { + lappend unapplied_list "\x1b(B" + } + } + + foreach gc [lrange $overlay_grapheme_control_list $gci+1 end] { + lassign $gc type item + #types g other sgr gx0 + if {$type eq "gx0"} { + if {$item eq "gx0_on"} { + lappend unapplied_list "\x1b(0" + } elseif {$item eq "gx0_off"} { + lappend unapplied_list "\x1b(B" + } + } else { + lappend unapplied_list $item + } + } + set unapplied [join $unapplied_list ""] + } + + #clearer - renders the specific gci forward as unapplied - prefixed with it's merged sgr stack + proc render_this_unapplied {overlay_grapheme_control_list gci} { + upvar idx_over idx_over + upvar unapplied unapplied + upvar unapplied_list unapplied_list + upvar overstacks overstacks + upvar overstacks_gx overstacks_gx + upvar overlay_grapheme_control_stacks og_stacks + + #set unapplied [join [lrange $overlay_grapheme_control_list $gci+1 end]] + set unapplied "" + set unapplied_list [list] + + set sgr_merged [punk::ansi::codetype::sgr_merge_list {*}[lindex $og_stacks $gci]] + if {$sgr_merged ne ""} { + lappend unapplied_list $sgr_merged + } + switch -- [lindex $overstacks_gx $idx_over] { + "gx0_on" { + lappend unapplied_list "\x1b(0" + } + "gx0_off" { + lappend unapplied_list "\x1b(B" + } + } + + foreach gc [lrange $overlay_grapheme_control_list $gci end] { + lassign $gc type item + #types g other sgr gx0 + if {$type eq "gx0"} { + if {$item eq "gx0_on"} { + lappend unapplied_list "\x1b(0" + } elseif {$item eq "gx0_off"} { + lappend unapplied_list "\x1b(B" + } + } else { + lappend unapplied_list $item + } + } + set unapplied [join $unapplied_list ""] + } + proc render_delchar {i} { + upvar outcols o + upvar understacks ustacks + upvar understacks_gx gxstacks + set nxt [llength $o] + if {$i < $nxt} { + set o [lreplace $o $i $i] + set ustacks [lreplace $ustacks $i $i] + set gxstacks [lreplace $gxstacks $i $i] + } elseif {$i == 0 || $i == $nxt} { + #nothing to do + } else { + puts stderr "render_delchar - attempt to delchar at index $i >= number of outcols $nxt - shouldn't happen" + } + } + proc render_erasechar {i count} { + upvar outcols o + upvar understacks ustacks + upvar understacks_gx gxstacks + upvar replay_codes_overlay replay + #ECH clears character attributes from erased character positions + #ECH accepts 0 or empty parameter, which is equivalent to 1. Caller of render_erasechar should do that mapping and only supply 1 or greater. + if {![tcl::string::is integer -strict $count] || $count < 1} { + error "render_erasechar count must be integer >= 1" + } + set start $i + set end [expr {$i + $count -1}] + #we restrict ECH to current line - as some terminals do - review - is that the only way it's implemented? + if {$i > [llength $o]-1} { + return + } + if {$end > [llength $o]-1} { + set end [expr {[llength $o]-1}] + } + set num [expr {$end - $start + 1}] + set o [lreplace $o $start $end {*}[lrepeat $num \u0000]] ;#or space? + #DECECM ??? + set ustacks [lreplace $ustacks $start $end {*}[lrepeat $num [list $replay]]] + set gxstacks [lreplace $gxstacks $start $end {*}[lrepeat $num [list]]] ;# ??? review + return + } + proc render_setchar {i c } { + upvar outcols o + lset o $i $c + } + + #Initial usecase is for old-terminal hack to add PM-wrapped \b + #review - can be used for other multibyte sequences that occupy one column? + #combiners? diacritics? + proc render_append_to_char {i c} { + upvar outcols o + if {$i > [llength $o]-1} { + error "render_append_to_char cannot append [ansistring VIEW -lf 1 -nul 1 $c] to existing char at index $i while $i >= llength outcols [llength $o]" + } + set existing [lindex $o $i] + if {$existing eq "\0"} { + lset o $i $c + } else { + lset o $i $existing$c + } + } + #is actually addgrapheme? + proc render_addchar {i c sgrstack gx0stack {insert_mode 0}} { + upvar outcols o + upvar understacks ustacks + upvar understacks_gx gxstacks + + # -- --- --- + #this is somewhat of a hack.. probably not really the equivalent of proper reverse video? review + #we should ideally be able to reverse the video of a sequence that already includes SGR reverse/noreverse attributes + upvar reverse_mode do_reverse + #if {$do_reverse} { + # lappend sgrstack [a+ reverse] + #} else { + # lappend sgrstack [a+ noreverse] + #} + + #JMN3 + if {$do_reverse} { + #note we can't just look for \x1b\[7m or \x1b\[27m + # it may be a more complex sequence like \x1b\[0\;\;7\;31m etc + + set existing_reverse_state 0 + set codeinfo [punk::ansi::codetype::sgr_merge $sgrstack -info 1] + set codestate_reverse [dict get $codeinfo codestate reverse] + switch -- $codestate_reverse { + 7 { + set existing_reverse_state 1 + } + 27 { + set existing_reverse_state 0 + } + "" { + } + } + if {$existing_reverse_state == 0} { + set rflip [a+ reverse] + } else { + #reverse of reverse + set rflip [a+ noreverse] + } + #note that mergeresult can have multiple esc (due to unmergeables or non sgr codes) + set sgrstack [list [dict get $codeinfo mergeresult] $rflip] + #set sgrstack [punk::ansi::codetype::sgr_merge [list [dict get $codeinfo mergeresult] $rflip]] + } + + # -- --- --- + + set nxt [llength $o] + if {!$insert_mode} { + if {$i < $nxt} { + #These lists must always be in sync + lset o $i $c + } else { + lappend o $c + } + if {$i < [llength $ustacks]} { + lset ustacks $i $sgrstack + lset gxstacks $i $gx0stack + } else { + lappend ustacks $sgrstack + lappend gxstacks $gx0stack + } + } else { + #insert of single-width vs double-width when underlying is double-width? + if {$i < $nxt} { + set o [linsert $o $i $c] + } else { + lappend o $c + } + if {$i < [llength $ustacks]} { + set ustacks [linsert $ustacks $i $sgrstack] + set gxstacks [linsert $gxstacks $i $gx0stack] + } else { + lappend ustacks $sgrstack + lappend gxstacks $gx0stack + } + } + } + +} + + + +# -- --- --- --- --- --- --- --- --- --- --- +tcl::namespace::eval overtype { + interp alias {} ::overtype::center {} ::overtype::centre +} + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Ready +package provide overtype [tcl::namespace::eval overtype { + variable version + set version 1.7.1 +}] +return + +#*** !doctools +#[manpage_end] diff --git a/src/vfs/_vfscommon.vfs/modules/packageTest-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/packageTest-0.1.0.tm deleted file mode 100644 index befc864a37b6b5d2d3fd0025f89833f11c7ed5a4..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 8506 zcmc&&3s_8B`_CoOi4@(*YPt}*s3VLnM~RdYanO`ZGrO9a*)z@FBVCWnAzhSPNyHK5 zt|QmVrCg4vNRgvBI+aUGsKe0(|F!l^moby?obUOb=f8QL-R!;AyWaP=e((GK)>a06 zF2e|p00eNj7zpE#L0~b93%GnH8xsP75EEcH8)KU*_Zbfi12G&EGD(aLL<9#91Ux=l zz-QCxJZ1>y2d(*uA4pB&1b|2ei%GJAKqR#o&KL5STuuZA7#uu+4+xf!BOraFku@{` z{uL=@0l9z)g?u5PiR}aAI6;d1#gEOw5}fG|!yx&9jggp;$H6gVO$46_m}HPSm>}R2 z1P6^Fm;o5z;Bb@x2r+^ba#$pXj}s22G^s_SrGB9xj3oX6EELdaASwzNFsOjA)f|E( zK==Fqz5g^I<&3mz1V*A**&HDdy958inLMo5AF0Wb;eJeEj(NGExE*HZCVFnt_@&$Hwz!DA?Vx&ljgUD#< z%|=tuB|XjYzn*3f7=0G+&q=f*;tk9f=%Y-y=ry{~kXgXU@tXr2fe|z#cZmE@yBCg> z|2lv##F((QtcIR}NHlnY(Q4Cvf$KBeQ4R;hfk^PBs*@zSkx{vH?4E({Tu2L8HpMut zmK!4)CO;7QPbEB%i<#^U6h4>5Brrdchmy>Xzyf&~4vP~5RXSL)Nj{e!)|2+VDGXD| z*H^~lUVAVrVKqg?lt3ZK+9O$9I-TUv>0DS0<(TRQp3Cy%Av3^8>}X%ZvSlAFg`A+K z^ofS5AQJDpEy}u&W=mxXY&fv+Q%NaV{%f3!q*wB#GOIU7zIywg5(bsQK3;Q$Ogs>_ zy}sVV_!0Jf^6;xQ0A!Rem}w}2MGF-jOh|IWVJRYD7e@AFHVs9ME`OL9A#&f!5=Zul z6mCXRf%KaPXr}^1TrMn`Axso#FrNb(1&fcv{tu*$P>lmp3R(6AbUF$V%>`5&;s?OS zEjGd=pxA)1LQCC`gjlGEBgEv!MzICeXg|25q^Vel5vRP7_QDtS9XJ?co578MT1Kk> z$Slxr??8Be9X)D7k^p54b&sbO@8c=)Fa1%Lu}tk7Rk>Jv9uIbT0#K<5B~t(al^TlH z7eIYPqxHvLL#8lLgvtis3y~UR1tHo(w()^KY=TfM!4yZYDcQIRnT6Krba$#XVkAq( zDHN_D#uP&0N<;xcM~ zyt6SbGn@c?9N>K1jA|TA=&h+-Cwh1)UIH-KP>6yM3>sj_Zdm`djb>pX1`>%LG3{vp z=b-fJ@xQ-~rnZF*B@Tzgz%0*slAZ2Dn4XlAgbu<`IzrVhBt+=O0#YtI$TNz`l7mCPgQyT>@aoa7pa-3AXpU z5>^g)V6(Tk??Wd^{psD6Uebb|J(E6%buZt2myNY&i+j-OG1af1vi+{xK4P8pxlY!; z+{4P(hmQXUs1#0A4vPyHERBplKYhQAhhbkpL^zf8pcmjCO!|ca1ui*V_a37II8esI zxjjcQc#1+D7(JqB4w(E+$ulq3|ME+1L!7~*fa*@dm zL**8Js~}J_g5Hrq7_2v}AXJRui47JPbYc_ttW_A!fx}>eqg00p3=+5fR9sFw^Ap~?zbN$2PlTl8_{M{)_~3vxFQC^r zYy`03t%72e`qE@30g*}oL^3gwkZRNyG&b-Lhq3?{!L1C36Ja_FsM8ljo=TsdJVL6L z3%@X!|0~ZHLpx%tkj1d|!XAY-60Rm;J5<%EBSGs-$Z9T9aY$3K<)@V-bqMs;NWc`L zY?4fZ-QGwp=@4Ai*R8LUb6?BVVFT190Ag}dVw6wDPA6uL{jq(Cf&0^H2fe2TfHh0GJ!hR%975j8gIUrt`} zpJckd%5LJSLzQ_fuk$B&H`t!2oZrl!cyrL!Es567x!|SCy|+JI@m-_3N!6}-$M$9F z1DZd7h`X`PP~b7fGsb1#dNm(wHB)k7N`iys*(iSGXC(2;)p$78pY zmnqW}H5IpHjagyhc50n*WUYlk>K4~88lTceMr$~w4xS&HRFrG={Mv%bH<*fiO7R7*l$ZBgEhM)%PwLvH$y@b|kBns(JLFeu+}=e|9A3YQwk6$Rz9 z7p`0Pq|7CVQCfhFVH;ej+4i`&BwaN~l>0Si3aZCe%3 zkJP++a7XdLv=e$28wNhPGd;6Vg=XJYsHgJEa@vpsUGLu9QuPQ~vu$0IfBH)uW?ECn z#s(U%#0l7@rMlS|2fp4?Rutcvw9xU_5bcGvmg&sFw|>Sd|~@mqobn2am#}u7tRY`Kl)wpk%X29D=ptI*VeTb9cH}I)SRZG%T~Hx z5i)FLjjxmScLmwTI{0#@^oFZxhllSz-FohR=b05ZUVRuccV>FlopZ*mX7kSJyjgWZ z)B0N3vWtIBKW#YESnJ@val74;+%&H&+SPI0cI~sYrXNFm&+nRCe%EE_q}|82EvtKN zO4vt^Z%_7)y>QPya}K#-#e87#UHt-|j!hnw+ICi^C#I zE1K>+)brWQv4UaIaii|H-92Ucpxj(%-+U8?7kdM}$}4`KI#zSGaazRQhKbwNRO(}y zq0=6Y)18^I*=3Yo`~q9m#+BwCPFapER+E=BWQ-sfmnUBE(zvekWB$2;ITkTjBEF2U z_wo50^R8w1l-1sh)LFOaX z^XFEoBp8^5Rol%9*czJmI@H9N5yE{x`1c00hOBljqbk2`$e>88JO};hxAVE_`)ll5 zM_MM4r&eCf-}E@u`TWxQ-*Tf_7j7t@@ahO_$lP%?$GO8+;PlPSgY0q2ZgozcKYHmGydm9vgqd;8#5o)vGyuY>n%g}<#_ zAgGFUu1vjPaMH8m4;|ej!_3)F95!1wJ{_+T9yYRMZS1nT<{MLn8z)#MYkw5D-q=M{ zrJfyrGBM3R%U(f$jfkr~E-20_*fsFPFwt(7PyMKrr7c#m?}|N~-z+xBo;o>tqw|PN zt76ZHc?VZGj-GTeu4Y8hgu>l z{O{XC+ioA$B>tfPX&Jjc&c35LW$-jd->hbJ*4^yr#9})=;*htub?Ju;=gq^rZf}mRP6N6}di1zxDiL^D>=* zyr#DB_Km^EPw}dgO1+k!Xl;o1%gLA%I{Kt2#xZKSW77k>xsP-{KV0jkc3k7|u=lb1 z#@Rbtm8IyP7ez)b*MG(N%MXw>=vbR#~oNmJr z@4B(A>Z%*>%{D5r$GOU&d>S0y54cnyNdRT;%4vD$O8Oxu3sGc`7mY@4h z-?)sZZpx|ru&~|p-5*h1A79M1HBrz%uW|%8{cx{+lJI56r1bP(D~*dao*U=rHkw3j zG7Ymf;k{B%R=OXT*1>Fc*wVi9ea?>h{lcg0toKIY!|bpLcea^qy|?tuj8&)Kwi^U4 zOx0#&*v&MsH{987Yh-0=%5>tuwM z&lBF+H67JHcJG5jH)f;@LryKh!!vvmKI!E-#23CQcdv=g$Sk)cTgSex^L-uF`RA8H9omAW09Dnz2CSB%=6t2;EZ zBmC9o2QKmY>Ft8{i|@9Nr+>EgD>S`S7r(c`S*7i5OpXnIS<0Nq%mN+S@Z?Dg$r)qL zx_W!WKHREn&Ce*WR9Z93`pcuZporSGg8Xr7!z*JButUo6hc%a?KFt}W;;DM$PQ{m` u9pR$7FP?4#25KqvFDap_gcndaw>C`k-wI4mH^m`n_5k?L2i}VT`t^T|v4o`n diff --git a/src/vfs/_vfscommon.vfs/modules/packageTest-0.1.1.tm b/src/vfs/_vfscommon.vfs/modules/packageTest-0.1.1.tm deleted file mode 100644 index b84f3fc2194d0a97df73848ac5ad657026112622..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 11509 zcmcgxc|26#`$v%oEtaxgJIPX6GImKxS+a*TX6}q(%#2w=QfRl85F$yG$WDAhNm)`_ z$&&VvwW74r@7x(g)OUG(U%%;(G54PHocFW8&l3+c?IXLJK!I=sA`JNx=w6ULh6oYK zXe>;HC{&mNldv#W4cZ3#F$h$c2Ekwrc;(3;5a|RG1oq-+s~|EJ+J&Q`P>3ix8S*7F zNOZ{G3lRz)QGf)VX(vLmCPX?+C86nrT`(~aVvvx1G%`f@Len8QfKEkY=r9(N^(A8| zWUML$jqyR_VbxtQl|~?wARL*9z$4HgfPjYfg(sh&X^L9~H;YRHg33}MhDpdXUKXbOc&rcenWafpF4#3R89-eFiV zMuRbQD98jdohzo1rA&Jei7*KdDvX?oJ7i!0X@JF4n9iV*prGKH&PKK%pPAcC|Lbjr zkn6O={{#{_5s4e5%*mO|QWtrRe2^t3keumX7nnkFK+K#==2ms`;Gnr*cbBY0FLLhyj)&6ZU0Rr-|f7gw7d`lRJ=aA_xo67Fc!)m{Uh&+1!fE z{d6J@=Cs-D9fg@9mgnWhc1f=r;F zlsFqcvU^6RfQADKKQk#Oj{n_Gax+hIXJ*!~9Qp0-ze*US3{FE$q@qc9(DtUIXO(XE zX?ghD84!plcSui`0g4tx@5k z55(lZ8vv0sq2nw;lk1s>PY3&-!Qq)DnCUrY>B5kGeLpqWA@cCwl@Q`p=>uw;@V z9f>PQaT*s<1jHOBL3F?hky7~!5e*PX8W~WkN$d~^E+UMk(IGs-fPE241irB_5gkZ_ z01@{mkg#Nb8bl$Y>7eof<_*{@iA+*uwi7f^L3wUu_Ff2i2OB|?WcUJB8wk1y5W=#) zx;k(Gf{jIBL304lL584#Kk5Etst=Ry&SZ;->5>?pbX3!xzHIQjI`rOt*kTEl7;-)gE zcaTNMM|PIIrpPihWu3p}F(`J(We)a5^r3-{jGRrMa6KCGr;>q>@eG(ogOt!zIspf+ zeGn*$XrzlGi3x5j!1L2$7sL#W0YgS}hZPGp08U{5E+F$4_`iJmR}1_*68>yxP(-QJ zt$*wzQ)q$DAaJ7vY@6^`G>GG*C-0cEp-s7DO1UX_1^-JB2pFc-Xmn5te_cUo;QDE3 zXgDo&Cu%FCkGKU~hJWRQA%p{M4&3$KNS+`RCsabswRifa2|+Xl1_Q%j*x&|g6T-5l zSMp!+_A4EsDfMPvX(#PE{d

    ygTi6nq8+Peo&yd=U&is35Nip!$LG55kUB^l^j$ z5P(c1NFx9JpxN|d62hO~uzWf_!e_g2&P(I(m%o4M;Ta}iaR6x2yG(Z=)&9Rce8Ta- zb1YLa<$>1cI_;a??oNpRvyE%HX-HfGns*EK|>*TM&)m32q|b(o6=ak0$yf?G$N+2-yJWz=UmT z>;$glVElkw$yuCa7fd36WuTz`nv((cgG4WDEAS%His!V`#8BbC^ztl`e`SfXI5d&y z3Fs}7P)P9y2{*~1W=TR4Mb^qx4RQkXg2`GifY*cWiI{@P0(@aCGKPSF-Dr?1m_LGE z2i~#b1TY!EsS##Co7)ky(+r6KWUw+-EdQE7$o|R7`x`%>QtIC<_e_F9!$UH^q7)go zPKlYK2Ec4A?IzY;C%rMkh3xt zI6$meb6u9m>Em296$Imyc-0B3Glz~yRI*GDVv{*D#zLNffG3g|!1oh#T?(_l0#`AM z+*INr7aby)IjQ|Q)eyA5A+-l`nA2h~QicFG0we;=ck$Z{(P{Yxtkv%)S1% z2`z9G>zeRynRS*aW}Y$g7xF(eQvnYG6cp26qeW30%X#w!+1S{)*)sjYwl~}tcJ*G$ z#zxu9#-;|IPWGRPs$~yueX1I2tJPMk&w2uSW2v|g?MdASy?wQu8TGkDo0E@rZC7BV zcUWZ;25_q~$BfaM5GBJVbRCy~h30~vRTV-0)$Hp+GG0-LG4qFZeIBif(2GtAdR3%< z^FRSk#V3_4W0=vLkDS;XBr*j@T4~ z=auzx+|IpuV z<`+k9Umy2;X^WFFhk)7TChFBxj+13FZ+Jc`bXlgJ*Uzx!@vh@ALi64Y5YJ8Du~0Q${TtSl^Bw!y@6Vh)*CLzIj83>-=Ynb)piMG^H@NBkM3_oeLgF=#IU4b09d=B(iR#^bBz) zT8G!I1w;Wc4T{NF-z`xGS z2rr&C&&>_;;}u%+ay47xut$VaSNDk}_avSh9?`s$=w`TMP1f~%F{4ig-IB^>YCT%K z<9wF`r9K=My=>zoHz*Xi?t=4M0-5v6v8}0En^4!*bR*CED z9l~&C^Kx#G$8Y)+pSJ#L*Pj9VM|t#@hO zQ|$QeWg}~keeg(n9e1k3FkGJR5aWG@^N675>LXNQeGH?lz+0ibeR*58 z7n{WTxK#XM#V)IiTSqUWlQ~RJ?%$6ihTTsY%_^$s3wFyVmacfAk-lPJU~@Y0QpV8$ z=TcOIoVK!GuHPD&3Q^u_^<$sp>vbdc?L76(%!s|Wjp*2Px~bzX$Hzq?=z!Szs7)`2 zJN=D<6uWe8uIDcKT)m|6ehXW3k+c4LO}0Mnx-ZYHWg9V)WoKM%&S`Bu)zk;E?R)Y( zR7+S|;%$Mkv&28T(s^@7 ze(0MZh z%#di?53S0t#|HZQv{C#@&6kY#I+~oeImdlVNLdsYRT%l9H+*QGyQ|hs0_GpvgK0uf z_B9(6eBx|A;JfFM@KpiM&i${NE_68Zq2dGA+68R46U1hDMa*~MK&=maK|5X5X-7yJ z?$PS%d(78VZW88wH*6f+qNB68P-$D%mi?~X-B0-Ny!S2m<vPND9w~M8g3aAU1=qbrhQ=1fjEq$z3>+Sb zIP>h<{zi?LF3AZ_Wj3#jGLGMd4;Xxsk}J6_Wn{8_$u>C=y5+JDMVvCRW%A3?loq_6 z_tN<3>9a=1PPRx$J=Oh|UBJn{QsKbyjXv!MH4a)o@?;Mef7tPO{G_}L*@O)%7IQya zS}pX-JYJy=&icLx{q}rL8$t4uJ{1Cr?_8u|rTvEaR`W8=!XE3Fe~MLdwPRncwIx#j zNKt{)!WraI?y8TfA+uf*>?$Uk`8Ow4dz^I}s0u8)!1#j8?leApg#cV^k% zP-_&+26Fj8wL09JUeE zrQI?9`0|H`h}6FMvVq_8N2Hz?=X_3Z61-x(Lh)1rmnCjltdX4ZQrleKxaj275~gmB z*N3-UcWM_~T=%HN#Ch{N#^IrS3)uE{Jp4A5qNC=VF+}60S zqj^qOZ0T4x=Y>$7j7mFCHT>FIpG^m4UP$ao_j<;0fB$Gxvd&mm$5sxZOKttVXD;lc z_1`Dg6%0s3E-G-ze*5(dTY~Pp%#PR&$bIW$IuCT^V8gn?CEm|?tf3Qd$;uEJCqBYm z%P;#+ttEtbC2F*Jp444+bo>5}QL*)JYf+h8;mcG{ZZd8?zR_r*lGOk^>KG>V(y*)c z#X~^@d^zemHVpCmY)_VV^$`8HiKg+bJT){<;;ggPOFWgD=6K-v7 z9VzbbCtuwg99*UFrBxx!`%Xt;n7B&f%2-BT5A^on5#^Su(Q$rtJ{$f}_SV$3W;-~u zO(cJ~xTXzCTZdK>EFB9=wb@jBRCWYPXuB4=$eGI}3tATFY}_;9dTGCd}r(YlTC$E=uB5wRIptU z_1y-&N9NXh`%v+k3aQ$Go5kO?wS1zjwTUFl3tsKH0Xw}9>Izo3`=360{IZ`^rJ-Sd zNQ$|7Es5)O9z)me@YXjsqREE`H*O?XVN>%9Ysue6hU~@@m%9lPUAzZABXz2OR7uxis|e&uZ2%SX?pq^<2~?mfEML2`YpK9^b#QR(fAbK`Fd z?{%u=o^a7f81j;VuH4lRAAik3g(SSamQ}%(x)#GL z8G${>mB`yaU%YR9d|>_+?9C8@e^(Pf+;Y)g!L?MrOPE`yT*#K~t-s(?+IZq^0eZrC zcxGBuR++&$ zJFBpYb`Q0`Y8xhnrAc15c-rn1m8cXL)9d*Y`lubWKsxoA394Kj?pA0m@4uIHYFF`lZG=p8*mVpYM1s>G~`nGi(>Fb1K5@okmL_wP* zkEs1<#=_BXvz+$utr-@d^J}(1t<9vw>Q&nlbTZs<94=zVQv%-05p0(2(F=$!$-k8* zldxd8@q~9sPHnxXTC$RpH$L=|O3=dl|KMtqWDhvi7Nc9{Ros00=$wcu-pgnhu4k{qCWE#M(#67s+=ot!4whr@3cMjPB(?2a&aPd@kdPO!JtBG3 zi1e_-kzQn-Rwa^ud#|3!iw{$4%n#2OIY|Kiczfl?7LWV(6pp z^ZGq$>CRc(Qo|$^8geckxq)}urF*}Qw^1O(zO;!=?67y)lD&gbKN@>qE>B8uTIg%3 zcCv9HV}w`OiY?FQc{xpeyZp)+`&Vh{^*NG1>;^MPnffo%NN3|Emj_@-mKsHNF8dgx zP}}AhF^8ioiiN0l0(3qFo$6S(;s;sR-gJyKe^2bo?Rjvyv_`C5OjF@Pb&hUT>Q#vm z_i=76a?p``Thi)F{W>-&EYQdicRASBm+28ks1>IPWL1ZR3}vhy5*jnjSEJ~+&EHj1 za(UfgKTuXcDy<(u+C^Br%)FLc`q@GT4b@n$!E3$Ho)rCM`#K6LNFt#vBBzEWYxy81(ea_OJ5lq9qyEV>9D-9`W_qI2%{L$cFiF;*+%Xj%^}J= z+_*Dmz}~lli(~l3vC)9V^*Wzcrpnw49!z&N%F)PrN*lY!A^Ij@{a6o|vjcIDmXjXa zx9z%_PNPPQF>lWr@y2uYtM8q`H|N~lz^_Se=lD1p9T!%_G2hwNNzP&Tu}4(WqQBCtD zIYJ$_C+%4M{yAzf}$(*Ygj$K@)CDBl~= zRvWZyPYTy8mCD)M;22cZasS)1ecwL5vu?Y2;L|3`-B`4{Vn%xF(GHHy*1_u4wB0Qd zJzgr$&XwwZeq^IBw?H{BCP*spis%iy(z5jT@%{zpL?!A+RT>T7AEzG)dfLOjOZ@@I z<4nZ zecu=5z9=&g$8n~s^?O#9?|k&<^M(IhefPuIT5A0#zaDDNcy^(~^DD*9_}q{&L!PK} z0w+~pNAcU}Qd0fiR$dIeqE&dBVc%nY%)o#5!1YI#MFvvYCi?S+^-ddSN-g>lR&TTQ z(93fYBYM7_Klt!lJ{=QlcsZO#Xv+AOp)7R6aIDDuRKMiPVaoFuyFe@M(#nS31UPlq zE5WRkrnhYuxkfhJJ?*H;uuAQ-gc;tW5&f0Tv5G6l$v+M*&lM60Xx9HA&GW9+`|C2} z?OxXQItw#0{Z8>D*PxT0+oA&Et-rbm>OZb+%NqQ-WuvCi`;fq=7r3qw#@|@HKHvUS z%i7|B^-#f*_a+;X$E7~RTpRqb&&HCSLy+yyb1N{qn)dn6rdT$XoLtCecJR*)d|w9h IFgCXT14g5cHUIzs diff --git a/src/vfs/_vfscommon.vfs/modules/packageTest-0.1.2.tm b/src/vfs/_vfscommon.vfs/modules/packageTest-0.1.2.tm deleted file mode 100644 index e69038aff2079adfcfb92e7cb382dbe03c205aac..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 11871 zcmch6c|4Tg+rPC?C|R-EkG95*|Up`k`@wkS`wIM-1`2jUA}B~tD41$YJb~nmz+r>XkP{YP3rcVJOqU=$kI&l`(J!_s`gGa`cGsQ^h631l)BUPDG; z(7-xi6%hh%qmZyj3NRg6Peydfp`lBD!AgkF;e*gVkf^o zB?52=U`Y==F9}K0 z?oay^7YhM#zXU-jgvOE4D}$5A=gG7(pbG2t*PVBn~cc ziFi0z!8;@^#>i+S1q#-O3|5M1cq!E$I2;=90V<5Rz6+$I11W*UBs9gBgolDdmpU8X z0)LinGx%R`(}kQC9sVbf@QHBTz-3Ncf0?@QYxn~%(TBth{<^>b5(i>dT(YvN^9Kj7 z{2D_bp%I|A1OQ}EFuYh=JV54;hFi4UV1*cFi@0BwP0 zr+^i8gqN+X$jVRW;$TIaE#CpFk3%BJXg69Vb|a%bywP}2oSfiFhxY&_5=Zb~Nc&$Y z3{uI(Wf|gM@@Ul*E~aEyh2`=nNSu}y#T)J$WXcMn<_(WSx_QH5AaNSd#e$cYefTIC z1a-?IZKxGw4*k5u zf%gDyZ!vmW>2_I^hrgWxfrxT}wu||Kq6HTnGzky`*vBXc7Qf7Au+s3y9puHq72ht8 zo8?cIm`!|%9)C;&*ijf?9Bz)4Ku%r+Ktr661UzW}&{84Pz5)6(EZGIp(tjE+oO*8?<>cM9oc@ zr2!&JJm`@@-;kX6yMu6Nw7X)kxD=CMN{xNv9$nF4vh z4A>i{MBp2R#vua95Fq0ISUig0Plkv%1O-$+z`Ox_#S`%I)OLaZD#)yi%+?bo?_eWn zlD^)6)dqrY0))`4uc!zd0Ar&OSkN56bC4kj;7^J_fpm~ccbBq7*!1vcAv36U0UZGa zm@jk?4FEeW50F0>Q&B}lS}4IRi^pmc%X`q6A+GL?H!I z4M$noIxsS7=FHtxR`d?M2>ysIv)2Myh8C>zw>$>L4!+ExyZTX0wCe*^)8 zp<0bh0j2QQ6_gCFpSrrbi$Zsg>aAk)JzAw>(gg{aGA{cs* zKwe`(^#kP}gdMHuW3T}r0I5jeME?6h%jv~Dgg?Kb`E+rFFL&dLm&V^OfB(_LOH4rH z0MNX5sqTQQ{r~dtImZLf(M&~^2U?%gqMt5*H{OzB{rGh}Xj@@r0l0S$^8 zCi8b~csv9+7Dy555Qf^YX!HdVUqtHujCEyKhOS%%#6T^gnR*G`g2=w^;3fht%>I-aP-o)0x!a?cttzS z4Hf>EUS1~huPjjvgTUe30lkG23NHR2;pREiGD&cvh*=mYK=y!MP+1ES@OscaVN+09 zfHxWik0BsnH!>s-=8vG)fp@ex0ZayPYM2?2S9ZkmG=n1m9;_@B%fBWNynnv({>IN2 zl=?5rJ(Zx4Js{CvQ3{V+7sM=317J3qcJuKGzURXj^h@A#T6V!i0pSNKFLgLbo6r6> z<(scV^WSq9cy9m$QW-UVhH%)S)9Bl{C|X*rd*kQILBe z;E8x&;QP6`E|FSafvc!RZXxmDiw+LVoD}|?YB1X0klF${)M+soDMNr80TKaw9-KCp z9^j${QwAU%F+UWBN%pTO<#cz`vrR6T;&$W(CY3I#D4`0 z%lZFMzu{w6uHk=vv-0}iCbYm&v}?kDW!7b;SbE0NU-19XECf6VP*6;NjTQy0%ov%t z>FDTK=!|8f9R>SJel~BQqcgUoqf-D+=ljoG)v^V*K6xbtWd#+*WlunFysLeX{CaCa z_tX}vWBij^sX`euT@SJ`O+hE`jJ8X@j&ADYR53O@alA}@S3VQg>BZZUNzK&|Ya%4^ zAS)vd&9!aYBp+SedGbVVN5Z=q&l=qT#Kn(oF`;!i$P*rs$x)`-==C!bn$@irzeoNf znUIih(s+=Smu>JF{T3zblvr zEk-oo%U6SohTa~ z8X6kAz*Xj{{W`#h?cZ8HlRFlJAt#x3l?}01NsKGhd^}0H5Si^;Cx=RjtpA{t5KtOf z@3+}g<>A+Xph=ZgX&QpUL%5-BV`=x^m=hZVWvnJg17legXZ?{m5X*Cw|BkaJLnCc@clGv@4>wX-s=4b`w(U^ z#HhbZjEhCJC^@mei!yM&T=(9sfzcP4vSq3vF9KBHOUaC3sTh{M{P9dy0lcCKsDE}twmX}!Yr zfdhJC8RhcXytS$GIh!pX+p*ns$49p4uMXia7pb$Odn)m|_DR6`1I|ogY;{OGzs!BzfP-LK-pdS!TCIay zUkbQd-;9ZQFg9Lquc6U{V+}Z)IHAVw5{HxzdGGP`qc4Ls9b*lLc@L@k*?XnSBFNo&tiTvWAX{0;V4sIi-^VcE~ik)$G+x_{hyR-q;8zH7UeYAIr8 zQ(OD#vPb%+(1&aLV`@i_gnh-pN9x0K30#s}OXD(6E={9QINSf>q9j<1t(n97YE z+QqB7<-zU#r^QcnED!yw=^(tbB1hGFM<%yN=`j{FVOghU4{kf9mQKHk$doPqTS9uZ z3a%%M_tYO0zP&B_k|H9BG*EcGW0mHnf6X%e8sbp`G7f#Iha|amoZ}K3^2863jvx?6 zG`YTWAT_O?Z(>VTLRK;siB>gNSDI+0tE8Q?FwJ*nWe@v@h4JfnDZ$E6=N&?xHOYo^ zN<;0XzL8Rs)!>c5Q(f_&u67ibo9piA5_jlMm92=a&#o$1x7)3vGGcXHmd8M_RdKNR zrRxsU0s+&5xaN&)B)V&u1N>IAB8quxW$8-wXLmDRWRP$sR&5hJnRN(SjQyf>i7?_$}35|}Ehq+RWU4+%&8VIO2xkQx* zv-00Le##rE=9g-*)6Ko1FahQtl$PxPq~fzFPI^nEP_? zRk4yKJ2<}l=v*`1*D_T<*{z)0RN#{m81AiuLT$buG^k_Zsi7Cjz%J#+lJag}bXg29 zi-?<lvq&VJ_a>n|aseuFN-E=}r%J zynV@(ntYq5=q~nBqey0+3tjqYVb+v8Ba$gOZ$2@O#Ctz!+>^~IqgH-oeW7oUfXxHw z10+Mj49m1fWrsP3ePfO7AJ@zIC#YVxq~wdasgQJ<%ZI(l%I23}3=>7yw-oM(%(~oZ zkS`_ckfZSVdOUquz!~***%zATbZ;j6y1jnm~nA;306T!mzHEmea z$Rl)KNuB5IeKlTDeC-E(#JQ0;XIsNVHRHp6kB=Hr7!=kzi){TO#Xbq?1z zaFFA0I{a#yOWzv)7`+zbvpD+$>3-@RXoAD{`+2rfH`eCH zS^ta}ubUC@WRJnDi*k4NM5M{cD!vZLIyAGkOEm-_~%WQN%ZtC_*T*~dRj zq1`br*aYVYqwA#%^EWS=ln4}PH0kg-4MV%3e;ub)>x8y_DZ`!GHIkl@zYg=hJ3 z^U)4<43b|zp2vJ&vco;qb)OhQHt{Omn{a!R!6Y438t&98U~r3}We4Yv_KhiL;*CXH8Xoj*m~@_251mt2Vn3Z!cw( zqTxq1q_Dsq9{b=Mohq`75=I9Mh0{;=`N?!&xR~9Z^|mqhba1EoEMaGR?X6a;tlUlu z_1jRNYUPg|yIt(BJ`za0SN_naRCOuSM2Rw_UU=bZ<3{mG>d;s}~FJKBsi) zA?EqDLZWI%f%=ylDmQsY`%}kS2Ka}1XX~sgaQ9a$Y}P=Ev~I~#dR=<|pySIj_kxbf zP#v5$`mJ3>llVv3*%t^^t6K8w2Ir2M3W1$*UZhhO;}AU;5oLhIgJt%#j%1~7LY?P1U$5z|#8^iez zvNHu={nyP5zI( z?C3j9!}YBi$q&T@x2wG}u{nIt>r+>XWtybygjFtcLSjIq(RrzI)@{unKfZHSH;kq~ zsW4D$L}@v0hjI2z9yqV~+)XN#vwBjxqi-Kex>V9WL5*Wrjm|SA_ z@!k0-beJ`-vYn0>!Itg((gehGls5GKZqwFKgIU{?CpEXp#It|m8({f}6Sw_Dk=hq^ zzdy42k)T+srSE{T5v7?o3#pS@6yMGFA?;X~nV-T;L;tP!Uzo0bVsRa7lG-^}#VnHx zr;!;=u`%KdeUW#gq^f#$Z1gZqtkyfoo)~UQI6`0fNceH|h6>@dcWWk1Uu*S{8*DDy zoZFVm# z+r2fcPqKU4a!0a?XM~GAznph8c*?ae#4dMS;$fU6D&L}*iOev(Pg>{IC6U{_*1epw zs#=b9H#S!`9T_RBw$)sJkT@b4yZH&-rS)Ovw_n*+l_l?ZSnoDIJ024I$dq9}k(&)~ z*-*gd_tVpoH$uqp@r@RvvWdhkKIZ~+)CG<_#_&8$={l=vdq$hZMX$=)%q$tY(l~PL zWtTcmwzOK(``NaK-_!&s2I<8J&nDh`9GaKHqAC-PS^XxpCOxCB(NoAuXr(bIY_>BVVzZn*?W`$V|Y2 zDIUQ%F}^yq2G*8W_I3}~&_|4nO1LiTMGK!n&3boPM;S}&sQS!+r;W{WtF`P6ztCSc zI@SA}*4(AM2%3B9Cx)5#k(9r zUfa^WMm3WfY}(^$#sx0f_q5({b?c7*$`QtNQsYwN0j-9nB(3pXV`6Q0H}gMh^UCfH z_t_f7RrLu13I-b(~`-T&fQf zos^WdhYW07Z9SwQn;I^ba{+spOceGO83euQlhOZjUVH68vRZ3J21zEB+r@Re{@q81 zeV^tVP8&E1>q?tu?v_&)kp9PUu(_KhWbcItwxX7@B4oQs>F8l#3|(|-#gY7utoA0C zF3A+j9CGY1OCODhd!k1`eu zk&c|Re`6d@F12YqbV*T^aMMv;pDTIbI-9&QgUGG2$U=Jtmi`~fwLZ|XL3JLf-S4f) zp5xJM_q90NOL!Ve%QkuGX_Q|7+I!*rtM8KsJH|Rgf5wk$6mXEGeT9v+^)@tLuRAG3 z?8;~M9Njd`D8ayz`y}URcF4_=txcTozRiv_Js(Zb+p|xs$eq}(tnfh~!1Q`Dw{^H| zZqLZk8&fFeTR6oev(baHCM8w}48ms27|5LJF7Y3>7k8eGm_Gkx&(;QxX^)EA)~Yp3 zI}e^@H{jp0P6VTS!dOPnEw8fw%B!mT>sVchjIxsDO6~2BEc5q7w<+s9sv52|%?Tzl z3*4Iaa5Nqsc^36}ZDH>!&w;Lla8t?Y)pu@|b5=ZE{Z4wu`RQqsl-IhQ_gT**p+4Bf z6|r6AVHgpu+I-r1 zOaH`|S6j2<+p8bhNT$7r*m{|}1K-BjD#ds|@vOpAxJ7Kby-e>6f zXmYoup!S2@v)|eCl%`d69>m44Uv9Yi=v8iljsBjz^t(O68n${zTlAy0?(CkmO#bnO z)#=QR1SSt1{+Hh7vO$8`hRJujgV`;bZgx3HIlZU9S^MBDbHJv_jn7&>jP>oi=lmw? zl@sD~qs}YqI1A*g$8PQZPQ40#58Y|m7Ytjc+zuViVEeaPXzE*gcSgOgd2;8*_{NsA zqb*aBcIYE(ezF)vV!dunZ!+31p`N?yu5V>uV%^5?8-%~vAF7(43&QvHajG!`8P`X0v(2Z1)Q7!bW_*+DtZe zA0H32V(g8)toPPkCzP|wzR2a4>RJubr;_2K!O8ntZvS}12q{d~x0+v9Y_MS+d%?E~ z9oVkCOIWzjRPmNk${9Y*P{hk7g+|6RO){O=6d#A29{t2)acRxeKw9V&n$FE-DE+dw z_4}|PKDX135gIM2IpNYF4%q`57fu@lUnw+&Bx5`_+ zX7xJP*T#SAiY?s2{*TR1$&7Nd;*;6k*fatcQmp6jv8~^`_ehrHzb&ycqi5iz`}2el c3<(!~{%7+-D>LR*@Me1O&l!9}@G*4%4}v98Q~&?~ diff --git a/src/vfs/_vfscommon.vfs/modules/packageTest-0.1.3.tm b/src/vfs/_vfscommon.vfs/modules/packageTest-0.1.3.tm deleted file mode 100644 index 676e404848fcec09010b01b2681194b06790d9bf..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 11953 zcmch6c|4SD+rK4QQq~CJvXp&~n5F22V90)u zy*C!Z;*mZmB19mf2q>Hn%10U6g9@Txh$s?-0&Bo4FA4@r#^4~Z7fn)x@I)vWO+p}G zQDi(6h^OGlP>3Ha6g(mT2^@<~grtnHWE2sHBx8b6*f5BKgZGi}5ZMn&hESnoBGQ|T z@`0oR@je8+j}igt9f0&jDFvg5Bn%!0q48K49)<(~1SDi2YW@k51SyjPY0CU^pf3uC zA|hd-6cPsKivSQ|(Fg<<y6uka-j zU<09uL|{tEIT$pnkSSjD$I6fc4(SCf3JmOn0`?2U;83tM3V239lKqq+SpuF!!oX`t zNHhvq2dpAMz-?qA#+wXGM>3F;TyiLN$uC$5={bB5DhQI4gd!p!2^X3|s89@vOoHa$ z|KH=6gqDC=3Jtge*3}0?gy?X_}tBnJC) zzuOW4SR}BdFAj1c5wI9CZPkJ>CAT@V(*(>#<&xdBX!zA?0I|w^NW-Y-<*jH*5}rcz zrfc`ReJYEEfVf|RfC{0oB-9EaCbcYfV2hAIj)ADbLm?>08;Jw@!5NGs5QumJ5d#tj z8@5C|9IW7-H$BEkC~q72G<#sND4Z{-Fw#bDke(i-3KkPlWC{@ng;SS0 z8{PtcmTuerzuu+~xhy*TcOc;t;kbdzoV3w0b>Y|W2VPx1hpj;AcMl;#j?_&a=$g)qUGCHhyl7HbM~cGr@7>Yg{~Nm^E=>gEC>tG z7U*^gT~SAP*~*Hn{B$l3R6@gWOo z|1*U_D!I8WL;O=7y_&+slmx4=TprmQi$IVA;l4p4uOMpP@K|q;Kv)bUO$WMI@ba<` z9|eP;ZCRuZt%A&KLrhtY63O_9==Z^o?PSQ(Ha-(I|&m8&X?SD!bxC|~r zjU^&+zM$;u8#m-!4<8vb~Jya-tF z?ee%;{$z>Sq?hRN+cbb3g{EM!bF2h%@y7!i;^K|Rf%XqA6+-J9pg+Ts-5>-4))3wc z(Yg>G4f-~X+CYH00L^`1LNot}NT*yY>P8C|xI}w^Bj?()c%I)P z5SFywh$4G00|jdc@ zh0N`wH))!%m4*1=aWZ5$t{|C3Tto&Ca}*9D16Bx^%AbfxfIyP)fKtt4hd^*)QAiRQ z@`V|2AWVtCw+{-73?o5+h=*WsKKKw4M8G1+pz;Cc4cIFVk5i(x6C_YUZe?WlelU3l z8$pw#1OiqY2D%9lLbtw(3UC07jZR=ea{$jlh9H4I$su@R0FCZ0Ws9)s;m<;5(Ch*_ zf)8N6Pyh-5c3B=Ezb~eeDk}6)f>{b&QkWrA4joDme zEegZYnE!2VMk!q?Xxhfh6t5V+9-wvG8C8rX3X^LNbU&=y>>pxlDHsQ(cJ z42EVk5*d`jpI1;4xPI#E>n{r3x!MZp!fpYV;h*`S51~Pu19yE_oEHeiIh7DA?OnWS zP7sOW?Ttc#VS_8EO)$$^T*-gN+s|}_7SvmMrJc9y;_oG@8N-zwF8CCJFA?cOa+iVX!vN3;T-KW50>_~hrD1PvM# zEllR`+VFS?a4e7_v>^1k_!6+OCECU7g=bQ|%A2@pHTY(qhR=lE} z=7tLYOD``I`A3#0g+^krUVz@h2?ZB_kZ|)HYMCTBQKYQ4D?^TeUeH*JH{kW4d%~um zv4B974?Ko|fZa%t5|}@NUI*UM;{-4nz^P$oKw8-m%hL>w0C=#nP%QtLK=A(g%KHmH zUr_45EcY~mLh^+qe?}=hZe0+wKn;M|=-SQ4C-|NZW6&>w&*|9(69r^2sJyh{Abmdj z%am`v4$XhhUEl)&43M*uW@tdH=yP4V$i?GaBoPGTf_SAltJ8*#a8%Mw4`P!xGxmYJ z!T?XiQGoB~=DGx0eFd(f6}g4PgD*N*FmqD=eX7A|e?e*w{qkf0@t%N71hd|CL#nnPTY~OMk)tL$eU@AV5Je{W)3`wy|Jd z#m~UNz{VhS?1;0`)>Guo;HQ=?1A{VnI^Tchs+K*t^(m<;t0`-!EPDcaW4&%b>e-!F zo=+xtO*_>Q^HfP~rZf@Zrx6SA7-pe`M@efLE=AE_zPW!6} z70t!PRmD2AMu2@tMnZwbSEgt4eov7fC$leZ@s;FyFww+0ASkC$)vluL^7_r8`Ukit z_zaZLodMA{mJ4bMVhPRsgikD8OrAz(4$HpMF-$(LIoV@S-Y?O~bt*euR?PdspzI6w zMAw^-DGwO0$a?l}o;>O&bjSAn-M4vzhc15Sl%0Uqr<{9nR_MY9t+m&fGG9mBnaqga zVs5lvaf0v4tHh><25HE|NZrN z#7CtT9#-E<4~7nrL*mDbDD{IPRQFRy?uK%gNs8TgxOac{!PMqT?Rbn$K1Q*7?Tit5 zmz9B@9_qP0wE5BJMr(BlTWNBRqAqxLi=y`pKU-zYjHmlCbV}Ie8*-=PI4@5)^Q>3n zy2jT1k=YV0__ym@-A2zT^zGD`K+$;W)Yc4kD})NmXx^(w>;0v=cSvlwbvG|@r}l$& zNM(btkla%_r%{l(&gWMJmu6D z?1b;o@QtPnsn=b@5qDxDV*~qle7g~yS)#x@BdnKUr(BA`+f9f&NjS@j7IWG)>YHgn ztasj>FS@DxN=P+Z#^@hS&h=_cqE2^DrihLXvUOU?d#w_a{&LG0ua0ST<=~ucifsEn zI)%%zBe)Uxm_s5aD8@A(s-b84@9g4=Lb2|aeS61JorCdR+KGKTbQ^KZ$^?;vYX3^E zai@M}!IKF-)O}mh8pv-Xlw%2X73XhyzV3gBQ?zv3dYCG)k7=C|!{9el?rGh|ci;9s zDd6}Z0NpBVQm#86F!s@VZ3!34j!nL%n@;8!-$*#l=Bp6(Fd=Z*_L8|8BF2$LP#v$z zX?~b$HgHY3@p}Zz6MMFk#%;tS07A>VKw^cX(Fz2}pfA1|_tNAOP z@b|l%Un-PPg49y#XFm^)a=0opzO(DdKA&3}bRkydfL7gAGYJ9D(>*cl8SlPmziqNp z7XB2Zc*nmANOO;zE2$pgo;d=JUIwkm2qavtf#9)0hYk#ZH!na85lV|Mi^W7TC> zZf|VVOv-QpR%Dp##>Ejw);=u6z?LH4;M%5?Q&85~;e8v(DnyoP`*E1V=IlaBfGmBcpZ6an!RzY0;Gq>8tkGs@8XzWhc74F+rxj#x(dp z`72W+!8Rf2k;Fkw?+j*+3m-##2to(UG+s>36z}dfRNj<*AN~BDu64X&=SaF}{tk}4 z8j8a^(q&rB@k(Jqg#?ujRn$5GcC|}mCTZOAci1mVHr|R)5S$i`TVGrIRQVel`E_uT zqi)k)hqP7SJ|B`%G~*k#NJF_^D@WWmvWkDm;V*VsDt$LcS8Y)a`wlM0JZZ9GVoniq zUl#JbNo1bMy3U|@qHK%Pey*Cs>J*aJUslB}vaYA3@11C$m^9|^@L>HOBRm?-rC{Ek zf%dzYTe(g>CjF55@S&!jX%p-FWfrZ&#;+_B9K=duTEBj)4LzE}aHw@-X#1J{d!DgA zzHZ!6d=ga=?TfeCT$T&5dit+B$+#Z+z`Mr8m7|JUyrn_T=GLadx++Z}|A1_zhu612 zEeB7B^Ra9tROP9b_1K(@Rf)nJH@V=EbH!20tX!ib!C}>{?CFa*_QXK*4cF3e%F_F7 zzxHcaoXDzkf)sTMSw@KtK>}SLQR}A}wmgqIQ^{v;CM{x>cH(lOjGU_g$~Ec)_n1$~ ztsKtU9Rga353iYWth?=!)0>Fp!)mth+YQK{u3|j+cbvg@=C4<7B-t~)-x>F12WE$4 z8H5+gd@6izLw4C4{gIJ8VK0iKlkAYN<5zJC*SUV)Rh@45E~j^~ygAnOVwxkng*6|! z#W#kt3tc{zW)(Ff{k7=vk7Q>h9RrN2V~xO;Sn|06#n6tOSFMgUV$yvNFeZ%irwD2D zPCVGCdzAS>!>+%w&;BcrD666)doUx>pQkX#$28rixHDk=K7@U=+$SdigG)zK98Yy? z4qj?+D@gywr1R=)h)Q>g;3xUW-)8b(@`H-;xm_5p~OD zJ+BG^I#{QaZZn2kU7Or1S~j{(f3wzx>f7s9{SC40xcrx!j@zd#N>VvUrMhkMaE;lk)WlG{bZ`aYRS zYxx}4xc`srN%=M5a!TW`O@{pQjW@I_wADY((+Nrz+%RA)D^vZ6(Vwj=(5^V~FJD#v zP$k0?IyL*Xko^4EwIPAdg+w-gthgbnfR(A}Lhafjy!P#=FWyftk{=0g=SZqV9dzfr zdfs07u;lK0F;4r@k_!7;aWuQXs_k8cz8x=Xi=Sg%=f1&SM5O5+>2o^; zi&P(1xtM-5S$pphi^mhSs10qC0$!H+6&L+HyAFR=D|0 z5l=grPAPZ1$&HU$7|qZ`SMIB=TT!i|e_Oip3^9hK-{r5NK5rutgb#;lL-}v9YLKK9aN59&2w8IN>28qMUBeo51FbLK4w3+?iIF@yTi1VS0JZ;E7pB`Belu< zu#k&VaXYu6WmWj(=-ZvA%D;2;P)9`b6Ad@zEBz~tZ#+@9xrfO0}?N=A#*S686VFj=U5Bgvrkh%D+&^fc$@mRivqq`qCFRdFgxH++4Wg<+$uaqlGWfr_DSC2l1W z<7#$frSvH0Xs-n)`}&Va;T-LUIl8OJQlS&lIod%CBOCd*I>nyoohGEzBk#ZN+Eaf~ z{g&3wS=K9h&oDWfioHe~6M}N%lCBhei+JhF(XVm!>jkycTs9wz!+}_4j`63|XJ?0> zt+~#e+u5i6Z0*ITT^|l9t8nESwq*&73<}=kXQ~>vxmR)iEqU7`HRf}iHcZDoxL8dR zq!TvIPRX~}jm@!t`NA}PItjH($3fMB>gCpE)NV0B+1KD29vN@VVzVxq@ky5EA@{WurFPO&aF^-7+KANxY0vdu4mLW3G?wOE%>2~b z<#pG+aR}3>t93@c{O!K$-uA1_6B`F0BEpc>wm2vc4xUodlfd18pzQj1!igUNH%#UthoHUO1 z5M^ejufDg>b&;@6Z7m(&{Pn(}W?P^!DQGJcz^z%*Y(&&L6pfef82ffJrC#E=3!9kX zF-2BVC-m1HTch@L3VQ9qe8iDlGco2!lD-=i`vyuAk**h)m`*J-k#0r~*lP;Mi@ezu|`5$KbAL3<3 zQ(K-UjnqmcotCZ0$TytW;NQup%pySLK5bGO=D}=#AQ$I*FVDw{kh+txy{h0FV~Fu9 z!CH$S=kNV6#B@78DXvNg-RKo7Jziy4?GXM%4Z-s~bFC*2>S9Y+Z0AREO@J2oK0 z2X`Fx*mG(lPalD(XmewHz_H1Tiw(;gZLW4UqpMFg^Y!$(Hj`{Ljk@-I zd9-aq;pQX(5ryNQ>x9Q@byznsIj#;!u};f9uKM87)ICxpBS~s=t)81Hk>Of1^%TaCwtEwMT=a^yonridgU9Be% z_?_m^tM0cEY&_&-a%$^&$Nm1#x|1_Np}<%Kmj=|~leZ{^+sB8nerP#%&?uro&ojQK zMdOSUbnjoIRV9jbL#;fwN@FLkjuxk~G4Fr)UL)yXLCzaWwxT8O2{oT9v z>1Tdw>Z(hxWcm9pm~NQ|=>Q zY&Ru1zh&h)vDfkPx^kr5wsZbYPZFz2@u{{l_B|qpv;u5AF&D9)_)(+z3?$QI&b<;p?WbF<$^q4$Eb)??}p*;96a`qFO6Q< z`nK?R$mBc7&|fG=$k2(gec0GtxKI6>Q>lcP@_yFQ@(K^+Uy`Hl5saD>`1UKpz>qH`Dn}c5Ly%59hRZ4t=5!`*<$r9xy@uNO&z3HMWgY zmr<;Y??k$MkWKT@<0f=bjC~DJjL`1k&@NONGq7gXFXiM^i}U4>H%_0S4m@vUqn|iK}Mtb_FcY|6wmR{oFnJ!iny8$c{2)+t$8tNXh=*S;JfY1 zD8_o?dGixne@jwQM9E3smhM-RJN%q$F5>K~w|kh1M+wUFj*i;y-Z@&EY{nH5k=<#O z+e^{Yz+2Y%A00Y)f1h~l@o*nwhi1+3H!66(c9~NIJ4wDB2ixpA-FQE{UfnG!JsP;~ zL;hVOiLM4g+j#NAyWi&-75rE=u=r>13nh*T`nE0=4RZUNp9(##Uq5C;_S{Z z&yQM*s~CKLRU(>l=H}xrL#Hhb3VUKNCmP#FZ*ug_Et63Q4Ge$3-Pyy%=ujLJ-yxB3 z-qSS|+2mu-g|LcA)6Ls*7ucBwfUd# zQOSK%Vqu|NVy}|}uJW=^?Q=B1#T1;s77<~tKUr`>dh|%1ftF?Z2BBmLOlj5WW6#vC z=lZub{u|Tr*L&_9&nHLj-9;AkRs=LOg-pGEB#9F9`#OL?tHdYsS#AzTr0pR*4dUwC zC}(+(sob;wjoQ7i+sY?Dg);CrhFXbauOb|%`}Vp1>0onuz3|)V9cIVIngjRXCS;YX zIh&{%9R3MPnJgh!N#Bhw%pfkSed&+tuJ2K{<*d6klWr4NMX3Vb74m@udIuMe|6Hm+*u zpuDMOUw^vdL;peH!v3>-B^KAelyP~u4HsnT+P;q*4u2qD*5Jr%=*DOp`uE;@f;|q~ z!_U>4L83{e7ggmp?){`!5Zm@vPG#m+yqeHi@@)3o!$Yh$pn^B%vClg_`X1L7hY+XZ z1>f8W!ZJnJJVbwTAb)sf|AW=Wf{}@z;rBB~Fm_z@`JYW7Z7f(;!object . myProperty -# will return the value of the property 'myProperty' -# >ojbect . myMethod -# will return the result of the method 'myMethod' -# contrast this with the write operations: -# set [>object . myProperty .] blah -# >object . myMethod blah -# however, the property can also be read using: -# set [>object . myProperty .] -# Note the trailing . to give us a sort of 'reference' to the property. -# this is NOT equivalent to -# set [>object . myProperty] -# This last example is of course calling set against a standard variable whose name is whatever value is returned by reading the property -# i.e it is equivalent in this case to: set blah - -#All objects are represented by a command, the name of which contains a leading ">". -#Any commands in the interp which use this naming convention are assumed to be a pattern object. -#Use of non-pattern commands containing this leading character is not supported. (Behaviour is undefined) - -#All user-added properties & methods of the wrapped object are accessed -# using the separator character "." -#Metamethods supplied by the patterm system are accessed with the object command using the metamethod separator ".." -# e.g to instantiate a new object from an existing 'pattern' (the equivalent of a class or prototype) -# you would use the 'Create' metamethod on the pattern object like so: -# >MyFactoryClassOrPrototypeLikeThing .. Create >NameOfNewObject -# '>NameOfNewObject' is now available as a command, with certain inherited methods and properties -# of the object it was created from. ( - - -#The use of the access-syntax separator character "." allows objects to be kept -# 'clean' in the sense that the only methods &/or properties that can be called this way are ones -# the programmer(you!) put there. Existing metamethods such as 'Create' are accessed using a different syntax -# so you are free to implement your own 'Create' method on your object that doesn't conflict with -# the metamethod. - -#Chainability (or how to violate the Law of Demeter!) -#The . access-syntax gives TCL an OO syntax more closely in line with many OO systems in other -# languages such as Python & VB, and allows left to right keyboard-entry of a deeply nested object-reference -# structure, without the need to regress to enter matching brackets as is required when using -# standard TCL command syntax. -# ie instead of: -# [[[object nextObject] getItem 4] getItem [chooseItemNumber]] doSomething -# we can use: -# >object . nextObject . getItem 4 . getItem [chooseItemNumber] . doSomething -# -# This separates out the object-traversal syntax from the TCL command syntax. - -# . is the 'traversal operator' when it appears between items in a commandlist -# . is the 'reference operator' when it is the last item in a commandlist -# , is the 'index traversal operator' (or 'nest operator') - mathematically it marks where there is a matrix 'partition'. -# It marks breaks in the multidimensional structure that correspond to how the data is stored. -# e.g obj . arraydata x y , x1 y1 z1 -# represents an element of a 5-dimensional array structured as a plane of cubes -# e.g2 obj . arraydata x y z , x1 y1 -# represents an element of a 5-dimensional array structured as a cube of planes -# The underlying storage for e.g2 might consist of something such as a Tcl array indexed such as cube($x,$y,$z) where each value is a patternlib::>matrix object with indices x1 y1 -# .. is the 'meta-traversal operator' when it appears between items in a commandlist -# .. is the 'meta-info operator'(?) when it is the last item in a commandlist - - -#!todo - Duck Typing: http://en.wikipedia.org/wiki/Duck_typing -# implement iStacks & pStacks (interface stacks & pattern stacks) - -#see also: Using namsepace ensemble without a namespace: http://wiki.tcl.tk/16975 - - -#------------------------------------------------------------ -# System objects. -#------------------------------------------------------------ -#::p::-1 ::p::internals::>metaface -#::p::0 ::p::ifaces::>null -#::p::1 ::>pattern -#------------------------------------------------------------ - -#TODO - -#investigate use of [namespace path ... ] to resolve command lookup (use it to chain iStacks?) - - -#CHANGES -#2018-09 - v 1.2.2 -# varied refactoring -# Changed invocant datastructure curried into commands (the _ID_ structure) -# Changed MAP structure to dict -# Default Method no longer magic "item" - must be explicitly set with .. DefaultMethod (or .. PatternDefaultMethod for patterns) -# updated test suites -#2018-08 - v 1.2.1 -# split ::p::predatorX functions into separate files (pkgs) -# e.g patternpredator2-1.0.tm -# patternpredator1-1.0 - split out but not updated/tested - probably obsolete and very broken -# -#2017-08 - v 1.1.6 Fairly big overhaul -# New predator function using coroutines -# Added bang operator ! -# Fixed Constructor chaining -# Added a few tests to test::pattern -# -#2008-03 - preserve ::errorInfo during var writes - -#2007-11 -#Major overhaul + new functionality + new tests v 1.1 -# new dispatch system - 'predator'. -# (preparing for multiple interface stacks, multiple invocants etc) -# -# -#2006-05 -# Adjusted 'var' expansion to use the new tcl8.5 'namespace upvar $ns v1 n1 v2 n2 ... ' feature. -# -#2005-12 -# Adjusted 'var' expansion in method/constructor etc bodies to be done 'inline' where it appears rather than aggregated at top. -# -# Fixed so that PatternVariable default applied on Create. -# -# unified interface/object datastructures under ::p:::: instead of seperate ::p::IFACE:::: -# - heading towards multiple-interface objects -# -#2005-10-28 -# 1.0.8.1 passes 80/80 tests -# >object .. Destroy - improved cleanup of interfaces & namespaces. -# -#2005-10-26 -# fixes to refsync (still messy!) -# remove variable traces on REF vars during .. Destroy -# passes 76/76 -# -#2005-10-24 -# fix objectRef_TraceHandler so that reading a property via an object reference using array syntax will call a PropertyRead function if defined. -# 1.0.8.0 now passes 75/76 -# -#2005-10-19 -# Command alias introduced by @next@ is now placed in the interfaces namespace. (was unnamespaced before) -# changed IFACE array names for level0 methods to be m-1 instead of just m. (now consistent with higher level m-X names) -# 1.0.8.0 (passes 74/76) -# tests now in own package -# usage: -# package require test::pattern -# test::p::list -# test::p::run ?nameglob? ?-version ? -# -#2005-09?-12 -# -# fixed standalone 'var' statement in method bodies so that no implicit variable declarations added to proc. -# fixed @next@ so that destination method resolved at interface compile time instead of call time -# fixed @next@ so that on Create, .. PatternMethod x overlays existing method produced by a previous .. PatternMethod x. -# (before, the overlay only occured when '.. Method' was used to override.) -# -# -# miscellaneous tidy-ups -# -# 1.0.7.8 (passes 71/73) -# -#2005-09-10 -# fix 'unknown' system such that unspecified 'unknown' handler represented by lack of (unknown) variable instead of empty string value -# this is so that a mixin with an unspecified 'unknown' handler will not undo a lowerlevel 'unknown' specificier. -# -#2005-09-07 -# bugfix indexed write to list property -# bugfix Variable default value -# 1.0.7.7 (passes 70/72) -# fails: -# arrayproperty.test - array-entire-reference -# properties.test - property_getter_filter_via_ObjectRef -# -#2005-04-22 -# basic fix to PatternPropertyRead dispatch code - updated tests (indexed case still not fixed!) -# -# 1.0.7.4 -# -#2004-11-05 -# basic PropertyRead implementation (non-indexed - no tests!) -# -#2004-08-22 -# object creation speedups - (pattern::internals::obj simplified/indirected) -# -#2004-08-17 -# indexed property setter fixes + tests -# meta::Create fixes - state preservation on overlay (correct constructor called, property defaults respect existing values) -# -#2004-08-16 -# PropertyUnset & PatternPropertyUnset metaMethods (filter method called on property unset) -# -#2004-08-15 -# reference syncing: ensure writes to properties always trigger traces on property references (+ tests) -# - i.e method that updates o_myProp var in >myObj will cause traces on [>myObj . myProp .] to trigger -# - also trigger on curried traces to indexed properties i.e list and array elements. -# - This feature presumably adds some overhead to all property writes - !todo - investigate desirability of mechanism to disable on specific properties. -# -# fix (+ tests) for ref to multiple indices on object i.e [>myObj key1 key2 .] -# -#2004-08-05 -# add PropertyWrite & PatternPropertyWrite metaMethods - (filter method called on property write) -# -# fix + add tests to support method & property of same name. (method precedence) -# -#2004-08-04 -# disallow attempt to use method reference as if it were a property (raise error instead of silently setting useless var) -# -# 1.0.7.1 -# use objectref array access to read properties even when some props unset; + test -# unset property using array access on object reference; + test -# -# -#2004-07-21 -# object reference changes - array property values appear as list value when accessed using upvared array. -# bugfixes + tests - properties containing lists (multidimensional access) -# -#1.0.7 -# -#2004-07-20 -# fix default property value append problem -# -#2004-07-17 -# add initial implementation of 'Unknown' and 'PatternUnknown' meta-methods -# ( -# -#2004-06-18 -# better cleanup on '>obj .. Destroy' - recursively destroy objects under parents subnamespaces. -# -#2004-06-05 -# change argsafety operator to be anything with leading - -# if standalone '-' then the dash itself is not added as a parameter, but if a string follows '-' -# i.e tkoption style; e.g -myoption ; then in addition to acting as an argsafety operator for the following arg, -# the entire dash-prefixed operator is also passed in as an argument. -# e.g >object . doStuff -window . -# will call the doStuff method with the 2 parameters -window . -# >object . doStuff - . -# will call doStuff with single parameter . -# >object . doStuff - -window . -# will result in a reference to the doStuff method with the argument -window 'curried' in. -# -#2004-05-19 -#1.0.6 -# fix so custom constructor code called. -# update Destroy metamethod to unset $self -# -#1.0.4 - 2004-04-22 -# bug fixes regarding method specialisation - added test -# -#------------------------------------------------------------ - -package provide pattern [namespace eval pattern {variable version; set version 1.2.4}] - - -namespace eval pattern::util { - - # Generally better to use 'package require $minver-' - # - this only gives us a different error - proc package_require_min {pkg minver} { - if {[package vsatisfies [lindex [set available [lsort -increasing [package versions $pkg]]] end] $minver-]} { - package require $pkg - } else { - error "Package pattern requires package $pkg of at least version $minver. Available: $available" - } - } -} - -package require patterncmd 1.2.4- -package require metaface 1.2.4- ;#utility/system diagnostic commands (may be used by metaface lib etc) - - - -#package require cmdline -package require overtype - -#package require md5 ;#will be loaded if/when needed -#package require md4 -#package require uuid - - - - - -namespace eval pattern { - variable initialised 0 - - - if 0 { - if {![catch {package require twapi_base} ]} { - #twapi is a windows only package - #MUCH faster to load just twapi_base than full 'package require twapi' IFF using the modular twapi distribution with multiple separately loadable dlls. - # If available - windows seems to provide a fast uuid generator.. - #*IF* tcllibc is missing, then as at 2008-05 twapi::new_uuid is significantly faster than uuid::uuid generate ( e.g 19 usec vs 76thousand usec! on 2.4GHZ machine) - # (2018 update - 15-30usec vs ~200usec on core i9 @ ~2.6GHZ (time for a single call e.g time {pattern::new_uuid})) - interp alias {} ::pattern::new_uuid {} ::twapi::new_uuid -localok - } else { - #performance on freebsd seems not great, but adequate. (e.g 500usec on dualcore 1.6GHZ) - # (e.g 200usec 2018 corei9) - #(with or without tcllibc?) - #very first call is extremely slow though - 3.5seconds on 2018 corei9 - package require uuid - interp alias {} ::pattern::new_uuid {} ::uuid::uuid generate - } - #variable fastobj 0 ;#precalculated invocant ID in method body (instead of call time ) - removed for now - see pattern 1.2.1 (a premature optimisation which was hampering refactoring & advancement) - } - - -} - - - - - - -namespace eval p { - #this is also the interp alias namespace. (object commands created here , then renamed into place) - #the object aliases are named as incrementing integers.. !todo - consider uuids? - variable ID 0 - namespace eval internals {} - - - #!?? - #namespace export ?? - variable coroutine_instance 0 -} - -#------------------------------------------------------------------------------------- -#review - what are these for? -#note - this function is deliberately not namespaced -# - it begins with the letters 'proc' (as do the created aliases) - to aid in editor's auto indexing/mapping features -proc process_pattern_aliases {object args} { - set o [namespace tail $object] - interp alias {} process_patternmethod_$o {} [$object .. PatternMethod .] - interp alias {} process_method_$o {} [$object .. Method .] - interp alias {} process_constructor_$o {} [$object .. Constructor .] -} -#------------------------------------------------------------------------------------- - - - - -#!store all interface objects here? -namespace eval ::p::ifaces {} - - - -#K combinator - see http://wiki.tcl.tk/1923 -#proc ::p::K {x y} {set x} -#- not used - use inline K if desired i.e set x [lreplace $x[set x{}] $a $b blah] - - - - - - - - -proc ::p::internals::(VIOLATE) {_ID_ violation_script} { - #set out [::p::fixed_var_statements @IMPLICITDECLS@\n$violation_script] - set processed [dict create {*}[::p::predator::expand_var_statements $violation_script]] - - if {![dict get $processed explicitvars]} { - #no explicit var statements - we need the implicit ones - set self [set ::p::${_ID_}::(self)] - set IFID [lindex [set $self] 1 0 end] - #upvar ::p::${IFID}:: self_IFINFO - - - set varDecls {} - set vlist [array get ::p::${IFID}:: v,name,*] - set _k ""; set v "" - if {[llength $vlist]} { - append varDecls "upvar #0 " - foreach {_k v} $vlist { - append varDecls "::p::\${_ID_}::$v $v " - } - append varDecls "\n" - } - - #set violation_script [string map [::list @IMPLICITDECLS@ $varDecls] $out] - set violation_script $varDecls\n[dict get $processed body] - - #tidy up - unset processed varDecls self IFID _k v - } else { - set violation_script [dict get $processed body] - } - unset processed - - - - - #!todo - review (& document) exactly what context this script runs in and what vars/procs are/should be visible. - eval "unset violation_script;$violation_script" -} - - -proc ::p::internals::DestroyObjectsBelowNamespace {ns} { - #puts "\n##################\n#################### destroyObjectsBelowNamespace $ns\n" - - set nsparts [split [string trim [string map {:: :} $ns] :] :] - if { ! ( ([llength $nsparts] == 3) & ([lindex $nsparts 0] == "p") & ([lindex $nsparts end] eq "_ref") )} { - #ns not of form ::p::?::_ref - - foreach obj [info commands ${ns}::>*] { - #catch {::p::meta::Destroy $obj} - #puts ">>found object $obj below ns $ns - destroying $obj" - $obj .. Destroy - } - } - - #set traces [trace info variable ${ns}::-->PATTERN_ANCHOR] - #foreach tinfo $traces { - # trace remove variable ${ns}::-->PATTERN_ANCHOR {*}$tinfo - #} - #unset -nocomplain ${ns}::-->PATTERN_ANCHOR - - foreach sub [namespace children $ns] { - ::p::internals::DestroyObjectsBelowNamespace $sub - } -} - - - - -################################################# -################################################# -################################################# -################################################# -################################################# -################################################# -################################################# -################################################# -################################################# -################################################# - - - - - - - - - -proc ::p::get_new_object_id {} { - tailcall incr ::p::ID - #tailcall ::pattern::new_uuid -} - -#create a new minimal object - with no interfaces or patterns. - -#proc ::p::internals::new_object [list cmd {wrapped ""} [list OID [expr {-2}]]] {} -proc ::p::internals::new_object {cmd {wrapped ""} {OID "-2"}} { - - #puts "-->new_object cmd:$cmd wrapped:$wrapped OID:$OID" - - if {$OID eq "-2"} { - set OID [::p::get_new_object_id] - #set OID [incr ::p::ID] ;#!todo - use uuids? (too slow?) (use uuids as configurable option?, pre-allocate a list of uuids?) - #set OID [pattern::new_uuid] - } - #if $wrapped provided it is assumed to be an existing namespace. - #if {[string length $wrapped]} { - # #??? - #} - - #sanity check - alias must not exist for this OID - if {[llength [interp alias {} ::p::$OID]]} { - error "Object alias '::p::$OID' already exists - cannot create new object with this id" - } - - #system 'varspaces' - - - #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://wiki.tcl.tk/1030 'Dangers of creative writing') - #set o_open 1 - every object is initially also an open interface (?) - #NOTE! comments within namespace eval slow it down. - namespace eval ::p::$OID { - #namespace ensemble create - namespace eval _ref {} - namespace eval _meta {} - namespace eval _iface { - variable o_usedby; - variable o_open 1; - array set o_usedby [list]; - variable o_varspace "" ; - variable o_varspaces [list]; - variable o_methods [dict create]; - variable o_properties [dict create]; - variable o_variables; - variable o_propertyunset_handlers; - set o_propertyunset_handlers [dict create] - } - } - - #set alias ::p::$OID - - #objectid alis default_method object_command wrapped_namespace - set INVOCANTDATA [list $OID ::p::$OID "" $cmd $wrapped] - - #MAP is a dict - set MAP [list invocantdata $INVOCANTDATA interfaces {level0 {} level0_default "" level1 {} level1_default ""} patterndata {patterndefaultmethod ""}] - - - - #NOTE 'interp alias' will prepend :: if chosen srccmd already exists as an alias token - #we've already checked that ::p::$OID doesn't pre-exist - # - so we know the return value of the [interp alias {} $alias {} ...] will be $alias - #interp alias {} ::p::$OID {} ::p::internals::predator $MAP - - - # _ID_ structure - set invocants_dict [dict create this [list $INVOCANTDATA] ] - #puts stdout "New _ID_structure: $interfaces_dict" - set _ID_ [dict create i $invocants_dict context ""] - - - interp alias {} ::p::$OID {} ::p::internals::predator $_ID_ - #rename the command into place - thus the alias & the command name no longer match! - rename ::p::$OID $cmd - - set ::p::${OID}::_meta::map $MAP - - # called when no DefaultMethod has been set for an object, but it is called with indices e.g >x something - interp alias {} ::p::${OID}:: {} ::p::internals::no_default_method $_ID_ - - #set p2 [string map {> ?} $cmd] - #interp alias {} $p2 {} ::p::internals::alternative_predator $_ID_ - - - #trace add command $cmd delete "$cmd .. Destroy ;#" - #puts "@@@ trace add command $cmd rename [list $cmd .. Rename]" - - trace add command $cmd rename [list $cmd .. Rename] ;#will receive $oldname $newname "rename" - #trace add command $cmd rename [$cmd .. Rename .] ;#EXTREMELY slow. (but why?) - - #puts "@@@ trace added for $cmd -> '[trace info command $cmd]'" - - - #uplevel #0 "trace add command $cmd delete \"puts deleting$cmd ;#\"" - #trace add command $cmd delete "puts deleting$cmd ;#" - #puts stdout "trace add command $cmd delete \"puts deleting$cmd ;#\"" - - - #puts "--> new_object returning map $MAP" - return $MAP -} - - - - -#>x .. Create >y -# ".." is special case equivalent to "._." -# (whereas in theory it would be ".default.") -# "." is equivalent to ".default." is equivalent to ".default.default." (...) - -#>x ._. Create >y -#>x ._.default. Create >y ??? -# -# - -# create object using 'blah' as source interface-stack ? -#>x .blah. .. Create >y -#>x .blah,_. ._. Create .iStackDestination. >y - - - -# -# ">x .blah,_." is a reference(cast) to >x that contains only the iStacks in the order listed. i.e [list blah _] -# the 1st item, blah in this case becomes the 'default' iStack. -# -#>x .*. -# cast to object with all iStacks -# -#>x .*,!_. -# cast to object with all iStacks except _ -# -# --------------------- -#!todo - MultiMethod support via transient and persistent object conglomerations. Operators '&' & '@' -# - a persistent conglomeration will have an object id (OID) and thus associated namespace, whereas a transient one will not. -# -#eg1: >x & >y . some_multi_method arg arg -# this is a call to the MultiMethod 'some_multi_method' with 2 objects as the invocants. ('>x & >y' is a transient conglomeration of the two objects) -# No explicit 'invocation role' is specified in this call - so it gets the default role for multiple invocants: 'these' -# The invocant signature is thus {these 2} -# (the default invocation role for a standard call on a method with a single object is 'this' - with the associated signature {this 1}) -# Invocation roles can be specified in the call using the @ operator. -# e.g >x & >y @ points . some_multi_method arg arg -# The invocant signature for this is: {points 2} -# -#eg2: {*}[join $objects &] @ objects & >p @ plane . move $path -# This has the signature {objects n plane 1} where n depends on the length of the list $objects -# -# -# To get a persistent conglomeration we would need to get a 'reference' to the conglomeration. -# e.g set pointset [>x & >y .] -# We can now call multimethods on $pointset -# - - - - - - -#set ::p::internals::predator to a particular predatorversion (from a patternpredatorX package) -proc ::pattern::predatorversion {{ver ""}} { - variable active_predatorversion - set allowed_predatorversions {1 2} - set default_predatorversion [lindex $allowed_predatorversions end] ;#default to last in list of allowed_predatorversions - - if {![info exists active_predatorversion]} { - set first_time_set 1 - } else { - set first_time_set 0 - } - - if {$ver eq ""} { - #get version - if {$first_time_set} { - set active_predatorversions $default_predatorversion - } - return $active_predatorversion - } else { - #set version - if {$ver ni $allowed_predatorversions} { - error "Invalid attempt to set predatorversion - unknown value: $ver, try one of: $allowed_predatorversions" - } - - if {!$first_time_set} { - if {$active_predatorversion eq $ver} { - #puts stderr "Active predator version is already '$ver'" - #ok - nothing to do - return $active_predatorversion - } else { - package require patternpredator$ver 1.2.4- - if {![llength [info commands ::p::predator$ver]]} { - error "Unable to set predatorversion - command ::p::predator$ver not found" - } - rename ::p::internals::predator ::p::predator$active_predatorversion - } - } - package require patternpredator$ver 1.2.4- - if {![llength [info commands ::p::predator$ver]]} { - error "Unable to set predatorversion - command ::p::predator$ver not found" - } - - rename ::p::predator$ver ::p::internals::predator - set active_predatorversion $ver - - return $active_predatorversion - } -} -::pattern::predatorversion 2 - - - - - - - - - - - - -# >pattern has object ID 1 -# meta interface has object ID 0 -proc ::pattern::init args { - - if {[set ::pattern::initialised]} { - if {[llength $args]} { - #if callers want to avoid this error, they can do their own check of $::pattern::initialised - error "pattern package is already initialised. Unable to apply args: $args" - } else { - return 1 - } - } - - #this seems out of date. - # - where is PatternPropertyRead? - # - Object is obsolete - # - Coinjoin, Combine don't seem to exist - array set ::p::metaMethods { - Clone object - Conjoin object - Combine object - Create object - Destroy simple - Info simple - Object simple - PatternProperty simple - PatternPropertyWrite simple - PatternPropertyUnset simple - Property simple - PropertyWrite simple - PatternMethod simple - Method simple - PatternVariable simple - Variable simple - Digest simple - PatternUnknown simple - Unknown simple - } - array set ::p::metaProperties { - Properties object - Methods object - PatternProperties object - PatternMethods object - } - - - - - - #create metaface - IID = -1 - also OID = -1 - # all objects implement this special interface - accessed via the .. operator. - - - - - - set ::p::ID 4 ;#0,1,2,3 reserved for null interface,>pattern, >ifinfo & ::p::>interface - - - #OID = 0 - ::p::internals::new_object ::p::ifaces::>null "" 0 - - #? null object has itself as level0 & level1 interfaces? - #set ::p::ifaces::>null [list [list 0 ::p::ifaces::>null item] [list [list 0] [list 0]] [list {} {}]] - - #null interface should always have 'usedby' members. It should never be extended. - array set ::p::0::_iface::o_usedby [list i-1 ::p::internals::>metaface i0 ::p::ifaces::>null i1 ::>pattern] ;#'usedby' array - set ::p::0::_iface::o_open 0 - - set ::p::0::_iface::o_constructor [list] - set ::p::0::_iface::o_variables [list] - set ::p::0::_iface::o_properties [dict create] - set ::p::0::_iface::o_methods [dict create] - set ::p::0::_iface::o_varspace "" - set ::p::0::_iface::o_varspaces [list] - array set ::p::0::_iface::o_definition [list] - set ::p::0::_iface::o_propertyunset_handlers [dict create] - - - - - ############################### - # OID = 1 - # >pattern - ############################### - ::p::internals::new_object ::>pattern "" 1 - - #set ::>pattern [list [list 1 ::>pattern item] [list [list 0] [list 0]]] - - - array set ::p::1::_iface::o_usedby [list] ;#'usedby' array - - set _self ::pattern - - #set IFID [::p::internals::new_interface 1] ;#level 0 interface usedby object 1 - #set IFID_1 [::p::internals::new_interface 1] ;#level 1 interface usedby object 1 - - - - #1)this object references its interfaces - #lappend ID $IFID $IFID_1 - #lset SELFMAP 1 0 $IFID - #lset SELFMAP 2 0 $IFID_1 - - - #set body [string map [::list @self@ ::>pattern @_self@ ::pattern @self_ID@ 0 @itemCmd@ item] $::p::internals::OBJECTCOMMAND] - #proc ::>pattern args $body - - - - - ####################################################################################### - #OID = 2 - # >ifinfo interface for accessing interfaces. - # - ::p::internals::new_object ::p::ifaces::>2 "" 2 ;#>ifinfo object - set ::p::2::_iface::o_constructor [list] - set ::p::2::_iface::o_variables [list] - set ::p::2::_iface::o_properties [dict create] - set ::p::2::_iface::o_methods [dict create] - set ::p::2::_iface::o_varspace "" - set ::p::2::_iface::o_varspaces [list] - array set ::p::2::_iface::o_definition [list] - set ::p::2::_iface::o_open 1 ;#open for extending - - ::p::ifaces::>2 .. AddInterface 2 - - #Manually create a minimal >ifinfo implementation using the same general pattern we use for all method implementations - #(bootstrap because we can't yet use metaface methods on it) - - - - proc ::p::2::_iface::isOpen.1 {_ID_} { - return $::p::2::_iface::o_open - } - interp alias {} ::p::2::_iface::isOpen {} ::p::2::_iface::isOpen.1 - - proc ::p::2::_iface::isClosed.1 {_ID_} { - return [expr {!$::p::2::_iface::o_open}] - } - interp alias {} ::p::2::_iface::isClosed {} ::p::2::_iface::isClosed.1 - - proc ::p::2::_iface::open.1 {_ID_} { - set ::p::2::_iface::o_open 1 - } - interp alias {} ::p::2::_iface::open {} ::p::2::_iface::open.1 - - proc ::p::2::_iface::close.1 {_ID_} { - set ::p::2::_iface::o_open 0 - } - interp alias {} ::p::2::_iface::close {} ::p::2::_iface::close.1 - - - #proc ::p::2::_iface::(GET)properties.1 {_ID_} { - # set ::p::2::_iface::o_properties - #} - #interp alias {} ::p::2::_iface::(GET)properties {} ::p::2::_iface::(GET)properties.1 - - #interp alias {} ::p::2::properties {} ::p::2::_iface::(GET)properties - - - #proc ::p::2::_iface::(GET)methods.1 {_ID_} { - # set ::p::2::_iface::o_methods - #} - #interp alias {} ::p::2::_iface::(GET)methods {} ::p::2::_iface::(GET)methods.1 - #interp alias {} ::p::2::methods {} ::p::2::_iface::(GET)methods - - - - - - #link from object to interface (which in this case are one and the same) - - #interp alias {} ::p::2::isOpen {} ::p::2::_iface::isOpen [::p::ifaces::>2 --] - #interp alias {} ::p::2::isClosed {} ::p::2::_iface::isClosed [::p::ifaces::>2 --] - #interp alias {} ::p::2::open {} ::p::2::_iface::open [::p::ifaces::>2 --] - #interp alias {} ::p::2::close {} ::p::2::_iface::close [::p::ifaces::>2 --] - - interp alias {} ::p::2::isOpen {} ::p::2::_iface::isOpen - interp alias {} ::p::2::isClosed {} ::p::2::_iface::isClosed - interp alias {} ::p::2::open {} ::p::2::_iface::open - interp alias {} ::p::2::close {} ::p::2::_iface::close - - - #namespace eval ::p::2 "namespace export $method" - - ####################################################################################### - - - - - - - set ::pattern::initialised 1 - - - ::p::internals::new_object ::p::>interface "" 3 - #create a convenience object on which to manipulate the >ifinfo interface - #set IF [::>pattern .. Create ::p::>interface] - set IF ::p::>interface - - - #!todo - put >ifinfo on a separate pStack so that end-user can more freely treat interfaces as objects? - # (or is forcing end user to add their own pStack/iStack ok .. ?) - # - ::p::>interface .. AddPatternInterface 2 ;# - - ::p::>interface .. PatternVarspace _iface - - ::p::>interface .. PatternProperty methods - ::p::>interface .. PatternPropertyRead methods {} { - varspace _iface - var {o_methods alias} - return $alias - } - ::p::>interface .. PatternProperty properties - ::p::>interface .. PatternPropertyRead properties {} { - varspace _iface - var o_properties - return $o_properties - } - ::p::>interface .. PatternProperty variables - - ::p::>interface .. PatternProperty varspaces - - ::p::>interface .. PatternProperty definition - - ::p::>interface .. Constructor {{usedbylist {}}} { - #var this - #set this @this@ - #set ns [$this .. Namespace] - #puts "-> creating ns ${ns}::_iface" - #namespace eval ${ns}::_iface {} - - varspace _iface - var o_constructor o_variables o_properties o_methods o_definition o_usedby o_varspace o_varspaces - - set o_constructor [list] - set o_variables [list] - set o_properties [dict create] - set o_methods [dict create] - set o_varspaces [list] - array set o_definition [list] - - foreach usedby $usedbylist { - set o_usedby(i$usedby) 1 - } - - - } - ::p::>interface .. PatternMethod isOpen {} { - varspace _iface - var o_open - - return $o_open - } - ::p::>interface .. PatternMethod isClosed {} { - varspace _iface - var o_open - - return [expr {!$o_open}] - } - ::p::>interface .. PatternMethod open {} { - varspace _iface - var o_open - set o_open 1 - } - ::p::>interface .. PatternMethod close {} { - varspace _iface - var o_open - set o_open 0 - } - ::p::>interface .. PatternMethod refCount {} { - varspace _iface - var o_usedby - return [array size o_usedby] - } - - set ::p::2::_iface::o_open 1 - - - - - uplevel #0 {pattern::util::package_require_min patternlib 1.2.4} - #uplevel #0 {package require patternlib} - return 1 -} - - - -proc ::p::merge_interface {old new} { - #puts stderr " ** ** ** merge_interface $old $new" - set ns_old ::p::$old - set ns_new ::p::$new - - upvar #0 ::p::${new}:: IFACE - upvar #0 ::p::${old}:: IFACEX - - if {![catch {set c_arglist $IFACEX(c,args)}]} { - #constructor - #for now.. just add newer constructor regardless of any existing one - #set IFACE(c,args) $IFACEX(c,args) - - #if {![info exists IFACE(c,args)]} { - # #target interface didn't have a constructor - # - #} else { - # # - #} - } - - - set methods [::list] - foreach nm [array names IFACEX m-1,name,*] { - lappend methods [lindex [split $nm ,] end] ;#use the method key-name not the value! (may have been overridden) - } - - #puts " *** merge interface $old -> $new ****merging-in methods: $methods " - - foreach method $methods { - if {![info exists IFACE(m-1,name,$method)]} { - #target interface doesn't yet have this method - - set THISNAME $method - - if {![string length [info command ${ns_new}::$method]]} { - - if {![set ::p::${old}::_iface::o_open]} { - #interp alias {} ${ns_new}::$method {} ${ns_old}::$method - #namespace eval $ns_new "namespace export [namespace tail $method]" - } else { - #wait to compile - } - - } else { - error "merge interface - command collision " - } - #set i 2 ??? - set i 1 - - } else { - #!todo - handle how? - #error "command $cmd already exists in interface $new" - - - set i [incr IFACE(m-1,chain,$method)] - - set THISNAME ___system___override_${method}_$i - - #move metadata using subindices for delegated methods - set IFACE(m-$i,name,$method) $IFACE(m-1,name,$method) - set IFACE(m-$i,iface,$method) $IFACE(m-1,iface,$method) - set IFACE(mp-$i,$method) $IFACE(mp-1,$method) - - set IFACE(m-$i,body,$method) $IFACE(m-1,body,$method) - set IFACE(m-$i,args,$method) $IFACE(m-1,args,$method) - - - #set next [::p::next_script $IFID0 $method] - if {![string length [info command ${ns_new}::$THISNAME]]} { - if {![set ::p::${old}::_iface::o_open]} { - interp alias {} ${ns_new}::$THISNAME {} ${ns_old}::$method - namespace eval $ns_new "namespace export $method" - } else { - #wait for compile - } - } else { - error "merge_interface - command collision " - } - - } - - array set IFACE [::list \ - m-1,chain,$method $i \ - m-1,body,$method $IFACEX(m-1,body,$method) \ - m-1,args,$method $IFACEX(m-1,args,$method) \ - m-1,name,$method $THISNAME \ - m-1,iface,$method $old \ - ] - - } - - - - - - #array set ${ns_new}:: [array get ${ns_old}::] - - - #!todo - review - #copy everything else across.. - - foreach {nm v} [array get IFACEX] { - #puts "-.- $nm" - if {([string first "m-1," $nm] != 0) && ($nm ne "usedby")} { - set IFACE($nm) $v - } - } - - #!todo -write a test - set ::p::${new}::_iface::o_open 1 - - #!todo - is this done also when iface compiled? - #namespace eval ::p::$new {namespace ensemble create} - - - #puts stderr "copy_interface $old $new" - - #assume that the (usedby) data is now obsolete - #???why? - #set ${ns_new}::(usedby) [::list] - - #leave ::(usedby) reference in place - - return -} - - - - -#detect attempt to treat a reference to a method as a property -proc ::p::internals::commandrefMisuse_TraceHandler {OID field args} { -#puts "commandrefMisuse_TraceHandler fired OID:$OID field:$field args:$args" - lassign [lrange $args end-2 end] vtraced vidx op - #NOTE! cannot rely on vtraced as it may have been upvared - - switch -- $op { - write { - error "$field is not a property" "property ref write failure for property $field (OID: $OID refvariable: [lindex $args 0])" - } - unset { - #!todo - monitor stat of Tcl bug# 1911919 - when/(if?) fixed - reinstate 'unset' trace - #trace add variable $traced {read write unset} [concat ::p::internals::commandrefMisuse_TraceHandler $OID $field $args] - - #!todo - don't use vtraced! - trace add variable $vtraced {read write unset array} [concat ::p::internals::commandrefMisuse_TraceHandler $OID $field $args] - - #pointless raising an error as "Any errors in unset traces are ignored" - #error "cannot unset. $field is a method not a property" - } - read { - error "$field is not a property (args $args)" "property ref read failure for property $field (OID: $OID refvariable: [lindex $args 0])" - } - array { - error "$field is not a property (args $args)" "property ref use as array failure for property $field (OID: $OID refvariable: [lindex $args 0])" - #error "unhandled operation in commandrefMisuse_TraceHandler - got op:$op expected read,write,unset. OID:$OID field:$field args:$args" - } - } - - return -} - - - - -#!todo - review calling-points for make_dispatcher.. probably being called unnecessarily at some points. -# -# The 'dispatcher' is an object instance's underlying object command. -# - -#proc ::p::make_dispatcher {obj ID IFID} { -# proc [string map {::> ::} $obj] {{methprop INFO} args} [string map [::list @IID@ $IFID @oid@ $ID] { -# ::p::@IID@ $methprop @oid@ {*}$args -# }] -# return -#} - - - - -################################################################################################################################################ -################################################################################################################################################ -################################################################################################################################################ - -#aliased from ::p::${OID}:: -# called when no DefaultMethod has been set for an object, but it is called with indices e.g >x something -proc ::p::internals::no_default_method {_ID_ args} { - puts stderr "p::internals::no_default_method _ID_:'$_ID_' args:'$args'" - lassign [lindex [dict get $_ID_ i this] 0] OID alias default_method object_command wrapped - tailcall error "No default method on object $object_command. (To get or set, use: $object_command .. DefaultMethod ?methodname? or use PatternDefaultMethod)" -} - -#force 1 will extend an interface even if shared. (??? why is this necessary here?) -#if IID empty string - create the interface. -proc ::p::internals::expand_interface {IID {force 0}} { - #puts stdout ">>> expand_interface $IID [info level -1]<<<" - if {![string length $IID]} { - #return [::p::internals::new_interface] ;#new interface is by default open for extending (o_open = 1) - set iid [expr {$::p::ID + 1}] - ::p::>interface .. Create ::p::ifaces::>$iid - return $iid - } else { - if {[set ::p::${IID}::_iface::o_open]} { - #interface open for extending - shared or not! - return $IID - } - - if {[array size ::p::${IID}::_iface::o_usedby] > 1} { - #upvar #0 ::p::${IID}::_iface::o_usedby prev_usedby - - #oops.. shared interface. Copy before specialising it. - set prev_IID $IID - - #set IID [::p::internals::new_interface] - set IID [expr {$::p::ID + 1}] - ::p::>interface .. Create ::p::ifaces::>$IID - - ::p::internals::linkcopy_interface $prev_IID $IID - #assert: prev_usedby contains at least one other element. - } - - #whether copied or not - mark as open for extending. - set ::p::${IID}::_iface::o_open 1 - return $IID - } -} - -#params: old - old (shared) interface ID -# new - new interface ID -proc ::p::internals::linkcopy_interface {old new} { - #puts stderr " ** ** ** linkcopy_interface $old $new" - set ns_old ::p::${old}::_iface - set ns_new ::p::${new}::_iface - - - - foreach nsmethod [info commands ${ns_old}::*.1] { - #puts ">>> adding $nsmethod to iface $new" - set tail [namespace tail $nsmethod] - set method [string range $tail 0 end-2] ;#strip .1 - - if {![llength [info commands ${ns_new}::$method]]} { - - set oldhead [interp alias {} ${ns_old}::$method] ;#the 'head' of the cmdchain that it actually points to ie $method.$x where $x >=1 - - #link from new interface namespace to existing one. - #(we assume that since ${ns_new}::$method didn't exist, that all the $method.$x chain slots are empty too...) - #!todo? verify? - #- actual link is chainslot to chainslot - interp alias {} ${ns_new}::$method.1 {} $oldhead - - #!todo - review. Shouldn't we be linking entire chain, not just creating a single .1 pointer to the old head? - - - #chainhead pointer within new interface - interp alias {} ${ns_new}::$method {} ${ns_new}::$method.1 - - namespace eval $ns_new "namespace export $method" - - #if {[string range $method 0 4] ni {(GET) (SET) (UNSE (CONS }} { - # lappend ${ns_new}::o_methods $method - #} - } else { - if {$method eq "(VIOLATE)"} { - #ignore for now - #!todo - continue - } - - #!todo - handle how? - #error "command $cmd already exists in interface $new" - - #warning - existing chainslot will be completely shadowed by linked method. - # - existing one becomes unreachable. #!todo review!? - - - error "linkcopy_interface $old -> $new - chainslot shadowing not implemented (method $method already exists on target interface $new)" - - } - } - - - #foreach propinf [set ${ns_old}::o_properties] { - # lassign $propinf prop _default - # #interp alias {} ${ns_new}::(GET)$prop {} ::p::predator::getprop $prop - # #interp alias {} ${ns_new}::(SET)$prop {} ::p::predator::setprop $prop - # lappend ${ns_new}::o_properties $propinf - #} - - - set ${ns_new}::o_variables [set ${ns_old}::o_variables] - set ${ns_new}::o_properties [set ${ns_old}::o_properties] - set ${ns_new}::o_methods [set ${ns_old}::o_methods] - set ${ns_new}::o_constructor [set ${ns_old}::o_constructor] - - - set ::p::${old}::_iface::o_usedby(i$new) linkcopy - - - #obsolete.? - array set ::p::${new}:: [array get ::p::${old}:: ] - - - - #!todo - is this done also when iface compiled? - #namespace eval ::p::${new}::_iface {namespace ensemble create} - - - #puts stderr "copy_interface $old $new" - - #assume that the (usedby) data is now obsolete - #???why? - #set ${ns_new}::(usedby) [::list] - - #leave ::(usedby) reference in place for caller to change as appropriate - 'copy' - - return -} -################################################################################################################################################ -################################################################################################################################################ -################################################################################################################################################ - -pattern::init - -return $::pattern::version diff --git a/src/vfs/_vfscommon.vfs/modules/patterncmd-0.1.tm b/src/vfs/_vfscommon.vfs/modules/patterncmd-0.1.tm deleted file mode 100644 index 8008673a..00000000 --- a/src/vfs/_vfscommon.vfs/modules/patterncmd-0.1.tm +++ /dev/null @@ -1,639 +0,0 @@ -package provide patterncmd [namespace eval patterncmd { - variable version - set version 0.1 -}] - - -namespace eval pattern { - variable idCounter 1 ;#used by pattern::uniqueKey - - namespace eval cmd { - namespace eval util { - package require overtype - variable colwidths_lib [dict create] - variable colwidths_lib_default 15 - - dict set colwidths_lib "library" [list ch " " num 21 head "|" tail ""] - dict set colwidths_lib "version" [list ch " " num 7 head "|" tail ""] - dict set colwidths_lib "type" [list ch " " num 9 head "|" tail ""] - dict set colwidths_lib "note" [list ch " " num 31 head "|" tail "|"] - - proc colhead {type args} { - upvar #0 ::pattern::cmd::util::colwidths_$type colwidths - set line "" - foreach colname [dict keys $colwidths] { - append line "[col $type $colname [string totitle $colname] {*}$args]" - } - return $line - } - proc colbreak {type} { - upvar #0 ::pattern::cmd::util::colwidths_$type colwidths - set line "" - foreach colname [dict keys $colwidths] { - append line "[col $type $colname {} -backchar - -headoverridechar + -tailoverridechar +]" - } - return $line - } - proc col {type col val args} { - # args -head bool -tail bool ? - #---------------------------------------------------------------------------- - set known_opts [list -backchar -headchar -tailchar -headoverridechar -tailoverridechar -justify] - dict set default -backchar "" - dict set default -headchar "" - dict set default -tailchar "" - dict set default -headoverridechar "" - dict set default -tailoverridechar "" - dict set default -justify "left" - if {([llength $args] % 2) != 0} { - error "(pattern::cmd::util::col) ERROR: uneven options supplied - must be of form '-option value' " - } - foreach {k v} $args { - if {$k ni $known_opts} { - error "((pattern::cmd::util::col) ERROR: option '$k' not in known options: '$known_opts'" - } - } - set opts [dict merge $default $args] - set backchar [dict get $opts -backchar] - set headchar [dict get $opts -headchar] - set tailchar [dict get $opts -tailchar] - set headoverridechar [dict get $opts -headoverridechar] - set tailoverridechar [dict get $opts -tailoverridechar] - set justify [dict get $opts -justify] - #---------------------------------------------------------------------------- - - - - upvar #0 ::pattern::cmd::util::colwidths_$type colwidths - #calculate headwidths - set headwidth 0 - set tailwidth 0 - foreach {key def} $colwidths { - set thisheadlen [string length [dict get $def head]] - if {$thisheadlen > $headwidth} { - set headwidth $thisheadlen - } - set thistaillen [string length [dict get $def tail]] - if {$thistaillen > $tailwidth} { - set tailwidth $thistaillen - } - } - - - set spec [dict get $colwidths $col] - if {[string length $backchar]} { - set ch $backchar - } else { - set ch [dict get $spec ch] - } - set num [dict get $spec num] - set headchar [dict get $spec head] - set tailchar [dict get $spec tail] - - if {[string length $headchar]} { - set headchar $headchar - } - if {[string length $tailchar]} { - set tailchar $tailchar - } - #overrides only apply if the head/tail has a length - if {[string length $headchar]} { - if {[string length $headoverridechar]} { - set headchar $headoverridechar - } - } - if {[string length $tailchar]} { - if {[string length $tailoverridechar]} { - set tailchar $tailoverridechar - } - } - set head [string repeat $headchar $headwidth] - set tail [string repeat $tailchar $tailwidth] - - set base [string repeat $ch [expr {$headwidth + $num + $tailwidth}]] - if {$justify eq "left"} { - set left_done [overtype::left $base "$head$val"] - return [overtype::right $left_done "$tail"] - } elseif {$justify in {centre center}} { - set mid_done [overtype::centre $base $val] - set left_mid_done [overtype::left $mid_done $head] - return [overtype::right $left_mid_done $tail] - } else { - set right_done [overtype::right $base "$val$tail"] - return [overtype::left $right_done $head] - } - - } - - } - } - -} - -#package require pattern - -proc ::pattern::libs {} { - set libs [list \ - pattern {-type core -note "alternative:pattern2"}\ - pattern2 {-type core -note "alternative:pattern"}\ - patterncmd {-type core}\ - metaface {-type core}\ - patternpredator2 {-type core}\ - patterndispatcher {-type core}\ - patternlib {-type core}\ - patterncipher {-type optional -note optional}\ - ] - - - - package require overtype - set result "" - - append result "[cmd::util::colbreak lib]\n" - append result "[cmd::util::colhead lib -justify centre]\n" - append result "[cmd::util::colbreak lib]\n" - foreach libname [dict keys $libs] { - set libinfo [dict get $libs $libname] - - append result [cmd::util::col lib library $libname] - if {[catch [list package present $libname] ver]} { - append result [cmd::util::col lib version "N/A"] - } else { - append result [cmd::util::col lib version $ver] - } - append result [cmd::util::col lib type [dict get $libinfo -type]] - - if {[dict exists $libinfo -note]} { - set note [dict get $libinfo -note] - } else { - set note "" - } - append result [cmd::util::col lib note $note] - append result "\n" - } - append result "[cmd::util::colbreak lib]\n" - return $result -} - -proc ::pattern::record {recname fields} { - if {[uplevel 1 [list namespace which $recname]] ne ""} { - error "(pattern::record) Can't create command '$recname': A command of that name already exists" - } - - set index -1 - set accessor [list ::apply { - {index rec args} - { - if {[llength $args] == 0} { - return [lindex $rec $index] - } - if {[llength $args] == 1} { - return [lreplace $rec $index $index [lindex $args 0]] - } - error "Invalid number of arguments." - } - - }] - - set map {} - foreach field $fields { - dict set map $field [linsert $accessor end [incr index]] - } - uplevel 1 [list namespace ensemble create -command $recname -map $map -parameters rec] -} -proc ::pattern::record2 {recname fields} { - if {[uplevel 1 [list namespace which $recname]] ne ""} { - error "(pattern::record) Can't create command '$recname': A command of that name already exists" - } - - set index -1 - set accessor [list ::apply] - - set template { - {rec args} - { - if {[llength $args] == 0} { - return [lindex $rec %idx%] - } - if {[llength $args] == 1} { - return [lreplace $rec %idx% %idx% [lindex $args 0]] - } - error "Invalid number of arguments." - } - } - - set map {} - foreach field $fields { - set body [string map [list %idx% [incr index]] $template] - dict set map $field [list ::apply $body] - } - uplevel 1 [list namespace ensemble create -command $recname -map $map -parameters rec] -} - -proc ::argstest {args} { - package require cmdline - -} - -proc ::pattern::objects {} { - set result [::list] - - foreach ns [namespace children ::pp] { - #lappend result [::list [namespace tail $ns] [set ${ns}::(self)]] - set ch [namespace tail $ns] - if {[string range $ch 0 2] eq "Obj"} { - set OID [string range $ch 3 end] ;#OID need not be digits (!?) - lappend result [::list $OID [list OID $OID object_command [set pp::${ch}::v_object_command] usedby [array names ${ns}::_iface::o_usedby]]] - } - } - - return $result -} - - - -proc ::pattern::name {num} { - #!todo - fix - #set ::p::${num}::(self) - - lassign [interp alias {} ::p::$num] _predator info - if {![string length $_predator$info]} { - error "No object found for num:$num (no interp alias for ::p::$num)" - } - set invocants [dict get $info i] - set invocants_with_role_this [dict get $invocants this] - set invocant_this [lindex $invocants_with_role_this 0] - - - #lassign $invocant_this id info - #set map [dict get $info map] - #set fields [lindex $map 0] - lassign $invocant_this _id _ns _defaultmethod name _etc - return $name -} - - -proc ::pattern::with {cmd script} { - foreach c [info commands ::p::-1::*] { - interp alias {} [namespace tail $c] {} $c $cmd - } - interp alias {} . {} $cmd . - interp alias {} .. {} $cmd .. - return [uplevel 1 $script] -} - - - - - -#system diagnostics etc - -proc ::pattern::varspace_list {IID} { - namespace upvar ::p::${IID}::_iface o_varspace o_varspace o_variables o_variables - - set varspaces [list] - dict for {vname vdef} $o_variables { - set vs [dict get $vdef varspace] - if {$vs ni $varspaces} { - lappend varspaces $vs - } - } - if {$o_varspace ni $varspaces} { - lappend varspaces $o_varspace - } - return $varspaces -} - -proc ::pattern::check_interfaces {} { - foreach ns [namespace children ::p] { - set IID [namespace tail $ns] - if {[string is digit $IID]} { - foreach ref [array names ${ns}::_iface::o_usedby] { - set OID [string range $ref 1 end] - if {![namespace exists ::p::${OID}::_iface]} { - puts -nonewline stdout "\r\nPROBLEM!!!!!!!!! nonexistant/invalid object $OID referenced by Interface $IID\r\n" - } else { - puts -nonewline stdout . - } - - - #if {![info exists ::p::${OID}::(self)]} { - # puts "PROBLEM!!!!!!!!! nonexistant object $OID referenced by Interface $IID" - #} - } - } - } - puts -nonewline stdout "\r\n" -} - - -#from: http://wiki.tcl.tk/8766 (Introspection on aliases) -#usedby: metaface-1.1.6+ -#required because aliases can be renamed. -#A renamed alias will still return it's target with 'interp alias {} oldname' -# - so given newname - we require which_alias to return the same info. - proc ::pattern::which_alias {cmd} { - uplevel 1 [list ::trace add execution $cmd enterstep ::error] - catch {uplevel 1 $cmd} res - uplevel 1 [list ::trace remove execution $cmd enterstep ::error] - #puts stdout "which_alias $cmd returning '$res'" - return $res - } -# [info args] like proc following an alias recursivly until it reaches -# the proc it originates from or cannot determine it. -# accounts for default parameters set by interp alias -# - - -proc ::pattern::aliasargs {cmd} { - set orig $cmd - - set defaultargs [list] - - # loop until error or return occurs - while {1} { - # is it a proc already? - if {[string equal [info procs $cmd] $cmd]} { - set result [info args $cmd] - # strip off the interp set default args - return [lrange $result [llength $defaultargs] end] - } - # is it a built in or extension command we can get no args for? - if {![string equal [info commands $cmd] $cmd]} { - error "\"$orig\" isn't a procedure" - } - - # catch bogus cmd names - if {[lsearch [interp aliases {}] $cmd]==-1} { - if {[catch {::pattern::which_alias $cmd} alias]} { - error "\"$orig\" isn't a procedure or alias or command" - } - #set cmd [lindex $alias 0] - if {[llength $alias]>1} { - set cmd [lindex $alias 0] - set defaultargs [concat [lrange $alias 1 end] $defaultargs] - } else { - set cmd $alias - } - } else { - - if {[llength [set cmdargs [interp alias {} $cmd]]]>0} { - # check if it is aliased in from another interpreter - if {[catch {interp target {} $cmd} msg]} { - error "Cannot resolve \"$orig\", alias leads to another interpreter." - } - if {$msg != {} } { - error "Not recursing into slave interpreter \"$msg\".\ - \"$orig\" could not be resolved." - } - # check if defaults are set for the alias - if {[llength $cmdargs]>1} { - set cmd [lindex $cmdargs 0] - set defaultargs [concat [lrange $cmdargs 1 end] $defaultargs] - } else { - set cmd $cmdargs - } - } - } - } -} - -proc ::pattern::aliasbody {cmd} { - set orig $cmd - - set defaultargs [list] - - # loop until error or return occurs - while {1} { - # is it a proc already? - if {[string equal [info procs $cmd] $cmd]} { - set result [info body $cmd] - # strip off the interp set default args - return $result - #return [lrange $result [llength $defaultargs] end] - } - # is it a built in or extension command we can get no args for? - if {![string equal [info commands $cmd] $cmd]} { - error "\"$orig\" isn't a procedure" - } - - # catch bogus cmd names - if {[lsearch [interp aliases {}] $cmd]==-1} { - if {[catch {::pattern::which_alias $cmd} alias]} { - error "\"$orig\" isn't a procedure or alias or command" - } - #set cmd [lindex $alias 0] - if {[llength $alias]>1} { - set cmd [lindex $alias 0] - set defaultargs [concat [lrange $alias 1 end] $defaultargs] - } else { - set cmd $alias - } - } else { - - if {[llength [set cmdargs [interp alias {} $cmd]]]>0} { - # check if it is aliased in from another interpreter - if {[catch {interp target {} $cmd} msg]} { - error "Cannot resolve \"$orig\", alias leads to another interpreter." - } - if {$msg != {} } { - error "Not recursing into slave interpreter \"$msg\".\ - \"$orig\" could not be resolved." - } - # check if defaults are set for the alias - if {[llength $cmdargs]>1} { - set cmd [lindex $cmdargs 0] - set defaultargs [concat [lrange $cmdargs 1 end] $defaultargs] - } else { - set cmd $cmdargs - } - } - } - } - } - - - - - -proc ::pattern::uniqueKey2 {} { - #!todo - something else?? - return [clock seconds]-[incr ::pattern::idCounter] -} - -#used by patternlib package -proc ::pattern::uniqueKey {} { - return [incr ::pattern::idCounter] - #uuid with tcllibc is about 30us compared with 2us - # for large datasets, e.g about 100K inserts this would be pretty noticable! - #!todo - uuid pool with background thread to repopulate when idle? - #return [uuid::uuid generate] -} - - - -#------------------------------------------------------------------------------------------------------------------------- - -proc ::pattern::test1 {} { - set msg "OK" - - puts stderr "next line should say:'--- saystuff:$msg" - ::>pattern .. Create ::>thing - - ::>thing .. PatternMethod saystuff args { - puts stderr "--- saystuff: $args" - } - ::>thing .. Create ::>jjj - - ::>jjj . saystuff $msg - ::>jjj .. Destroy - ::>thing .. Destroy -} - -proc ::pattern::test2 {} { - set msg "OK" - - puts stderr "next line should say:'--- property 'stuff' value:$msg" - ::>pattern .. Create ::>thing - - ::>thing .. PatternProperty stuff $msg - - ::>thing .. Create ::>jjj - - puts stderr "--- property 'stuff' value:[::>jjj . stuff]" - ::>jjj .. Destroy - ::>thing .. Destroy -} - -proc ::pattern::test3 {} { - set msg "OK" - - puts stderr "next line should say:'--- property 'stuff' value:$msg" - ::>pattern .. Create ::>thing - - ::>thing .. Property stuff $msg - - puts stderr "--- property 'stuff' value:[::>thing . stuff]" - ::>thing .. Destroy -} - -#--------------------------------- -#unknown/obsolete - - - - - - - -#proc ::p::internals::showargs {args {ch stdout}} {puts $ch $args} - -if {0} { - proc ::p::internals::new_interface {{usedbylist {}}} { - set OID [incr ::p::ID] - ::p::internals::new_object ::p::ifaces::>$OID "" $OID - puts "obsolete >> new_interface created object $OID" - foreach usedby $usedbylist { - set ::p::${OID}::_iface::o_usedby(i$usedby) 1 - } - set ::p::${OID}::_iface::o_varspace "" ;#default varspace is the object's namespace. (varspace is absolute if it has leading :: , otherwise it's a relative namespace below the object's namespace) - #NOTE - o_varspace is only the default varspace for when new methods/properties are added. - # it is possible to create some methods/props with one varspace value, then create more methods/props with a different varspace value. - - set ::p::${OID}::_iface::o_constructor [list] - set ::p::${OID}::_iface::o_variables [list] - set ::p::${OID}::_iface::o_properties [dict create] - set ::p::${OID}::_iface::o_methods [dict create] - array set ::p::${OID}::_iface::o_definition [list] - set ::p::${OID}::_iface::o_open 1 ;#open for extending - return $OID - } - - - #temporary way to get OID - assumes single 'this' invocant - #!todo - make generic. - proc ::pattern::get_oid {_ID_} { - #puts stderr "#* get_oid: [lindex [dict get $_ID_ i this] 0 0]" - return [lindex [dict get $_ID_ i this] 0 0] - - #set invocants [dict get $_ID_ i] - #set invocant_roles [dict keys $invocants] - #set role_members [dict get $invocants this] - ##set this_invocant [lindex $role_members 0] ;#for the role 'this' we assume only one invocant in the list. - #set this_invocant [lindex [dict get $_ID_ i this] 0] ; - #lassign $this_invocant OID this_info - # - #return $OID - } - - #compile the uncompiled level1 interface - #assert: no more than one uncompiled interface present at level1 - proc ::p::meta::PatternCompile {self} { - error "PatternCompile ????" - - upvar #0 $self SELFMAP - set ID [lindex $SELFMAP 0 0] - - set patterns [lindex $SELFMAP 1 1] ;#list of level1 interfaces - - set iid -1 - foreach i $patterns { - if {[set ::p::${i}::_iface::o_open]} { - set iid $i ;#found it - break - } - } - - if {$iid > -1} { - #!todo - - ::p::compile_interface $iid - set ::p::${iid}::_iface::o_open 0 - } else { - #no uncompiled interface present at level 1. Do nothing. - return - } - } - - - proc ::p::meta::Def {self} { - error ::p::meta::Def - - upvar #0 $self SELFMAP - set self_ID [lindex $SELFMAP 0 0] - set IFID [lindex $SELFMAP 1 0 end] - - set maxc1 0 - set maxc2 0 - - set arrName ::p::${IFID}:: - - upvar #0 $arrName state - - array set methods {} - - foreach nm [array names state] { - if {[regexp {^m-1,name,(.+)} $nm _match mname]} { - set methods($mname) [set state($nm)] - - if {[string length $mname] > $maxc1} { - set maxc1 [string length $mname] - } - if {[string length [set state($nm)]] > $maxc2} { - set maxc2 [string length [set state($nm)]] - } - } - } - set bg1 [string repeat " " [expr {$maxc1 + 2}]] - set bg2 [string repeat " " [expr {$maxc2 + 2}]] - - - set r {} - foreach nm [lsort -dictionary [array names methods]] { - set arglist $state(m-1,args,$nm) - append r "[overtype::left $bg1 $nm] : [overtype::left $bg2 $methods($nm)] [::list $arglist]\n" - } - return $r - } - - -} \ No newline at end of file diff --git a/src/vfs/_vfscommon.vfs/modules/patterncmd-1.2.4.tm b/src/vfs/_vfscommon.vfs/modules/patterncmd-1.2.4.tm deleted file mode 100644 index ca061a7c..00000000 --- a/src/vfs/_vfscommon.vfs/modules/patterncmd-1.2.4.tm +++ /dev/null @@ -1,645 +0,0 @@ -package provide patterncmd [namespace eval patterncmd { - variable version - - set version 1.2.4 -}] - - -namespace eval pattern { - variable idCounter 1 ;#used by pattern::uniqueKey - - namespace eval cmd { - namespace eval util { - package require overtype - variable colwidths_lib [dict create] - variable colwidths_lib_default 15 - - dict set colwidths_lib "library" [list ch " " num 21 head "|" tail ""] - dict set colwidths_lib "version" [list ch " " num 7 head "|" tail ""] - dict set colwidths_lib "type" [list ch " " num 9 head "|" tail ""] - dict set colwidths_lib "note" [list ch " " num 31 head "|" tail "|"] - - proc colhead {type args} { - upvar #0 ::pattern::cmd::util::colwidths_$type colwidths - set line "" - foreach colname [dict keys $colwidths] { - append line "[col $type $colname [string totitle $colname] {*}$args]" - } - return $line - } - proc colbreak {type} { - upvar #0 ::pattern::cmd::util::colwidths_$type colwidths - set line "" - foreach colname [dict keys $colwidths] { - append line "[col $type $colname {} -backchar - -headoverridechar + -tailoverridechar +]" - } - return $line - } - proc col {type col val args} { - # args -head bool -tail bool ? - #---------------------------------------------------------------------------- - set known_opts [list -backchar -headchar -tailchar -headoverridechar -tailoverridechar -justify] - dict set default -backchar "" - dict set default -headchar "" - dict set default -tailchar "" - dict set default -headoverridechar "" - dict set default -tailoverridechar "" - dict set default -justify "left" - if {([llength $args] % 2) != 0} { - error "(pattern::cmd::util::col) ERROR: uneven options supplied - must be of form '-option value' " - } - foreach {k v} $args { - if {$k ni $known_opts} { - error "((pattern::cmd::util::col) ERROR: option '$k' not in known options: '$known_opts'" - } - } - set opts [dict merge $default $args] - set backchar [dict get $opts -backchar] - set headchar [dict get $opts -headchar] - set tailchar [dict get $opts -tailchar] - set headoverridechar [dict get $opts -headoverridechar] - set tailoverridechar [dict get $opts -tailoverridechar] - set justify [dict get $opts -justify] - #---------------------------------------------------------------------------- - - - - upvar #0 ::pattern::cmd::util::colwidths_$type colwidths - #calculate headwidths - set headwidth 0 - set tailwidth 0 - foreach {key def} $colwidths { - set thisheadlen [string length [dict get $def head]] - if {$thisheadlen > $headwidth} { - set headwidth $thisheadlen - } - set thistaillen [string length [dict get $def tail]] - if {$thistaillen > $tailwidth} { - set tailwidth $thistaillen - } - } - - - set spec [dict get $colwidths $col] - if {[string length $backchar]} { - set ch $backchar - } else { - set ch [dict get $spec ch] - } - set num [dict get $spec num] - set headchar [dict get $spec head] - set tailchar [dict get $spec tail] - - if {[string length $headchar]} { - set headchar $headchar - } - if {[string length $tailchar]} { - set tailchar $tailchar - } - #overrides only apply if the head/tail has a length - if {[string length $headchar]} { - if {[string length $headoverridechar]} { - set headchar $headoverridechar - } - } - if {[string length $tailchar]} { - if {[string length $tailoverridechar]} { - set tailchar $tailoverridechar - } - } - set head [string repeat $headchar $headwidth] - set tail [string repeat $tailchar $tailwidth] - - set base [string repeat $ch [expr {$headwidth + $num + $tailwidth}]] - if {$justify eq "left"} { - set left_done [overtype::left $base "$head$val"] - return [overtype::right $left_done "$tail"] - } elseif {$justify in {centre center}} { - set mid_done [overtype::centre $base $val] - set left_mid_done [overtype::left $mid_done $head] - return [overtype::right $left_mid_done $tail] - } else { - set right_done [overtype::right $base "$val$tail"] - return [overtype::left $right_done $head] - } - - } - - } - } - -} - -#package require pattern - -proc ::pattern::libs {} { - set libs [list \ - pattern {-type core -note "alternative:pattern2"}\ - pattern2 {-type core -note "alternative:pattern"}\ - patterncmd {-type core}\ - metaface {-type core}\ - patternpredator2 {-type core}\ - patterndispatcher {-type core}\ - patternlib {-type core}\ - patterncipher {-type optional -note optional}\ - ] - - - - package require overtype - set result "" - - append result "[cmd::util::colbreak lib]\n" - append result "[cmd::util::colhead lib -justify centre]\n" - append result "[cmd::util::colbreak lib]\n" - foreach libname [dict keys $libs] { - set libinfo [dict get $libs $libname] - - append result [cmd::util::col lib library $libname] - if {[catch [list package present $libname] ver]} { - append result [cmd::util::col lib version "N/A"] - } else { - append result [cmd::util::col lib version $ver] - } - append result [cmd::util::col lib type [dict get $libinfo -type]] - - if {[dict exists $libinfo -note]} { - set note [dict get $libinfo -note] - } else { - set note "" - } - append result [cmd::util::col lib note $note] - append result "\n" - } - append result "[cmd::util::colbreak lib]\n" - return $result -} - -proc ::pattern::record {recname fields} { - if {[uplevel 1 [list namespace which $recname]] ne ""} { - error "(pattern::record) Can't create command '$recname': A command of that name already exists" - } - - set index -1 - set accessor [list ::apply { - {index rec args} - { - if {[llength $args] == 0} { - return [lindex $rec $index] - } - if {[llength $args] == 1} { - return [lreplace $rec $index $index [lindex $args 0]] - } - error "Invalid number of arguments." - } - - }] - - set map {} - foreach field $fields { - dict set map $field [linsert $accessor end [incr index]] - } - uplevel 1 [list namespace ensemble create -command $recname -map $map -parameters rec] -} -proc ::pattern::record2 {recname fields} { - if {[uplevel 1 [list namespace which $recname]] ne ""} { - error "(pattern::record) Can't create command '$recname': A command of that name already exists" - } - - set index -1 - set accessor [list ::apply] - - set template { - {rec args} - { - if {[llength $args] == 0} { - return [lindex $rec %idx%] - } - if {[llength $args] == 1} { - return [lreplace $rec %idx% %idx% [lindex $args 0]] - } - error "Invalid number of arguments." - } - } - - set map {} - foreach field $fields { - set body [string map [list %idx% [incr index]] $template] - dict set map $field [list ::apply $body] - } - uplevel 1 [list namespace ensemble create -command $recname -map $map -parameters rec] -} - -proc ::argstest {args} { - package require cmdline - -} - -proc ::pattern::objects {} { - set result [::list] - - foreach ns [namespace children ::pp] { - #lappend result [::list [namespace tail $ns] [set ${ns}::(self)]] - set ch [namespace tail $ns] - if {[string range $ch 0 2] eq "Obj"} { - set OID [string range $ch 3 end] ;#OID need not be digits (!?) - lappend result [::list $OID [list OID $OID object_command [set pp::${ch}::v_object_command] usedby [array names ${ns}::_iface::o_usedby]]] - } - } - - - - - return $result -} - - - -proc ::pattern::name {num} { - #!todo - fix - #set ::p::${num}::(self) - - lassign [interp alias {} ::p::$num] _predator info - if {![string length $_predator$info]} { - error "No object found for num:$num (no interp alias for ::p::$num)" - } - set invocants [dict get $info i] - set invocants_with_role_this [dict get $invocants this] - set invocant_this [lindex $invocants_with_role_this 0] - - - #lassign $invocant_this id info - #set map [dict get $info map] - #set fields [lindex $map 0] - lassign $invocant_this _id _ns _defaultmethod name _etc - return $name -} - - -proc ::pattern::with {cmd script} { - foreach c [info commands ::p::-1::*] { - interp alias {} [namespace tail $c] {} $c $cmd - } - interp alias {} . {} $cmd . - interp alias {} .. {} $cmd .. - - return [uplevel 1 $script] -} - - - - - -#system diagnostics etc - -proc ::pattern::varspace_list {IID} { - namespace upvar ::p::${IID}::_iface o_varspace o_varspace o_variables o_variables - - set varspaces [list] - dict for {vname vdef} $o_variables { - set vs [dict get $vdef varspace] - if {$vs ni $varspaces} { - lappend varspaces $vs - } - } - if {$o_varspace ni $varspaces} { - lappend varspaces $o_varspace - } - return $varspaces -} - -proc ::pattern::check_interfaces {} { - foreach ns [namespace children ::p] { - set IID [namespace tail $ns] - if {[string is digit $IID]} { - foreach ref [array names ${ns}::_iface::o_usedby] { - set OID [string range $ref 1 end] - if {![namespace exists ::p::${OID}::_iface]} { - puts -nonewline stdout "\r\nPROBLEM!!!!!!!!! nonexistant/invalid object $OID referenced by Interface $IID\r\n" - } else { - puts -nonewline stdout . - } - - - #if {![info exists ::p::${OID}::(self)]} { - # puts "PROBLEM!!!!!!!!! nonexistant object $OID referenced by Interface $IID" - #} - } - } - } - puts -nonewline stdout "\r\n" -} - - -#from: http://wiki.tcl.tk/8766 (Introspection on aliases) -#usedby: metaface-1.1.6+ -#required because aliases can be renamed. -#A renamed alias will still return it's target with 'interp alias {} oldname' -# - so given newname - we require which_alias to return the same info. - proc ::pattern::which_alias {cmd} { - uplevel 1 [list ::trace add execution $cmd enterstep ::error] - catch {uplevel 1 $cmd} res - uplevel 1 [list ::trace remove execution $cmd enterstep ::error] - #puts stdout "which_alias $cmd returning '$res'" - return $res - } -# [info args] like proc following an alias recursivly until it reaches -# the proc it originates from or cannot determine it. -# accounts for default parameters set by interp alias -# - - - -proc ::pattern::aliasargs {cmd} { - set orig $cmd - - set defaultargs [list] - - # loop until error or return occurs - while {1} { - # is it a proc already? - if {[string equal [info procs $cmd] $cmd]} { - set result [info args $cmd] - # strip off the interp set default args - return [lrange $result [llength $defaultargs] end] - } - # is it a built in or extension command we can get no args for? - if {![string equal [info commands $cmd] $cmd]} { - error "\"$orig\" isn't a procedure" - } - - # catch bogus cmd names - if {[lsearch [interp aliases {}] $cmd]==-1} { - if {[catch {::pattern::which_alias $cmd} alias]} { - error "\"$orig\" isn't a procedure or alias or command" - } - #set cmd [lindex $alias 0] - if {[llength $alias]>1} { - set cmd [lindex $alias 0] - set defaultargs [concat [lrange $alias 1 end] $defaultargs] - } else { - set cmd $alias - } - } else { - - if {[llength [set cmdargs [interp alias {} $cmd]]]>0} { - # check if it is aliased in from another interpreter - if {[catch {interp target {} $cmd} msg]} { - error "Cannot resolve \"$orig\", alias leads to another interpreter." - } - if {$msg != {} } { - error "Not recursing into slave interpreter \"$msg\".\ - \"$orig\" could not be resolved." - } - # check if defaults are set for the alias - if {[llength $cmdargs]>1} { - set cmd [lindex $cmdargs 0] - set defaultargs [concat [lrange $cmdargs 1 end] $defaultargs] - } else { - set cmd $cmdargs - } - } - } - } - } -proc ::pattern::aliasbody {cmd} { - set orig $cmd - - set defaultargs [list] - - # loop until error or return occurs - while {1} { - # is it a proc already? - if {[string equal [info procs $cmd] $cmd]} { - set result [info body $cmd] - # strip off the interp set default args - return $result - #return [lrange $result [llength $defaultargs] end] - } - # is it a built in or extension command we can get no args for? - if {![string equal [info commands $cmd] $cmd]} { - error "\"$orig\" isn't a procedure" - } - - # catch bogus cmd names - if {[lsearch [interp aliases {}] $cmd]==-1} { - if {[catch {::pattern::which_alias $cmd} alias]} { - error "\"$orig\" isn't a procedure or alias or command" - } - #set cmd [lindex $alias 0] - if {[llength $alias]>1} { - set cmd [lindex $alias 0] - set defaultargs [concat [lrange $alias 1 end] $defaultargs] - } else { - set cmd $alias - } - } else { - - if {[llength [set cmdargs [interp alias {} $cmd]]]>0} { - # check if it is aliased in from another interpreter - if {[catch {interp target {} $cmd} msg]} { - error "Cannot resolve \"$orig\", alias leads to another interpreter." - } - if {$msg != {} } { - error "Not recursing into slave interpreter \"$msg\".\ - \"$orig\" could not be resolved." - } - # check if defaults are set for the alias - if {[llength $cmdargs]>1} { - set cmd [lindex $cmdargs 0] - set defaultargs [concat [lrange $cmdargs 1 end] $defaultargs] - } else { - set cmd $cmdargs - } - } - } - } - } - - - - - -proc ::pattern::uniqueKey2 {} { - #!todo - something else?? - return [clock seconds]-[incr ::pattern::idCounter] -} - -#used by patternlib package -proc ::pattern::uniqueKey {} { - return [incr ::pattern::idCounter] - #uuid with tcllibc is about 30us compared with 2us - # for large datasets, e.g about 100K inserts this would be pretty noticable! - #!todo - uuid pool with background thread to repopulate when idle? - #return [uuid::uuid generate] -} - - - -#------------------------------------------------------------------------------------------------------------------------- - -proc ::pattern::test1 {} { - set msg "OK" - - puts stderr "next line should say:'--- saystuff:$msg" - ::>pattern .. Create ::>thing - - ::>thing .. PatternMethod saystuff args { - puts stderr "--- saystuff: $args" - } - ::>thing .. Create ::>jjj - - ::>jjj . saystuff $msg - ::>jjj .. Destroy - ::>thing .. Destroy -} - -proc ::pattern::test2 {} { - set msg "OK" - - puts stderr "next line should say:'--- property 'stuff' value:$msg" - ::>pattern .. Create ::>thing - - ::>thing .. PatternProperty stuff $msg - - ::>thing .. Create ::>jjj - - puts stderr "--- property 'stuff' value:[::>jjj . stuff]" - ::>jjj .. Destroy - ::>thing .. Destroy -} - -proc ::pattern::test3 {} { - set msg "OK" - - puts stderr "next line should say:'--- property 'stuff' value:$msg" - ::>pattern .. Create ::>thing - - ::>thing .. Property stuff $msg - - puts stderr "--- property 'stuff' value:[::>thing . stuff]" - ::>thing .. Destroy -} - -#--------------------------------- -#unknown/obsolete - - - - - - - - -#proc ::p::internals::showargs {args {ch stdout}} {puts $ch $args} -if {0} { - proc ::p::internals::new_interface {{usedbylist {}}} { - set OID [incr ::p::ID] - ::p::internals::new_object ::p::ifaces::>$OID "" $OID - puts "obsolete >> new_interface created object $OID" - foreach usedby $usedbylist { - set ::p::${OID}::_iface::o_usedby(i$usedby) 1 - } - set ::p::${OID}::_iface::o_varspace "" ;#default varspace is the object's namespace. (varspace is absolute if it has leading :: , otherwise it's a relative namespace below the object's namespace) - #NOTE - o_varspace is only the default varspace for when new methods/properties are added. - # it is possible to create some methods/props with one varspace value, then create more methods/props with a different varspace value. - - set ::p::${OID}::_iface::o_constructor [list] - set ::p::${OID}::_iface::o_variables [list] - set ::p::${OID}::_iface::o_properties [dict create] - set ::p::${OID}::_iface::o_methods [dict create] - array set ::p::${OID}::_iface::o_definition [list] - set ::p::${OID}::_iface::o_open 1 ;#open for extending - return $OID - } - - - #temporary way to get OID - assumes single 'this' invocant - #!todo - make generic. - proc ::pattern::get_oid {_ID_} { - #puts stderr "#* get_oid: [lindex [dict get $_ID_ i this] 0 0]" - return [lindex [dict get $_ID_ i this] 0 0] - - #set invocants [dict get $_ID_ i] - #set invocant_roles [dict keys $invocants] - #set role_members [dict get $invocants this] - ##set this_invocant [lindex $role_members 0] ;#for the role 'this' we assume only one invocant in the list. - #set this_invocant [lindex [dict get $_ID_ i this] 0] ; - #lassign $this_invocant OID this_info - # - #return $OID - } - - #compile the uncompiled level1 interface - #assert: no more than one uncompiled interface present at level1 - proc ::p::meta::PatternCompile {self} { - ???? - - upvar #0 $self SELFMAP - set ID [lindex $SELFMAP 0 0] - - set patterns [lindex $SELFMAP 1 1] ;#list of level1 interfaces - - set iid -1 - foreach i $patterns { - if {[set ::p::${i}::_iface::o_open]} { - set iid $i ;#found it - break - } - } - - if {$iid > -1} { - #!todo - - ::p::compile_interface $iid - set ::p::${iid}::_iface::o_open 0 - } else { - #no uncompiled interface present at level 1. Do nothing. - return - } - } - - - proc ::p::meta::Def {self} { - error ::p::meta::Def - - upvar #0 $self SELFMAP - set self_ID [lindex $SELFMAP 0 0] - set IFID [lindex $SELFMAP 1 0 end] - - set maxc1 0 - set maxc2 0 - - set arrName ::p::${IFID}:: - - upvar #0 $arrName state - - array set methods {} - - foreach nm [array names state] { - if {[regexp {^m-1,name,(.+)} $nm _match mname]} { - set methods($mname) [set state($nm)] - - if {[string length $mname] > $maxc1} { - set maxc1 [string length $mname] - } - if {[string length [set state($nm)]] > $maxc2} { - set maxc2 [string length [set state($nm)]] - } - } - } - set bg1 [string repeat " " [expr {$maxc1 + 2}]] - set bg2 [string repeat " " [expr {$maxc2 + 2}]] - - - set r {} - foreach nm [lsort -dictionary [array names methods]] { - set arglist $state(m-1,args,$nm) - append r "[overtype::left $bg1 $nm] : [overtype::left $bg2 $methods($nm)] [::list $arglist]\n" - } - return $r - } - - - -} \ No newline at end of file diff --git a/src/vfs/_vfscommon.vfs/modules/patternpredator1-1.0.tm b/src/vfs/_vfscommon.vfs/modules/patternpredator1-1.0.tm deleted file mode 100644 index 067c5540..00000000 --- a/src/vfs/_vfscommon.vfs/modules/patternpredator1-1.0.tm +++ /dev/null @@ -1,664 +0,0 @@ -package provide patternpredator1 1.0 - -proc ::p::internals::trailing, {map command stack i arglist pending} { - error "trailing ',' is not a valid sequence. If the comma was meant to be an argument, precede it with the -- operator." -} -proc ::p::internals::trailing.. {map command stack i arglist pending} { - error "trailing .. references not implemented." -} - -proc ::p::internals::trailing. {map command _ID_ stack i arglist pending} { - if {![llength $map]} { - error "Trailing . but no map - command:'$command' stack:$stack i:$i arglist:$arglist pending:$pending" - } - - - - #trailing dot - get reference. - #puts ">>trailing dot>> map:$map command:$command _ID_:$_ID_ stack:$stack i:$i arglist:$arglist pending:$pending" - lassign [lindex $map 0] OID alias itemCmd cmd - - - #lassign $command command _ID_ - - - if {$pending eq {}} { - #no pending operation requiring evaluation. - - #presumably we're getting a ref to the object, not a property or method. - #set traceCmd [::list ::p::objectRef_TraceHandler $cmd $_self $OID] - #if {[::list {array read write unset} $traceCmd] ni [trace info variable $refname]} { - # trace add variable $refname {array read write unset} $traceCmd - #} - set refname ::p::${OID}::_ref::__OBJECT ;#!todo - avoid potential collision with ref to member named '__OBJECT'. - #object ref - ensure trace-var is an array upon which the objects methods & properties can be accessed as indices - array set $refname [list] - #!todo?- populate array with object methods/properties now? - - - set _ID_ [list i [list this [list [list $OID [list map $map]]]]] - - #!todo - review. What if $map is out of date? - - set traceCmd [list ::p::predator::object_read_trace $OID $_ID_] - if {[list {read} $traceCmd] ni [trace info variable $refname]} { - trace add variable $refname {read} $traceCmd - } - - set traceCmd [list ::p::predator::object_array_trace $OID $_ID_] - if {[list {array} $traceCmd] ni [trace info variable $refname]} { - trace add variable $refname {array} $traceCmd - } - - set traceCmd [list ::p::predator::object_write_trace $OID $_ID_] - if {[list {write} $traceCmd] ni [trace info variable $refname]} { - trace add variable $refname {write} $traceCmd - } - - set traceCmd [list ::p::predator::object_unset_trace $OID $_ID_] - if {[list {unset} $traceCmd] ni [trace info variable $refname]} { - trace add variable $refname {unset} $traceCmd - } - - - #set command $refname - return $refname - } else { - #puts "- 11111111 '$command' '$stack'" - - if {[string range $command 0 171] eq "::p::-1::"} { - #!todo - review/enable this branch? - - #reference to meta-member - - #STALE map problem!! - - puts "\naaaaa command: $command\n" - - set field [namespace tail [lindex $command 0]] - set map [lindex $stack 0] - set OID [lindex $map 0 0] - - - if {[llength $stack]} { - set refname ::p::${OID}::_ref::[join [concat $field [lrange $stack 1 end]] +] - set command [interp alias {} $refname {} {*}$command {*}$stack] - } else { - set refname ::p::${OID}::_ref::$field - set command [interp alias {} $refname {} {*}$command] - } - puts "???? command '$command' \n refname '$refname' \n" - - } else { - #Property or Method reference (possibly with curried indices or arguments) - - #we don't want our references to look like objects. - #(If they did, they might be found by namespace tidyup code and treated incorrectly) - set field [string map {> __OBJECT_} [namespace tail $command]] - - #!todo? - # - make every object's OID unpredictable and sparse (UUID) and modify 'namespace child' etc to prevent iteration/inspection of ::p namespace. - - - #references created under ::p::${OID}::_ref are effectively inside a 'varspace' within the object itself. - # - this would in theory allow a set of interface functions on the object which have direct access to the reference variables. - - - if {[llength $stack]} { - set refname ::p::${OID}::_ref::[join [concat $field $stack] +] - #puts stdout " ------------>>>> refname:$refname" - if {[string length $_ID_]} { - set command [interp alias {} $refname {} $command $_ID_ {*}$stack] - } else { - set command [interp alias {} $refname {} $command {*}$stack] - } - } else { - set refname ::p::${OID}::_ref::$field - #!review - for consistency.. we don't directly return method name. - if {[string length $_ID_]} { - set command [interp alias {} $refname {} $command $_ID_] - } else { - set command [interp alias {} $refname {} $command] - } - } - - - #puts ">>>!>>>> refname $refname \n" - - - #NOTE! - we always create a command alias even if $field is not a method. - #( - - #!todo? - build a list of properties from all interfaces (cache it on object??) - set iflist [lindex $map 1 0] - - - - - set found 0 - foreach IFID [lreverse $iflist] { - #if {$field in [dict keys [set ::p::${IFID}::_iface::o_methods]]} { - # set found 1 - # break - #} - if {[llength [info commands ::p::${IFID}::_iface::(GET)$field]] || [llength [info commands ::p::${IFID}::_iface::(SET)$field]]} { - set found 1 - break - } - } - - - if {$found} { - #property reference - - #? - #set readref [string map [list ::_ref:: ::_ref::(GET) - #set writeref [string map [list ::_ref:: ::_ref::(SET) - - #puts "-2222222222 $refname" - - #puts "---HERE! $OID $property ::p::${OID}::_ref::${property}" - #trace remove variable $refname {read write unset} [list ::p::internals::commandrefMisuse_TraceHandler $alias $field] - foreach tinfo [trace info variable $refname] { - #puts "-->removing traces on $refname: $tinfo" - if {[lindex $tinfo 1 0] eq "::p::internals::commandrefMisuse_TraceHandler"} { - trace remove variable $refname {*}$tinfo - } - } - - - - - - #!todo - move to within trace info test below.. no need to test for refsync trace if no other trace? - #We only trace on entire property.. not array elements (if references existed to both the array and an element both traces would be fired -(entire array trace first)) - set Hndlr [::list ::p::predator::refsync_TraceHandler $OID $alias "" $field] - if { [::list {write unset} $Hndlr] ni [trace info variable ::p::${OID}::o_${field}]} { - trace add variable ::p::${OID}::o_${field} {write unset} $Hndlr - } - - set _ID_ [dict create i [dict create this [list [list $OID [list map $map] ]]]] - - #supply all data in easy-access form so that prop_trace_read is not doing any extra work. - set get_cmd ::p::${OID}::(GET)$field - set traceCmd [list ::p::predator::prop_trace_read $get_cmd $_ID_ $refname $field $stack] - - if {[list {read} $traceCmd] ni [trace info variable $refname]} { - - #synch the refvar with the real var if it exists - #catch {set $refname [$refname]} - if {[array exists ::p::${OID}::o_$field]} { - if {![llength $stack]} { - #unindexed reference - array set $refname [array get ::p::${OID}::o_$field] - } else { - #refs to nonexistant array members common? (catch vs 'info exists') - if {[info exists ::p::${OID}::o_${field}([lindex $stack 0])]} { - set $refname [set ::p::${OID}::o_${field}([lindex $stack 0])] - } - } - } else { - #catch means retrieving refs to non-initialised props slightly slower. - set errorInfo_prev $::errorInfo ;#preserve errorInfo across these catches! - - if {![llength $stack]} { - catch {set $refname [set ::p::${OID}::o_$field]} - } else { - if {[llength $stack] == 1} { - catch {set $refname [lindex [set ::p::${OID}::o_$field] [lindex $stack 0]]} - } else { - catch {set $refname [lindex [set ::p::${OID}::o_$field] $stack]} - } - } - - #! what if someone has put a trace on ::errorInfo?? - set ::errorInfo $errorInfo_prev - - } - - trace add variable $refname {read} $traceCmd - - set traceCmd [list ::p::predator::prop_trace_write $_ID_ $OID $alias $refname] - trace add variable $refname {write} $traceCmd - - set traceCmd [list ::p::predator::prop_trace_unset $_ID_ $OID $alias $refname] - trace add variable $refname {unset} $traceCmd - - set traceCmd [list ::p::predator::prop_trace_array $_ID_ $OID $alias $refname] - trace add variable $refname {array} $traceCmd - - } - - - } else { - #matching variable in order to detect attempted use as property and throw error - #puts "$refname ====> adding refMisuse_traceHandler $alias $field" - trace add variable $refname {read write unset} [list ::p::internals::commandrefMisuse_TraceHandler $alias $field] - } - } - - return $command - } -} - - -#script to inline at placeholder @reduce_pending_stack@ -set ::p::internals::reduce_pending_stack { - if {$pending eq {idx}} { - if {$OID ne {null}} { - #pattern object - #set command [list ::p::${OID}::$itemCmd [dict create i [dict create this [list $OID]]]] - set command ::p::${OID}::$itemCmd - set _ID_ [dict create i [dict create this [list [list $OID [list map $map]]]]] - #todo: set _ID_ [dict create i [dict create this [list [list $OID - - - {}]]] context {}] - - } else { - set command [list $itemCmd $command] - } - } - if {![llength [info commands [lindex $command 0]]]} { - set cmdname [namespace tail [lindex $command 0]] - if {[llength [info commands ::p::${OID}::(UNKNOWN)]]} { - lset command 0 ::p::${OID}::(UNKNOWN) - #puts stdout "!\n calling UNKNOWN $command $cmdname $stack\n\n" - - if {[string length $_ID_]} { - set interim [uplevel 1 [list {*}$command $_ID_ $cmdname {*}$stack]] ;#delegate to UNKNOWN, along with original commandname as 1st arg. - } else { - set interim [uplevel 1 [list {*}$command $cmdname {*}$stack]] ;#delegate to UNKNOWN, along with original commandname as 1st arg. - } - } else { - return -code error -errorinfo "1)error running command:'$command' argstack:'$stack'\n - command not found and no 'unknown' handler" "method '$command' not found" - } - } else { - #puts "---??? uplevelling $command $_ID_ $stack" - - if {[string length $_ID_]} { - set interim [uplevel 1 [list {*}$command $_ID_ {*}$stack]] - } else { - set interim [uplevel 1 [list {*}$command {*}$stack]] - } - #puts "---?2? interim:$interim" - } - - - - if {[string first ::> $interim] >= 0} { - #puts "--- ---> tailcalling $interim [lrange $args $i end]" - tailcall {*}$interim {*}[lrange $args $i end] ;#don't use a return statement as tailcall implies return - } else { - #the interim result is not a pattern object - but the . indicates we should treat it as a command - #tailcall ::p::internals::predator [list [list {null} {} {lindex} $interim {}]] {*}[lrange $args $i end] - #set nextmap [list [list {null} {} {lindex} $interim {}]] - #tailcall ::p::internals::predator [dict create i [dict create this [list null ]] map $nextmap] {*}[lrange $args $i end] - #tailcall ::p::internals::predator [dict create i [dict create this [list [list null [list]] ]] xmap $nextmap] {*}[lrange $args $i end] - - tailcall ::p::internals::predator [dict create i [dict create this [list [list null [list map [list [list {null} {} {lindex} $interim {}]]]] ]] callerinfo ""] {*}[lrange $args $i end] - - } -} - - - - -proc ::p::predator1 {subject args} [string map [list @reduce_pending_stack@ $::p::internals::reduce_pending_stack] { - #set OID [lindex [dict get $subject i this] 0 0] - - set this_invocant [lindex [dict get $subject i this] 0] ;#for the role 'this' we assume only one invocant in the list. - lassign $this_invocant OID this_info - - if {$OID ne {null}} { - #upvar #0 ::p::${OID}::_meta::map map - #if {![dict exists [lindex [dict get $subject i this] 0 1] map]} { - # set map [set ::p::${OID}::_meta::map] - #} else { - # set map [dict get [lindex [dict get $subject i this] 0 1] map] - #} - #seems to be faster just to grab from the variable, than to unwrap from $_ID_ !? - #set map [set ::p::${OID}::_meta::map] - - - - # if {![dict exists $this_info map]} { - set map [set ::p::${OID}::_meta::map] - #} else { - # set map [dict get $this_info map] - #} - - - - - - lassign [lindex $map 0] OID alias itemCmd cmd - - set cheat 1 - #------- - #the common optimised case first. A single . followed by args which contain no other operators (non-chained call) - #(it should be functionally equivalent to remove this shortcut block) - if {$cheat} { - if {([llength $args] > 1) && ([lindex $args 0] eq {.}) && ([llength [lsearch -all $args .]] == 1) && ({,} ni $args) && ({..} ni $args) && ({--} ni $args)} { - set command ::p::${OID}::[lindex $args 1] - - if {![llength [info commands $command]]} { - if {[llength [info commands ::p::${OID}::(UNKNOWN)]]} { - set cmdname [namespace tail $command] - lset command 0 ::p::${OID}::(UNKNOWN) - #return [uplevel 1 [list {*}$command [dict create i [dict create this [list [list $OID [list map $map]]]]] $cmdname {*}[lrange $args 2 end]]] ;#delegate to UNKNOWN, along with original commandname as 1st arg. - tailcall {*}$command [dict create i [dict create this [list [list $OID [list map [list [lindex $map 0] {{} {}} ] ] ]]]] $cmdname {*}[lrange $args 2 end] ;#delegate to UNKNOWN, along with original commandname as 1st arg. - } else { - return -code error -errorinfo "2)error running command:'$command' argstack:'[lrange $args 2 end]'\n - command not found and no 'unknown' handler" "method '$command' not found" - } - } else { - #puts " -->> tailcalling $command [lrange $args 2 end]" - #tailcall $command [dict create i [dict create this [list [list $OID [list map $map]] ]]] {*}[lrange $args 2 end] - #tailcall $command [dict create i [dict create this [list [list $OID {}] ]]] {*}[lrange $args 2 end] - - #jjj - #tailcall $command [list i [list this [list [list $OID [list map $map]] ]]] {*}[lrange $args 2 end] - tailcall $command [list i [list this [list [list $OID [list map [list [lindex $map 0] { {} {} } ]]] ]]] {*}[lrange $args 2 end] - } - } - } - #------------ - - - if {![llength $args]} { - #return $map - return [lindex $map 0 1] - } elseif {[llength $args] == 1} { - #short-circuit the single index case for speed. - if {$args ni {.. . -- - & @}} { - if {$cheat} { - - lassign [lindex $map 0] OID alias itemCmd - #return [::p::${OID}::$itemCmd [lindex $args 0]] - #tailcall ::p::${OID}::$itemCmd [dict create i [dict create this [list [list $OID [list map $map]]]]] [lindex $args 0] - tailcall ::p::${OID}::$itemCmd [list i [list this [list [list $OID [list map $map]]]]] [lindex $args 0] - } - } elseif {[lindex $args 0] eq {--}} { - #!todo - we could hide the invocant by only allowing this call from certain uplevel procs.. - # - combined with using UUIDs for $OID, and a secured/removed metaface on the object - # - (and also hiding of [interp aliases] command so they can't iterate and examine all aliases) - # - this could effectively hide the object's namespaces,vars etc from the caller (?) - return $map - } - } - } else { - #null OID - assume map is included in the _ID_ dict. - #set map [dict get $subject map] - set map [dict get $this_info map] - - lassign [lindex $map 0] OID alias itemCmd cmd - } - #puts "predator==== subject:$subject args:$args map:$map cmd:$cmd " - - - - #set map $invocant ;#retain 'invocant' in case we need original caller info.. 'map' is the data for whatever is at base of stack. - set command $cmd - set stack [list] - - #set operators [list . , ..] ;#(exclude --) - - - #!todo? short-circuit/inline commonest/simplest case {llength $args == 2} - - - set argProtect 0 - set pending "" ;#pending operator e.g . , idx .. & @ - set _ID_ "" - - set i 0 - - while {$i < [llength $args]} { - set word [lindex $args $i] - - if {$argProtect} { - #argProtect must be checked first. - # We are here because a previous operator necessitates that this word is an argument, not another operator. - set argProtect 0 - lappend stack $word - if {$pending eq {}} { - set pending idx ;#An argument only implies the index operator if no existing operator is in effect. (because '>obj $arg' must be equivalent to '>obj . item $arg' - } - incr i - } else { - switch -- $word {.} { - #$i is the operator, $i + 1 is the command. - if {[llength $args] > ($i + 1)} { - #there is at least a command, possibly args too - - if {$pending ne {}} { - #puts ">>>> >>>>> about to reduce. pending:$pending command:$command _ID_:$_ID_ stack:$stack" - - - #always bounces back into the predator via tailcall - @reduce_pending_stack@ - } else { - if {$OID ne {null}} { - #set command ::p::${OID}::[lindex $args $i+1] - #lappend stack [dict create i [dict create this [list $OID]]] - - set command ::p::${OID}::[lindex $args $i+1] - set _ID_ [list i [list this [list [list $OID [list map $map]]]]] - - } else { - #set command [list $command [lindex $args $i+1]] - lappend stack [lindex $args $i+1] - } - set pending . - set argProtect 0 - incr i 2 - } - } else { - #this is a trailing . - #puts "----> MAP $map ,command $command ,stack $stack" - if {$OID ne {null}} { - return [::p::internals::trailing. $map $command $_ID_ $stack $i $args $pending] - } else { - #!todo - fix. This is broken! - #the usefulness of a reference to an already-resolved value is questionable.. but for consistency it should probably be made to work. - - #for a null object - we need to supply the map in the invocation data - set command ::p::internals::predator - - set this_info [dict create map [list [list {null} {} {lindex} $command {}]] ] - set this_invocant [list null $this_info] - - set _ID_ [dict create i [dict create this [list $this_invocant]] ] - - return [::p::internals::trailing. $map $command $_ID_ $stack $i $args $pending] - } - } - } {--} { - #argSafety operator (see also "," & -* below) - set argProtect 1 - incr i - } {,} { - set argProtect 1 - if {$i+1 < [llength $args]} { - #not trailing - if {$pending ne {}} { - @reduce_pending_stack@ - } else { - if {$OID ne {null}} { - #set command [list ::p::[lindex $map 0 0]::$itemCmd [lindex $args $i+1]] - #set command [list $command . $itemCmd [lindex $args $i+1]] - - set stack [list . $itemCmd [lindex $args $i+1]] - - set _ID_ "" - - #lappend stack [dict create i [dict create this [list $OID]]] - - set pending "." - } else { - # this is an index operation into what is presumed to be a previously returned standard tcl list. (as opposed to an index operation into a returned pattern object) - #set command [list $itemCmd $command [lindex $args $i+1]] - #set command [list ::p::internals::predator [list [list {null} {} {lindex} $command {}]] [lindex $args $i+1] ] - - - #set command ::p::internals::predator - #set _ID_ [dict create i [dict create this [list null]] map [list [list {null} {} {lindex} [lindex $args $i+1] {}]] ] - #lappend stack [lindex $args $i+1] - - - set command [list $itemCmd $command] ;#e.g {lindex {a b c}} - - #set command ::p::internals::predator - #set _ID_ [dict create i [dict create this [list null]] map [list [list {null} {} {lindex} $nextcommand {}]]] - set _ID_ {} - lappend stack [lindex $args $i+1] - - - set pending "." ;#*not* idx or "," - } - - set argProtect 0 - incr i 2 - } - } else { - return [::p::internals::trailing, $map $command $stack $i $args $pending] - } - } {..} { - #Metaface operator - if {$i+1 < [llength $args]} { - #operator is not trailing. - if {$pending ne {}} { - @reduce_pending_stack@ - } else { - incr i - - #set command [list ::p::-1::[lindex $args $i] [dict create i [dict create this [list $OID]]]] - set command ::p::-1::[lindex $args $i] - - #_ID_ is a list, 1st element being a dict of invocants. - # Each key of the dict is an invocant 'role' - # Each value is a list of invocant-aliases fulfilling that role - #lappend stack [list [list caller [lindex $map 0 1] ]] - #lappend stack [list [dict create this [lindex $map 0 1]]] ;#'this' being the 'subject' in a standard singledispatch method call. - #lappend stack [dict create i [dict create this [list [lindex $map 0 1]]]] - - set _ID_ [dict create i [dict create this [list [list $OID [list map $map]]]]] - - set pending .. - incr i - } - } else { - return [::p::internals::trailing.. $map $command $stack $i $args $pending] - } - } {&} { - #conglomeration operator - if {$i+1 < [llength $args]} { - if {$pending ne {} } { - @reduce_pending_stack@ - - #set interim [uplevel 1 [list {*}$command {*}$stack]] - #tailcall {*}$interim {*}[lrange $args $i end] ;#don't use a return statement as tailcall implies return - } - - set command [list ::p::-1::Conglomerate $command] - lappend stack [lindex $args $i+1] - set pending & - incr i - - - - } else { - error "trailing & not supported" - } - } {@} { - #named-invocant operator - if {$i+1 < [llength $args]} { - if {$pending ne {} } { - @reduce_pending_stack@ - } else { - error "@ not implemented" - - set pending @ - incr i - } - } else { - error "trailing @ not supported" - } - } default { - if {[string index $word 0] ni {. -}} { - lappend stack $word - if {$pending eq {}} { - set pending idx - } - incr i - } else { - if {[string match "-*" $word]} { - #argSafety operator (tokens that appear to be Tcl 'options' automatically 'protect' the subsequent argument) - set argProtect 1 - lappend stack $word - incr i - } else { - if {([string index $word 0] eq ".") && ([string index $word end] eq ".") } { - #interface accessor! - error "interface casts not yet implemented!" - - set ifspec [string range $word 1 end] - if {$ifspec eq "!"} { - #create 'snapshot' reference with all current interfaces - - } else { - foreach ifname [split $ifspec ,] { - #make each comma-separated interface-name accessible via the 'casted object' - - } - } - - } else { - #has a leading . only. treat as an argument not an operator. - lappend stack $word - if {$pending eq {}} { - set pending idx - } - incr i - } - } - } - } - - - } - } - - #assert: $pending ne "" - #(we've run out of args, and if no 'operators' were found, then $pending will have been set to 'idx' - equivalent to '. item' ) - - #puts "---> evalling command + stack:'$command' '$stack' (pending:'$pending')" - if {$pending in {idx}} { - if {$OID ne {null}} { - #pattern object - set command ::p::${OID}::$itemCmd - set _ID_ [dict create i [dict create this [list [list $OID [list map $map] ] ]]] - } else { - # some other kind of command - set command [list $itemCmd $command] - } - } - if {![llength [info commands [lindex $command 0]]]} { - set cmdname [namespace tail [lindex $command 0]] - if {[llength [info commands ::p::${OID}::(UNKNOWN)]]} { - lset command 0 ::p::${OID}::(UNKNOWN) - #puts stdout "!\n calling UNKNOWN $command $cmdname $stack\n\n" - - if {[string length $_ID_]} { - tailcall {*}$command $_ID_ $cmdname {*}$stack ;#delegate to UNKNOWN, along with original commandname as 1st arg. - } else { - tailcall {*}$command $cmdname {*}$stack ;#delegate to UNKNOWN, along with original commandname as 1st arg. - } - } else { - return -code error -errorinfo "3)error running command:'$command' argstack:'$stack'\n - command not found and no 'unknown' handler" "method '$command' not found" - } - } - #puts "... tailcalling $command $stack" - if {[string length $_ID_]} { - tailcall {*}$command $_ID_ {*}$stack - } else { - tailcall {*}$command {*}$stack - } -}] diff --git a/src/vfs/_vfscommon.vfs/modules/patternpredator2-1.2.4.tm b/src/vfs/_vfscommon.vfs/modules/patternpredator2-1.2.4.tm deleted file mode 100644 index 680ea88f..00000000 --- a/src/vfs/_vfscommon.vfs/modules/patternpredator2-1.2.4.tm +++ /dev/null @@ -1,754 +0,0 @@ -package provide patternpredator2 1.2.4 - -proc ::p::internals::jaws {OID _ID_ args} { - #puts stderr ">>>(patternpredator2 lib)jaws called with _ID_:$_ID_ args: $args" - #set OID [lindex [dict get $_ID_ i this] 0 0] ;#get_oid - - yield - set w 1 - - set stack [list] - set wordcount [llength $args] - set terminals [list . .. , # @ !] ;#tokens which require the current stack to be evaluated first - set unsupported 0 - set operator "" - set operator_prev "" ;#used only by argprotect to revert to previous operator - - - if {$OID ne "null"} { - #!DO NOT use upvar here for MAP! (calling set on a MAP in another iteration/call will overwrite a map for another object!) - #upvar #0 ::p::${OID}::_meta::map MAP - set MAP [set ::p::${OID}::_meta::map] - } else { - # error "jaws - OID = 'null' ???" - set MAP [list invocantdata [lindex [dict get $_ID_ i this] 0] ] ;#MAP taken from _ID_ will be missing 'interfaces' key - } - set invocantdata [dict get $MAP invocantdata] - lassign $invocantdata OID alias default_method object_command wrapped - - set finished_args 0 ;#whether we've completely processed all args in the while loop and therefor don't need to peform the final word processing code - - #don't use 'foreach word $args' - we sometimes need to backtrack a little by manipulating $w - while {$w < $wordcount} { - set word [lindex $args [expr {$w -1}]] - #puts stdout "w:$w word:$word stack:$stack" - - if {$operator eq "argprotect"} { - set operator $operator_prev - lappend stack $word - incr w - } else { - if {[llength $stack]} { - if {$word in $terminals} { - set reduction [list 0 $_ID_ {*}$stack ] - #puts stderr ">>>jaws yielding value: $reduction triggered by word $word in position:$w" - - - set _ID_ [yield $reduction] - set stack [list] - #set OID [::pattern::get_oid $_ID_] - set OID [lindex [dict get $_ID_ i this] 0 0] ;#get_oid - - if {$OID ne "null"} { - set MAP [set ::p::${OID}::_meta::map] ;#Do not use upvar here! - } else { - set MAP [list invocantdata [lindex [dict get $_ID_ i this] 0] interfaces [list level0 {} level1 {}]] - #puts stderr "WARNING REVIEW: jaws-branch - leave empty??????" - } - - #review - 2018. switched to _ID_ instead of MAP - lassign [lindex [dict get $_ID_ i this] 0] OID alias default_method object_command - #lassign [dict get $MAP invocantdata] OID alias default_method object_command - - - #puts stdout "---->>> yielded _ID_: $_ID_ OID:$OID alias:$alias default_method:$default_method object_command:$object_command" - set operator $word - #don't incr w - #incr w - } else { - if {$operator eq "argprotect"} { - set operator $operator_prev - set operator_prev "" - lappend stack $word - } else { - #only look for leading argprotect chacter (-) if we're not already in argprotect mode - if {$word eq "--"} { - set operator_prev $operator - set operator "argprotect" - #Don't add the plain argprotector to the stack - } elseif {[string match "-*" $word]} { - #argSafety operator (tokens that appear to be Tcl 'options' automatically 'protect' the subsequent argument) - set operator_prev $operator - set operator "argprotect" - lappend stack $word - } else { - lappend stack $word - } - } - - - incr w - } - } else { - #no stack - switch -- $word {.} { - - if {$OID ne "null"} { - #we know next word is a property or method of a pattern object - incr w - set nextword [lindex $args [expr {$w - 1}]] - set command ::p::${OID}::$nextword - set stack [list $command] ;#2018 j - set operator . - if {$w eq $wordcount} { - set finished_args 1 - } - } else { - # don't incr w - #set nextword [lindex $args [expr {$w - 1}]] - set command $object_command ;#taken from the MAP - set stack [list "_exec_" $command] - set operator . - } - - - } {..} { - incr w - set nextword [lindex $args [expr {$w -1}]] - set command ::p::-1::$nextword - #lappend stack $command ;#lappend a small number of items to an empty list is slower than just setting the list. - set stack [list $command] ;#faster, and intent is clearer than lappend. - set operator .. - if {$w eq $wordcount} { - set finished_args 1 - } - } {,} { - #puts stdout "Stackless comma!" - - - if {$OID ne "null"} { - set command ::p::${OID}::$default_method - } else { - set command [list $default_method $object_command] - #object_command in this instance presumably be a list and $default_method a list operation - #e.g "lindex {A B C}" - } - #lappend stack $command - set stack [list $command] - set operator , - } {--} { - set operator_prev $operator - set operator argprotect - #no stack - - } {!} { - set command $object_command - set stack [list "_exec_" $object_command] - #puts stdout "!!!! !!!! $stack" - set operator ! - } default { - if {$operator eq ""} { - if {$OID ne "null"} { - set command ::p::${OID}::$default_method - } else { - set command [list $default_method $object_command] - } - set stack [list $command] - set operator , - lappend stack $word - } else { - #no stack - so we don't expect to be in argprotect mode already. - if {[string match "-*" $word]} { - #argSafety operator (tokens that appear to be Tcl 'options' automatically 'protect' the subsequent argument) - set operator_prev $operator - set operator "argprotect" - lappend stack $word - } else { - lappend stack $word - } - - } - } - incr w - } - - } - } ;#end while - - #process final word outside of loop - #assert $w == $wordcount - #trailing operators or last argument - if {!$finished_args} { - set word [lindex $args [expr {$w -1}]] - if {$operator eq "argprotect"} { - set operator $operator_prev - set operator_prev "" - - lappend stack $word - incr w - } else { - - - switch -- $word {.} { - if {![llength $stack]} { - #set stack [list "_result_" [::p::internals::ref_to_object $_ID_]] - yieldto return [::p::internals::ref_to_object $_ID_] - error "assert: never gets here" - - } else { - #puts stdout "==== $stack" - #assert - whenever _ID_ changed in this proc - we have updated the $OID variable - yieldto return [::p::internals::ref_to_stack $OID $_ID_ $stack] - error "assert: never gets here" - } - set operator . - - } {..} { - #trailing .. after chained call e.g >x . item 0 .. - #puts stdout "$$$$$$$$$$$$ [list 0 $_ID_ {*}$stack] $$$$" - #set reduction [list 0 $_ID_ {*}$stack] - yieldto return [yield [list 0 $_ID_ {*}$stack]] - } {#} { - set unsupported 1 - } {,} { - set unsupported 1 - } {&} { - set unsupported 1 - } {@} { - set unsupported 1 - } {--} { - - #set reduction [list 0 $_ID_ {*}$stack[set stack [list]]] - #puts stdout " -> -> -> about to call yield $reduction <- <- <-" - set _ID_ [yield [list 0 $_ID_ {*}$stack[set stack [list]]] ] - #set OID [::pattern::get_oid $_ID_] - set OID [lindex [dict get $_ID_ i this] 0 0] ;#get_oid - - if {$OID ne "null"} { - set MAP [set ::p::${OID}::_meta::map] ;#DO not use upvar here! - } else { - set MAP [list invocantdata [lindex [dict get $_ID_ i this] 0] interfaces {level0 {} level1 {}} ] - } - yieldto return $MAP - } {!} { - #error "untested branch" - set _ID_ [yield [list 0 $_ID_ {*}$stack[set stack [list]]]] - #set OID [::pattern::get_oid $_ID_] - set OID [lindex [dict get $_ID_ i this] 0 0] ;#get_oid - - if {$OID ne "null"} { - set MAP [set ::p::${OID}::_meta::map] ;#DO not use upvar here! - } else { - set MAP [list invocantdata [lindex [dict get $_ID_ i this] 0] ] - } - lassign [dict get $MAP invocantdata] OID alias default_command object_command - set command $object_command - set stack [list "_exec_" $command] - set operator ! - } default { - if {$operator eq ""} { - #error "untested branch" - lassign [dict get $MAP invocantdata] OID alias default_command object_command - #set command ::p::${OID}::item - set command ::p::${OID}::$default_command - lappend stack $command - set operator , - - } - #do not look for argprotect items here (e.g -option) as the final word can't be an argprotector anyway. - lappend stack $word - } - if {$unsupported} { - set unsupported 0 - error "trailing '$word' not supported" - - } - - #if {$operator eq ","} { - # incr wordcount 2 - # set stack [linsert $stack end-1 . item] - #} - incr w - } - } - - - #final = 1 - #puts stderr ">>>jaws final return value: [list 1 $_ID_ {*}$stack]" - - return [list 1 $_ID_ {*}$stack] -} - - - -#trailing. directly after object -proc ::p::internals::ref_to_object {_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 object_command - set refname ::p::${OID}::_ref::__OBJECT - - array set $refname [list] ;#important to initialise the variable as an array here - or initial read attempts on elements will not fire traces - - set traceCmd [list ::p::predator::object_read_trace $OID $_ID_] - if {[list {read} $traceCmd] ni [trace info variable $refname]} { - #puts stdout "adding read trace on variable '$refname' - traceCmd:'$traceCmd'" - trace add variable $refname {read} $traceCmd - } - set traceCmd [list ::p::predator::object_array_trace $OID $_ID_] - if {[list {array} $traceCmd] ni [trace info variable $refname]} { - trace add variable $refname {array} $traceCmd - } - - set traceCmd [list ::p::predator::object_write_trace $OID $_ID_] - if {[list {write} $traceCmd] ni [trace info variable $refname]} { - trace add variable $refname {write} $traceCmd - } - - set traceCmd [list ::p::predator::object_unset_trace $OID $_ID_] - if {[list {unset} $traceCmd] ni [trace info variable $refname]} { - trace add variable $refname {unset} $traceCmd - } - return $refname -} - - -proc ::p::internals::create_or_update_reference {OID _ID_ refname command} { - #if {[lindex $fullstack 0] eq "_exec_"} { - # #strip it. This instruction isn't relevant for a reference. - # set commandstack [lrange $fullstack 1 end] - #} else { - # set commandstack $fullstack - #} - #set argstack [lassign $commandstack command] - #set field [string map {> __OBJECT_} [namespace tail $command]] - - - - set reftail [namespace tail $refname] - set argstack [lassign [split $reftail +] field] - set field [string map {> __OBJECT_} [namespace tail $command]] - - #puts stderr "refname:'$refname' command: $command field:$field" - - - if {$OID ne "null"} { - upvar #0 ::p::${OID}::_meta::map MAP - } else { - #set map [dict get [lindex [dict get $_ID_ i this] 0 1] map] - set MAP [list invocantdata [lindex [dict get $_ID_ i this] 0] interfaces {level0 {} level1 {}}] - } - lassign [dict get $MAP invocantdata] OID alias default_method object_command - - - - if {$OID ne "null"} { - interp alias {} $refname {} $command $_ID_ {*}$argstack - } else { - interp alias {} $refname {} $command {*}$argstack - } - - - #set iflist [lindex $map 1 0] - set iflist [dict get $MAP interfaces level0] - #set iflist [dict get $MAP interfaces level0] - set field_is_property_like 0 - foreach IFID [lreverse $iflist] { - #tcl (braced) expr has lazy evaluation for &&, || & ?: operators - so this should be reasonably efficient. - if {[llength [info commands ::p::${IFID}::_iface::(GET)$field]] || [llength [info commands ::p::${IFID}::_iface::(SET)$field]]} { - set field_is_property_like 1 - #There is a setter or getter (but not necessarily an entry in the o_properties dict) - break - } - } - - - - - #whether field is a property or a method - remove any commandrefMisuse_TraceHandler - foreach tinfo [trace info variable $refname] { - #puts "-->removing traces on $refname: $tinfo" - if {[lindex $tinfo 1 0] eq "::p::internals::commandrefMisuse_TraceHandler"} { - trace remove variable $refname {*}$tinfo - } - } - - if {$field_is_property_like} { - #property reference - - - set this_invocantdata [lindex [dict get $_ID_ i this] 0] - lassign $this_invocantdata OID _alias _defaultmethod object_command - #get fully qualified varspace - - # - set propdict [$object_command .. GetPropertyInfo $field] - if {[dict exist $propdict $field]} { - set field_is_a_property 1 - set propinfo [dict get $propdict $field] - set varspace [dict get $propinfo varspace] - if {$varspace eq ""} { - set full_varspace ::p::${OID} - } else { - if {[::string match "::*" $varspace]} { - set full_varspace $varspace - } else { - set full_varspace ::p::${OID}::$varspace - } - } - } else { - set field_is_a_property 0 - #no propertyinfo - this field was probably established as a PropertyRead and/or PropertyWrite without a Property - #this is ok - and we still set the trace infrastructure below (app may convert it to a normal Property later) - set full_varspace ::p::${OID} - } - - - - - - #We only trace on entire property.. not array elements (if references existed to both the array and an element both traces would be fired -(entire array trace first)) - set Hndlr [::list ::p::predator::propvar_write_TraceHandler $OID $field] - if { [::list {write} $Hndlr] ni [trace info variable ${full_varspace}::o_${field}]} { - trace add variable ${full_varspace}::o_${field} {write} $Hndlr - } - set Hndlr [::list ::p::predator::propvar_unset_TraceHandler $OID $field] - if { [::list {unset} $Hndlr] ni [trace info variable ${full_varspace}::o_${field}]} { - trace add variable ${full_varspace}::o_${field} {unset} $Hndlr - } - - - #supply all data in easy-access form so that propref_trace_read is not doing any extra work. - set get_cmd ::p::${OID}::(GET)$field - set traceCmd [list ::p::predator::propref_trace_read $get_cmd $_ID_ $refname $field $argstack] - - if {[list {read} $traceCmd] ni [trace info variable $refname]} { - set fieldvarname ${full_varspace}::o_${field} - - - #synch the refvar with the real var if it exists - #catch {set $refname [$refname]} - if {[array exists $fieldvarname]} { - if {![llength $argstack]} { - #unindexed reference - array set $refname [array get $fieldvarname] - #upvar $fieldvarname $refname - } else { - set s0 [lindex $argstack 0] - #refs to nonexistant array members common? (catch vs 'info exists') - if {[info exists ${fieldvarname}($s0)]} { - set $refname [set ${fieldvarname}($s0)] - } - } - } else { - #refs to uninitialised props actually should be *very* common. - #If we use 'catch', it means retrieving refs to non-initialised props is slower. Fired catches can be relatively expensive. - #Because it's common to get a ref to uninitialised props (e.g for initial setting of their value) - we will use 'info exists' instead of catch. - - #set errorInfo_prev $::errorInfo ;#preserve errorInfo across catches! - - #puts stdout " ---->>!!! ref to uninitialised prop $field $argstack !!!<------" - - - if {![llength $argstack]} { - #catch {set $refname [set ::p::${OID}::o_$field]} - if {[info exists $fieldvarname]} { - set $refname [set $fieldvarname] - #upvar $fieldvarname $refname - } - } else { - if {[llength $argstack] == 1} { - #catch {set $refname [lindex [set ::p::${OID}::o_$field] [lindex $argstack 0]]} - if {[info exists $fieldvarname]} { - set $refname [lindex [set $fieldvarname] [lindex $argstack 0]] - } - - } else { - #catch {set $refname [lindex [set ::p::${OID}::o_$field] $argstack]} - if {[info exists $fieldvarname]} { - set $refname [lindex [set $fieldvarname] $argstack] - } - } - } - - #! what if someone has put a trace on ::errorInfo?? - #set ::errorInfo $errorInfo_prev - } - trace add variable $refname {read} $traceCmd - - set traceCmd [list ::p::predator::propref_trace_write $_ID_ $OID $full_varspace $refname] - trace add variable $refname {write} $traceCmd - - set traceCmd [list ::p::predator::propref_trace_unset $_ID_ $OID $refname] - trace add variable $refname {unset} $traceCmd - - - set traceCmd [list ::p::predator::propref_trace_array $_ID_ $OID $refname] - # puts "**************** installing array variable trace on ref:$refname - cmd:$traceCmd" - trace add variable $refname {array} $traceCmd - } - - } else { - #puts "$refname ====> adding refMisuse_traceHandler $alias $field" - #matching variable in order to detect attempted use as property and throw error - - #2018 - #Note that we are adding a trace on a variable (the refname) which does not exist. - #this is fine - except that the trace won't fire for attempt to write it as an array using syntax such as set $ref(someindex) - #we could set the ref to an empty array - but then we have to also undo this if a property with matching name is added - ##array set $refname {} ;#empty array - # - the empty array would mean a slightly better error message when misusing a command ref as an array - #but this seems like a code complication for little benefit - #review - - trace add variable $refname {read write unset array} [list ::p::internals::commandrefMisuse_TraceHandler $OID $field] - } -} - - - -#trailing. after command/property -proc ::p::internals::ref_to_stack {OID _ID_ fullstack} { - if {[lindex $fullstack 0] eq "_exec_"} { - #strip it. This instruction isn't relevant for a reference. - set commandstack [lrange $fullstack 1 end] - } else { - set commandstack $fullstack - } - set argstack [lassign $commandstack command] - set field [string map {> __OBJECT_} [namespace tail $command]] - - - #!todo? - # - make every object's OID unpredictable and sparse (UUID) and modify 'namespace child' etc to prevent iteration/inspection of ::p namespace. - # - this would only make sense for an environment where any meta methods taking a code body (e.g .. Method .. PatternMethod etc) are restricted. - - - #references created under ::p::${OID}::_ref are effectively inside a 'varspace' within the object itself. - # - this would in theory allow a set of interface functions on the object which have direct access to the reference variables. - - - set refname ::p::${OID}::_ref::[join [concat $field $argstack] +] - - if {[llength [info commands $refname]]} { - #todo - review - what if the field changed to/from a property/method? - #probably should fix that where such a change is made and leave this short circuit here to give reasonable performance for existing refs - return $refname - } - ::p::internals::create_or_update_reference $OID $_ID_ $refname $command - return $refname -} - - -namespace eval pp { - variable operators [list .. . -- - & @ # , !] - variable operators_notin_args "" - foreach op $operators { - append operators_notin_args "({$op} ni \$args) && " - } - set operators_notin_args [string trimright $operators_notin_args " &"] ;#trim trailing spaces and ampersands - #set operators_notin_args {({.} ni $args) && ({,} ni $args) && ({..} ni $args)} -} -interp alias {} strmap {} string map ;#stop code editor from mono-colouring our big string mapped code blocks! - - - - - -# 2017 ::p::predator2 is the development version - intended for eventual use as the main dispatch mechanism. -#each map is a 2 element list of lists. -# form: {$commandinfo $interfaceinfo} -# commandinfo is of the form: {ID Namespace defaultmethod commandname _?} - -#2018 -#each map is a dict. -#form: {invocantdata {ID Namespace defaultmethod commandname _?} interfaces {level0 {} level1 {}}} - - -#OID = Object ID (integer for now - could in future be a uuid) -proc ::p::predator2 {_ID_ args} { - #puts stderr "predator2: _ID_:'$_ID_' args:'$args'" - #set invocants [dict get $_ID_ i] - #set invocant_roles [dict keys $invocants] - - #For now - we are 'this'-centric (single dispatch). todo - adapt for multiple roles, multimethods etc. - #set this_role_members [dict get $invocants this] - #set this_invocant [lindex [dict get $_ID_ i this] 0] ;#for the role 'this' we assume only one invocant in the list. - #lassign $this_invocant this_OID this_info_dict - - set this_OID [lindex [dict get $_ID_ i this] 0 0] ;#get_oid - - - set cheat 1 ;# - #------- - #Optimise the next most common use case. A single . followed by args which contain no other operators (non-chained call) - #(it should be functionally equivalent to remove this shortcut block) - if {$cheat} { - if { ([lindex $args 0] eq {.}) && ([llength $args] > 1) && ([llength [lsearch -all -inline $args .]] == 1) && ({,} ni $args) && ({..} ni $args) && ({--} ni $args) && ({!} ni $args)} { - - set remaining_args [lassign $args dot method_or_prop] - - #how will we do multiple apis? (separate interface stacks) apply? apply [list [list _ID_ {*}$arglist] ::p::${stackid?}::$method_or_prop ::p::${this_OID}] ??? - set command ::p::${this_OID}::$method_or_prop - #REVIEW! - #e.g what if the method is named "say hello" ?? (hint - it will break because we will look for 'say') - #if {[llength $command] > 1} { - # error "methods with spaces not included in test suites - todo fix!" - #} - #Dont use {*}$command - (so we can support methods with spaces) - #if {![llength [info commands $command]]} {} - if {[namespace which $command] eq ""} { - if {[namespace which ::p::${this_OID}::(UNKNOWN)] ne ""} { - #lset command 0 ::p::${this_OID}::(UNKNOWN) ;#seems wrong - command could have spaces - set command ::p::${this_OID}::(UNKNOWN) - #tailcall {*}$command $_ID_ $cmdname {*}[lrange $args 2 end] ;#delegate to UNKNOWN, along with original commandname as 1st arg. - tailcall $command $_ID_ $method_or_prop {*}[lrange $args 2 end] ;#delegate to UNKNOWN, along with original commandname as 1st arg. - } else { - return -code error -errorinfo "(::p::predator2) error running command:'$command' argstack:'[lrange $args 2 end]'\n - command not found and no 'unknown' handler" "method '$method_or_prop' not found" - } - } else { - #tailcall {*}$command $_ID_ {*}$remaining_args - tailcall $command $_ID_ {*}$remaining_args - } - } - } - #------------ - - - if {([llength $args] == 1) && ([lindex $args 0] eq "..")} { - return $_ID_ - } - - - #puts stderr "pattern::predator (test version) called with: _ID_:$_ID_ args:$args" - - - - #puts stderr "this_info_dict: $this_info_dict" - - - - - if {![llength $args]} { - #should return some sort of public info.. i.e probably not the ID which is an implementation detail - #return cmd - return [lindex [dict get [set ::p::${this_OID}::_meta::map] invocantdata] 0] ;#Object ID - - #return a dict keyed on object command name - (suitable as use for a .. Create 'target') - #lassign [dict get [set ::p::${this_OID}::_meta::map] invocantdata] this_OID alias default_method object_command wrapped - #return [list $object_command [list -id $this_OID ]] - } elseif {[llength $args] == 1} { - #short-circuit the single index case for speed. - if {[lindex $args 0] ni {.. . -- - & @ # , !}} { - #lassign [dict get [set ::p::${this_OID}::_meta::map] invocantdata] this_OID alias default_method - lassign [lindex [dict get $_ID_ i this] 0] this_OID alias default_method - - tailcall ::p::${this_OID}::$default_method $_ID_ [lindex $args 0] - } elseif {[lindex $args 0] eq {--}} { - - #!todo - we could hide the invocant by only allowing this call from certain uplevel procs.. - # - combined with using UUIDs for $OID, and a secured/removed metaface on the object - # - (and also hiding of [interp aliases] command so they can't iterate and examine all aliases) - # - this could effectively hide the object's namespaces,vars etc from the caller (?) - return [set ::p::${this_OID}::_meta::map] - } - } - - - - #upvar ::p::coroutine_instance c ;#coroutine names must be unique per call to predator (not just per object - or we could get a clash during some cyclic calls) - #incr c - #set reduce ::p::reducer${this_OID}_$c - set reduce ::p::reducer${this_OID}_[incr ::p::coroutine_instance] - #puts stderr "..................creating reducer $reduce with args $this_OID _ID_ $args" - coroutine $reduce ::p::internals::jaws $this_OID $_ID_ {*}$args - - - set current_ID_ $_ID_ - - set final 0 - set result "" - while {$final == 0} { - #the argument given here to $reduce will be returned by 'yield' within the coroutine context (jaws) - set reduction_args [lassign [$reduce $current_ID_[set current_ID_ [list]] ] final current_ID_ command] - #puts stderr "..> final:$final current_ID_:'$current_ID_' command:'$command' reduction_args:'$reduction_args'" - #if {[string match *Destroy $command]} { - # puts stdout " calling Destroy reduction_args:'$reduction_args'" - #} - if {$final == 1} { - - if {[llength $command] == 1} { - if {$command eq "_exec_"} { - tailcall {*}$reduction_args - } - if {[llength [info commands $command]]} { - tailcall {*}$command $current_ID_ {*}$reduction_args - } - set cmdname [namespace tail $command] - set this_OID [lindex [dict get $current_ID_ i this] 0 0] - if {[llength [info commands ::p::${this_OID}::(UNKNOWN)]]} { - lset command 0 ::p::${this_OID}::(UNKNOWN) - tailcall {*}$command $current_ID_ $cmdname {*}$reduction_args ;#delegate to UNKNOWN, along with original commandname as 1st arg. - } else { - return -code error -errorinfo "1)error running command:'$command' argstack:'$reduction_args'\n - command not found and no 'unknown' handler" "method '$cmdname' not found" - } - - } else { - #e.g lindex {a b c} - tailcall {*}$command {*}$reduction_args - } - - - } else { - if {[lindex $command 0] eq "_exec_"} { - set result [uplevel 1 [list {*}[lrange $command 1 end] {*}$reduction_args]] - - set current_ID_ [list i [list this [list [list "null" {} {lindex} $result {} ] ] ] context {} ] - } else { - if {[llength $command] == 1} { - if {![llength [info commands $command]]} { - set cmdname [namespace tail $command] - set this_OID [lindex [dict get $current_ID_ i this] 0 0] - if {[llength [info commands ::p::${this_OID}::(UNKNOWN)]]} { - - lset command 0 ::p::${this_OID}::(UNKNOWN) - set result [uplevel 1 [list {*}$command $current_ID_ $cmdname {*}$reduction_args]] ;#delegate to UNKNOWN, along with original commandname as 1st arg. - } else { - return -code error -errorinfo "2)error running command:'$command' argstack:'$reduction_args'\n - command not found and no 'unknown' handler" "method '$cmdname' not found" - } - } else { - #set result [uplevel 1 [list {*}$command $current_ID_ {*}$reduction_args ]] - set result [uplevel 1 [list {*}$command $current_ID_ {*}$reduction_args ]] - - } - } else { - set result [uplevel 1 [list {*}$command {*}$reduction_args]] - } - - if {[llength [info commands $result]]} { - if {([llength $result] == 1) && ([string first ">" [namespace tail $result]] == 0)} { - #looks like a pattern command - set current_ID_ [$result .. INVOCANTDATA] - - - #todo - determine if plain .. INVOCANTDATA is sufficient instead of .. UPDATEDINVOCANTDATA - #if {![catch {$result .. INVOCANTDATA} result_invocantdata]} { - # set current_ID_ $result_invocantdata - #} else { - # return -code error -errorinfo "3)error running command:'$command' argstack:'$reduction_args'\n - Failed to access result:'$result' as a pattern object." "Failed to access result:'$result' as a pattern object" - #} - } else { - #non-pattern command - set current_ID_ [list i [list this [list [list "null" {} {lindex} $result {} ] ] ] context {}] - } - } else { - set current_ID_ [list i [list this [list [list "null" {} {lindex} $result {} ] ] ] context {}] - #!todo - allow further operations on non-command values. e.g dicts, lists & strings (treat strings as lists) - - } - } - - } - } - error "Assert: Shouldn't get here (end of ::p::predator2)" - #return $result -} diff --git a/src/vfs/_vfscommon.vfs/modules/punk-0.1.tm.txt b/src/vfs/_vfscommon.vfs/modules/punk-0.1.tm.txt deleted file mode 100644 index db0f494a..00000000 --- a/src/vfs/_vfscommon.vfs/modules/punk-0.1.tm.txt +++ /dev/null @@ -1,7672 +0,0 @@ -#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} { - 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 - return "\ - apply {{ap tmlist} { - set ::auto_path \$ap - tcl::tm::list - set ::tcl::tm::paths \$tmlist - }} {$::auto_path} {[tcl::tm::list]} - " - } - - proc rehash {{refresh 0}} { - global auto_execs - if {!$refresh} { - unset -nocomplain auto_execs - } else { - set names [array names auto_execs] - unset -nocomplain auto_execs - foreach nm $names { - auto_execok_windows $nm - } - } - return - } - - - proc ::punk::auto_execok_original name [info body ::auto_execok] - variable better_autoexec - - #set better_autoexec 0 ;#use this var via better_autoexec only - #proc ::punk::auto_execok_windows name { - # ::punk::auto_execok_original $name - #} - - 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] && $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::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::rehash - } else { - puts "no change" - } - } - #better_autoexec $better_autoexec ;#init to default - - - proc auto_execok_better {name} { - global auto_execs env tcl_platform - - 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} { - foreach ext $execExtensions { - set file ${name}${ext} - if {[file exists $file] && ![file isdirectory $file]} { - return [set auto_execs($name) [list $file]] - } - } - return "" - } - - #change1 - #set path "[file dirname [info nameofexecutable]];.;" - set path "[file dirname [info nameofexecutable]];" - - 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;" - } - - foreach var {PATH Path path} { - if {[info exists env($var)]} { - append path ";$env($var)" - } - } - - #change2 - set lookfor [lmap ext $execExtensions {string cat ${name} ${ext}}] - foreach dir [split $path {;}] { - #set dir [file normalize $dir] - # Skip already checked directories - if {[info exists checked($dir)] || ($dir eq "")} { - continue - } - set checked($dir) {} - - foreach match [glob -nocomplain -dir $dir -tail {*}$lookfor] { - set file [file join $dir $match] - if {[file exists $file] && ![file isdirectory $file]} { - return [set auto_execs($name) [list $file]] - } - } - } - - #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 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 - 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 -package require punk::console ;#requires Thread -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 funcl - - 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 objclone {obj} { - append obj2 $obj {} - } - proc set_clone {varname obj} { - #maintenance: also punk::lib::set_clone - #e.g used by repl's codeinterp. Maintains internal rep, easier to call e.g interp eval code [list punk::set_clone varnmame $val] - append obj2 $obj {} - uplevel 1 [list set $varname $obj2] - } - - interp alias "" strlen "" ::punk::strlen - interp alias "" str_len "" ::punk::strlen - interp alias "" objclone "" ::punk::objclone - #proc ::strlen {str} { - # string length [append str2 $str {}] - #} - #proc ::objclone {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} - - 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 - } - - #review - there are various type of uuid - we should use something consistent across platforms - #twapi is used on windows because it's about 5 times faster - but is this more important than consistency? - #twapi is much slower to load in the first place (e.g 75ms vs 6ms if package names already loaded) - so for oneshots tcllib uuid is better anyway - #(counterpoint: in the case of punk - we currently need twapi anyway on windows) - #does tcllib's uuid use the same mechanisms on different platforms anyway? - proc ::punk::uuid {} { - set has_twapi 0 - if 0 { - if {"windows" eq $::tcl_platform(platform)} { - if { - ![catch { - set loader [zzzload::pkg_wait twapi] - } errM] - } { - if {$loader in [list failed loading]} { - catch {puts stderr "Unexpected problem during thread-load of pkg twapi - zzload::pkg_wait returned $loader"} - } - } else { - package require twapi - } - if {[package provide twapi] ne ""} { - set has_twapi 1 - } - } - } - if {!$has_twapi} { - if {[catch {package require uuid} errM]} { - error "Unable to load a package for uuid on this platform. Try installing tcllib's uuid (any platform) - or twapi for windows" - } - return [uuid::uuid generate] - } else { - return [twapi::new_uuid] - } - } - - #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} 0} { - lassign [scan $token %${first_term}s%s] var spec - } else { - if {$first_term == 0} { - set var "" - set spec $token - } - } - lappend varlist [list $var $spec] - set token "" - set token_index -1 ;#reduce by 1 because , not included in next token - set first_term -1 - } else { - append token $c - if {$first_term == -1 && (($c in $var_terminals) && ($prevc ni $protect_terminals))} { - set first_term $token_index - } elseif {$c eq "("} { - set in_brackets 1 - } - } - } - set prevc $c - incr token_index - } - if {[string length $token]} { - #lappend varlist [splitstrposn $token $first_term] - set var $token - set spec "" - if {$first_term > 0} { - lassign [scan $token %${first_term}s%s] var spec - } else { - if {$first_term == 0} { - set var "" - set spec $token - } - } - lappend varlist [list $var $spec] - } - return $varlist - } - proc _split_var_key_at_unbracketed_comma1 {varspecs} { - set varlist [list] - set var_terminals [list "@" "/" "#" "!"] - set in_brackets 0 - #set varspecs [string trimleft $varspecs ,] - set token "" - #if {[string first "," $varspecs] <0} { - # return $varspecs - #} - set first_term -1 - set token_index 0 ;#index of terminal char within each token - foreach c [split $varspecs ""] { - if {$in_brackets} { - if {$c eq ")"} { - set in_brackets 0 - } - append token $c - } else { - if {$c eq ","} { - 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 ""] - } - 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! - 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 (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 { - 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 - } - %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 { - 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 - }] - } - %* { - 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 {[string first "end" $index] >= 0} { - 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]} { - 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} { - #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"} { - if {[string match *-* $index]} { - lappend INDEX_OPERATIONS string-range - 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 "*"} { - 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 var_display_names [list] - foreach v $var_names { - if {$v eq ""} { - lappend var_display_names {{}} - } else { - lappend var_display_names $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::objclone $args] - set nscaller [uplevel 1 [list 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::objclone $args] - set nscaller [uplevel 1 [list 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 ::namespace path]] - if {$cmdns ni $existing_path} { - uplevel 1 [list ::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 $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 |>) - 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 = "" "" {*}$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 ::namespace path]] - if {$cmdns ni $existing_path} { - uplevel 1 [list ::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? - } - 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 ] - 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 - - - #--------------------------------------------------------------------- - # 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) && (![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 {::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} { - #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 {::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 {[dict get $::punk::config::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 redir ">&@stdout <@stdin" - uplevel 1 [list ::catch [concat exec $redir $new [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. - 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 - 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 ::namespace current]] - #jmn - set rhsmapped [punk::pipe::lib::pipecmd_namemapping $equalsrhs] - set commands [uplevel 1 [list ::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] - } - - 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 ".=" "" "" {*}$args] - } - } - 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 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] - 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 {::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} { - upvar ::punk::config::running running_config - set scriptlib [dict get $running_config 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]} { - uplevel #0 [list {*}$args | more] - } 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 {{glob *}} { - set pipe [punk::path_list_pipe $glob] - {*}$pipe |> list_as_lines - } - - #------------------------------------------------------------------- - #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 - - - #tilde - #These aliases work fine for interactive use - but the result is always a string int-rep - #interp alias {} ~ {} file join $::env(HOME) ;#HOME must be capitalized to work cross platform (lowercase home works on windows - but probably not elsewhere) - #interp alias {} ~ {} apply {args {file join $::env(HOME) $args}} - proc ~ {args} { - set hdir [punk::objclone $::env(HOME)] - file pathtype $hdir - set d $hdir - #use the file join 2-arg optimisation to avoid losing path-rep - probably doesn't give any advantage on all Tcl versions - foreach a $args { - set d [file join $d $a] - } - file pathtype $d - return [punk::objclone $d] - } - interp alias {} ~ {} punk::~ - - - #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 - } else { - lappend newrow [lindex $oldrow $j] - } - } - lappend res $newrow - } - return $res - } - 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] - 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 ::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 - } - - - #An implementation of a notoriously controversial metric. - proc LOC {args} { - set argspecs [subst { - @dynamic - @id -id ::punk::LOC - @cmd -name punk::LOC -help\ - "LOC - lines of code. - An implementation of a notoriously controversial metric" - -dir -default "\uFFFF" - -exclude_dupfiles -default 1 -type boolean - ${[punk::args::resolved_def ::punk::path::treefilenames -antiglob_paths]} - -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 - to report on." - #we could map away whitespace and use string is punct - but not as flexible? review - -punctchars -default { [list \{ \} \" \\ - _ + = . > , < ' : \; ` ~ ! @ # \$ % ^ & * \[ \] ( ) | / ?] } - }] - set argd [punk::args::get_dict $argspecs $args] - lassign [dict values $argd] leaders opts values received - set searchspecs [dict values $values] - - # -- --- --- --- --- --- - 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_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_punctchars [dict get $opts -punctchars] - set opt_largest [dict get $opts -show_largest] - # -- --- --- --- --- --- - - - set filepaths [punk::path::treefilenames -dir $opt_dir {*}$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_exclude_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_exclude_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_exclude_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 - } - } - - if {$opt_exclude_punctlines} { - set result [dict create \ - loc $loc \ - filecount [llength $filepaths] \ - dupfiles $dupfilecount \ - dupfilemech $dupfilemech \ - dupfileloc $dupfileloc \ - dupinfo $dupinfo \ - extensions $extensions \ - purepunctuationlines $purepunctlines \ - notes $notes] - } else { - set result [dict create \ - loc $loc \ - filecount [llength $filepaths] \ - dupfiles $dupfilecount \ - dupfilemech $dupfilemech \ - dupfileloc $dupfileloc \ - dupinfo $dupinfo \ - extensions $extensions \ - notes $notes] - } - 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 - } - return $result - } - - - #!!!todo fix - linedict is unfinished and non-functioning - #linedict based on indents - proc linedict {args} { - set data [lindex $args 0] - set opts [lrange $args 1 end] ;#todo - set nlsplit [split $data \n] - set rootindent -1 - set stepindent -1 - - #set wordlike_parts [regexp -inline -all {\S+} $lastitem] - set d [dict create] - set keys [list] - set i 1 - set firstkeyline "N/A" - set firststepline "N/A" - foreach ln $nlsplit { - if {![string length [string trim $ln]]} { - incr i - continue - } - set is_rootkey 0 - regexp {(\s*)(.*)} $ln _ space linedata - puts stderr ">>line:'$ln' [string length $space] $linedata" - set this_indent [string length $space] - if {$rootindent < 0} { - set firstkeyline $ln - set rootindent $this_indent - } - if {$this_indent == $rootindent} { - set is_rootkey 1 - } - if {$this_indent < $rootindent} { - error "bad root indentation ($this_indent) at line: $i smallest indent was set by first key line: $firstkeyline" - } - if {$is_rootkey} { - dict set d $linedata {} - lappend keys $linedata - } else { - if {$stepindent < 0} { - set stepindent $this_indent - set firststepline $ln - } - if {$this_indent == $stepindent} { - dict set d [lindex $keys end] $ln - } else { - if {($this_indent % $stepindent) != 0} { - error "bad indentation ($this_indent) at line: $i not a multiple of the first key indent $step_indent seen on $firststepline" - } - - #todo fix! - set parentkey [lindex $keys end] - lappend keys [list $parentkey $ln] - set oldval [dict get $d $parentkey] - if {[string length $oldval]} { - set new [dict create $oldval $ln] - } else { - dict set d $parentkey $ln - } - } - } - incr i - } - return $d - } - proc dictline {d} { - puts stderr "unimplemented" - set lines [list] - - return $lines - } - - - proc ooinspect {obj} { - set obj [uplevel 1 [list 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 - .= lseq 20 to 50 by 3 |> .=>* inspect -limit 4 -- |> .=>* tcl::mathop::+ - (11) 20 23 26 29... - - - 385 - - 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::get_by_id ::punk::inspect $args - } - } - 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] - } - } - 2 { - set displayval $ansibase[ansistring VIEW $displayval] - if {$ansibase ne ""} { - set displayval [::textblock::ansibase_lines $displayval $ansibase] - } - } - 3 { - set displayval $ansibase[ansistring VIEWCODE $displayval] - if {$ansibase ne ""} { - set displayval [::textblock::ansibase_lines $displayval $ansibase] - } - } - 4 { - set displayval $ansibase[ansistring VIEWSTYLE $displayval] - if {$ansibase ne ""} { - set displayval [::textblock::ansibase_lines $displayval $ansibase] - } - } - } - - if {![string length $more]} { - puts $channel "$displaycount$label$displayval[a]" - } else { - puts $channel "$displaycount$label$displayval[a yellow bold]$more[a]" - } - return $val - } - - - #return list of {chan chunk} elements - proc help_chunks {args} { - set chunks [list] - set linesep [string repeat - 76] - set mascotblock "" - catch { - package require patternpunk - #lappend chunks [list stderr [>punk . rhs]] - append mascotblock [textblock::frame -checkargs 0 [>punk . banner -title "Punk Shell" -left Tcl -right [package provide Tcl]]] - } - - set topic [lindex $args end] - set argopts [lrange $args 0 end-1] - - - set title "[a+ brightgreen] Punk core navigation commands: " - - #todo - load from source code annotation? - set cmdinfo [list] - lappend cmdinfo [list help "?topics?" "This help. To see available subitems type: help topics"] - lappend cmdinfo [list i "cmd ?subcommand...?" "Show usage for a command or ensemble subcommand"] - lappend cmdinfo [list ./ "?subdir?" "view/change directory"] - lappend cmdinfo [list ../ "" "go up one directory"] - lappend cmdinfo [list ./new "subdir" "make new directory and switch to it"] - lappend cmdinfo [list n/ "?glob...?" "view/change namespace\n (accepts ns path globs e.g **::*get* to match comands at any level )"] - lappend cmdinfo [list n// "" "view/change namespace (with command listing)"] - lappend cmdinfo [list "nn/" "" "go up one namespace"] - lappend cmdinfo [list "n/new" "" "make child namespace and switch to it"] - lappend cmdinfo [list dev "?subcommand?" "(ensemble command to make new projects/modules and to generate docs)"] - lappend cmdinfo [list a? "?subcommand...?" "view ANSI colours\n e.g a? web"] - - #set cmds [lsearch -all -inline -index 0 -subindices $cmdinfo *] - #set descr [lsearch -all -inline -index 1 -subindices $cmdinfo *] - #set widest1 [tcl::mathfunc::max {*}[lmap v $cmds {string length $v}]] - #set widest2 [tcl::mathfunc::max {*}[lmap v $descr {string length $v}]] - set t [textblock::class::table new -show_seps 0] - #foreach c $cmds d $descr { - # $t add_row [list $c $d] - #} - 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] - - - set warningblock "" - set introblock $mascotblock - append introblock \n $text - - #if {[catch {package require textblock} errM]} { - # append warningblock \n "WARNING: textblock package couldn't be loaded. Side-by-side display not available" - #} else { - # set introblock [textblock::join -- " " \n$mascotblock " " $text] - #} - - - lappend chunks [list stdout $introblock] - - - if {$topic in [list tcl]} { - if {[punk::lib::check::has_tclbug_script_var]} { - append warningblock \n "minor warning: punk::lib::check::has_tclbug_script_var returned true! (string rep for list variable in script generated when script changed)" - } - if {[punk::lib::check::has_tclbug_safeinterp_compile]} { - set indent " " - append warningblock \n "[a+ web-red]warning: punk::lib::check::has_tclbug_safeinterp returned true!" \n - append warningblock "${indent}(ensemble commands not compiled in safe interps - heavy performance impact in safe interps)" \n - append warningblock "${indent}see [punk::ansi::hyperlink https://core.tcl-lang.org/tcl/tktview/1095bf7f75]" - append warningblock [a] - } - if {[punk::lib::check::has_tclbug_lsearch_strideallinline]} { - set indent " " - append warningblock \n "[a+ web-red]warning: punk::lib::check::has_tclbug_lsearch_strideallinline returned true!" \n - append warningblock "${indent}(lsearch using -stride -all -inline -subindices does not return values corresponding to subindex when a single -index value is used)" \n - append warningblock "${indent}see [punk::ansi::hyperlink https://core.tcl-lang.org/tcl/tktview/5a1aaa201d]" - append warningblock [a] - } - if {[punk::lib::check::has_tclbug_list_quoting_emptyjoin]} { - set indent " " - append warningblock \n "[a+ web-red]warning: punk::lib::check::has_tclbug_list_quoting returned true!" \n - append warningblock "${indent}lists elements not properly quoted in some cases. e.g 'list {*}[lindex {etc #foo} 1] {*}[list]' (#foo not braced)" \n - append warningblock "${indent}see [punk::ansi::hyperlink https://core.tcl-lang.org/tcl/tktview/e38dce74e2]" - } - } - - set text "" - if {$topic in [list env environment]} { - #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]] - 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]] - foreach {v vinfo} $otherenv_config { - if {[info exists ::env($v)]} { - set c2 [set ::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 - } 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] - } - - if {$topic in [list console terminal]} { - set indent [string repeat " " [string length "WARNING: "]] - lappend cstring_tests [dict create \ - type "PM " \ - msg "PRIVACY MESSAGE" \ - f7 punk::ansi::controlstring_PM \ - f7desc "7bit ESC ^" \ - f8 punk::ansi::controlstring_PM8 \ - f8desc "8bit \\x9e"] - lappend cstring_tests [dict create \ - type SOS \ - msg "STRING" \ - f7 punk::ansi::controlstring_SOS \ - f7desc "7bit ESC X" \ - f8 punk::ansi::controlstring_SOS8 \ - f8desc "8bit \\x98"] - lappend cstring_tests [dict create \ - type APC \ - msg "APPLICATION PROGRAM COMMAND" \ - f7 punk::ansi::controlstring_APC \ - f7desc "7bit ESC _" \ - f8 punk::ansi::controlstring_APC8 \ - f8desc "8bit \\x9f"] - - 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 f7desc] [a red]${m}[a]" - } else { - set d "[a+ yellow bold][dict get $test f7desc] [a red]$m[a]" - } - if {$hidden_width_m8 == 0} { - set d8 "[a+ green][dict get $test f8desc] [a red]$m8[a]" - } else { - set d8 "[a+ yellow bold][dict get $test f8desc] [a red]$m8[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." - } - } - } - } - } - - lappend chunks [list stderr $warningblock] - if {$topic in [list 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"] - - set t [textblock::class::table new -show_seps 0] - $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] - } - - return $chunks - } - proc help {args} { - set chunks [help_chunks {*}$args] - foreach chunk $chunks { - lassign $chunk chan text - puts -nonewline $chan $text - } - } - 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::lib::aliases $glob - } - proc alias {{aliasorglob ""} args} { - tailcall punk::lib::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/#| - - - #interp alias {} c {} clear ;#external executable 'clear' may not always be available - #todo - review - interp alias {} clear {} ::punk::reset - interp alias {} c {} ::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] - } - } - - - #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 - interp alias {} ./ {} punk::nav::fs::d/ - interp alias {} ../ {} punk::nav::fs::dd/ - interp alias {} d/ {} punk::nav::fs::d/ - interp alias {} dd/ {} punk::nav::fs::dd/ - - interp alias {} vwd {} punk::nav::fs::vwd ;#return punk::nav::fs::VIRTUAL_CWD - and report to stderr pwd if different - interp alias {} dirlist {} punk::nav::fs::dirlist - interp alias {} dirfiles {} punk::nav::fs::dirfiles - interp alias {} dirfiles_dict {} punk::nav::fs::dirfiles_dict - - interp alias {} ./new {} punk::nav::fs::d/new - interp alias {} d/new {} punk::nav::fs::d/new - interp alias {} ./~ {} punk::nav::fs::d/~ - interp alias {} d/~ {} punk::nav::fs::d/~ - interp alias "" x/ "" punk::nav::fs::x/ - - - if {$::tcl_platform(platform) eq "windows"} { - set has_powershell 1 - 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 - powershell detection on other platforms - set has_powershell 0 - } - if {$has_powershell} { - #see also powershell runspaces etc: - # powershell runspaces e.g $rs=[RunspaceFactory]::CreateRunspace() - # $ps = [Powershell]::Create() - - interp alias {} ps {} exec >@stdout pwsh -nolo -nop -c - interp alias {} psx {} runx -n pwsh -nop -nolo -c - interp alias {} psr {} run -n pwsh -nop -nolo -c - interp alias {} psout {} runout -n pwsh -nop -nolo -c - interp alias {} pserr {} runerr -n pwsh -nop -nolo -c - interp alias {} psls {} shellrun::runconsole pwsh -nop -nolo -c ls - interp alias {} psps {} shellrun::runconsole pwsh -nop -nolo -c ps - } else { - set ps_missing "powershell missing (powershell is open source and can be installed on windows and most unix-like platforms)" - interp alias {} ps {} 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 -}] 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 6a2a3376..c20e3b51 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 @@ -4950,7 +4950,7 @@ tcl::namespace::eval punk::args { set argd [punk::args::parse $args withid ::myns::myfunc] lassign [dict values $argd] leaders opts values received solos if {[dict exists $received] -configfile} { - puts "have option for existing file [dict get $opts -configfile]" + puts "have option for existing file [dict get $opts -configfile]" } } }]} @@ -6515,7 +6515,7 @@ tcl::namespace::eval punk::args { set range [lindex $ranges $clausecolumn] #todo - small-value double comparisons with error-margin? review lassign $range low high - if {$low$high ne ""} { + if {"$low$high" ne ""} { if {$low eq ""} { #lowside unspecified - check only high if {$e_check > $high} { diff --git a/src/vfs/_vfscommon.vfs/modules/punk/mix/templates-0.1.3.tm b/src/vfs/_vfscommon.vfs/modules/punk/mix/templates-0.1.3.tm new file mode 100644 index 0000000000000000000000000000000000000000..e679d01307bca6d437e4c564d9e02e4bee17a1a0 GIT binary patch literal 70519 zcmce;1z1#F*Eddzl1eut-Ju}e(%sz*-7|Dbhk&9;BMkx)0@5G?5&{y^(%oH3d}mPa zc=W#C=X<~Z^`Gk+2F}@g?bYkI7iSMD=r1oSFKZ`|g|!_RS}EVwRQjjb1fjuAV(LFn+1fA4@L^=2(ou{ zb%280tzblfOHKd<)W56;~WMXD(VhLt(1G_-19UVXxj&?BitRWzP1Bi(|_~#W92#6JGe=W>^ENBUK z0K1sLh`K_o9W40(7Gb3M`0T7r`S|QjY{5nV4@Tdwf><0aEFfSg)YAzJGI24p0@wrz z0QX^95&{W8?XQ3Nn@H9cAa6Z06R4RL$opEE4vsGNCU(|dV33}*gM}jqV&-D)1U2wA z@CAAQZ6-`HU>6rag_J**zt#rS)%5#iR*;5+i7B8-K(XdvKyUWe4qzDnuD~@X6Q~s{ zh~CK&0-E$aKXzf7E*05f=d14LoG|BgeL zeAGYggTT%pN=lHA59qGmwX9$dYX}qq`g#AiBK|*%NeTKJ&oFv_mjZSLuo_G?=GHEt z@2mm8Ilw&R58i$u0-FN%0RKAWJAwbSBaE7(1u((P6$&$pfq}tqNdjCLnK+mm0Z#ja z6&FWG=ru3j2}4b+?fzuzS0Z*MfK4qOKza}-J8S6m$Ug|O82oU6Ya&15;gwVE^7j2z+rLf|`(IBJ z0_pu_@qc0xwj#`6uvA1X`isP{+prgGh$x6!>|Y0nfv5p8za8>>QGYJ%{rlS%jxJym zApSi7&OqLi(`LkKf7& z8~S@eet-3cAN*Elzwr&KUvd@9_aQ(o2eOnS$Q=waGjRaC7*;6&W?dYeT&#fvZRhz5 zvoKBCnVCSqM&A>!5d>^$4|V_&jvg$*IamUj(azERk2w1?UVxbXhv@uH4~S79iNbOy zG3_kW5)SoZk~|8_1W4wgW@`>Pz^ zld-{Hg8M(#00C}l0OF@|g#gtI@B*+4P>NvIHV47T|5kjM3QU1uv;FPeU)}fDD}PfU z_21<9$Jm0I%)-^q?gtzJ>Df2}_(RXk(E+IYpuZEjPS=2M!6+Mm`1oKF!sddm3xJ~q zP`Ix#4G4fNfaK;dB=hr<%Xh5xTiLGN1{O0$z>+`k5!-i#UvuNl==*m@4A_8Cz<97Z z3t$Qunu1lrpM~U?HGDx}JHQbC?6ZGW0F2TP8Gj)JGtqCE{l8-e^%ug|mb=b}W{&pu zK!t^XuA>wN&j18^Evx|uKuDC7|Kz?@CN7q)unYp=Rv3^pvx508;BSr~Qy?t?a0!TZ z*zIdT{1e#n@hMy9ksmX^XU%J3zb9hu=s*XB`4x!nFZhfOK;&Qt5EOugu%!7XM-Tu( zLL32*^pkfG;9PcK69^P!34^}&FeCzenuG03JRu+efxBBfm^->dKu&fhP#^~akQ;!n z4vr2i*EPxn5P{+MoT*#EP&+UYsJyQB0DkfWN)$lkyY|`G00Y2y`;K6NiUV8+BE$r+ zC)C~1#r7KS{)z+t=4{t`0cwLe0DVEWV1Qx0UmfJ1(<&t!+jm!D1Kj(2pizPxtYHBS z{PmsqKRMR58<+z{&Ke2^i7Lzd@T|W$=pRA;L)9R6SONg{2QE-oU_S)g4LLXhrgJjC z)(OjxQu*DWwhoT&z<%U!z6*0vM^`8a>f(8=IOy-S1LN#Ea(--4erp}rAlQrQ7k&MK zQ$c@d=ilNONOrJY9M~Qv4+N;qu(hE-Om6~mcX0%4Z0QPyKtS{+E>LR=V7~_flA;N$ zp27kX*s=hY|BLSeJ_B(DgM@$YR^QnM7Yq`|5XG34TXPJG>}AHTonGX zj{LzbU^5V~l?C9B^}lihGu+*uo6BEW`@;RyOeyua^he~R0)AjjU0h)hYJwb)3NL=L@XvR?+w`v<{;L^brTdqX4b#IP^&9AR{Eu$- zHx+y*2>NN=YjeP|{r__DABG1kcWt!qH3cYrdVl%T;NO+^w`Ak$@SUUI@bj+`@}qz9 zXQRXdC{WjK@)PO6`a%H4f+_D>>9B$Y{0{4(Q2zzf{4=k=H>L0Ivj7#4i@vM+Z*U6) zaWw_@B*0eO5eR(~J9k()g_S}W*Z{Z#T5Eswn}9tMuFbqhje>TVf z^aJzW?^6LQ0z%pUR!^=@c3_~@2I2s4IDl<{s^aPbz>NQ;)qgFX{|XzaEKKa|OaZ(L zi!fL<03z@wsQN9pRElD(AT0oIT*DYM0O$kd6sDVNSYQvdYG4-tMM6Lyf$K>;uL9&a${VB!Yk;_H6l_g3wHH2!{Ork|fb`ULg> z8$c9O%2)tU>wAm$JITLxc1>IW_xyuA%MZ0*#}Ldc@yVOt+Npe?}q&%p=d_CGjP2k2Zkj)Cqn2tZ2!tbmywSnWr^09!8@ zhybXY{Ok|IVE3PG<-aDSO?CnV1p@L%n;8ITKUw{E2EQjEYCx60^=g<5{~9N- z0kGHgKGPhe_cKO*ZXteh0s7Tp|8YSWz5l}F|G%j;u*LplTH{A9r?vnx@qdQczcLJ? z^Z!Fehb{B_tp3k;en0*n((5l$|95KsMK^z6)Ytb%hvh#z(?9;hVDKM_5BC3^KVk&% zX&?dr+4LkpXXRkM z&-NdG1I0C0Ytm)%!EN7BExXq}JOokQORsG56;qDyVkNCr`hD~exLq4(90VsGkf#xQ z)o2MH7e~rhr53|ReRFeZa~v(7)0;Q@3CWpo(jZ-~y>XFU-{HVlWp2;@KGx2%Itx^i zJc@<*sV`s5xpM@pmAdgid*m$?e&$v$WD=s)dRBT+D_~A3%wtn1hMcFdCHu9uPWS4b z-h&C;QGM^#&i4w5@+Pe>`;kp*D+~$r#oxTORXv=XX^#4=MDeLJ?6t`~KFg>yrs5LY zP&*2z;$roFIeX}sYEdh#uI~*T9(TVD!~~*BA17q@tfFKs{ZaikgEV!e+BcQvrrD!j z)^Wu4kfHFZnrBmzY)Y$}s8^IXvtHS3;%P88tJ>xzGp)Ef9cevmV6m-k zZB*}2((cR*(P6#|7@e3u8!Ze>lQqS`W5pNoD-UptzeBp}dQ9t02OqEY=EjCx99qlj zs5jgKvd0PTg-O&c@=vqMElk6SaEV`B(Zk{Hrjti4+x2^*w=u>Cyc8IiWEe0y&mG`O zunX!yu-p*DU0^cl+ke@0F}x@YRif35-`pctsn@h1P5LAmL_1nIBAcaKm&MUASaVUl z)&2C7twG4a0bSiL;czt$yq9t`F5#4W4O)!BVLwF^0}pqaaG9ndk%k63`F3MwE9fXn zcHdO{c}Ll6FHS3lTc^B%s;j#C*_QkneQU(BA_#YUFFl5Ypz=46`CEAKT&lO)GeR4p zu+K*t)l3)BOG~+`(>Ti-g$^zHH@h75%~av#3DchFdRZn1)Hl3p@9)dkraljiUL){A z7l`Om5?5VkdSDO@@+vrf*W5TZl_sn(huD2g_BFJSm6PQeI9Nob=q>im=NUJwA0NFR zH&d~fA7%2f!ABjSH;`V!jpvSgSEIjQ+{$669uD6p9t3hUd$ce1#jnGfV2~n?XdpCR z#g`;nxEvP?RY zMwIlLH?G=N?Y+K|+_eEev&T6MJi|1e+gPUrT`?G>yNddaT1379f!fMzo=ox7ElgI< z3}o_;$$W-dDs&_`%g~V}v2*?PD78tF;F;fu*3p8*9kzXhsO7O*q88l)$*pPh*rrt3 zg9!bVG2-^L8|-{~4!iG;7}(hem5oRph9EwQ!r_oTK8u7j24;reb#si}5HfFHyXtxE zNqNvr?KlBBG>Ry`7<^5#XK%c$?T?L}JIfk9(S|_kSv5LlcHqd(7pqcgR#S|4-_8Vt z&mnR$-`Gr8uxe@d87tU4{< zeumj#!c*HgwUoZQZfdVAXfz#d!Yg5Y!kHTV@`0K4<)-qYmJ4%sivY<0zbD~U-}c;- zWfTO~_Y^p_480boNv^&StIl|GPy4iZFNjFBN&0$NXJ-8C)CifF9X;GN&%yzS^$Yr^ zU3dKX9+7#Ey8HAMnDYA+9ah<#M=kO z*bm^P0=)mnV!#Hp2Z3Ickqg)Y!Upv6ZGerA2(WK4cXVNLa&@p}`f=^Lhya5S;r?9E zJBm}gh$KGnIj~S0@D_$c`L7rJV=*>}iy0g2(FAi=pp$TQg$M@+kDw9#5%oR$ZHbe! zNLxL6dYL0Eqy*L}w*di35@NL;MCSQsl0p)0ND{=N<|t2X#NFAP>+}Vcb+v`ju_k!q zF?~Tuf_vcOn}?kbo;=cJSCNhBo|EyS7waU?lTQ1BfEkaI6LsIE@-npLNxGAvKPZ?m zfcJdhqjaB%t6(;rb@=uqyr0DIX3;&vFawB>)+Sv~@i@w#a*L+==_+{+&hr7~Hm4pA zP6+PC|59$)Lk!==28;&386;EGG`uNOkvOq5*gQNuaD5~w;wr4qj0w?4=c;f` z>e^>Y7v2QCq$=;rVtg7BuBNgm_tolIupC1-Q*EA6YgXqAXYFq3hbBak8t7Y}BEjU2 zvg;@;?X*2$-AIiW5AP9-qdrmy%1kvhjoOn)jkz_Z9nGz&03V@>JEt4@aJm!e29DWk zVRQNo(Ytcac=%c}sj?h|k#{ez1}-rJ6_6_k*Y2E-J_-;{VQgeAF^{`RNvcHHWOI1R zg`xVcc?>kLsE`;wj$W^tUk`V8D%g|MkeWD@a*&QXN4mm?jCOA(=c`~O1c^?leT`9# zZ26!TE$prn|GGw~Go|E%Q_0xgqb14&|JU>SB_^4udkhg#E|<}hrep*XsfO!pX*+Su zkB!lGwODsKN=jtLOv;FrE&q9aY1Y@|<-q2-QC6bUWUsIw4=J83^6*49 zS28)s4@rDsYoS0%h_D8)%@{CU&9NC##=JzFr)yE>y@>ijDXA4t^}fjJ;T-By*|<%7 zXQnrdVUoi)64P3@6Z%Za}r7ts7F&Yao2mU?zK3M5vtz!?f*dE$MSTU{>0 z*$6CP5LE$(P~+=#3(o?s^8@}{Jye5_OtXm_PH6Ibl96Z;L+0c?lTdw-e;8R~dhcq( zJ7p6Mizo$c!-xV(>3fY42h0+h#)^8P#c%0b8<5tclu{RS}(0R$w z^yPh}@qNcX%jj5R?-F1P5J zOIzh$wIlW(JJv8BQhdeJ=GxsmfJmS&ehzq0{h0gR{*#aXHR(}~p*JR2I_H_m5K(Ta z&67G=h%WY@R>sIs4#`m~nYlHDew`H0i}YCM9kE2YLa)Gmh!Oj^SSD4I0c~C_lN~R| zH<7$wGxQySsCnz1w<$d=HD1_McA@oeC3+3Axh_QwN%G^NO=DF7ei}-KR8EM=hNWQHTCOyw{yeQbi#8GxX?#IP!Y$^_EK zWfR54rM7yH;2x#=j20y9gvQdU&SoS(;X*B39bn6;F5Z@9Mth{RtQ@BDnU4p)8e_e8 zz07HGQ};1ng=+v`FXux;hLBQKdQqqM=?kLqt9VS$gKNJ~*QsRc-aYH;gu^?t9UOz> zdZKp@G0gS&{Gw*KTmzTD$?9#52uTv%Bm;)(l_kB%`cOF*PH+<#bqFB``;w@>l59vc zhNXUmk~xEjId4RO^hS4(56BrEAJb0hNpb>Z97+E@QRa>U2agv|^0-r8FMR5&PBy-D zoN5wjkUu>9u)|-^R=T)fSI_NBR&c=)+zziGXDf!F!#5eq6(*HN8##~dE~tE4Yixj7 ztx7zcqvD}X!1gwtRH!)ovmTms8XgY?PxJds7U~6WW0}W#)z-*AH=PR75YU(qPlb`NAJVq;rDQUwtxtR}E*;pcgB^UNoV8d0Aux@vCb3 z)#5I47+0x?;@s1&kOu^rL&Ysg&zyp!9&+vt7)bB#c8{&=7-_ZZV7Py|vo(vw9+um0 zPvCT;GqC~f;N$xdah+ZV;@*-ph3Mf^Ez{j{xcQzN^P}pVO)Z~@DQ?*Z4BfUHpo~vd zI$QXVZ~1BOS+jZ#!A5MOxcr!`D81TyTP)%UZ9kz}ziIfghXKx_VSEvf@Pfu&QkI^s z@!z$8yXS_tvLR+y(Y^Yxt+aIAgtd?-g0JH#Y z+NcLsTgD%v-4_MVq9bYEKv~{wK1Crts;^)b;UH=6#pY8I<1DvW)x;My z1Xh($EqbG-d-zd&*V@aB?}4Z@vMT&QmSRomZIX|URy(v~#sqO%6Nr62i#7{nq#bjX zTu;=Ty%?v{{XIgi($mw4GZa3D%(1UVBVlA9p@Z9&Yjj(v>uKBy6vDxpG@G~Up2%{f z9-*_}emNGrX_}0veZ!9Xq?Jbl((msbY8w3k6j>OJ4S%O-f?bH8PT8n%kcM2(n`Dz> zd~(;fs_h_pVotNcB($WwhQRu{vXx5clA!ITDHJ&?3m=}Iu(P0-&2e>sp6VpmgSck- zV}Zkt2PgEKWr?FG+WZIF%JcLR#e-XQp=X0cC{AfnJ56{>DeKYvB^SNOkG-Z;-96q< zwALEO=D1ATJQTNF)a7S)8%(YY?s`QS(swpMSqJZj`;~@|!Rao8(*qOz>OB*jlKho) zFM?;ar|Wuq@`ta9-05sH$Mpo#s-0W~2Mm?=I-V0-XZ1Yf_7EULq_E*EdiwPpcXxhX z`h9{b$1?_-hs6sciMGv9?gtrSwUbX{Z+Pvdy$*k3vcbH>g}P;F-=TX!V`_@-_2iLh zhOx~oB6N_vkV?-|>lUh|{idTb1!-WqY6eZZ0nUB2Xpt^axF|Y_w=Y(An$-O)mqtQf zto9>6qo&;;Peb*55l-M}v@Z%LDdVFeu2%C-=hcgMmWvTC&Oss~WVLY4QhaG4o!TcX zCGRozbdfmlISOv8BGh&|>c0-jt`5?Ec=5j^ZbI?oD{tq!*{2amFKuv4 zABaOdGWT4}q^sB#(~T3#2252Y>fowlp5Cco6i~^{IeJ7YmJ}69xsE|kv2XXRBNwX0 zZ60=l%*V&eek(C1ZJRd>>3WFh3hS@sT8kAnc*2y8EfVHFpx9G-7Yv)>E#Id8;U)sgb<* zulvre7Z+^yOHKP#1ydeBBkV^y#dwqI>yJWapf@LJC*-l{yg3x?Z-L2jqpEI_&pI-q zwgbJ(46zK0O!dOz*0O*rDbGtpEIU#Qn@aYE0UVo>ZzcR+ODgaw%HC%A>vlekeTj28 zasRHBbMv^9RI==ez5sou_&vE?OpNLQk{nBu12xjTvZnE~WBG-|x%65cFZYC`vag6N zbJ;O@0uuRaUqvSyGxHD0tzB-6u8b|b-#mFtYk%~3oG|yMa(KG@6GA&T>^F-XF(O%Z ziM1w`T(R?xdlqzf3yxo(E7N8wXGGo?z{LxrN?bnQy5eSvS7V_Tta?Dc3QsSgtjPKZCg ztM2toPz56PrjHm$&^gGH<#??)%0;)j$?kNiaYm1XMsaTQ{bD?qM9Y(Ld0*Y-cWOwC zDjv{$r{rUn_0Mog-csaMp~(994V!4w{C&5*KWwC?1yW=cS=@D0p8K{)L^A&3>sJS{ z7v?J6(OJC?ew@yNbAf$n2Lr478YU81R`mtFZ9Nu@ZAAi~T*g>$`a1RGplprQkI+pZ zyCei*MAIUuxsM9iyQfhVStY%Vm~FP@P^IWw_O4@zTo0sD{xJ0Bj(bHC&t!y>E8m<^ z5&I*Y$JTMEhYck6HgVh1OrdUKkrh>kP$^b&vX9$0F@{FvE8vk1Gl@gCX(siJY#?<^ zyzkRdS0uC_&gn}@#B^DstjjzyJl5-;&7i1Cey+KJMqPl(fYzfz({#)1*-ISo<B1rCBfTe@yNo>7>fMzS%? zGYBfNE=Ilqf^S!(m(6{jMl^VbY%bUVHJa;uM8V~O1#};+^$B|Bwh+OLA5;2~ecS_4 zDPMYTO^3>DyG9%-hnr(|4J4a(+#5L)AIERyG%)Ll*dZ5osUEjb8%$Cmv+MZuOHKNs zB1Sl18B5|zc%;7H_PRK}2qSQuHa6p`@)kqOmL~IeC@#1Foj>JiK6W7JYa787G!Ix^ zg=^0w(8_IKE`5K9jq~v|%t~m7qNgkBAR2BqUQ(S|`YQcXyFb~q<;>}~7-IXbBQ9_= zU)QOZHHWD38K%ZG2UxFSG}6UOC(Ud!)4f;_Ns>iDvhj8(*$a0^Itv?rzoX-&GyYuL z-X24oXFEOWD2>L)g$pciSSxxp<>|$gW2>)vNHa{x6*bUxe6Qw@Qnc7kqF1=ZVkoxG zJ1(D+yFbDbOLcpPFOO zxABfM&U@akM7|#K6ix(@ZoS^uuh{!qC~#0trYS@`{ptSFBWSRHcY@>aT+X_axG#|~ z?);Gx+w(?kZ(rr;yRk-ZZec*Wz>zoS%H_ZqR z{L`sp2B<}~V%xWk#QRNN=e#&g#`^jL_T(Zwi&${Hb@e$%$Ze%O>}l=VLBt4HZ#SsC z6IvgshTCqw$k=+#sOW--P$Y4?R$tRN;!9`6l3UW)t#;%jO4+V_X2XVA^T-O$?qYN8 zrrZ*?itodZx=Q$no!3JD-#Pt1e zNR)>R{it(o{8mIm3U;@aacA&WDCVR)1amSrWPAx$a~`|584J{qn@i@P_9vr36Cd26$A zw2Sa@ZYi>OW4W@l-x_!7-x$A(^5}KMYSh*MN97TVwp zpwt5|dGX4RRfZ+s6pYxii(k=J1?Xs35Dg1|!Xn`2uTOuNkTRYAh*2Y>anLe+dYtdl zXQa-JslXi70JWrabiD|*b9~+fJ$f~3#KN{DmC+-)LZKb&UVBl$_8Qt*ifP%6Q_WG) zf{$%$qNd8ual@Pi3Z@V39))$*j(mEM=(;y2FRHyt()O{CzTzmUDXn#iSOYhe6>ZtL zFWg;_15wG*u|MOHc0NjP7zV*!g#4qFcXT&5iUt)xLbcrH_#wGOwCgYA5B#d?ymQ}T zYky)ts~JkQQTaee<-;lYSTDaw4IRWFZal4Tnq7{U>_6S;wYQ(IHRQVJIJodMmj$dE z9E-6JMT#O9d2&BLK$ES5dx5O$^eCddERm>BNw>R`22Cc&%dG<~#4l!=w2%Db{Ora2 zLwTo)SrxtA7^0-!gV_1m>3(O5C}Bp)zNq$f32m>F;dgqS?a`r=E0+a?r?;&S!~F9Z z6{Niu5j|eTh*QbVs;)IR$aXB2bli~vJ#N*AaKA;Robgr-8`1w1tKoHxt_nEdmGQTn zdD|9d%+Sv==a*|kn&?e*sIm7|bBH`j$**L%4o^Z^R;D2XV1|4$s44YJ2I>uOmSdT! zTGU~-Zx-Rm39H6;urLr<4e?Rc=ekA|qnI-%GoIF#7RJvMD#Pnce--WZsXQyFc`R76 zY-o=;4}H(nvJZ(sR>LW7TfuKy`uJXd0V!&sF#4fS&}WXv-r*b?4<2E4fX z;gu3k*vuYIc&U^Bpg2wESw!<~23m8BJ6p=lpcn8dx*8NVPQlnO>YSc?q|zlp3q?lO zh`h@4msV8E?npj4vuHk(^utV`@p&8;hPIc*#l;1h^&irB!2!1&RY{owpZAJ2SQW0D%rfu)x1l@W$LzlKGNlaX+J} z?eYiRO}?i1?c+=sL?&AabAne$;%00v&ih#JWGHJ<;nmEV8D1lKj1e=F6gIDoz=3og zE!`L$?7X?CXl0P4Cbv4jdgtC7bTq-wcrkZqJu|~qre)RSipKIj8cWZZi)rJLdp$O= z=h$cQ+}EIfs`+y4c&@HYZ0zv>OU{-<>$d2Mn`Mb?|Ei5fi)!?W7!nJ~n8dOWExQPY z{!sbQZq*mpbCQ*5@wUk^ z@*K>kGLPC^WV$A(JMy!J)s8IEqxCb=&F@!#5yvPAN$#Vw6{#HTl4Klp-jVMT-uc*9 z+2qt!)Gf~U?b)G7R-kz3i=(2H-jg6s=vGL9Uhmehef&kcZ_L4?*Af*jTWo1*_wMyV zd*q}V0v7_uTJEkPWP9C>{b;r8CO{pLiH76*4ea>AGvn00&4K9*C>`dCuv@Hur@=}PejN^% zlpYhbp;C5ud2~XRO)*XFUv~mw9%m}^ExseE~2#%->L|~C>2sydXX42q>1PM zV9998{pr|EkuV9bS7OnmxGT&(6;2hmY;qlN7WnxLRi926%L^?gNkY1xBNoe$mnKOw zGBzfFnutaWDW1`b&gjLY#Hn$GJqWDITEstJJHNlnON&=rr%2_;-tlHj5feWB=~Kf{ z)*x>u(g!Vq3)QWX6#dGy6ow7o=7z&g$kE537nkR~AGLNS_AI?$5ofNl&8lc0#`sgj z29lX>ACe2Crv%t*2Vw6OKKg*Bc^IDc^tG3%b9sMmXR^C~>Uv3|W&+qbDdiz*Fgrfz-iNtYN#&T z%6y}^XBkBg`-0Rn5#PsOOJ8}o(v8K)hkqBxtG6r)%^@k{0|EvAOVi$y51%8wY^ab3 zHwSj4zPWm>sIcXBRpWY;x(Q4?tF7m^1Ak+3_Tt=*5of>Yb*DmOE6vxqQb^EdV<7wO zWwACV1LN1b;-!p1aiPOR^2ZgNylEHhGH>un(IIu|cW%tadVbZ7qZuTcH`alF>cY7E`)J=#T! zVs>uPfP7^76r6mc>8N<&Q5Ad8-NyZDOm2~$R~lroGZoU+bT!z?oHo41j2?PJw7FHd zL&gOo(ofpzUg-HPh>Dk6gn6~AE0?c757_V5akz@K9??5eG_g8fjqvIa7pEDT7hC^g z=MoTH_1fAV|KeS-*Qkc_AjiEJ24l%NtTMP&_f_$laT1JvE2W3R@DZbvi`AnBQV(4*!BA2j;Bm3!h!IJbj?Dd2H6S(#M0M$KBdPmmA7%Q()E z6vtBP@folMTmkB5Pu|>v*DCB%8$CLnDJaad3&^Y$uYLPoA^T%P-x9pO; zeS>|u*DJ?*Aru z&dd8X5OnJ0=@sO9a@p7Ma3se*{tRfYYGB$!4SOnF{m}V$cuK3X80ee3M28>q(}N{1 z62m-`KT2uL-~@ktNSRHZbm31x>ZJ3&wqv6W0lx1M)cKZ~OtRms7#@Ymoq;DUFH#50 zc>;{-%e@#k?qrXoCENKt{A?TdMUbFpoy*KIGE#A5&TGDJ#_#GY%AR0>#Qbo*`^rw9 zS6;NpylP;=7nv%~G_ z2&t-1#EX=x)r^t6kG!|odiD{*;fz#A)AmU^P;aH35jkV-xId*Q|LC1KZhjJRG%K$H ziYs(pSz)l?M&4ItEqkI?%0!fVo3BzxD`J<5K)Sbbfc*KntEzc6WmA}?Iy$jNi&~g zRN8$h-$JJq*;*lXUuF?c1TL+*@XKZa;%!3JVTJRqY<&ucK7kK2##ZIGs<*?+J<>-w zDD%NnVoS&qM)T=NdstCNVgAkGGBlJ^p&B_~NzR`mTI&kae@>&S#84WYJARIy#+*lO zqaoE<9zyM(^BR1P8Q{twC^ z3#O1~hRnXN`aVOmkL?>nM$57ATgQi+Z0k5k>-$o@Pj|WXdVQOoTp7-J=Ik_$5c&>z zm(3W`O;^e^l_i*$8co$d@uTDKz#k8(El5jxz#_`uvwu@T2%VVDt>I>~70;Iq1mO=- zN}dXZRW+SiTcjA68V&0oJ^2rx0zP8*?VY?XtW-cIPy z5Du&rG=|V+xj864N2g&yUNR&jq}xKSdu7DZ+ddeP#bE6A(ebU;xn$L=Qz?l%Jn%2g zK1rHy2sp+Ct{XC}wrG}%e92pH)FP|ooYpxCuVWU6%HBnAm2w%$IByS4jCuAEi2^^% ze;0Ui#g(XpJH+F?qC)&#_1u2yypHG)I4`xY807x4-Cw>)9=zlIGE?L(KfXCif7YiPjw2a5($Zd2VU+kovy)?$xs|Wt}{R z@2AbZWL*?IHS||Z5DA%KA#>fZRdHmv zCuiEb(L4>z9Tf>{*bhjcgQXyGlzr4UpG4BIl8Kl`&QGf;m9UNEnjT_7Y9iT6XA@G` zV|g#*_RaI=G4it4I60H~N|1z$eI$-wB8ZkIsI|N;wSJMKH99GYa$|0k{%K^r@)?>z z#vP+`)eZ_GwEFEibLIl1#X!x{J--q+A1=m9q!&tKUJgwq2+|{NlZLpO$Hb4^D8XYN zEy3i^@2Jt;eoBgffj(ftD1h9Aw zbVOO2f#(*yrPF18ZPR`SXLs#sujB3vW^7XshK?W$cfD|~PQ70bu4MH4HU)oIIbM>9 zQRAmtvk{2o0d9_%AIrPw`LQQvlcI@fy;z4QlHQp~z56^a&Z#?Hh-zb*7Wa)r4$&0) z{64m{jZ%}XhPG+lNqy*WIE%rViD;Z#S-IxwaCppFv;R@C;WtKf=+Y~9ge_*}44xy! zsU9{|>m9cj{&j;|R6d3`A%!v$OQ5N4Hx`A*JFE-lTNC9Dt{kE^OytFzU=4W|kXtEO0bX&R9und^`$vNOp;nUUkxJmc=t!1 zpPId2bE*-QSr`oZ9Dg+4=o+8ta+8|Hu7WPlsp(!x0q4WMdasF_9s2=D{uM720YcZm8&s4R1Mu?9TG3sr@EbC8$DRu-ir&Oj8Ta8O}S6M==P(J0v ze|)B=w>LY^@>z8gqsxYNtY6ReP_G1iMnMLbB6f3&S}O$2eW$8FPt_{ha=IES`Zk@& zsvx}n#)B|^DM9K(v9i=`mZK@}y7S}#p)nz?q+;^@X!k6N$WPbd-+PV{BDwb=>3@=c)SZ}ba zJsA7krVhXOOQ$|`j*M9X(XlcKM`5#om|mR}Pn3ODyii-vxYwx<;v zit@WD%l7_@h?on3$v98lMy@ zPF9cu(s-%8x8xLrcr%3-LX=)KkxPubbb;>$W$_@ zz7n-ndbf)~NHXv#qs${j1X|oOBkyTEO1e`78QLngs-lVN_`1#632EbPi9|Qs!Gn3l z9XYa-8IRYmaiv@%G3ARFE=Vn%A}=X(F+Bs}QCi;CT{G2G7Cf&HD?I=&Z z`pvCdhgr`39s;U7F-pe`)zDQE+P2|sMR(%eY0T73W&Lg6w{4B2`PL~P-*l@*c&6Q? z|7aN$l=;|Wv2k*vXyG^^XcgyBF($2Aw0+U5*et}uKT1{d_G#Db-Po*PZXMF6voW>( zOe-rbUfD5P46#jq8i7>j?Oe?vPi9#XSX`%1vM^uDC~qhZ$wy&PX)3M_hR8N?@`fi5 z$hXbnZp>)tkB~_0ti9XL{B-yB@;Ci%;U@pCzIQyYg~WFxzs?_Apsh&S-!OcR;zgm% zoIji!y}SAj!}hRX##g3k!kPK~XOF@)?M=@-dV}Sd4FBh0z2RK^>#gqdYb|Wj=gF6y zY5KQq$jSmQ*i4F3+uHG7NYdKMH!`li5nRG4xLBQ9WUqSklKd-QU(1cjvm+>DF$>R# z&3H{Z-ikTa_FkDnwT!8NHe+r8u0fJiN#rtYvy7 zCAib3*g9{M-$IBX;5QR$|3 z=N&!x#5!MDL^xZ3-0k@7tL(1Igj6ayu~9)(vxnrC&#}j1%xnZF&l23k(4L81`U5u; z_h3>@XJXoS&wGpX`LQA|=E9DB>fb&=#WT|+!Lnm{AcauQY(*+_@#WU!_Uiik%AOSu ze3Hi9PU#D6H9Wg{WitMe#k&_!_buQRjOb z%=0`R9z-A3WLlk-+D*}Xv`7)3ofnrSXuC1-VjZhhQ~3;vsMcxWx7d8%c8Vok%M!q+Kw5}VoRvN!uu=fwNGfV@`xYmW2^{FaA61(s%h z-~?}go=EsGuKeX}2*qh*d-KjX_lR^;0tpGF6!+Svid{Nyp^c_;-R2N!7T2t!&M)}I zJ4^+u7>pZ=1P?8^2M4j1Z3QjkuP_$nRzeQ=`*Ju8V% z$~LVBE7wjh9QRc5Xw+%gkx!S=gX9UHXlEaqqaaz_#(cjd1|P&rO5`~|%Y9DEX*w@W?3Y?fT*)i&+xbEs<)|D7#$h8Eht(5k z1`JY@9ANuTTnB!h`Zq@-&(&}RRVWxqZ~8ZLu*@;qG}k{`;+?BOBZwvm@OpUPS>Lis ziwKV}@0f=)0ByOIKqNkQ*A_HMJ+?Z$rAZ~ zS^mz3Jvx&-*mzfBX!UFev3f&~*t(C=rE47_jlN&Z30vT~;n*D)O)A{^=*>$E3KPMk zvKMa@>K-4JsJ#`uXt42acdz@AD3eET2+&-dQ51{$u^L zGs`ULbU&|Pw}uZgZ_Q6P>=GBm@7cDeqpl?r=9$JzR!>-G;4xLM^B08+epbTiA)4!B zOb}!Zp^nhSpYF#ZnI<1m>pEr1mPNmOg)~KI@;PNXH{?n#t}LB8sjMyg+<=R?hmcfm z?ad3x(LmNqnpgTUIp1(h7|`KuX~hGsB=wEB+D0neDgD|WaU|L|? z%idEju4Wr!leU#tN=h%`{|rQxT$THm(xYz$fCu9Rfw$&=^>F9-@?(5Ax~Wm^QE!~cc^2PgIa&Nl4JOIU#eZ9n)#+qJN`V*&>sLRLyi_#}Ym zHq**-KJH@vD#EM5RQ0JhpR?wB&IK;u3TQDy6DAEM%%_bF1ztuxGT|pd3}SUqV4q7p zZ+kw!nAH=A-59r+I`JgPvl_$WII_8nZFlM&uCI6RanOW@`@N)(eWTO`g(247rD`hv zlZPwSp(ll-_4f`_^^bk8=I*#=A0|-G+%3&(W#bi2#j@ysdC>jJ*JMGfT0U=aY`dVj z`_4oPw=Szb-Dcc3ZY1DExl%NUdq9NOf|2&c|jD~>IW#KhzVE}GR>^I3FLIJsMezST*Kv zO?F2O>#4=NJG}lp;_Yi`pLG~(HZk6zC>wHiWy=MQJ10M^TvAi}S4Yf0LXkV|V)biD#xj+Kuvj{%=@Qm0!pNtdH+#2p$bCtYG2GaWr9Q zPwy{$_~Lo*siS@o-TqZ#{e{(HYe?kwJjvH_{%sv%n!-b#gWWgwPu>nO`&Y}(?sVlU zRgmIuZq9N+lMaKA8hqe7@;w<*mnWx(R9ZEgp8W1DvC+cR_ZKS(F6k#`N_kawXXmcY z!=ID$aQC0S>^QQ2Ad=2<_aS13oJ0r>L`j=OPD?U)^m1^r3r+|G zK?vH(PelVWJ&j(ib;(r|wh{&_3L+1_*3UbMMYIl<7~ALQp?t!dm$PhRz7hXA>YftZ zYX}yP8;ZH0ck`hZbb|wtVBE{oLO?Xy4o`euvFj=!=KbryGl6$0@fbOwL^p$ohzMyp zf;|3`Pv~{0D4th0nzFnK#r)0``NbjL;IFai3nt%LV#Z}FG{crs~f2Q#bgaJ*sTy4K_ zfcLk+`yufDpAS|2hJWBIhOWO&6!@AP82b{@EtrAq=%G7u$C&!Z*lmdg`tkzsUToQ7 zuIPiV0?h_I9yZOT7n9$@RaO-`U6&s08YTAY9Ed4aO1gdgVZV;42P1VfMPlj`x5=#@BXwt*+t- zoHX|1p1pD^GpJOsU|UNsL=t`LfaQBrxzh9gp@^3c@P>)b)|6UR-4K}YAqMn1k}v`a zJ_lCE!nUZAzW&azO73pUpPq=Fke3()b5q31xzpA9!!0TTkC?%nr6{5XrsY|tW{dV1&^945P;bDuy3`}g7oxnKONqNU*}tvt`1MfDSV7CFSovfVZFb_Uy;z1h0STA#r;!k0;Tx- zqz3B`E&pOJX_&|s;yh=UNSb`Oz^SL1VRG{hGaFjd z&S{3*s?PzTLv{oyHe^AicbA9Mzs*Ln*`lU2$^kS+dB9OGu_wDoaM*T4F$jLp8lI;AoHQWwza)kyvhv@tt-zcdx;25? zt|JRB=u0g76P|oa>yk;-gt3EU3w&q5!)0p$&v46|<+E}c$xekq8Wn6nf<$(PmS9>U zTqHB!MD{~88-r^9ZU}XY_+!zgT!?j08xe6{xm4s(w!6fyGa@0DDFj=_exp)Kv?8>i z7&vx6N_LvuQA3PoQeV*uF~ky(CX*n1a)m9V&bPzsmbmPx>h%Mk+0FK?#iderz$$IR z10`W?yMN34-_VrnrlhVm-bQo$dtim3{v&?*zY|0Jzo6-V9atkP^Zz1x|9M#dBZpX| zY8`XHg7BTK$EaPSxw?^f1nuuT+lPlQXV`{(*-~DPW4fNs)m)dQ>!I?)%`7*srcQzG zv=L>>^DxOw{|s=yfs?=ZnE|`2K!H35L5#Saj^IUHP+trXWf+8j4zW{g+NfJ2ZixW+ zYdcVx0rf{!EMZyH4Pw{g`KRdJPlR5HLq}DJh@`q{4ZQs0{2`>rE~-F%7vK}K!)*XG zaQ)Lgn%YQK3dO6TY61u3{r&~3<>mPSLimrxUlj?~eA>+EI?gIYV#9(wpDIb!4j5lq zn`H412w)Lx20|TPTnf0Bf$6$iX5NcBY1Om^03}Q!MCp=tQoB<@A)LN~20_sa_REJQ>i5qQe#P(4J!p)7@~;MlM^BcngAz2m+L-P? zbDTm{9NY{fOd(!|*F$Or9&)6X+_Xe{)qeO=!adtcDcJ@uY&`Z44Q2I~h-#{0mQKE) zP*R&o8#XpJdkxznY#1y39Qn4I_Pr?iEk3!C17(X;HP%aJnay@PIU;;{RrBppY7e4; z=(GX!uB_#yb^QbeANm*R4^I(H+9!x#GV(+GWDOmV0BNO`EQrl+a6REzg!<=!Y*YRh zebcRCWm<*+Y!^w=SZ>`$E`fDU$qju4Cxg!!1yMvm@lN#2 z`L|f=WZppS=4|_S1rKn0jT7J9B_UDl`9O4naf_Rg~?+9~6x{R6ekZ0!u8+UV>}xpBbnY9)r&?)J<^o z6mxDlaej$!k$ukK86L)VU9*w#*BSov-d)c89X*`CYjlw*&BcT6)fr+n-~x=8yh!}} z_)|HJ@?z^QEmVl^K8@&^aom_@@59&?w_b!A{!3aDJc*T^af>HkUK2`oB~^r_X6|=d zpGHSpHT54p>U?UA+in99?w_u-1bsIbg~sppM90C07b({y6Q3aFxl^yIUOqunQql|r zYu+R38J6FBL?{V%i&G|38|W1ura3@K8T+`0-fRD#s9I_C%pEh$4e$k>k%nIL*2fs4 z^evf&RyN23{eJ_Ar~Z&Sp_Cj2*l&vnB@zID(Em3e`7dPoe_%5~s^^_4z1raK?07IM+qk9@{M< zKuXpp%La3QnNzq1usT>cM2r|77A(}E%j6jZdbOhu3E-Uzr5?f|7xZ|zQvz~!orP?+ z;jPLm7eS=rEmt}{z*kO3Q90tn!M9UL z=TLD-%@UM07zIxD^F6MO#vdlMISlmx_)%h((C31_%~x{PWtDu&E)P+A;7D`M7R|G? zFbZ-R@L+76oxyfQ5#BfH1F6P}T!6QEu9i=K7@V#;giKYUT?{@>u;C8&;tJ{l zRBcTr;JMH2CufUmTc06rzaN&E0CPb_{l@$97ySO@3)G%I5QwPPqCCbvNw)3NFa*aH z<;~H=>`gCZA6(e=L-R)T$_Sa$IZwp>$ygFNmPB?%HM51()8=Gxkk#;bkrI6y5 z_UIKBRD}jCA%gb{&y7e>%k42 zlS=+SHiT;oSeI)t!?wBv*?~XOmLux5Xhe9Z=$g9ZnuMQ6%;%$iD*M1Wa50($`TbZs zQ&QGu8(wp664S{&9xn>W8S%`YVXfJ{Kod{A>4_3cM+Q`pk0F6;pM+eWyXg%&R&-5w z;3ycXRIq)=2WGkWC46zl)I^R}QU*z1N1)K#)%KT<3iVNu=g8pdsI)n(q(6Dm_p4gC z)69pPP#s&>8-FK@7lysl$?>_EMEIh@z;yniG(HxhhNRdL|9N|)ykk=mwSMOwf5m*~ z)$U_=L{>;+aKN7*ClBkiO!murxU}J+M+2F3`xgyq~5prOW4`j zOV~+hD5Zr;lr<$q%W5u*CYi8`>_w&RNW~Me(<#4TckTe=Cdz0O_eiE>y9@CnDu!m} zDwQ?b$~x?5CYkr(hbpTKC_gY;a2}VVb3j z%#=1VKJNq4kPe$=Ng!cvl5eQoFK~=cszm)ZJe8U1E^bkKy)`jXwZftju_r}~kEF4$ z(EhiaeWs?j_o2%V^L2QngjHR{&}6RLnae)khhm?{f}e>BI*59yjMaZXu%0tB_^@Eg z2ZE7(1$~w>2)|#@Rw{d%WAJLTYVssi5`(Xz2anS8=P|`okBT@&k^4j5^Lt%$ZsG3w z?fP+}G#R3NuntYy9FX!ry;=nA()QyO@uCq)4AOb~ZO7-^`+3C%9d-XWfh8Y0Fjg)| zV`1&h(gK4&an`QxAeESMv>V)6>2P@NN?in>j2t^3pCkMUYWYbL_Zk$5ZK9?~GFB{v zl2Dk=ywk@*z+%7Z!B!9Ogs!W6(rD>D>dxmKawq5cpo>tRgCuH@hJGvbxafJQO3Hn@ zp99UrfO0A!UU;@-%=F>Qb<&Ho2RC#(U_>d7l0buv8rV3Wf@EC5>(7Bq9vj%(`ALw} zmucY4c0#P>pDwB{+)*w>%yiZQT~IN^cj3Eg=q+ye*{uV;BH2hP^%JzWsY0~&It;gj zekWUPt>bSre`z~K&5&SVj+-qV_7(LYz$Aj7#R>0@wWh$hYL-0zW|0lT{R6A>dm++i zfVl4Yhs=)|q^w^5Vp`^qe-_5MG2i~he#JzSGMoc{N!T~{vW=m#lre~x9Z6T7%~NWV zqIp&*g*N9~Crmq=q!h7o`s_Mm1!vF3jC0h*5%ICO1sG~j#z?2kXAL_GY>3n4HMF39 ze)Rd)LaGPqC-99R*$s$UgiPcWpiR>jp%3p>Gavzd>XFqmaQQQfeu!9RBN!)GL;(Q< zC{5^g6MEf5ETZd(R2*1*;Bv^k!DUlQ;4^{|PK>FkPk(3B z6Z)uy=1zF5g|wjA&;*T(DTA2;$;CJn+Ij8=V2g>O6_=y^XMX}Dw%N4G)>T($DpeU@ zV40$EfeOQrKE;gkzFaFRR8_L>E&~c_ho?=GczCxU>D^0iY;RS=`1={08oM9UAuC+) z-G7uH9&jJQ>~PjCQ=4u?(YwIOGWrgV<#8WS^Bq&ZoiV<#{yqD}vt{Yt*g_(XCZ?}; zzX=PT%40!bd``oNZ*MP8t8pc2Hsqs~|^w@`HQYaoiU4(n5F%^fk=lzSy|(8JK|E+)AY2s5m|ZK?^Efy*p0HGVNC- zsFhm(NpUDjnvv_#X}&VZ+STC6Qf&%fslhSVuVsnQs26F;T%JaoE`*v0={Pm8sHd53_CQP}cleh#yV`aY7E+3(fX{A!Sio|GQ;fj|{U) zfe6dO#l_}1amR9xKwJrd(JbmryS%(Y(3ipc9#j`=6nNK=mNyywI|2rO&?gu;KGIf6dKv0n?$9v!?;en{Y9-dxt3X6sews zhK&c#wSkBm)0*ZbRXne;5XkrER)I*v_J5UkgM3F2t%onMP9#2E9W!hh)uOdyhv7PR zKM=0^3)eozOWSK|9g>?AIP=vrRZ#<8vNzJPsnjH)Q*YL2Xlmw9qllV1Quko4IG+{e zWOlrOPs<&}&afPlEYUwa9uMdHpO;4!5nSg&AYKL=UhC3=an)Z8x+{bz6{snL<_LmSWVw$r($ec}b50XDGX9{X0js7$o-MwT1 z%hMIcA$oclD%9hjzoX|JX=4{i!%g9$zP-j*Kz2n$UkjAscWT zh^`rnq-3$`{vSpHY#f}L`?eoH`)|!E^4Dx<_ubG3*%Fh4DxUxuxHIvlN zlH7kTIwBSx67D)&%3+YXM_^dzUg@<(sCxQBcsdwCmr2LGb&d15!iWnh+YdruD;yaI z7QVi^BO{-o6V5@4^?g1J^@=m>ce>?0!Ua5GpWP64#b9jotS`%eom$s0%i1Vq5`#R- zYmOW3HI1R+{nw!qCjEDBG{X8Sp4xNdI*_$X3FB-9{>?1nrefp@Ur2*$Ad$ulK_y7- zEEpFWfrQ-%#2_6gYooPmUnB&h$CSEFoAKe`<* zBUAZ}M`g*zQ+s6%#W9H*sAQJUuOfMX=Xxa;y{en{SN6BjCDJ8H5+}*3aK=>i&bcb2 z2DOJtLo`vv|MgKcyDX%#BvLUM-y}oz)dr~7&%t(LoHZ3F_jo`16zbysVo)`;SsEHUYvba7cYMDyl&{D*=R;-y5GALbyitMS zWNyvCFdPy_^>>K{#uX>GYr`2eIj{^k_!|)<88ndW#>_~yB1#$JRa?L33md@^Qd}mA zHndP=005s#un>}*tsYR#h(%SyOoaB2Y7jVL=g`NTBls7#G` z3DmgRGMHdIQOHWr z0@gzfEX1S(ruIl1SK-jhucI;nh`isg+Via0~IQza;}ygoyqFt}&0 z6)Pb=Pd2YX&!0l{b||yue8>1#u<%y8Ar!Ow{Su;&DjgoH5jTClxC^{cJkm)WeKUyY zWPP&zob{!3RGkI$3{Av%+W4o+S&%4Xf>&jL1CQr7he^x&`YlWxV8|DCn^%HM zb!}~Z(REXSf|Jc;F&bkx)LCIdY~z|m*u>G;wF{3JM3{VENx#wCmFvLuR*P^;BWT8* zW5cyaj=>D18#ay^Vo{-?h?}U7S%mCUkfvJ?pXiCW7A2=Eh)wgRh7uE;&w*S4xgZNtcj13W&wr2Pw1fEv27Kf?e+G@@!+;yD>#KwGb(wonH^; z3i-zp74JHKM^gyHwaX&~b_PTcHZE--*B2Qx+!Z*}&q* z#)~fTwq@aKZL(0h3`xN*EqTJ_keA&3bxHA(t~W^CF+sa&@=bjZnyURAq+3MLa`jOG z@ha4B>8#=8Iqyz6drx6hehMwcYQFSeF94f$bzNqM?cXrLH!j9__WWSG4(NBkSuWHW zr6R@L-#%jvmb;{KGA{XyyL_}e%-oF6nJ!6e zL#RsL7V4`_Nu6^!akKedkrWDQv}x#vP!0n_a?%ITdD_pL)JtDz#&jWH7D_Ko8|kOt z05&+8B@P0#gib4~FN&5BvRz{q9b$!se;U*CgZrhEtiQhAQVe~oOMgwxqRz%l+fE6A z{R^jDiE`fv8V+7xYE27Ub#u>lMF&+8>r{nD(~int9NLObVlS+E4RgWGuJi4QlBoeW zYfFbH!_8jS0Dw9}mV23#=r0I`KL{f9q6u^nFj4_IGnpWwc73l$Vf*BppZH?dn|FJ zRuRp}{P5p2JUe<#8_FRJ&|q2iQU(3 zxJhkTERM#;o*!KPo?P{8A$7WJcB8K>{M`8y>1vF{J0#4b7d0`MU#6 zQi-U5Y+4wx(szpQITB)I|tx{?ezV5LB+A%5xrdbJQgpz_17!aoPmx? zBs{z(u@WF>cQ?1(>wQQlrsfp{tQU^KStXOEBCNik;A4cme;$=#9USq}3@odKw4Bd> z)Hd5d-5)llvGcC3DT1XwG>an7DCWIV#FK(>W!lvf3?Sp0GnWW0&90r!EL)RY!b8O_ z%T6o3wrHmTqZ^)qIzJ{Qw!NKETxmR?UpJ2{l3i))6m&L>#W+u_pgfnwfPAqB!td{CTBBhkEY>?FT|k8>#VdX7e4DDG0|j0 z+KVo16J1Axo{UtYwo>keEn09@McwzzaL%9{;G)i34Au;i1H!Z);vm$mML%7E6)^U; zlj2hfZ>X1e_mK$DomNlshoK-IKnW`VArS)^#fVH9UCm1rudfKGpG6FTHMfUrOCc?@ z0L6-@<&Gg- zIGMSyEYv@^wrylzKYf0=-jjdle>zZuQTiQtq&1+NIV1h8F)VOwKuH!%Ie(S8_T%IW z@=gx`{sxY?5O;yLX8UVMtTi9`rDvJtwUbW=9E`K2zS`@k?+9ih3-Ss zxbFNDfNLa8W6Q~l>!bX-av@x7SPy|Ed&PN%}&Wax%O%U0C|!I zW%l#=V^I_rNupt*mzcQS6sLIvs-5QC~a*Xa&ZCNrIiABpr^1e zA+x2%mj6ttgz;hGBn%(iqIKU|V^N-XQlDL0?_CN*mg(Qp{gIOwIM|b3b6pqQ;cOlm zsr;rAZ5iv+f`Q;<44_8~P(^BxG-m8fC*OJ`rI?d{hyF}wf)5<7H9i5wykbi>y7Mm1%XR;( zZv}o@V6T;CZEvF9|TEr9Hxpyf4Du3~o zPpwyZZkT$xm6vQqmSn`dtt0w4g>LEQ1H%5Bdg~?waXy^S?Q-6&2v0VcQN8xg9uqN) z#QLshTRr+Z-uws5U!YR+?yqBdg8J6Wfu%4v9J%Usid-aeVqA1AQS#yLwTG9jC#mz& z{$TUSP??izn1m))uv>uT(!Y{n%_rPfRt4cCu_kVHQQld+?)fW+K{tsy5v!$De^XNo zwbf)w6pYG+j6=Oh#(fz%rn1a z@$1Z@6R9g$DWYBfTvr8DuiKggc) zDN*U=Z#*7hCRXf~l;-L%3dn+Uz4>F)-&&XiK_M0P#FNg6$ubP>i-oZ|F3Dd-vu!)_W!XZ#{PHM@4q>^k+t!E za`dGxOJQuzd5X_1{=F}fmaDp~JJ5s+4m%(~radblD}sbAT0a;hXL9fPUk?I72myREtFy^SoF8xf_zlj+{)X)-yC z@HBpnY}rqV$S(mLSn~Z|NHTe$PsHpNa5hg&IdQ{gUwUSrJrH>prnQB2@=adC)sdrh*K1hf zl@}2;?H&q3prRCZCwFdOl$ku1@7H<`S^}`C;@WZS`d2jMwHWcEn8 z$`c{9YsI^hqv+GHD2qJm>8xJNw*k0WaDxcD-9J%u5pJjMriQ|++Y*6#$KHn!9=m#6 zw2YargpCiN_=Kn@*&aj65P-inD%fe2A8wPD#CRAiE;l$!sS7Nl-6f(B-aGOs4I8fg zhI}hwey=n6D_7>O`mN}H1Pyqko(Gxxp)AQZ#;M&;Hvx2(uVQBLs(Ydp; z?e$=DXYw+z7w6j2(L(&Z6I#&H5wdT4F>u|7D8Jo?#l?I)REHfHhw=8%H;5>56Gx;8 zogT+CX>999He1sB#^hpv0*Vk12G~oZZF5L3gw-4beE@NDBAlCPOz*KTChfTq+&>!s z+&d(`Iy_x;(AO$c5FAQYk z%hoH`!}lpo25@`*@LCgfn1Km`VTu?OE(9756C9A=9z+|#Jeh0hyrjIdrn zD7VS{-lN{+XOK`<7*C9+JpPa(vcj=9eA8amXj`P!1V|+9<=~Z+XXEIFO>(M)-7HRF zbl*Lk`Vd4It`?+ea6kSSc`An92a5EdEoW?#-CH2EV11ZcEdsuEy<-Y-FM2C}ZJ+w? z?@MzJ3q20m4NI==BJ5W@sMO;k+}2V2DO)^kpa)hJ{`Hw$!FVb6t>L0Hh2+SbSmCDxcYuD(ZHcnUNE71E--s~w9PIk+T)w; zM>%NFcXtb1kFJG9Ml2=L_uduVMJ=Toj4fKBmQV|oIEG=YDv6Bk}3MtoGJe z_+*Ax=wr|&cC!PB_Ly0Hr~5Bx?E+ubsbgs%T#h|YBq#R;(rWA3!8+3;z8ipvLHcD6 zVeiiFb94WG-yt}nsUiJ0V#j>Y$SCN6#a+@IN90R_Z>;q^Vo?Yv7z{CeRyqi%2>43z zNXW~S^YdAFpjk6lO0pwkUy<-#%moO+#o~XV<)*lYSQhE4AZ5Y^>9jPxg7LX4l-(Xm zjWW|_J;2Aep`6PCxN?j@cHzfnDo0VZW|RHdMVu3gto*>O3Hd7GPt%oUwQ(TVsCg!l z;R?M1Ef_xZ^SNZ$XQ(0PfAjS|{U|x@hg->@G-UP)$Z*HpV+R|;97vteTz5SZNS~N( zf92-Tz$&zg$)zQw*JKlz*Ur4S7-|TGrt+y2m5F!%ql%K(gU3b-7}?DOCD8;vhJb6O zm2<%>ZKxyE5&SJBgs^fjg60$YKx~z{bYQT)GBBA?MLSDmnC^ir;<8i1WjN<}2Ip`M zmJo_GCTlgSu;B>bS_i0u^nT7T$x_BSSm7orJ^&_Gb?BfU?gPg1rxXSZ3GdV^nNJ?5 z>S74r>nyYfME^FNx7x{F$8ou=j$v{CpZSLQ-3!B$-<}z?x*C0F_ZI&(MAhWIi*pZN z#!tl{Ms&2Y(!naoMX69IV0CTnS3D&`)9xR#lMYVysWmv-n*)?^QX)tumbk)ikO<&$ z>Ro@i_+5s-v}V2MPnFSsdp|%b@&9PKW{giU=yowo+a<_WO#pC#AEh+gI;p~ZY6z3&Vhy|iSmjCKh8 z7#@rArU1L_#C~~Ti+E<1dq6Ao88SnzH3fu=%us#GCd$SBy?GWam(;O5fm%gMs^Hi*j2WEFY#GJzph`iTYAHJ`3y&5A6DEC%9x*1vFN0 zY*b#~-vt|k-5^?Vf`D6A&yjJ|zTvUL%IPQb0|Duvj>DJ=F1b6s45gF8K7zJFHyMWp z4#XJhR{zB0Fp`xw*$LRImm(Y<*$^qlNIHz_9#06g^1wVHC2~RG7)ScWex^0Bhl&=t z;v}yMjVdL&@Z=vSei?9Br?O)<&AS1z(74-ylL}!-8)gChszROC=AewpbZ_M&Cp$ z!X~-_Vo^yvW@FP^iTi^Fg=04Pybg?7!wv%uJzQ%c$XE403GSfrdtoG034gNRdV%Bq z^3|rA8O0-U2*@tmpjW@x;))a4l1-B`L>-FbuPE?_b5J}2ps=Pk_5I59z3j}`snM>a zXepKaz&&|INHTF#qp>UfiM*Tk2r8_ZpDZ}KPscghI8Una3~~X->Y= z2|?Wc8j+jEi2i8$9O7utO;ba~NL&=C_lC}PVn(uAHUJZoHCP9|c3^v@fa`wvx|Ecc zz7zl|5U5KuU`8+Fn5=+7r#vJ$07cLvX=81H%Gs;H>Xd%!*O)~094_PxQKMCX4T|jv z^7gY9XR`J{p&&dSb2#1Z+O7sxfu%S&)EdIL15JE$35^B^MY%Wk)`Tkwyjae_FnKgT z8%1-)Q*h_#^~TK;b^~Tu=)fMbA0-Z7emwB0qsZ+|`LbJ93cjO&J|mx7mIID6R%4o3uIKRrT>&|vYa*Y-@q@D3QAorQ z(#9m}QUFV<=!<*LB8BMt_Ns|r7n#?bBP^O|Pg~>#P+e^nL|v~&@MeMox=R?YDuE~e z_2nu0;#YXxz@n8=o#z6@6=LF(HML zB$7v*eH+8wTv5JKxmGWvQbgZeU32fCuLlqz{isx2CD1cKr+}PzSJ;({F+S}RuR;%M zV|CCx1&%#i#N3Jwp-KW*>8d!42PF3s4ED?d8neye(@3JZ4JWOKKhQOADRYWDjY~|MDoTv4{6(U&ju#ZJ4j2u(xC)w8Q*5UQkA|0y0B`s~GC=lA-b~Qf z?2iD(uG~CKE3F8#3()i1Cf~trL|F`d001!r(CoDq_Te+!3Z2?u(iffl)vBV1!}N zHUkcqc6Tk0I`u{|-wJMMb0utbYd&ke_GzMf)9YGR?wqc0_nF_(*-93VPZ+*3LK7T_ zQX;I$k_Kj&4vP)ozxGBqLX-)>YuI`2$Zy`4a)PNCeZk#OCP@yD?r!~faD5gaA3pUY zhH{W$!Xt#j#U3?L@8Xs{Jnr`s^j8i(b2x8us~||Me?7&Jh5hwU(}Pn=AS34-t7m@; zZQCfXEI=MwA8rjKzrQ*HM+tZfFJ!L!cS~99tVLYDki?IX0`O)@F{x(ErZY?Y0*9{q zZ^=<}qx-X+jfppWXM<$CD zycVO{kL*-B9gM#QLOP?c^9`(Tw_H}%f{l3iJO0*xZ3)F=+_K(|(Pqkkt$*cv229o= zOQ_qtD++Iv?fDOWM6oRZ6Naf-Eo$~Bck^J8*oOx$i-Lt@F1k{BP=W8Cy@-;2DO?fM zkYluN++ioqIz`beZ8(ZW-bPT1EyZ{k8`Ktu>vSB5sq+Pw+P_71?J33NDJ$nc8;oCV z6*%=2Iy)7d073eL1p|oQ#8=KmLxw;J>%=vO#*!a$trDY4R)^BnVs}tim=Y5zfWs=F z4v+={uujHhhmM#!7|rM>biV0(Y?RaELFr1Zv_+Z4@gC`c&~jZ6?!4&*z$44T6OUzi z(Y@<^X2v`t>KK^sAw0_D2IbC%c3%NOl(mA@b-@4jz|kp^#ug66aOBLG#87)wib7WK z4ore0Qx@NuxsxuHb1jj*{tC}4NIVL!04MW~;v7qiLP^*iW6wD1B3m}>!fWX0zqCg| zr%P0uvF7tYGlZ87j>!fHdb^wwAQ+dTpeZ6H`jW>qOo_-$+79k?+QfJvGe z1{T(d1p+*6b~~nSPx6IcS^W0?QK01s_MV|eL?+e?_^v&hk>DoQ;jxL_WRvT}`!UDy zz;!W@Rr05`+P6r%g-d1zhQEj6*+fb1O$o{b;>m}b(8jk!bl}$8RiOwD7<*F!@7>f9 z)SHx^RH0cgo>7DaS*NaYx`>m>C3u~@aKX~V@6MV`oWmv)XM#ARwh&8ZM*R^dB zXXvl;E<^9%^*%-K1yynn-}$9)FQqdrr5yn6#2j+_LV*I@Q`z=y4iHeJiaY3w-k(XThkvo^DlHSMzk7HyfNosFn>tFA;_W%dvq$g7K#na8 zwTi#$Dz|D60la{b!TXg~h7mSrfED70hkvIx&wj-;y2uDa?OUR;r}-A@5-ha?Ow*`S zqOeVSrrzKP!TI}y+n2*DLXa?8V~#@j(uT8mwweS^k01S#N=O?%Tn<2+3%^ixj>3)H zYho9&nYixS+XXQoN&4-^Jg+gIR3Tuj zgKZwc{&D#;LXo=GqeIG6?6m}P3dS2sRMCr=QQCZz0y>1U=BLPoK1eC~9qG^29)hN@K%6{tF*$+=js>R<<|kH8onkvQx8 z>joix{Ra2*)AUuucDDexYY4=NyponkXDmf!Xd1cifx*Rvn$Y&8lJ;laj0+ck@c6G| z3BjoTEPz5&!({l5W}=js9I{`L&6R|GS@3&5P7F-H7sP)~T=|Cj=jFo<_YI?@vDs6C zERf0CmiH$p1Q^LihK=Mkso_A%)Wu`7LS?PZ<|P?E2?Qz<`~* z8c}~$1J7^|D~V85ixJf;8bb^@GGZBOR8oiEYcbLdMFRi*z{w#*A$gr=9G^QyjL=O3#1kucHU@$iOqhBi@)tbh}=)o}YZbt44D`BVi+3KICaGpdeV^20PyNzf7 z3p200#3)z+G>7cx3IZPbI-QF*CVif~3|+fN;+EzL3=;s>NZxs4{hVoYNhF9co+Her>|_d+k# zcUi5SQpPD=hQ^VgNZpYwU&-~>7wbjaxibq`p&-q!xHV@?w1PeK>02+&#$thiu{E8G zq=iOMU>uukMWMzS)`Y$&a#$M|jWokuRDxk6%J`NcitNN09NHz9qO{d5zJdxrbdCsW zNZM{Sdepj+-o=4uhVXqZ0>1vSS&@4as%EVoQNVXY!Rb}j+MMgZ*eeKQ7%N(HFVO$) zzbH(OJfywPkE&5@c!X9);_Y08mn_WGW^lfw7lV}*BErPZ^V<3nb3EOVwZj(U+>AQ( zx=UylV5df+hW>Xaf|mdf9n6CH!cq6y%aeThP7hCkLXS3{9lQNXCVWY^rd<`aiRYDS zT)D>)iGG1Obw=zyG1N|G`8{}h;ZTMLg}=_7cpdju3d$bq4u~23JOH1)MdXjw-1q+X zE`P2}=5nPl7e*^*LN(@2gPa{^6P3AhA0V+jvpkl;8OWNpWV%QaihZ(c8wP zbs0+tf`!3W2Oqu76?8k%DFQ4^zlm+|!#OgxT$OB5%N8IIKN9}C!+XLi7rX^L{?b_` z(ts>q<6J)N7)wpuD zL^lF0<69&ot=t8%{i%*Ay$^8w=N4x;c)P-0N6;(ul#`{b-rfY}e-N-z{X%hQ$%BjBsmjj!~Xr8evNCP3Ari3qj=$Dql zm8^r<*rFR(UK~QeAcrUtQd{sV0}x`)Z|f|pe#~GINK=Sv;E?lnz(zP|N-x)tLGw`1 z&%gY7Nm{@2Y>fq~W91qpnJ-eaw|OV;@p>pGGh<=@&h7$ZOLRoo#l7v{7OT)tCb!?_ zZ}uGIFaFXu-W#G@DAT|~C}qHq>#+)Jl5-0po+{84L`j;v0&=4;A$vZDV?crO(x5Ua z@*{A?qi+tovR`m2-4V0dmF{3v9zc}ed{q{;sf2N9*!R}G9K;1e;L~y(N3PsZ)k5+L zIh3tDEJDi`bZIT0!8({9d8GT2=W~@eYUfm!bu2rJ`i(7B*T&aKbg3$pI~c;G6ev~) z`e5+WSsB6)W;e=A!PP!BJk0!K^ADV5ZSyv)V_~e3{@K;cM$GR_T{N2fA*0q0q z0D#{@=V^Gqun!mj%d3z*&ikPfhj0*i5e_dxytu=JsjTiv#UncBg@VQlTrojf$;jZb z-=%zH7cYLCs``KQ5abZKE_)olnW`-wpH^~gFsnWKNVG$cE(^F7x>oGNz%Pb`G!>1@ zH3eYTrQ#lB=T9#5)2j!vU2mc-j&B)8bGV;s{3SoOdo}q*hKYC@iM$Ipqeu8SrAa{_ zhJSQj_Zu;PICy%{ws}v;q!HhW*4}heZ_I?xMyjihVTi&UW7fQL814OYQCI0|7mj?R zdT^n*zA%FuP?DJfVTu|8`?HnS$P)liN`l@RWi{W9&nu8+XKG7$6u}4}QLg?*4CmTcN z$7!ryECWsuhFp}2X`AKicjp9mIia13g}H8#$@wD#urrfF&9&VCrqq*!*Oy**KNOBq zd-%2aRRe_hTC|5ya34fMY=Y%wuH{klW`5Rrk*-!igLzV8M&x2&v+w&BsI&I=$r&?3 zPKf8ItZ+PeJUgQFf{Eww()#FkngIp4wc4^yJ0Fjc>!N>#u?5{9guKtbm)w-&YId%> zIjI(*Eq=yNVU|VERejK$-I<`kX%u-Tr-#i}_X-2dBDpXqXy7+S5Nqi~2Zyjz8_Oc+ z2(`z`Ne z|KTLfr*O)=!j9OlcItfzSSvYrX0Lm9UkXA}Kh(OeRXvw4<=>HQ$jyDKRHD&Gs1Q;w zsu8I%`Z)b)TC#9UQf5-fQ=(jp^D#I3KhHC0{~xTKLzgaH)MZmQZR1JXwr$(CZQHhO z=bN@|+jiznqwY7VYSbU75uG!l5v|jSz2{o}8i zrbd49U@i@9EgB1SMgE@itZPQFtVE=KxR_AxBVgB&Lw;5xP2<9!-dT}E_ARW=o6bgHN$icdVW z5X%X6Ozo;c6>LS%2ccBoW@guK4480FzI>;8FL@ocx1Q&J5_J~;&#k`}E)7#SOp)F_ z@Sk7k7o>+_!T~P>1XJt@bW^GtQm9Qu#}};8!@r1NO2o~>5vGeIO>hKO{B!H`(x95> zD{5e$+4bJd!X!T+-{S==A5qdHSHQdl1ucfaG`JE{D;eQvA5S5~+n(?&ZmF48Pm_}_ z_afFQ(pl%8LZoF6jzVuzG%R_3nj*fD(aCDwh{O)RbM4hE+2{1l@TSHr@e{Ug)#-V< z$9sc;sb}qn57YvzEOYo<5aq<*?3$^lgfia$Z9ufh+5b$=2OqSobjp`Qp-h5lBVI)V zP3V_02S8%uQ>ZEB>KdicqY+SfWB3dUk60ALs3CTe$5LjiL9YsIAJi zpy*-qbOBOBM1I&*!#`L)F&^i|12aQjaAFA9gJ3XZwyXoATx#g!D)!(JR*EH{r2|vx zPYCq(75qg?Y+K2&2&g!?NQ(vk4uIbVKjU1)^CPc>3j)C-dLf<>6sy6uvE}6^en# z(TU0)6N2KTta$&hrov&fZdzx&CF^D&nfx8J00E_{VOXRddcvM7Y=MJ|*AW7EReen? zWb#h{r^JpRA=gV?; zlIKHJRI5$W+wvzDJ)7DaU4Fbh=MG2YkPJ7N$T*|Pa&ZBrch%&up&DAa6WhjPR2=p@ zT8&UtD&+&-G$dYr0}4rG*WOKGK2I=wa8n$xdV5~*K|-@#PvO9IsOJcVOaIa#p5~ zeCd9Ak8bzmA79-BY}QVS1X|fK(ZQx;nI9?T?e-&paA5-1{NmIn>Y+0_0k$_s)(%8z zo(_5p#v8q7@#+cpN!%>zc}8kuI9tQy&~h^{kGF{=K+`55lYhX6HQmDluNO@zim&f( z@B_?W!?9?1@)?CSmsPpZaM$6>kq~_lwSR9HHSb)Kf`F6jt7_C89gMfQg7ssundXSS zOnGGcP%M@3Bi5_D-1UfOT1174?rhE81zWT}gAaI!6>X-#p;$Ra9rki1q4U{XOZ^D; z=q%%Tr^W`Y$+G}0W>X6DKN;5Ii;qdGzgtz`E!ao-cGcfD3Ait=ODb`ZF)mIEYurA-c+t_NsN3j;qr>{ zjG6&F)`W$Lrlbo6PfK|+c0z4V^Jzf3lo1o)EJ4Sn@d$RoMPVJxCMvjop?9hJmlMU|2>E=4#xsd~u;wW2R!!?x zk9DHSj~)lL0|zkpXEb)^f&BTQwak0`*&HET znp=4ywU!)@L+F9Fg)4hM{PNuPT=M$*Tzy|S>J6FknL*$NlC)QxJUL3@xg5N|5%Ruf zsLRKZb8_*h(moOEgCsdd@HpGMrC&H1tI}~W_D8u|PKT=_mVx!=gM*iRnBY=y{W&YP zHAe`g(#I+CRY+EPeplT`UjKg0_V59baLHDAx0a>EQmKEH2=nf{GYzr5!$jS*k(pgq ziGz8sUGUl-I+;t2CjfK?Y!V$I;KO2Y%&3uF^^Huk0pN=JBcP#HGyf8y0=!C=ETdKr z_+J4hEV+`E=G$wa2(hXWZ$Jz;nGpM)IS3XR__g1UU@|S@b0X%p-$92-_eEhEk?Wx*>MSj!? zlzmd8xCwf0NFXonv@hrqGD$q**YWrKY zok3O^(f=LydKD@#Y}Y*W;DBR1n=)l-jz!ouxa4IHFDU{&q9%8d(o^omk|(ZLLnVSlr#%+&1I3DNpqh;)H(;|4$p-k*Yd0e#@vycA90P zqF5I_F2gfqU*aSLQD>M)J}2T6KB83KY=|4h4Dz3=7{Mf)4^ZE^nsyi(^tZsDy9yI) z=69j7FIZchtTUG$Ak#FZLc(Dlrb3t<(&3E@0bF-t0df+T7;Tkj(Sdth=0*h~ztmMd zJ8sHS1_a1zVn}f^)+9fxvC?66TbFKpV!q3dPJ-ht4JUKasPgw|ABQkMl;9Z@Sk-}y zxZ7a2`lhB~{nPHmHsZrOy7vlB-2G06vSy1)r3?e)EXp0uOHo=LX@yvh%A(|xFWTNZ zO0Wyaih`%Nbs_RKYYlC9a;v34V!31E&iD)(_-+JB!XynN>Da8g`bo4=`xkx#vQVj$ z|7aprI7VA2va7 zYg$cA19T@8F0MirM%5*XW4VVFd&j=4^XevhQ~6()Z3=13GdVXV(5AXu-G0I;ABH3g zML6^Hx#u%w0$q6>FE&kFo&ES+#o={*B|-G}#v%iG+li$-;~P7kN4ROC7-0xg8HX*- z$3c72Ge+YFSVlN;mC3e{zE@T_2(?&w4LX?7aKYY-%v~SQlC#EEP}Ne+Na@Dq9sJ@S z3fz)^X5fDW>zM$mEpMy}9j*)lDFJj86x>r@&?P2|M13lC$jqrxLitM*49;a_zF9lm zW%lHMsLbSNnS8lVbCARsMbdSUBqgR7ijt9-J)`$0pH=g-|8DABd-EVGI+P&+Pem#Ofugkld#RDz=iv!Eivw-z+*K=;)?uLn=c z2g zWAJZbFjxKvt<zX+P04j6?)`@2Th0&+QOHmIGQqS$HkKyCim7FR6?C=L62yC8#YzsE_y(9i}S zK?`m~(cg_|>_|2nO8rAjH!LC(O5Q(>s1J4@0n{v}6BXKyEd3z<6EOTg-}Hu!p!@7& zCs-uw{SENx6Zi)1T&z|1^C3?*(2zNW8|fW_Va#8calMj{g*iEv?XJLFxQQ3@bBilZ z;y?ZqhN|39H1OtKszRmdo_6VXH^VnCh454T6;Rd-y3DTfJxQgn`ehC6FRDqS)#!BU zt8?madsyEMeEyTP0rz^UOzsfgfdZc*6R-bTlV6fr(|Wwhb%lV>>-YG)L7%p(+D3)j zn$CG)p@RcGJQ?>$Gj=!P+mhY#(IeIMZio9Cj-5(nRzn?k7lpc|KxpTZFQk`{xBV=k z*H#d`q!cfG2>xTuXQ328^+lV~%i7@?S+|FIIRwUJ%Ehl+Qpv&>iGw`Ol;>v~YxzgQT(3?UQc$U(`sUL_LR3{Xly40q>muc~_ok1>NX% z3v)UXbDZ5&B2-l&`HzVw+XH8)k@VlC1qw$$9Yq|Pe+jdV+6kFjHZx`S#>p!mM{5=R zDgnwv2kJCC($Lul)3%Q+$WSnLd~^Asz>2!=^NuPMU_})i^fE_9nZ(P;&NFgvW7lku zoB#{|@#A-JTnlv%SQK|7`UQ*|uc3*Yy0`-8kn6o;Q0*36>bnlezoyvhzx2-APjHT( ziEhOgei$w!Z7fR?*T)sr+ST{qw61>wdSTP&dcih%XFX33x$`*nt3EH*=Y8wwpKPF<^^Sm|0`8$#3q=}rwrRPIAl2K2->AOcnd@L0o zbMo~1D0c4KF2xF;jp?GxyYJ8mX+>eUrulIYr3X@u1VZa5+`HbUd`8yZs?^gX z)vd3?)9Y7h@Ul+7f2mW9-bIiO&7EP1*OGIL=&|;CabHNg$T}4>Hilrj6=ZZ5t2xpy z599f6?0nSbx^$5tZtq3X5k0m}$2*YoDKQ08j;v--8r_sACL+9H2M7!2(x*ZX0Q9kg z*5c!TjCI(<3&sMf;@g}^5zz-C7itr6Hx8LW5KkV?OBhOW9`9L|#V#k5y~EB2Yxv>g zcpa~EBb;<%1iSR|FKZU+k9n8VQhg){Pwo@MSYrgXph8^l?Vc*8OacxWo*tBJ5i>yn z`d&13ma?t)sKI}p8xjzsA<}&6+&sP$9=-We%0^@Z@5&Cn&zMD_nrJ+f`w=l=Co?^~ zbYQ&<#_Cl8L;n@QXA+)3brYX}o|bcA`xQ^2PbKlOgM*VLP||v;-R92D3xnCKsp2ZA z#PPa!rAVO!QLieHqIBp@l25$u%Uxk;Nxay(3YMbK^vdPCwGhwOJsk z&rpHeZg#c^G|+vm%{I}!R^rs$5N<{0|0bD~)GI!_xZMv2$wiU3HNx zHciopVHgnSa5s~6DulCi*DOm(c-q$R`8y_Rg`O4Bj$4ar9Gbiqvr{fQ?RA>>(Rk-QYT$yT*ap_6O#+9sm1*#M+ zf*Pw0Hu%i>Y^a@S&ZtyyZoj@krtu+FlxHUYQUW?7}QarF=Q79&3{( z-61V^b;*KCs%nnr6vd&>7#8hG%8+)cpf_q@lIqEL*liiN^{@y7x9)ein)m)qP4 zVr;gZ>^hw)k383urY3Noblw4N?y*;lRR9~93z&Nw|{!t3qiBIzp0+Vz&vFyfev zQ&f`A8Famb)ihHfGFiYLN0QZfQhFV@1cWf;<1pD7evWCiuu^FqX8T2u*UANYAM@Yt z&Q_rk8hwZ-lf<3WtCN_t#o}n0kB;X;WoAOgpu!X6MvTDlfiXFePS`D=IOo<2;?kXD z<^-W!Hg9ODVemxROGgxFaERA;h4>1)@suzhMf;+h87k%9s9+q|jv58>k;~M^o?}@` zo)TQStio?&33X}tmH_3j&*bxl+h&mTME+{5%q#mm(%ZPJ%f zIj8e66Yt5pN1(gx7UVhIHCU<|b!Gd=?3sXaDNvxeE>|*?JWP^vUV<TA|3#HN2eF9ze}jkJNtTFXA@|yTbu~V_(Ls3Qk7YE92kuhMd5EsL&b=&I`cE zua_3x<3%aev?$Kt8#8#WVMjo_n|vn1IZg^KQXK;5zLut_VQFS{X%qD=Q^j^qqc3_I zw4h%QpN|n9WeAp=+tFcbdWR#PpK1R|M zQna$|A*r*M_NXdlA#6bI&^`CmyQx}TO6TgJJK-!aHJXeaxqbpy6|ql*A)^2@iikqg z`^P-8H0bnf7*>|8ko*#@hzx3~pB`GJ6Aa`6sBLC0XbAMtE@HvXY)iydQkkG&J=2+Y>#8+O$vRCEbG1rdcuAooIJ;bB84>&Or4dfZU&} z+?M!scBI&MsHQ18<}}n^q7$P#X=>4^qe0z}pfQJPZ}LS*FVu;@)5jBP1L9LPpN&AV zfmAO}!fY&Zdk4lr8p{bWkA7&NjqQGToWc`dk{6{HNcj3kNTzaIh8;*_)W=sPyuwm3 zkGy!oYirxO?phJz+2Z-|%rp@Zh|8*K^S5Uip?sq}GgPSH+j^rs-WH8F|5F2@Bra{T z*y-pKEnR))8$j4xq}wM*HX{K{XDr?ry@|G2504Dvz<5yf+Iu`baCT*g+Zoufo-1P) z`OvyI+HZdM=I~QWWWlxxOI^PpGax-_GQ|a8^8gc8TB@^cfznZydmG&gB#}2ipS$fe z#D|H@geXBEJ#>d83N-|b2+4w*^>c-37D?#B?+8c=RCaGZ)aG60(eS8(u38ReCs60# z#qVM7V+0k2(Lu(->yJ~=pRKGhRmB)tcu0}pyrC^vM$!tv%4;%Z(GE!l85`~dC6e-} z!S*qE9An3h#=j95{+DS(*|&YLgmRiW=LVd>e_>PbkHVuj%blbZ8N+zToPI7W#LgVrqsW`S^F1bbXjV(%t~ z^unSBO?2~#A>{EmZ^_d~1IQ>LdQ}>Ofx&j9SQkRG$_feLTp;oGZVVpkPLy0;Uq}#( zf>S0W1fp1gRmSt`>y@w=Vo~LEXwVOg{y(7JM&81%n^Y-8sLaBJ{_sl?UN4#et%(SS zXA8hMrL57YK#_d3KQt{^` z9Gppap_8*}W4w>3vFo*3>1!yD&Lo`ZE-Mz?MU0jh#mzdNliE)tbKG-;gtOuw2#4NK z=kRaA#i?=?J>{c48?A0 z!Dk{dupJK`xR{Ko2H9W~r)uQXO5UQkRmK&6is-FdntwC5r_2#gM33j`c@IFqhO9&X)s!aXDndI8Xjcuu$?*#+eY0i}0%kmYOI=pg%SS1SFJrKPIR` z!1x*1Wh4ZKT1Q~=yeJMfg9*zCFcDJL-U_0tZN9DK>sq>gytTl*F=4D{gWAy zPMTko4c;qG5bSfc!8^9nI&(mh3}RN^_LuCc6iC4S12UB>4-l;z+ej-7zMEbS+doe& z8+Pjc)NJSgmlh)Ic=O%m*C8^A!hF6l+U+oE{5CV?ka3y;?Et-9mKkyV)fyocg<37wR zDzf`&igKHcIDo?sVt%ulUk&j8jE_AjGWZ296=P^ZQ6(*7;H~3z)Le+!mWMP+SMaks z{R+ep(l{t)$3~9G*_LJi6oXp>;U0}GtndUD>84Cy6q^~;%D`{HnWf`YL^voIhH<|2ZLE= z@%!1XTtf+sNt>)BKV0Xc)6b^e1xULHh;UF#B!L8-jMeD``JJK&Rod=6ZNs-!v?o=<|vWedZuqhtEXy~p6_ zDRh}{)<%*^2+>BMI9-|J6_+1-{N+*{2OA8~TB0Gm;i!3|)6Nc(r0=7(uJWC5LYwj3IDqlFx}I!YJg7b5IRr; ze9A2R=@S=4GYVBVDWI_z$>9T67pvdJKQQ>|dz~?O1dTTp=}1Cx zpT>=)9gxNtAETV|n8uVAtitTTzyR{yN$uujC{t~btlq(ibvlqb`57+$%ePJ_fs6~? zvA^}lxIP|t9*t=|GL(5=!3(#ZGz0ED2wMtkAeeR|##>+%i`(LD6H*;tpY<+RFg0f1 zi68?E_;^_JKX~hr`tREBp1lul?K`g(h!so-%_MY-T!G|P>^Cxr)HhBw6XM>4u|5Jk z!}`#FEEoKtam}-%me-DLHj36M5POIaQ$-+;7PEoe#bm_v8^*t(j#415F#j%V|2Y9v z)#b7CQxlcdZr03RvBGWHGpA4`$^0AgGqOWyp+Dk*8qudhJAhbsT6WeSLKDMAVPUqB7nEbcUFS|G+GFgH)5xxhJp1}oR|%_`f}`l0lNkq zaN*gKj{QMOJXWUDU&$el zO0`66ppYx4(Bvq~cQMDSWz_A7b)<9GqW}D;Ty{AivMCb#LIc+lT3!tW5dP!`wpQOD zMTgbgV_-(9KSkAqQT>^K5ji{(NIv1LGS8k~YuFIEOPkbbH*VX!AW0R~SO`P#poYwa zEHfeUm6?V;K?Vl_u|CmZ|2}$KqENW|l_+xY8C)wNbO}lQ;&3k{wR3&&Iou*;7)=yK zKmPMHhh`t^t-ze4z~lz`-|`7m8VAT!7HaNp<-|--S>im;=>zhp^OIe@9FLH>j|0}S zRi5<3&@_^>Fg&=TcBmIjCi!x|;>bl1Op1I8x|ZIY?bBa&FM0{{a>j2f+9zb)0{%;O z-Ye%TFwhfP=Gkb-nHf;H-=cLZO+slQWIjXj`1Ba4%I=^!xLhPTabr~AK&;O2ST%=> ziwb;B+IxdaBC2}#9B9ZH>U5%(=9QS?C)rGJi6E>G<`xEuKh}taB=f1H!~~h5b`L^Tg`bXeLEUj~N8Ehae(W}YE(7PjO6cp7A(Wv6L#Eq0><_Dz z6NoGOB07U;zJtILm~ze0Eve|VnFlrHzhS)#$Lq4KG!BeDfB{?T~tF znE6W{q_3sGNj&<3*Fm1a4$?`^tT2+z>U&OH5+^N5nN7&zA!_-EMiP-POxO~Kf?c$6 zTlwMI3Am0!&vaaAR&kQBqBH7Y@s4~d4V}OpsHw_%=`uP1f>RewOb1kM*9k+rgX0> zF+CW$#CVEk$J)O|29$ayAg2H|WU5>}$MulqS1rnIQVALRpzJr;mawVYQV-HpPo=|H zH0=cGz}p$V7lj=CtJX>jpMUnrQ6M87NIB{U(T`_*@T$klAAI~~ymWQ}h3 zGd=&9B_ZEFM)$fTaW}yw(RAs61Ln)vO|_I&998efkQk|ViCligPZC+mF_jQ|fQz^u zJ*wwr3eGL;shgmf7-N<0uE1v=rVxv@YfOR>vlAY{SyewjO{i}x!)yX5n9CbJaXa}d zWFOz?e0xyNTKQtMTUDe`Ocohf7BPs~kh`b^sn>6;cig!bQCcL{1-JVhyoEUvxh$y| zZ<8v`o>LCK*ismr(uU;Ce)fW~Dj$mtA=+BSJH;;Y_7VouG%T3TW7zn2*npBbYVk}Q zqOPelD&XI>s8-Nkyn%HZauB()qpBs@tFtXhO$m%e2Dv4Bqq`F)5`$i`C$Y8Xh=(pE z($x_w3OA5T|JNL?UU?q*-`SsM78_cz!>J-O1ffos%AXwQ(G8@+5-)Y?`T=V*g@%&^ z7cs$og}SS7g)yr9+aY_*N^HJ|)zhRvC%0s6mq)7}C zqKu;%gv$53WW;4+UdaRwZuNz+@!XJ|+q%v30I`PThf#6*dX*>AbJG8~Fm^LOiaGVl zH<&M3^(V_&gUjyT71OzkN7N7^9nGi(KBykhm(B`t<| zkAqd?!l&VCFJVFEDyYFv z^xbYSgwHx)NGoRPDrR)*=sQZvb?E0-L`EjaHN7LLgm(ae5q!0~Z>#TJLe-=iu^|JwAl{eqfi2b>;t%CY_h$Ma3f`|DxFHmxAuVIEPgb%=ae z`OL8R=;<&{bsjh?jplW0QErqFY>9JHh!bk-{WZ0pu753F96p!x z-$DBkj~|N<3ua8-HxmFhZ+-6CJl@}v&4*+M0RmHuhx9;hjm~+0&WG(uxQrzh+bP6I zw8LP6Z(dKvYdy6Z=6w)-rCk7xeVQZU2<=mGGR}R2H4;duCCzvI^`C>x8P?@Jq`9es z{|%wjre3szUZDZSS`8mCR*TDD5tZF(Q8WcrT@+P&r}c+yS1)MUEgZtb^rclg{sDlD zaDP^NVR0x@ud9S(^%z5{TaUYE|B!iU#36sf-okNl%I1E$@3l>R^dAn~1D*!P95C&B zpreLz*)j)`X@|^p<$OAqcb-N)v+~Nfl;vj!``x7t(dAOD?1C^^tlhe?1@T%`wgX9AG5!O5F~#RR zK%~$Q@1X8laDTXG+^63KbU1-$c%o4rnJzqE(nz`xLV!$Skw_0Gn0CtoF(@nR()e-H zCPDJ;`x~MfI~mixZq}KX(VQkljU8zmAjq~?L3oKQ%=E*wO@)d}{|#1~E2;-+gbR$$ zHlI0{lzSv%HK8+!6@^D?zzl_m;8Z9IqGC6Qird8&uE~d%S?{7Ud&-_8JN(kG+o|s_ zf;kk`TRxOPzcaUifwe+r>|_&X*F{wHU0Gwr$*GzVEKc=qqJf1a!FaxV%1(>`9qef$ zirM6f^JnH^+3Kl~aaGEH(hXy+k~lUXdn+ zPSM>WT#_5h`4)>OAY-SSc~^=l49n&RJ*XWf0#p1w>Z7XW831+d2{tf191k=p?axu9 zv4Dad9{OV`fU-W+^P41Xcd2yK+U{6wQF;i13k@ojO%>G&w@Mj48#$itBZVcdfK<5% z$}3YhUJ84K%QszkG^C?9bic#5&(K3_zcMbx1%9oNClc0c(K-e^uDpj3a>fgfe8HIa z@Sop9>amL0;bNJWT#wY8KBl#IeNEY%?cchcVOhbnZdwaHd^NN=hS&8`IX1iunnbeu zXobM)r)<+E$wJsR2%M%opSF6t4Ozf0Y34vdO_^g}vIhvZ?o_C(yMfP3B-O*tRg|+{ z`owPsxvizGwtm08S#Xxvx+RhjKfiFr@7qK*{m_0gSCe{4G<4diKZ}#296jJUB88!f zdjse^ZvuAq^&_E8abz!8va17)cS#l_+~Lg*7IUVCy9Vzj0qL|0^?urO zn$iE5dJImstRSoXFsdwH?FwT)P`O_3n{)sNc?Pi|{wMP#?*n?MlPzN&Ciw@qe?}#? z3VE|S^PqKFp$+t7oOYG3nYvXAIqo}OsA_(1EhF;f{a@wqzHV2v5cCe5!$4IzPMgU& zcuCIt?j8hbcY?!$bm>z}tJ@iePss-?aAzeCE!9!cicmRt38TNT-<~wzI-LJy2WiR& zMpU&f(+;vo^T?6!UPUz^@LzuxwmsXPwoVsjTUF)H-oZb` z@{S#a!ka_SWzQ1}07NWX^Zn(qsx2d~A_`2%F~E zTDAP$4(4WI&D|o_mK2+aA#Yd*6A$W3$Zxtr#EpGes+lNT` zyk#k)V)x-eZ|7j&;0A_A$PUVV`cfu+qq_?jLo{x;NN!0dE;nS4kD9M(Sf<#V>QJYvtR+cB5-N+O}Wh)@1Z$d&5G^&U$e#b9Ryho2!+ z>Roc$5$X*}_EbIbV%MN?9CYdF;f?tFc#JJov(q`yJSz zlKu$a+I0|yQbNWI5SiFvi0MjG6@IlUBJpv17qc7;6w5aYk)K`V@Cm%@B~6 zXri*EdnT2f*s3s28>ldlj9!6-(}D#CxwU7zXg?9P=p;Rf?7<&h-<#R?{>f`LKpKF3 zbxp_n2BPbO0M8^JKXWGu0H5Kk_BV}-%f!wY?-{=Kmxk#QeJIk#1mZub-j0-406q4t zCBd)Aref7rl+7B(=Y6GObXPPNT~o>@x_0KNKK^_*pG>aGGo~91=uw_;_mZGqT6Yb4 zbBJ$>N4aSk_lCdfQ-yd>N+ads7s!iQ7+Y+TW(tS6I0mWq6er^z*Iva6lL>Qx0gDls z6h+Wusn6pf;)U(q96=uB`bUbCUe~5QNJ7ub%p>M(7`ReD?w{8(lk)bUG-{T? zWOXcIJz$M)*#>wZFKiU&C0wRH7>#PvJcd3Of%M&T0uWS(M1q};M!4YhaJ|)p%qiua z%dl6iG-{7^(o=;|Je0$gTWJJlBZJ%yY|+tLF~v>BRHScIK>+& zZ8R_K7-O2FB59Vk!f45?Ofq^~;k+p0>oWhgv9tS$TXj{>r@AJ8#xVB=fy{VCS$(z3 zrbuZVlQC*6d3}R_lYkBq!U2kmg>>8KR(#7KFy#bXJ(+ob+7dm&_>Ii9?6@r*cRZg6 zD-}s}S3$KovQ-UkWRW>0F;!(DzpPdXi?!R?H)@a+qGGV32jg#R7}7=epj=i6xRXsv z0+hVkJ>6TJ>34~1e{OMWjlJzQEM;880NTWkbK+u5qOHR1k=LccFn!cfPw(eCi`cDHef2&PE`2v1RcqjlW7!LLV~c31ngKv+haH=GMAT-1{4&uis^r&gnfphs#etT^P1Oq*ehlLCJdgdmg& ze(r+qDw*OWZy>nwjw&y*>ZSw z@gYY>Z;=@_L+FB3?b*f49zwqM;$i4W+JbbJS8(Bn%men(XMoZ}AN_~_YeB8g1e4se z&cYa?#9XAY4gexnSnT+y=N-{Sh>9qNULI7n~n#!z?0w5)Pg+sK)eqDn&H>9ev? zGZln>P8q^>E|5s-zztJGAv9sf-%ySpIMfA=Tt3V4j9v#iEfcm+Kh!j3ntmBy zO%agDB9Q<)GyijurqC4IlOb-Q4;R=p<)afQf3C4529;J0knEJ;aMhYnV#uKlZs>C`4y2b{u!APM>P7y;~C@a3i397{0 zE6;vy0WAsd2ns!fnIkADU_{&M2C5d8FdDbOeDa8jb$8`T2d5Yn-snQ0`SLdvFFtr~ zw?LF213Im7vtmjg9YOFAqzY>QIOjMZ7>nb`<91zn3uqQPVl;5|9@brM#Uii7Y5IPA z7OOcXtAP5@5)=92;)C~KLYfsBejZCcc=@a@@AJSUEAC4`Zu|Kw)S<{S3ZbY!_?`Ex zPp3o;%xpX+#$|e0CK)+KqCh!0AP`Zp`)pB3@t&=QltzCa#CYh#l5?x7HeuW%8UYLV z$p$5@`b?lTL^ES)Jk-;Gz7F$GL#d4ME%g2AquJ4WI#U@{2|vZAy3mq%4MgCx1s8)o z0j9wc>M4%&8yt0bc3S@6;GqLbk~N{bpfjjTFc7Ff zLrq@QMtDULVog7ib8T^d3mwo}ze)o#1Lw9B+SK44a0L)c2nd8H#sVM62$;J~ffGWy zLYeTJ7nv{?3Y(>FDh=3A;WwBn^zkC0jT`}W%}jCbQBSbCwzmLdfgO&U;7D3dY@Oczkpzg9brSQi6e=x856T#ldxEDCJM zX)PTAC$Sh5%fexp#D+;~8Ik&G%qvY-W)yT5z|G_l{2J(UW4wK=aDrtdLlkMVU=sPP z0e{Vz=Wz}B!9JRy1aJs)h!%=>VE~-5hUUn@oR(179*i9v#FqsV^&p9|^=jgcDZ#_q zxLrdO9g9xdLH7~H`0f*;kYYcn&j27oUU^7xpbMeN$V0wir+s*nfbqvU#Dt9we4ry> zG%@C5NR94jRT9G1TR=5dm!PQhY17ntzr`|E-VXkK$GH3YI zgbZ(EP54FJn^?=3H12g2v!jP*JMa*7E6UY%7fMCIZsG$% zPiT>6uKYO-&G$LC8@%P_s03Yz4lnnySYT>4Et1hzH%50V)$+6qKj#IdaU;caGK=!O zq<`NWSKT2$HcjOxL@wCzH^VMv1Y>!QmmaYpcB^)*1g4cXH37d+nX@_ycv^WcuiMQ# zEgdVzS!r3>!=#v$S#-(N_1n!tz00V-3pzxwy%g*%6g}{P56#rO;uY4n&I*V#r zO584AKmbY|6p|P=Q}Rq7l*K$zhcVr64$C4ct5CRCgXJNGptoejLb<>$au~bKIPU|y zS-MGv>vVzfxGvS_(LO*u%=n>dvkhv3BoR0_Kr*@D3v}a`JXK78PA-?Jr2zKWT87ve z9P}Wol@TIegsHt0?i_H7)^->$83}QSlw>28BsJ3) zAWl0qGIR*pP8suYLv$3P zuLM?6OAk=jwl z*F@+B?`fOdBrSwzib$x)`Z)1rsPhxy_#xRQ$cy#yRphILeDGl|2!HPd2s}7O2{4O8 z^_J|1*8}9Zu!^$R+%<$m*Cm-5?}aym3`G{~fU<0?dJFL;vOS9uIuE_$Ee59{3L_rT z!tUX8Va$EBpCHJ>cz4*f_F3Ks$l;=VEhBQK(AzQ&ydL`{C874Jk_{1KZyM}F{PHPr zUCA|WoCtYXG9E5Z$-`s6q8oL=dl!h>wgaE3Q7G(Ct@v+=MHeXz40*sTn&^AmPYOYZ zqVpj8=MH*GkPy1yg7g9poJWYb&1xni#*&e2S!3pi3$olz)~OC5-gN;`w{ z!jiV1CyIe9RrsLz8=*L}3=$I495q}SjMiXM)VwJv1_$o;2l{>sNSfHZ-q3zI1r2&0 zQ)br)a8F)0da~Wj5vY7!xv!i-M(A4LCN(-HSlqbfaC3~Ad=;YaTGbHSv&4}XzDiJBgd79?V3G9(^xUBpoxg8y5)Z4<;*!yK5Z9Mcf!B=lE>P*yADv>HWf zwa88NQZ8A}OJsB1>XH(lxUvc}VsYl|NAzNub%WA4PFwG#=9QmFmhqhl$A)J2_c*0> ztbB!H?y!NE$?Fm~DvSb9*p#uKcbV_TA93PT_4SdwN>>b7lnMM;RkFunlq+W`z0a3@ zD#I*pl9Xl$HfyT+$&#N(w!>ciIJmvIdu;G7ZLFg|4-ada$Uq!IXIGWB)!c!2=zOf5 z_}cJh^bXA56xib-n(ylrQYn$v46l~)>g!ZRrKS1`Co9mdfB{QeR8g@T(X);TnlWJJ zn2b(w?f(s+ONJ5>wu2n*;+GtG!Q~AOF9zq{n6?mSpvh;`h2nD^>74}?@xFjT@1Hq37j-ABtH`6Pza%PQbG@^m)_Qx{dXy}&TlED0@q|Qr1JOG> z(bq#9)5_rI?JCJSvUmL@t`EUFQ;RytnKSf9Zgocvh?wzWTKHhbUtvDhDUf>TY~J;| zmPh1QhOe=5kHgF&+b+~Mgy4wjmOTxL>=2jE7dp*s=iiZG)*ls<+4yb`OXT^i2Ll-G z)nn-t?9P5oUDO?QH&&vYqLc;h2^H}I>eFSCoaFrzU7xm(&e?piJPV?5$YtL1nT(yh z%xkb4?=iPo0BwMt+b)tMw-e#Zxcf_--hH*2aZwdKUFnh}6W|(;*YvMTux#^*E{HS( zOVAOaosqA@=gPTv^E%S?Y%>IyMdga!S9nLCG8GNCT$XlRA7Wiqwk@F}V|$a-=r8T+Xy_WMn0}c-k&d~f6OHTR z;l6o34k}DqM~rW0+bqsD=XQwCz^ebG40C)My%$)33Ncl(z`br+nCakWhN%AZ*j+>T z(I_uik1Ffv=ENtMWVMiUdV#x$7d1W@F-dGdl+TtGzhx$JV^7brrsqsJ-_}>Z?Tqzh z;vg~`LHEq*+pp$Xoi-gy*bdL9(C4bhp_TH69GFBQ&0SxPz6h(V>4#vu__4ugPCmB? zbVw}r(!eIjL|&p^<(x}H%hIzmLzeWUHt5`lvFUi}*Sc{rLjIt7Iwo_Nr4#}GJ(pYy z3PHqvKOb=iMNIHKR58?F=+Nfj5@M-j!^RdI5e9LfUU$%dgdK+1=>R&u;JlrIMr7nl zJDYG#c(r<`SUYQ+=p*Nh=$S=d$P=d6?dWMX)6t192yjSm%8jrypH4DIrPxHZVnW)D zOt%#`NV$Isbndr8r3<5e=b!-Sp4OrB-oIFf-u#@Oo8n=Z*d5kZr^i{OjF!zQA=Lgx*93MT(v05)J{qIERayOzu2Q6+JRRgG&U{=soL zs547m=Vb4oP+g_+Z?n8@iRLl~3fnmG!!#$*M4+aXU=t zK3XszNmz6w%%G;UoMv>g9?lkfOkNQO-Iiu}KgYdnFeWrZ=v@W3iqJkL7LQH^LS;u3 z>SdHCT=bW2io7e1sme)0qSKFS?r-k37q!;y`yIOs=R1(+#U}NP?vr!?XFqYVz#zg1n;hH(4rwe_k4THn zmU%y-=FnULp~7M36aaxCrkmB*U>@Zzt~9)My;4lSXhhcOe4(7xq53P?gEm@tw3lFzBeHv^ zu(Ba!CS{U-ri8QhlQ8iC(PSvag-V+N#c3$Ap}E{rzw!qg8t*goobQ&n{R0%Pc6l}s z!vp4rfm;41634B*25yK70%26`C-bZ@DrB0ihvQT=e@R&b`$MtjNrk%XROBe$45J@JQ#Z*NoRj-J??!@g*|M;mp;{*fRVGU312h4tkBa zjkEr9w;Lsace=QSPa>-{aNG#Ly>v~U>Lyc8wsAs~G>||=qn^tHB4Ix$=YV3AGeI|E zgifj7T%H`4q>3c=xe{_$%EVi9J%U?g_rr@I+4MIC8>S&}9~dkz?MA2OMeZUxtoD8>esfUqm;(8ZECBA5n<}ce5*^ zyocf6((KGbEX8fa!);>=wZ7VS${hA%z!%^O2qwHOi`6}$jE5EqScBNymkl}VCpnj} zk)Kft}iOw7L`Y6Ji%jJ5NNkUd~Cypib-|V{F>si z6)WjtsZ{GSwYD^NsG63ksm0j^|Iks=>YcIvBHKVZRN>lSWPH?7=U-HV%9*K8^|04C{W(IxC% z`7KdhcRHyuZ94t>Qpu5iynfc9a=#)XaUoAg>q|roIGmkja)boK+zqQJoE#GFjiTnlr(R&Xv!ujZtSQ7UE zN4O?oL?0|!8}p;d2$2LX7r2koiBiG^EM~O@HM86&)+Yf)@u5f)X&rqtP_XWhYR7_o z!qHWt!yt883*N!cWfa9ub=`#K<*t22Hcv4pi1J4dWh@I2ZnGUJx=|wE=D1DW@Ty$W zPgLfxG6Dm-2_P#Yvz#-fuI7@J*TgN2TiT?BeGE1s=FeGM8)r&vC3zu;S8Y^Lv6Syn z&eG8>!?e3quN-+_mA{&$`#pOJAGNI;cXf;HB_qD(4ybFCV(xe}ThL!r4XV~)eP>IC zli4?r?nJ8@Y+gdH`G#|?b{6?g^G5VA$X!Q|IGF!rf31fbVSFw4i;rYN> zuIRyZ4$SVS)K;VbtSANle8TQ<4gUnn;vJ>&!IZQpKXrNuU~Y_uYkauG`PV7h@Os_L z9>NcXbth3Io2_X_7+RG1N%)iiR07)$bNLwQCdr&Z;eF7NK=0+C((Y30&Ali+CcU>d z#fteeZtMGtb|1*DyKTQ+5MAE9V|BLY@)LdKXPOhE`B2?HW{>Q5tRJ7cpj`aQ4k%uJ z)J4A1X>o^5fFa{Xw7q%_L~;X4%fBvY|=hA!i1gdT%t4 zLOe}WbZ>u$Z$(h^QKuNsyCLxLa7A;JU>P;{5;kUKu3G&jO^q{-)3fYMVZHL9VPO#A zmm5B}vmU5l)r#bCUjQe^$x zQ7{!cl^FvOMmu*I4#{@-ul^AeXEivN=zYcd?EFgyecYRDIbpt>@RI!W zvf#o&C;B^TGvZ<7EwlXopE-bH>fV9n3!w*W{K-oRm(>y0*;c_Ryckic#0cDTJ}?fU*+O95_3<%xJA$4>;Z%5mNV+})I^LP?mEqM9QF9&RrhTxSEy6v;}Hu4ytEaavCKU*U1Ebq zGV=7ljN;1;i4pUxZXlhUA{UhumSFC1O&Pj11n|Y2%KLIC)hR_Bf$-}$pJ1LR;e6&r zsFQs-60?~TIq`B@y5%fUPYe`j<|xsN;N_&>xWCO9ZChMxq`b+Yiyf9`_xD8>?8@m= zSkwfrAtOJg`mtz<3qsX5MbT}wm6TA@ZOVtL*mH63e@eG#*IrUWL7~cPdT@Kr%P7=3 z0^{->>Kc8x07QPUP&~c2GIKXzuPW6%alTXW$Gkt?P9fClB9$JaZF*PZH?B|MH_Q%@ z;=Fl&|?6#-_vOBtj3f;Emf@TDrm2Tr8+{Mm{Ky@tF+c56@vUJBbo z+Vrze)k4zn;m?EbHdXl*nJyM^bc?g$tTes|rd+Yax6uU{{u)#>r?fN{0yBJNpiQAn zW9WGFTSviXR-`kdEQ5n;!hV4xs2D49#Z>J!0%1`huQM?X@TL$C>UC!BGv}WMpRs>T zBzJ-8;l<+1Fy^GoRfq|p<_K443mlV^6~_3L7_P{0?T`($5fp6LnJyN-F50Uy!b zYwDNM{5EM_ZM zxAJ(A!XT0iA}tJ|_{?7r$38*XEW?OrbPZdnry-Ca+AU0Rhs*7gF@+=e7WL5Alse3cax4)=b^J9 zPO$9>dT}m@H7v6TV z#+=P7XZ|Go(deXu%bHX$ua_TM^(`2CA0oVvL3$-)vVi9!P9!;=+*eOZ|AHUZ1{UD^ zK_iD5I8gA|)(5g##z_V?vA>GbX3qIXw~7i~X567uZlYU4oxIHU5IH$o;x7Z;!NHh& z^9UJ8n6SfzDdUfAup4gTb-4x^?27DvtgCg>XevL>!3iS7whP3t#SrY|Oyz4>;&Qwn z?A7rMS&qgll7if0-SC>WhmM_D>8YJNh6>`V1~9quDtU1%il-6_E<+2yJ*>^0YkZwt z7pEYE)o*~6N+@`@k8eK0rWw|9{Iai^KLI|K3w$>tv366c`zsOoZTx_kkhr&Y2ix!8KaitnC?JA0l&}D154F zA~rvJ&&ag*aIV|k=2C8l3G`FF&3=vM(nE8HVTrind%XfBorE}4meYs;rvvW`Y=r*` zAVpRT#uE!MA#ti#*8b&`2yIS$;(~>9xL#Qkh2B}&*kNld<&aiY+VY^^VxOTv0?`ik zq;*~lI=@V0!5zo%=4YN(l@Xez9J$kFiIqyce$Hj5lZ&6b!~*H#ekai=LL`qdp|rSW z5NV~&N^Yh@Q(im$oXdx5H6hpxFo6iSR+Iha{AMm-paPJ!PInW2)A-e^~Ik z&uH*9*8bAAWK~7dPCsi-NFzSqYwf>i@1U9u^_r%apD>yr3B#ePCGH;XU6riq)1#xU zl{|rG`r-NQ=NV{l*FZci<)W&A;yI3w78$)ji1iz0BV0c#FFZ%+lIV8HiB3IN-x~A_emP7H+eS+Um&j46P#k9M zM<4k~6{xiIbHIa14yQ;?zCDT(FxFpIe->CS!k8`8Ag#OC) zK$i>K2t%Nf?_KoqHb%wuK2@}?9N;XHaYS|P>xazKfr4-3J#$I9Qk>mBPO8rCXi1rp z`ACwb_^i{$;9#l7n1piVbcRwfV8oQ|_pnOnZ?!yb!q|LCVdne<+%!D=lZ$lV`I$S^^OXYhh}d_*OchcXCub}!-Vduu2~kSG4GWtz$eSwLAExbx{|Do5*LEet$>B! ziMg=vn%sq@(!?zp&b-d<)>I~xS-uXefjhc2imAeXeZ(9-n zt==Bz1LZOWkH9ITfE&()R0 z?3m{^)A z)wgDw#dopuwIQPt9P;jSuzS8{By{0#F zMfEl}S=99@*TpQb`)^H`Ukf`ZoAgDC$Pq8{I&q)n9fKLjXbo;6zV9WSxXRDTNGt!? zD>|V(DOY6(TM>xd12;l`Br1GknKL)N+lVzKHBHOqySUJucYAMb||9K^G4E7Yz$`MUe_)6K+do+ZI_ zC5H0A%CedT!Qsrt{a4J**xEo9NPad4;T6^7TFH z%R8rGa(_yIt!$>%K$4;~ccm~ops~w8m36iq0kf*;t|3F#9Dz)e9%;1P>P(mv z7exnm(Ha(Wx03Is*&tMW5m@tCDuFh5mRveV{}l8ze|IEHlMBqbqw`Ge#yedT&h|mF z5Vvac=xuk=obLYhvh0d}o@_FE(Qp#0pS`{XJ#1Y00vQ?p?{k~{0| zV5;UA9;q{2TbCeuOl6=?{+QN1E2Y`Z-eX(_dVoNitw{RfNe^DHn?@N1U++_*n>fKp zza0&GefhB2BP4--`aSOh>6daEdg8ejG{VZa=__D<`2bbog#v1#+lP|D|QU{ zz@+hYt=Dp`$tZ;&czo(g)p4byeoswS!)?R{t5Rl5u_+Obuj%8r%%*eS=6$i$97Re8BK zHay;QT($a_7B3sA{h-S{a41ot226J8)=lhbnlGBhls>3tAM(ta52=q8R}Jg2M);^Q zAWEOrI+KiYu^znizJ?rjdwaDtt^F+K{n|^|W+a8WS}P~-_Ru0PPkZ}S!`2WynJbcb z9u&Nxh{u#`f;G1p3VFRZ@3H12xUZM-mIquQ_c5q+m>3G2OiPk+>t~<2*(WgQ6P~aA zRQ;9urf!!>ENK4Ly%xM;l5ej2JDTmt1J}z|c9HgLYPT2d$u;G*O?I~kMlwe794a+% zvs73P+WluzIv;<`SNI#1evu*e3<}N@W^@)ly>ow(B9ZF)K2b~**03cuYCqeB!CqOy zcaZgAnI12gnVnuJDd>`VawLE--#^HTI{=Jl_bORp1mPYRCF4y)}iw5 zd^i_5{``Iz37<5>wOFw?txs+sy`b}y+kkY6cegRxy2dx#=IPq$%?I4_rvYKi;G^cL zOHIh@(VLea6?K@ycSZ8jKa`N&o-Rs1`^xU1HhtTTTc9tEnm$+eBmO-33al3m^h*Ol zMkB+?57EWPmBzY0T#8Zx&HOWiw>`7-xO{Z&IvZma&zSAeQdtj+~qX)1Di?P>C-IhLoPyf#KM({WCQ7}IB`m#?Ts-#jyGUg znIPLDZ5O%KlVdp{t6G+u0F~>~1A8t{CHZ(%E#u@0_Z?47>U1VppmS*r)uKH2d%P2pQx7H=@E@9FV5TUzgcg^ij$^qY_T5(ERP-1T zq-r`ElD_E?F2SFjg%@hDj)n}fru7Onx|~xetS-$wHAQ(^gTftXQ8w{oUMb1Yl9}3! zvcsR4laRsG8EcUvI}33E-l?1A>%{h-YZSSna3UGoC$5u!$a>$IiV!X{o8Kgd*oPH>0g--1{7pK8eeT|@7mu4N_UZhn z*z&?vj@~L_Onu{`tp&d9Z18H+$jY!m7OD5SKP={Bp%x@H_wjrpqfxcJp!@!seQS@* z)^WsK{i%vDy0j)gk7vXXJ?AP;;Is{!cTezaTA+_PxhalA!EE^HV^rBM!Ehp!bT zR~r>#nDp|eK7anKWY=Okfh7W=eyK@qgHaXPGT)WvZ?wC%H0qCEQ0cMgke=45@7XH<5E(*>aYEx0s9$L6^(;8)msYn|RG_@r*TX zsq0Mo+8fB{@bO=kd@U>Pa%N5o#|NNS*tkz6?)Io8@KqT;@T(w8(z}vu3HWdAdfK}B zrxV*l9*>jPJl7Al_BF}BpT{#A}zY!PI3P04D#~uUG;iWTH~?>f=iOG zD)&n41NuCU&5Kctk7v1KSoORKU3;h2hKo3bqvc0?BFj^Ws4sRu*i=ZoW7|_Ke7Kb8 zi_dZU@k3i$0%JW%^d7eMzDRXoWqly4JnAvh#!TyK$UFz9t6-m#kY9rFee z>d>9tvvQXOPEGjgN47|PmUgcH9sxSHCNE6l zFB~#g6qNR0{UJ(h1@^o23hp^sK`ny{@9MHaKAU!P13`dc0BPVjVAHjCx;U;#W&A0+ zfpPWRl-GAixBFm2z^;dRV$;p3DBF$UQR$^wFI;jA6H+@0C19g8>{2jEU*r~j_}vW0 zZ91f}JX~Jfe3kr(0}9hq;)xbLcER;w+J-f6JLR*%RsbNys{(qV-*m1cY+Pin1wrR2 zG>Y8nR~Qf5XkF0E3*Z!Jt=`$D718kpIg}#sH+4@}aVMipMDKLd_@eW0E9ApHqs5jHX!gAhR;}(`lD%XrEbo~voetu3 zFJ4}MRpFl&^INGsS9%?+3(;pFUb$Ov zIiKY^o)^<^yT{Gm=w2Kc^KLY-6hV1sX1U1j3gZFSJ%_r@!24-tgw zFnc`u=r`E{s;}`5)#H56zW+jw8vLoLFDqCXLoML#;TK;%x6Cu^EOoTjV@4N78vSlK zhS*$^pI&-7*3f|46hkXKSSp`>m3`BEx@WK!{ziqc*;9*r8$AP)cQ7w%sPKGA8qmKtJ=!^ZGEw2p+r% zs&#YGpeIyAx$rCnP3Z!bya|woE7miexb_7r({uJ38$DTjDE(yV1CzfHQLx<2l32j7 z)>H`=%SawZd3YE{T)jp;!5$W`PdzwwD z$n=%|pHIt+w!*7Z6~=EHLIMC@NB{umzxTAfg{h5=k)gA`DszJ@DaUpSQE~)8mFQ z%pWZ^^7SKw*y=|(k!?QCB5D==t(^NCo|vUfA;tCAaM*$y@kWKw`>zJ7r6%0*KiCs$ zSF(c%+edQ_Mz!7uh9HM>BY*BZC3P53fpK+v~>!q(2yBIGzcYMH;ZPKojJQ_GQZM-{0KWrGhfPc zLauEmU*hk#2VJ0ei3sUt7UGdaScm#T_MnsxTOEu?|>m<-{SCY1is=b$pVDv&P3=G4lFMk~nO5*8{#kbJL zwZ|h*$fb|Q@|OPn8PkR@`&efiw~Aw8@_D%BsEq0(e8ALUZCD-D61hbODz1`SM&J&&knj>kfAPQ$bU6{4>Upx@<;%Ri1^wX z(0C2P=_Z|9QcK5j(gCe+ULM-q)mneQWHc8ILde*3w*cBrl1MveIp?v)7R|Qo-x^%4%R!_E~nK_q)VMSe)Ze z^f@|jl3)#OXYNTO!diBgmjw)^E7I|k1V+YMdw4_C;nY-mi~J1hc!Z8|UANJM%=&X> zQZMZCinAyLK4JS1ZaQN@{pTbQU$1RI*Uci7Q~^axLQFf!19A|QR!Sl{oDUO^3Uv;+ z6$`dj&_N(xg;uIMuGb`TP&G}1AiV|26$&&ea+su?%AyOuq3)eEMJ0{094Oh5%U65X z^i-<4=^`uJHA=;Am$pZtxlpJD>t*IF*a_2BhbK~3kODsv?D%=ZUA(bJWNB7tUr79G z8-uV}!89sL*;gV+nlAAwBneLs;_+VkP77Zd?oCk&tcV-LHzPaBWfdpbV7+vy5PCVy z1t`CBI7CrvKyp3F+<&XYTE15UZ6OL~HNTyG$4kj}oL&DJ4ZFt`S2{h2AaU!ehQjFR zvleQ`!)!O6a8f+ZjS1$>a~{3%)k6Eh`OTxZ`RW9;SPI|9vnwlx&cd(a20H4;#4pdo zj>gj4(H{nGa9ukC7q>%TQLiY4^dB}dw~m0X_MCw+G4gwIIF!r%E=}KtnYffYmr$-W zo1uf5pVdOc-YR?j1rl#}*OnBz=lrHEk377?nSLS{NBx0I*b}U6lx@T5hp04j-}u>= z<;VTH9>21ix1P!yUnMH8o=a_qH8V8<{Bk0FTylla4SHzDp$-8u0J$yqcG(@x(E@lF zfu`=Vsu2WCxws=DkBfJjATH@U>O#FkF8Nbi+=!eX)fgCNdY_%7WvwCLg>Xkz>bzdL z1!^SWaYnvoS7svh3>LveT=1^&(OUXbS^A@IvRNdC4Lqh}5&24;X)R7baZTjE&}Y*G zUd-QB{zJj1osxqWlwv#)Mk$oO> z)S%2UHUX8xkNGBffxTFa;VBVAJ=i4sNpM}dJB=-*iGo;CZlpWUlfdN@+UM`BC{MsB z(CkD!jgNp_M>3-&tDGvq!mFI#z~3dJNGGGIG@;F*&E87ipjRs0{%~(g zMt62`k^ClEcAV}3OEkjSsRQ_@u-333>RE=`esMrS-+_e#0QqkV3slFM4k+~dJ19`p zl;}Fxeg>@IM}duPi7JTvonIYKNOmXj#g+(zUs?R5OZYlycM9kbq1?O)#P@Vd&%xQ= z(sYYBKAyj}&*D+%o?gUHZP(VY(Cl&B%!tJj;^0s*C7V9mQ?IuBH(V<@gHe!H@AfLV z)(1zy$%;(J?Y|fEMVtI=sZ&|JPR)N=Kw=ZIeg+X2x-KxTGoZ@(r>ayv?`nQe-#{0E zYAygn0?z+XRi=OHnyn~kHNb$>NqP5y4 zlYd;q`{@&RVfJ#u!U!yyoXi-Tlt^MRW-$~c1S1|>jK5^=khHZc@(gG34PE-i<$h5P zbBw_2;2z%D422+X{=Jjt=dtc|X49C)4#(TjN;d2|!_1JYhxWkRY}21w@P6#N?9bQsSYCs|3_;#0~XOgK?}J4mr$Uwo&K;gaBpX5YpVaZ zhV~EZ|1nPdjywgOQ3Did_=W>f&A=k^C!`Vge~2_O{d?5{>-(?7YrvGo=ZDdEX`p3O zfUQpWPed7DrT@>p`R~d({j=E_+Ijq;DzN)9&@uhRedKv4Yp9R5eL4UFg<=2Ne_w&! z`9A;}+gSb$2E1+jldtkN_@+T5B}WMf^np|;0D#b+v=alG_dkIBqXYe|Q~ia96C

    Yf_`{OrK7rIYH90Oa@WROx@i{;$}{*2Tuz(&>-8e>w*z#@~CyPdEi_ zW$M-^BNYI^9R&m+^*aRMWAyJ({@w`;9UR;ofnPxXNB!M_Fm^L)zhn179Rf5)(&|2vq!M!vsu{xwYfowN5JaQ-W3{hji! l5#sNZsf&MKn?ERjix(B7A%HOj0DunsD8m2%U{`+}{ePlXsp0?t literal 0 HcmV?d00001 diff --git a/src/vfs/_vfscommon.vfs/modules/punk/repl-0.1.2.tm b/src/vfs/_vfscommon.vfs/modules/punk/repl-0.1.2.tm index f2977c09..f976ae57 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/repl-0.1.2.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/repl-0.1.2.tm @@ -3,9 +3,7 @@ #todo - make repls configurable/pluggable packages -#list/string-rep bug -global run_commandstr "" - +# ----------------------------------- set stdin_info [chan configure stdin] if {[dict exists $stdin_info -inputmode]} { #this is the only way I currently know to detect console on windows.. doesn't work on Alma linux. @@ -19,37 +17,46 @@ if {[dict exists $stdin_info -mode]} { } #give up for now set tcl_interactive 1 +unset stdin_info +# ----------------------------------- + #------------------------------------------------------------------------------------- if {[package provide punk::libunknown] eq ""} { #maintenance - also in src/vfs/_config/punk_main.tcl - set libunks [list] - foreach tm_path [tcl::tm::list] { - set punkdir [file join $tm_path punk] - if {![file exists $punkdir]} {continue} - lappend libunks {*}[glob -nocomplain -dir $punkdir -type f libunknown-*.tm] - } - set libunknown "" - set libunknown_version_sofar "" - foreach lib $libunks { - #expecting to be of form libunknown-.tm - set vtail [lindex [split [file tail $lib] -] 1] - set thisver [file rootname $vtail] ;#file rootname x.y.z.tm - if {$libunknown_version_sofar eq ""} { - set libunknown_version_sofar $thisver - set libunknown $lib - } else { - if {[package vcompare $thisver $libunknown_version_sofar] == 1} { - set libunknown_version_sofar $thisver - set libunknown $lib + namespace eval ::punk::libunknown::boot { + variable libunknown_boot + set libunknown_boot {{} { + set libunks [list] + foreach tm_path [tcl::tm::list] { + set punkdir [file join $tm_path punk] + if {![file exists $punkdir]} {continue} + lappend libunks {*}[glob -nocomplain -dir $punkdir -type f libunknown-*.tm] } - } - } - if {$libunknown ne ""} { - source $libunknown - if {[catch {punk::libunknown::init -caller triggered_by_repl_package_require} errM]} { - puts "error initialising punk::libunknown\n$errM" - } + set libunknown "" + set libunknown_version_sofar "" + foreach lib $libunks { + #expecting to be of form libunknown-.tm + set vtail [lindex [split [file tail $lib] -] 1] + set thisver [file rootname $vtail] ;#file rootname x.y.z.tm + if {$libunknown_version_sofar eq ""} { + set libunknown_version_sofar $thisver + set libunknown $lib + } else { + if {[package vcompare $thisver $libunknown_version_sofar] == 1} { + set libunknown_version_sofar $thisver + set libunknown $lib + } + } + } + if {$libunknown ne ""} { + uplevel 1 [list source $libunknown] + if {[catch {punk::libunknown::init -caller triggered_by_repl_package_require} errM]} { + puts "error initialising punk::libunknown\n$errM" + } + } + }} + apply $libunknown_boot } } else { #This should be reasonably common - a punk shell will generally have libunknown loaded @@ -2817,38 +2824,41 @@ namespace eval repl { namespace eval ::punk::libunknown {} set ::punk::libunknown::epoch %lib_epoch% - set libunks [list] - foreach tm_path [tcl::tm::list] { - set punkdir [file join $tm_path punk] - if {![file exists $punkdir]} {continue} - lappend libunks {*}[glob -nocomplain -dir $punkdir -type f libunknown-*.tm] - } - set libunknown "" - set libunknown_version_sofar "" - foreach lib $libunks { - #expecting to be of form libunknown-.tm - set vtail [lindex [split [file tail $lib] -] 1] - set thisver [file rootname $vtail] ;#file rootname x.y.z.tm - if {$libunknown_version_sofar eq ""} { - set libunknown_version_sofar $thisver - set libunknown $lib - } else { - if {[package vcompare $thisver $libunknown_version_sofar] == 1} { + apply {{} { + set libunks [list] + foreach tm_path [tcl::tm::list] { + set punkdir [file join $tm_path punk] + if {![file exists $punkdir]} {continue} + lappend libunks {*}[glob -nocomplain -dir $punkdir -type f libunknown-*.tm] + } + set libunknown "" + set libunknown_version_sofar "" + foreach lib $libunks { + #expecting to be of form libunknown-.tm + set vtail [lindex [split [file tail $lib] -] 1] + set thisver [file rootname $vtail] ;#file rootname x.y.z.tm + if {$libunknown_version_sofar eq ""} { set libunknown_version_sofar $thisver set libunknown $lib + } else { + if {[package vcompare $thisver $libunknown_version_sofar] == 1} { + set libunknown_version_sofar $thisver + set libunknown $lib + } } } - } - if {$libunknown ne ""} { - source $libunknown - if {[catch {punk::libunknown::init -caller "repl::init init_script parent interp"} errM]} { - puts "repl::init problem - error initialising punk::libunknown\n$errM" + if {$libunknown ne ""} { + uplevel 1 [list source $libunknown] + if {[catch {punk::libunknown::init -caller "repl::init init_script parent interp"} errM]} { + puts "repl::init problem - error initialising punk::libunknown\n$errM" + } + #package require punk::lib + #puts [punk::libunknown::package_query snit] + } else { + puts "repl::init problem - can't load punk::libunknown" } - #package require punk::lib - #puts [punk::libunknown::package_query snit] - } else { - puts "repl::init problem - can't load punk::libunknown" - } + }} + #----------------------------------------------------------------------------- package require punk::packagepreference @@ -3543,34 +3553,38 @@ namespace eval repl { if {[package provide punk::libunknown] eq ""} { namespace eval ::punk::libunknown {} set ::punk::libunknown::epoch %lib_epoch% - set libunks [list] - foreach tm_path [tcl::tm::list] { - set punkdir [file join $tm_path punk] - if {![file exists $punkdir]} {continue} - lappend libunks {*}[glob -nocomplain -dir $punkdir -type f libunknown-*.tm] - } - set libunknown "" - set libunknown_version_sofar "" - foreach lib $libunks { - #expecting to be of form libunknown-.tm - set vtail [lindex [split [file tail $lib] -] 1] - set thisver [file rootname $vtail] ;#file rootname x.y.z.tm - if {$libunknown_version_sofar eq ""} { - set libunknown_version_sofar $thisver - set libunknown $lib - } else { - if {[package vcompare $thisver $libunknown_version_sofar] == 1} { + + apply {{} { + set libunks [list] + foreach tm_path [tcl::tm::list] { + set punkdir [file join $tm_path punk] + if {![file exists $punkdir]} {continue} + lappend libunks {*}[glob -nocomplain -dir $punkdir -type f libunknown-*.tm] + } + set libunknown "" + set libunknown_version_sofar "" + foreach lib $libunks { + #expecting to be of form libunknown-.tm + set vtail [lindex [split [file tail $lib] -] 1] + set thisver [file rootname $vtail] ;#file rootname x.y.z.tm + if {$libunknown_version_sofar eq ""} { set libunknown_version_sofar $thisver set libunknown $lib + } else { + if {[package vcompare $thisver $libunknown_version_sofar] == 1} { + set libunknown_version_sofar $thisver + set libunknown $lib + } } } - } - if {$libunknown ne ""} { - source $libunknown - if {[catch {punk::libunknown::init -caller "repl::init init_script code interp for punk"} errM]} { - puts "error initialising punk::libunknown\n$errM" + if {$libunknown ne ""} { + uplevel 1 [list source $libunknown] + if {[catch {punk::libunknown::init -caller "repl::init init_script code interp for punk"} errM]} { + puts "error initialising punk::libunknown\n$errM" + } } - } + }} + } else { puts stderr "punk::libunknown [package provide punk::libunknown] already loaded" } @@ -3594,6 +3608,9 @@ namespace eval repl { } else { puts stderr "repl code interp loaded vfs,vfs::zip lag:[expr {[clock millis] - $tsstart}]" } + unset errM + unset tsstart + #puts stderr "package unknown: [package unknown]" #puts stderr ----- @@ -3634,6 +3651,8 @@ namespace eval repl { puts stderr "========================" lappend ::codethread_initstatus "error $errM" error "$errM" + } else { + unset errM } } } @@ -3682,7 +3701,8 @@ namespace eval repl { thread::id } set init_script [string map $scriptmap $init_script] - + #REVIEW - the same initscript sent for all values of $safe and it switches on values of $safe provided in %args% + #we already know $safe in this thread when generating the script - so why send the large script to the thread to then switch on that? #thread::send $codethread $init_script if {![catch { diff --git a/src/vfs/_vfscommon.vfs/modules/shellfilter-0.1.9.tm b/src/vfs/_vfscommon.vfs/modules/shellfilter-0.1.9.tm deleted file mode 100644 index 73ea752c..00000000 --- a/src/vfs/_vfscommon.vfs/modules/shellfilter-0.1.9.tm +++ /dev/null @@ -1,3209 +0,0 @@ -#copyright 2023 Julian Marcel Noble -#license: BSD (revised 3-clause) -# -#Note shellfilter is currently only directly useful for unidirectional channels e.g stdin,stderr,stdout, or for example fifo2 where only one direction is being used. -#To generalize this to bidrectional channels would require shifting around read & write methods on transform objects in a very complicated manner. -#e.g each transform would probably be a generic transform container which holds sub-objects to which read & write are indirected. -#This is left as a future exercise...possibly it's best left as a concept for uni-directional channels anyway -# - as presumably the reads/writes from a bidirectional channel could be diverted off to unidirectional pipelines for processing with less work -# (and maybe even better speed/efficiency if the data volume is asymmetrical and there is significant processing on one direction) -# - - -tcl::namespace::eval shellfilter::log { - variable allow_adhoc_tags 1 - variable open_logs [tcl::dict::create] - variable is_enabled 0 - - proc disable {} { - variable is_enabled - set is_enabled 0 - proc ::shellfilter::log::open {tag settingsdict} {} - proc ::shellfilter::log::write {tag msg} {} - proc ::shellfilter::log::write_sync {tag msg} {} - proc ::shellfilter::log::close {tag} {} - } - - proc enable {} { - variable is_enabled - set is_enabled 1 - #'tag' is an identifier for the log source. - # each tag will use it's own thread to write to the configured log target - proc ::shellfilter::log::open {tag {settingsdict {}}} { - upvar ::shellfilter::sources sourcelist - if {![dict exists $settingsdict -tag]} { - tcl::dict::set settingsdict -tag $tag - } else { - #review - if {$tag ne [tcl::dict::get $settingsdict -tag]} { - error "shellfilter::log::open first argument tag: '$tag' does not match -tag '[tcl::dict::get $settingsdict -tag]' omit -tag, or supply same value" - } - } - if {$tag ni $sourcelist} { - lappend sourcelist $tag - } - - #note new_worker - set worker_tid [shellthread::manager::new_worker $tag $settingsdict] - #puts stderr "shellfilter::log::open this_threadid: [thread::id] tag: $tag worker_tid: $worker_tid" - return $worker_tid - } - proc ::shellfilter::log::write {tag msg} { - upvar ::shellfilter::sources sourcelist - variable allow_adhoc_tags - if {!$allow_adhoc_tags} { - if {$tag ni $sourcelist} { - error "shellfilter::log::write tag '$tag' hasn't been initialised with a call to shellfilter::log::open $tag , and allow_adhoc_tags has been set false. use shellfilter::log::require_open false to allow adhoc tags" - } - } - shellthread::manager::write_log $tag $msg - } - #write_sync - synchronous processing with logging thread, slower but potentially useful for debugging/testing or forcing delay til log written - proc ::shellfilter::log::write_sync {tag msg} { - shellthread::manager::write_log $tag $msg -async 0 - } - proc ::shellfilter::log::close {tag} { - #shellthread::manager::close_worker $tag - shellthread::manager::unsubscribe [list $tag]; #workertid will be added back to free list if no tags remain subscribed - } - - } - - #review - #configure whether we can call shellfilter::log::write without having called open first - proc require_open {{is_open_required {}}} { - variable allow_adhoc_tags - if {![string length $is_open_required]} { - return $allow_adhoc_tags - } else { - set truevalues [list y yes true 1] - set falsevalues [list n no false 0] - if {[string tolower $is_open_required] in $truevalues} { - set allow_adhoc_tags 1 - } elseif {[string tolower $is_open_required] in $falsevalues} { - set allow_adhoc_tags 0 - } else { - error "shellfilter::log::require_open unrecognised value '$is_open_required' try one of $truevalues or $falsevalues" - } - } - } - if {[catch {package require shellthread}]} { - shellfilter::log::disable - } else { - shellfilter::log::enable - } - -} -namespace eval shellfilter::pipe { - #write channel for program. workerthread reads other end of fifo2 and writes data somewhere - proc open_out {tag_pipename {pipesettingsdict {}}} { - set defaultsettings {-buffering full} - set settingsdict [dict merge $defaultsettings $pipesettingsdict] - package require shellthread - #we are only using the fifo in a single direction to pipe to another thread - # - so whilst wchan and rchan could theoretically each be both read & write we're only using them for one operation each - if {![catch {package require Memchan}]} { - lassign [fifo2] wchan rchan - } else { - package require tcl::chan::fifo2 - lassign [tcl::chan::fifo2] wchan rchan - } - #default -translation for both types of fifo on windows is {auto crlf} - # -encoding is as per '[encoding system]' on the platform - e.g utf-8 (e.g windows when beta-utf8 enabled) - chan configure $wchan -buffering [dict get $settingsdict -buffering] ;# - #application end must not be binary for our filters to operate on it - - - #chan configure $rchan -buffering [dict get $settingsdict -buffering] -translation binary ;#works reasonably.. - chan configure $rchan -buffering [dict get $settingsdict -buffering] -translation lf - - set worker_tid [shellthread::manager::new_pipe_worker $tag_pipename $settingsdict] - #puts stderr "worker_tid: $worker_tid" - - #set_read_pipe does the thread::transfer of the rchan end. -buffering setting is maintained during thread transfer - shellthread::manager::set_pipe_read_from_client $tag_pipename $worker_tid $rchan - - set pipeinfo [list localchan $wchan remotechan $rchan workertid $worker_tid direction out] - return $pipeinfo - } - - #read channel for program. workerthread writes to other end of fifo2 from whereever it's reading (stdin, file?) - proc open_in {tag_pipename {settingsdict {} }} { - package require shellthread - package require tcl::chan::fifo2 - lassign [tcl::chan::fifo2] wchan rchan - set program_chan $rchan - set worker_chan $wchan - chan configure $worker_chan -buffering [dict get $settingsdict -buffering] - chan configure $program_chan -buffering [dict get $settingsdict -buffering] - - chan configure $program_chan -blocking 0 - chan configure $worker_chan -blocking 0 - set worker_tid [shellthread::manager::new_worker $tag_pipename $settingsdict] - - shellthread::manager::set_pipe_write_to_client $tag_pipename $worker_tid $worker_chan - - set pipeinfo [list localchan $program_chan remotechan $worker_chan workertid $worker_tid direction in] - puts stderr "|jn>pipe::open_in returning $pipeinfo" - puts stderr "program_chan: [chan conf $program_chan]" - return $pipeinfo - } - -} - - - -namespace eval shellfilter::ansi { - #maint warning - - #ansistrip from punk::ansi is better/more comprehensive - proc stripcodes {text} { - #obsolete? - #single "final byte" in the range 0x40–0x7E (ASCII @A–Z[\]^_`a–z{|}~). - dict set escape_terminals CSI [list @ \\ ^ _ ` | ~ 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 "\{" "\}"] - #dict set escape_terminals CSI [list J K m n A B C D E F G s u] ;#basic - dict set escape_terminals OSC [list \007 \033\\] ;#note mix of 1 and 2-byte terminals - #we process char by char - line-endings whether \r\n or \n should be processed as per any other character. - #line endings can theoretically occur within an ansi escape sequence (review e.g title?) - set inputlist [split $text ""] - set outputlist [list] - - #self-contained 2 byte ansi escape sequences - review more? - set 2bytecodes_dict [dict create\ - "reset_terminal" "\033c"\ - "save_cursor_posn" "\u001b7"\ - "restore_cursor_posn" "\u001b8"\ - "cursor_up_one" "\u001bM"\ - ] - set 2bytecodes [dict values $2bytecodes_dict] - - set in_escapesequence 0 - #assumption - undertext already 'rendered' - ie no backspaces or carriagereturns or other cursor movement controls - set i 0 - foreach u $inputlist { - set v [lindex $inputlist $i+1] - set uv ${u}${v} - if {$in_escapesequence eq "2b"} { - #2nd byte - done. - set in_escapesequence 0 - } elseif {$in_escapesequence != 0} { - set escseq [dict get $escape_terminals $in_escapesequence] - if {$u in $escseq} { - set in_escapesequence 0 - } elseif {$uv in $escseq} { - set in_escapseequence 2b ;#flag next byte as last in sequence - } - } else { - #handle both 7-bit and 8-bit CSI and OSC - if {[regexp {^(?:\033\[|\u009b)} $uv]} { - set in_escapesequence CSI - } elseif {[regexp {^(?:\033\]|\u009c)} $uv]} { - set in_escapesequence OSC - } elseif {$uv in $2bytecodes} { - #self-contained e.g terminal reset - don't pass through. - set in_escapesequence 2b - } else { - lappend outputlist $u - } - } - incr i - } - return [join $outputlist ""] - } - -} -namespace eval shellfilter::chan { - set testobj ::shellfilter::chan::var - if {$testobj ni [info commands $testobj]} { - - oo::class create var { - variable o_datavar - variable o_trecord - variable o_enc - variable o_is_junction - constructor {tf} { - set o_trecord $tf - set o_enc [dict get $tf -encoding] - set settingsdict [dict get $tf -settings] - set varname [dict get $settingsdict -varname] - set o_datavar $varname - if {[dict exists $tf -junction]} { - set o_is_junction [dict get $tf -junction] - } else { - set o_is_junction 1 ;# as a var is diversionary - default it to be a jucntion - } - } - method initialize {ch mode} { - return [list initialize finalize write] - } - method finalize {ch} { - my destroy - } - method watch {ch events} { - # must be present but we ignore it because we do not - # post any events - } - #method read {ch count} { - # return ? - #} - method write {ch bytes} { - set stringdata [encoding convertfrom $o_enc $bytes] - append $o_datavar $stringdata - return "" - } - method meta_is_redirection {} { - return $o_is_junction - } - method meta_buffering_supported {} { - return [list line full none] - } - } - - #todo - something similar for multiple grep specs each with own -pre & -post .. store to dict? - oo::class create tee_grep_to_var { - variable o_datavar - variable o_lastxlines - variable o_trecord - variable o_grepfor - variable o_prelines - variable o_postlines - variable o_postcountdown - variable o_enc - variable o_is_junction - constructor {tf} { - set o_trecord $tf - set o_enc [tcl::dict::get $tf -encoding] - set o_lastxlines [list] - set o_postcountdown 0 - set defaults [tcl::dict::create -pre 1 -post 1] - set settingsdict [tcl::dict::get $tf -settings] - set settings [tcl::dict::merge $defaults $settingsdict] - set o_datavar [tcl::dict::get $settings -varname] - set o_grepfor [tcl::dict::get $settings -grep] - set o_prelines [tcl::dict::get $settings -pre] - set o_postlines [tcl::dict::get $settings -post] - 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 finalize write] - } - method finalize {transform_handle} { - my destroy - } - method watch {transform_handle events} { - } - #method read {transform_handle count} { - # return ? - #} - method write {transform_handle bytes} { - set logdata [tcl::encoding::convertfrom $o_enc $bytes] - set lastx $o_lastxlines - lappend o_lastxlines $logdata - - if {$o_postcountdown > 0} { - append $o_datavar $logdata - if {[regexp $o_grepfor $logdata]} { - #another match in postlines - set o_postcountdown $o_postlines - } else { - incr o_postcountdown -1 - } - } else { - if {[regexp $o_grepfor $logdata]} { - append $o_datavar [join $lastx] - append $o_datavar $logdata - set o_postcountdown $o_postlines - } - } - - if {[llength $o_lastxlines] > $o_prelines} { - set o_lastxlines [lrange $o_lastxlines 1 end] - } - return $bytes - } - method meta_is_redirection {} { - return $o_is_junction - } - method meta_buffering_supported {} { - return [list line] - } - } - - oo::class create tee_to_var { - variable o_datavars - variable o_trecord - variable o_enc - variable o_is_junction - constructor {tf} { - set o_trecord $tf - set o_enc [tcl::dict::get $tf -encoding] - set settingsdict [tcl::dict::get $tf -settings] - set varname [tcl::dict::get $settingsdict -varname] - set o_datavars $varname - if {[tcl::dict::exists $tf -junction]} { - set o_is_junction [tcl::dict::get $tf -junction] - } else { - set o_is_junction 0 - } - } - method initialize {ch mode} { - return [list initialize finalize write flush clear] - } - method finalize {ch} { - my destroy - } - method clear {ch} { - return - } - method watch {ch events} { - # must be present but we ignore it because we do not - # post any events - } - #method read {ch count} { - # return ? - #} - method flush {ch} { - return "" - } - method write {ch bytes} { - set stringdata [tcl::encoding::convertfrom $o_enc $bytes] - foreach v $o_datavars { - append $v $stringdata - } - return $bytes - } - method meta_is_redirection {} { - return $o_is_junction - } - } - oo::class create tee_to_pipe { - variable o_logsource - variable o_localchan - variable o_enc - variable o_trecord - variable o_is_junction - constructor {tf} { - set o_trecord $tf - set o_enc [tcl::dict::get $tf -encoding] - set settingsdict [tcl::dict::get $tf -settings] - if {![dict exists $settingsdict -tag]} { - error "tee_to_pipe constructor settingsdict missing -tag" - } - set o_localchan [tcl::dict::get $settingsdict -pipechan] - set o_logsource [tcl::dict::get $settingsdict -tag] - 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 read drain write flush clear finalize] - } - method finalize {transform_handle} { - ::shellfilter::log::close $o_logsource - my destroy - } - method watch {transform_handle events} { - # must be present but we ignore it because we do not - # post any events - } - method clear {transform_handle} { - return - } - method drain {transform_handle} { - return "" - } - method read {transform_handle bytes} { - set logdata [tcl::encoding::convertfrom $o_enc $bytes] - #::shellfilter::log::write $o_logsource $logdata - puts -nonewline $o_localchan $logdata - return $bytes - } - method flush {transform_handle} { - return "" - } - method write {transform_handle bytes} { - set logdata [tcl::encoding::convertfrom $o_enc $bytes] - #::shellfilter::log::write $o_logsource $logdata - puts -nonewline $o_localchan $logdata - return $bytes - } - #a tee is not a redirection - because data still flows along the main path - method meta_is_redirection {} { - return $o_is_junction - } - - } - oo::class create tee_to_log { - variable o_tid - variable o_logsource - variable o_trecord - variable o_enc - variable o_is_junction - constructor {tf} { - set o_trecord $tf - set o_enc [tcl::dict::get $tf -encoding] - set settingsdict [tcl::dict::get $tf -settings] - if {![tcl::dict::exists $settingsdict -tag]} { - error "tee_to_log constructor settingsdict missing -tag" - } - set o_logsource [tcl::dict::get $settingsdict -tag] - set o_tid [::shellfilter::log::open $o_logsource $settingsdict] - if {[tcl::dict::exists $tf -junction]} { - set o_is_junction [tcl::dict::get $tf -junction] - } else { - set o_is_junction 0 - } - } - method initialize {ch mode} { - return [list initialize read write finalize] - } - method finalize {ch} { - ::shellfilter::log::close $o_logsource - my destroy - } - method watch {ch events} { - # must be present but we ignore it because we do not - # post any events - } - method read {ch bytes} { - set logdata [tcl::encoding::convertfrom $o_enc $bytes] - ::shellfilter::log::write $o_logsource $logdata - return $bytes - } - method write {ch bytes} { - set logdata [tcl::encoding::convertfrom $o_enc $bytes] - ::shellfilter::log::write $o_logsource $logdata - return $bytes - } - method meta_is_redirection {} { - return $o_is_junction - } - } - - - oo::class create logonly { - variable o_tid - variable o_logsource - variable o_trecord - variable o_enc - constructor {tf} { - set o_trecord $tf - set o_enc [dict get $tf -encoding] - set settingsdict [dict get $tf -settings] - if {![dict exists $settingsdict -tag]} { - error "logonly constructor settingsdict missing -tag" - } - set o_logsource [dict get $settingsdict -tag] - set o_tid [::shellfilter::log::open $o_logsource $settingsdict] - } - method initialize {transform_handle mode} { - return [list initialize finalize write] - } - method finalize {transform_handle} { - ::shellfilter::log::close $o_logsource - my destroy - } - method watch {transform_handle events} { - # must be present but we ignore it because we do not - # post any events - } - #method read {transform_handle count} { - # return ? - #} - method write {transform_handle bytes} { - set logdata [encoding convertfrom $o_enc $bytes] - if 0 { - if {"utf-16le" in [encoding names]} { - set logdata [encoding convertfrom utf-16le $bytes] - } else { - set logdata [encoding convertto utf-8 $bytes] - #set logdata [encoding convertfrom unicode $bytes] - #set logdata $bytes - } - } - #set logdata $bytes - #set logdata [string map [list \r -r- \n -n-] $logdata] - #if {[string equal [string range $logdata end-1 end] "\r\n"]} { - # set logdata [string range $logdata 0 end-2] - #} - #::shellfilter::log::write_sync $o_logsource $logdata - ::shellfilter::log::write $o_logsource $logdata - #return $bytes - return - } - method meta_is_redirection {} { - return 1 - } - } - - #review - we should probably provide a more narrow filter than only strips color - and one that strips most(?) - # - but does it ever really make sense to strip things like "esc(0" and "esc(B" which flip to the G0 G1 characters? (once stripped - things like box-lines become ordinary letters - unlikely to be desired?) - #punk::ansi::ansistrip converts at least some of the box drawing G0 chars to unicode - todo - more complete conversion - #assumes line-buffering. a more advanced filter required if ansicodes can arrive split across separate read or write operations! - oo::class create ansistrip { - variable o_trecord - variable o_enc - variable o_is_junction - constructor {tf} { - package require punk::ansi - set o_trecord $tf - set o_enc [dict get $tf -encoding] - if {[dict exists $tf -junction]} { - set o_is_junction [dict get $tf -junction] - } else { - set o_is_junction 0 - } - } - method initialize {transform_handle mode} { - return [list initialize read write clear flush drain finalize] - } - method finalize {transform_handle} { - my destroy - } - method clear {transform_handle} { - return - } - method watch {transform_handle events} { - } - method drain {transform_handle} { - return "" - } - method read {transform_handle bytes} { - set instring [encoding convertfrom $o_enc $bytes] - set outstring [punk::ansi::ansistrip $instring] - return [encoding convertto $o_enc $outstring] - } - method flush {transform_handle} { - return "" - } - method write {transform_handle bytes} { - set instring [encoding convertfrom $o_enc $bytes] - set outstring [punk::ansi::ansistrip $instring] - return [encoding convertto $o_enc $outstring] - } - method meta_is_redirection {} { - return $o_is_junction - } - } - - #a test - oo::class create reconvert { - variable o_trecord - variable o_enc - constructor {tf} { - set o_trecord $tf - set o_enc [dict get $tf -encoding] - } - method initialize {transform_handle mode} { - return [list initialize read write finalize] - } - method finalize {transform_handle} { - my destroy - } - method watch {transform_handle events} { - } - method read {transform_handle bytes} { - set instring [encoding convertfrom $o_enc $bytes] - - set outstring $instring - - return [encoding convertto $o_enc $outstring] - } - method write {transform_handle bytes} { - set instring [encoding convertfrom $o_enc $bytes] - - set outstring $instring - - return [encoding convertto $o_enc $outstring] - } - } - oo::define reconvert { - method meta_is_redirection {} { - return 0 - } - } - - - #this isn't a particularly nice thing to do to a stream - especially if someone isn't expecting ansi codes sprinkled through it. - #It can be useful for test/debugging - #Due to chunking at random breaks - we have to check if an ansi code in the underlying stream has been split - otherwise our wrapping will break the existing ansi - # - set sixelstart_re {\x1bP([;0-9]*)q} ;#7-bit - todo 8bit - #todo kitty graphics \x1b_G... - #todo iterm graphics - - oo::class create ansiwrap { - variable o_trecord - variable o_enc - variable o_colour - variable o_do_colour - variable o_do_normal - variable o_is_junction - variable o_codestack - variable o_gx_state ;#on/off alt graphics - variable o_buffered - constructor {tf} { - package require punk::ansi - set o_trecord $tf - set o_enc [tcl::dict::get $tf -encoding] - set settingsdict [tcl::dict::get $tf -settings] - if {[tcl::dict::exists $settingsdict -colour]} { - set o_colour [tcl::dict::get $settingsdict -colour] - set o_do_colour [punk::ansi::a+ {*}$o_colour] - set o_do_normal [punk::ansi::a] - } else { - set o_colour {} - set o_do_colour "" - set o_do_normal "" - } - set o_codestack [list] - set o_gx_state [expr {off}] - set o_buffered "" ;#hold back data that potentially contains partial ansi codes - if {[tcl::dict::exists $tf -junction]} { - set o_is_junction [tcl::dict::get $tf -junction] - } else { - set o_is_junction 0 - } - } - - - #todo - track when in sixel,iterm,kitty graphics data - can be very large - method Trackcodes {chunk} { - #note - caller can use 2 resets in a single unit to temporarily reset to no sgr (override ansiwrap filter) - #e.g [a+ reset reset] (0;0m vs 0;m) - - #puts stdout "===[ansistring VIEW -lf 1 $o_buffered]" - set buf $o_buffered$chunk - set emit "" - if {[string last \x1b $buf] >= 0} { - #detect will detect ansi SGR and gron groff and other codes - if {[punk::ansi::ta::detect $buf]} { - #split_codes_single regex faster than split_codes - but more resulting parts - #'single' refers to number of escapes - but can still contain e.g multiple SGR codes (or mode set operations etc) - set parts [punk::ansi::ta::split_codes_single $buf] - #process all pt/code pairs except for trailing pt - foreach {pt code} [lrange $parts 0 end-1] { - #puts "<==[ansistring VIEW -lf 1 $pt]==>" - switch -- [llength $o_codestack] { - 0 { - append emit $o_do_colour$pt$o_do_normal - } - 1 { - if {[punk::ansi::codetype::is_sgr_reset [lindex $o_codestack 0]]} { - append emit $o_do_colour$pt$o_do_normal - set o_codestack [list] - } else { - #append emit [lindex $o_codestack 0]$pt - append emit [punk::ansi::codetype::sgr_merge_singles [list $o_do_colour {*}$o_codestack]]$pt - } - } - default { - append emit [punk::ansi::codetype::sgr_merge_singles [list $o_do_colour {*}$o_codestack]]$pt - } - } - #if {( ![llength $o_codestack] || ([llength $o_codestack] == 1 && [punk::ansi::codetype::is_sgr_reset [lindex $o_codestack 0]]))} { - # append emit $o_do_colour$pt$o_do_normal - # #append emit $pt - #} else { - # append emit $pt - #} - - set c1c2 [tcl::string::range $code 0 1] - set leadernorm [tcl::string::range [tcl::string::map [list\ - \x1b\[ 7CSI\ - \x9b 8CSI\ - \x1b\( 7GFX\ - ] $c1c2] 0 3] - switch -- $leadernorm { - 7CSI - 8CSI { - if {[punk::ansi::codetype::is_sgr_reset $code]} { - set o_codestack [list "\x1b\[m"] - } elseif {[punk::ansi::codetype::has_sgr_leadingreset $code]} { - set o_codestack [list $code] - } elseif {[punk::ansi::codetype::is_sgr $code]} { - #todo - make caching is_sgr method - set dup_posns [lsearch -all -exact $o_codestack $code] - set o_codestack [lremove $o_codestack {*}$dup_posns] - lappend o_codestack $code - } else { - - } - } - 7GFX { - switch -- [tcl::string::index $code 2] { - "0" { - set o_gx_state on - } - "B" { - set o_gx_state off - } - } - } - default { - #other ansi codes - } - } - append emit $code - } - - - set trailing_pt [lindex $parts end] - if {[string first \x1b $trailing_pt] >= 0} { - #puts stdout "...[ansistring VIEW -lf 1 $trailing_pt]...buffered:<[ansistring VIEW $o_buffered]> '[ansistring VIEW -lf 1 $emit]'" - #may not be plaintext after all - set o_buffered $trailing_pt - #puts stdout "=-=[ansistring VIEWCODES $o_buffered]" - } else { - #puts [a+ yellow]???[ansistring VIEW "'$o_buffered'<+>'$trailing_pt'"]???[a] - switch -- [llength $o_codestack] { - 0 { - append emit $o_do_colour$trailing_pt$o_do_normal - } - 1 { - if {[punk::ansi::codetype::is_sgr_reset [lindex $o_codestack 0]]} { - append emit $o_do_colour$trailing_pt$o_do_normal - set o_codestack [list] - } else { - #append emit [lindex $o_codestack 0]$trailing_pt - append emit [punk::ansi::codetype::sgr_merge_singles [list $o_do_colour {*}$o_codestack]]$trailing_pt - } - } - default { - append emit [punk::ansi::codetype::sgr_merge_singles [list $o_do_colour {*}$o_codestack]]$trailing_pt - } - } - #if {![llength $o_codestack] || ([llength $o_codestack] ==1 && [punk::ansi::codetype::is_sgr_reset [lindex $o_codestack 0]])} { - # append emit $o_do_colour$trailing_pt$o_do_normal - #} else { - # append emit $trailing_pt - #} - #the previous o_buffered formed the data we emitted - nothing new to buffer because we emitted all parts including the trailing plaintext - set o_buffered "" - } - - - } else { - #REVIEW - this holding a buffer without emitting as we go is ugly. - # - we may do better to detect and retain the opener, then use that opener to avoid false splits within the sequence. - # - we'd then need to detect the appropriate close to restart splitting and codestacking - # - we may still need to retain and append the data to the opener (in some cases?) - which is a slight memory issue - but at least we would emit everything immediately. - - - #puts "-->esc but no detect" - #no complete ansi codes - but at least one esc is present - if {[string index $buf end] eq "\x1b" && [string first \x1b $buf] == [string length $buf]-1} { - #string index in first part of && clause to avoid some unneeded scans of whole string for this test - #we can't use 'string last' - as we need to know only esc is last char in buf - #puts ">>trailing-esc<<" - set o_buffered \x1b - set emit $o_do_colour[string range $buf 0 end-1]$o_do_normal - #set emit [string range $buf 0 end-1] - set buf "" - } else { - set emit_anyway 0 - #todo - ensure non-ansi escapes in middle of chunks don't lead to ever growing buffer - if {[punk::ansi::ta::detect_st_open $buf]} { - #no detect - but we have an ST open (privacy msg etc) - allow a larger chunk before we give up - could include newlines (and even nested codes - although not widely interpreted that way in terms) - set st_partial_len [expr {[string length $buf] - [string last \x1b $buf]}] ;#length of unclosed ST code - #todo - configurable ST max - use 1k for now - if {$st_partial_len < 1001} { - append o_buffered $chunk - set emit "" - set buf "" - } else { - set emit_anyway 1 - set o_buffered "" - } - } else { - set possible_code_len [expr {[string length $buf] - [string last \x1b $buf]}] ;#length of possible code - #most opening sequences are 1,2 or 3 chars - review? - set open_sequence_detected [punk::ansi::ta::detect_open $buf] - if {$possible_code_len > 10 && !$open_sequence_detected} { - set emit_anyway 1 - set o_buffered "" - } else { - #could be composite sequence with params - allow some reasonable max sequence length - #todo - configurable max sequence length - #len 40-50 quite possible for SGR sequence using coloured underlines etc, even without redundancies - # - allow some headroom for redundant codes when the caller didn't merge. - if {$possible_code_len < 101} { - append o_buffered $chunk - set buf "" - set emit "" - } else { - #allow a little more grace if we at least have an opening ansi sequence of any type.. - if {$open_sequence_detected && $possible_code_len < 151} { - append o_buffered $chunk - set buf "" - set emit "" - } else { - set emit_anyway 1 - set o_buffered "" - } - } - } - } - if {$emit_anyway} { - #assert: any time emit_anyway == 1 buf already contains all of previous o_buffered and o_buffered has been cleared. - - #looked ansi-like - but we've given enough length without detecting close.. - #treat as possible plain text with some esc or unrecognised ansi sequence - switch -- [llength $o_codestack] { - 0 { - set emit $o_do_colour$buf$o_do_normal - } - 1 { - if {[punk::ansi::codetype::is_sgr_reset [lindex $o_codestack 0]]} { - set emit $o_do_colour$buf$o_do_normal - set o_codestack [list] - } else { - #set emit [lindex $o_codestack 0]$buf - set emit [punk::ansi::codetype::sgr_merge_singles [list $o_do_colour {*}$o_codestack]]$buf - } - } - default { - #set emit [punk::ansi::codetype::sgr_merge_singles $o_codestack]$buf - set emit [punk::ansi::codetype::sgr_merge_singles [list $o_do_colour {*}$o_codestack]]$buf - } - } - #if {( ![llength $o_codestack] || ([llength $o_codestack] == 1 && [punk::ansi::codetype::is_sgr_reset [lindex $o_codestack 0]]))} { - # set emit $o_do_colour$buf$o_do_normal - #} else { - # set emit $buf - #} - } - } - } - } else { - #no esc - #puts stdout [a+ yellow]...[a] - #test! - switch -- [llength $o_codestack] { - 0 { - set emit $o_do_colour$buf$o_do_normal - } - 1 { - if {[punk::ansi::codetype::is_sgr_reset [lindex $o_codestack 0]]} { - set emit $o_do_colour$buf$o_do_normal - set o_codestack [list] - } else { - #set emit [lindex $o_codestack 0]$buf - set emit [punk::ansi::codetype::sgr_merge_singles [list $o_do_colour {*}$o_codestack]]$buf - } - } - default { - #set emit [punk::ansi::codetype::sgr_merge_singles $o_codestack]$buf - set emit [punk::ansi::codetype::sgr_merge_singles [list $o_do_colour {*}$o_codestack]]$buf - } - } - set o_buffered "" - } - return [dict create emit $emit stacksize [llength $o_codestack]] - } - method initialize {transform_handle mode} { - #clear undesirable in terminal output channels (review) - return [list initialize write flush read drain finalize] - } - method finalize {transform_handle} { - my destroy - } - method watch {transform_handle events} { - } - method clear {transform_handle} { - #In the context of stderr/stdout - we probably don't want clear to run. - #Terminals might call it in the middle of a split ansi code - resulting in broken output. - #Leave clear of it the init call - puts stdout "" - set emit [tcl::encoding::convertto $o_enc $o_buffered] - set o_buffered "" - return $emit - } - method flush {transform_handle} { - #puts stdout "" - set emit [tcl::encoding::convertto $o_enc $o_buffered] - set o_buffered "" - return $emit - return - } - method write {transform_handle bytes} { - set instring [tcl::encoding::convertfrom $o_enc $bytes] - set streaminfo [my Trackcodes $instring] - set emit [dict get $streaminfo emit] - - #review - wrapping already done in Trackcodes - #if {[dict get $streaminfo stacksize] == 0} { - # #no ansi on the stack - we can wrap - # #review - # set outstring "$o_do_colour$emit$o_do_normal" - #} else { - #} - #if {[llength $o_codestack]} { - # set outstring [punk::ansi::codetype::sgr_merge_singles $o_codestack]$emit - #} else { - # set outstring $emit - #} - - set outstring $emit - - #puts stdout "decoded >>>[ansistring VIEWCODES $outstring]<<<" - #puts stdout "re-encoded>>>[ansistring VIEW [tcl::encoding::convertto $o_enc $outstring]]<<<" - return [tcl::encoding::convertto $o_enc $outstring] - } - method Write_naive {transform_handle bytes} { - set instring [tcl::encoding::convertfrom $o_enc $bytes] - set outstring "$o_do_colour$instring$o_do_normal" - #set outstring ">>>$instring" - return [tcl::encoding::convertto $o_enc $outstring] - } - method drain {transform_handle} { - return "" - } - method read {transform_handle bytes} { - set instring [tcl::encoding::convertfrom $o_enc $bytes] - set outstring "$o_do_colour$instring$o_do_normal" - return [tcl::encoding::convertto $o_enc $outstring] - } - method meta_is_redirection {} { - return $o_is_junction - } - } - #todo - something - oo::class create rebuffer { - variable o_trecord - variable o_enc - constructor {tf} { - set o_trecord $tf - set o_enc [dict get $tf -encoding] - } - method initialize {transform_handle mode} { - return [list initialize read write finalize] - } - method finalize {transform_handle} { - my destroy - } - method watch {transform_handle events} { - } - method read {transform_handle bytes} { - set instring [encoding convertfrom $o_enc $bytes] - - set outstring $instring - - return [encoding convertto $o_enc $outstring] - } - method write {transform_handle bytes} { - set instring [encoding convertfrom $o_enc $bytes] - - #set outstring [string map [list \n ] $instring] - set outstring $instring - - return [encoding convertto $o_enc $outstring] - #return [encoding convertto utf-16le $outstring] - } - } - oo::define rebuffer { - method meta_is_redirection {} { - return 0 - } - } - - #has slight buffering/withholding of lone training cr - we can't be sure that a cr at end of chunk is part of \r\n sequence - oo::class create tounix { - variable o_trecord - variable o_enc - variable o_last_char_was_cr - variable o_is_junction - constructor {tf} { - set o_trecord $tf - set o_enc [dict get $tf -encoding] - set settingsdict [dict get $tf -settings] - if {[dict exists $tf -junction]} { - set o_is_junction [dict get $tf -junction] - } else { - set o_is_junction 0 - } - set o_last_char_was_cr 0 - } - method initialize {transform_handle mode} { - return [list initialize write finalize] - } - method finalize {transform_handle} { - my destroy - } - method watch {transform_handle events} { - } - #don't use read - method read {transform_handle bytes} { - set instring [encoding convertfrom $o_enc $bytes] - - set outstring $instring - - return [encoding convertto $o_enc $outstring] - } - method write {transform_handle bytes} { - set instring [encoding convertfrom $o_enc $bytes] - #set outstring [string map [list \n ] $instring] - - if {$o_last_char_was_cr} { - set instring "\r$instring" - } - - set outstring [string map {\r\n \n} $instring] - set lastchar [string range $outstring end end] - if {$lastchar eq "\r"} { - set o_last_char_was_cr 1 - set outstring [string range $outstring 0 end-1] - } else { - set o_last_char_was_cr 0 - } - #review! can we detect eof here on the transform_handle? - #if eof, we don't want to strip a trailing \r - - return [encoding convertto $o_enc $outstring] - #return [encoding convertto utf-16le $outstring] - } - } - oo::define tounix { - method meta_is_redirection {} { - return $o_is_junction - } - } - #write to handle case where line-endings already \r\n too - oo::class create towindows { - variable o_trecord - variable o_enc - variable o_last_char_was_cr - variable o_is_junction - constructor {tf} { - set o_trecord $tf - set o_enc [dict get $tf -encoding] - set settingsdict [dict get $tf -settings] - if {[dict exists $tf -junction]} { - set o_is_junction [dict get $tf -junction] - } else { - set o_is_junction 0 - } - set o_last_char_was_cr 0 - } - method initialize {transform_handle mode} { - return [list initialize write finalize] - } - method finalize {transform_handle} { - my destroy - } - method watch {transform_handle events} { - } - #don't use read - method read {transform_handle bytes} { - set instring [encoding convertfrom $o_enc $bytes] - - set outstring $instring - - return [encoding convertto $o_enc $outstring] - } - method write {transform_handle bytes} { - set instring [encoding convertfrom $o_enc $bytes] - #set outstring [string map [list \n ] $instring] - - if {$o_last_char_was_cr} { - set instring "\r$instring" - } - - set outstring [string map {\r\n \uFFFF} $instring] - set outstring [string map {\n \r\n} $outstring] - set outstring [string map {\uFFFF \r\n} $outstring] - - set lastchar [string range $outstring end end] - if {$lastchar eq "\r"} { - set o_last_char_was_cr 1 - set outstring [string range $outstring 0 end-1] - } else { - set o_last_char_was_cr 0 - } - #review! can we detect eof here on the transform_handle? - #if eof, we don't want to strip a trailing \r - - return [encoding convertto $o_enc $outstring] - #return [encoding convertto utf-16le $outstring] - } - } - oo::define towindows { - method meta_is_redirection {} { - return $o_is_junction - } - } - - } -} - -# ---------------------------------------------------------------------------- -#review float/sink metaphor. -#perhaps something with the concept of upstream and downstream? -#need concepts for push towards data, sit in middle where placed, and lag at tail of data stream. -## upstream for stdin is at the bottom of the stack and for stdout is the top of the stack. -#upstream,neutral-upstream,downstream,downstream-aside,downstream-replace (default neutral-upstream - require action 'stack' to use standard channel stacking concept and ignore other actions) -#This is is a bit different from the float/sink metaphor which refers to the channel stacking order as opposed to the data-flow direction. -#The idea would be that whether input or output -# upstream additions go to the side closest to the datasource -# downstream additions go furthest from the datasource -# - all new additions go ahead of any diversions as the most upstream diversion is the current end of the stream in a way. -# - this needs review regarding subsequent removal of the diversion and whether filters re-order in response.. -# or if downstream & neutral additions are reclassified upon insertion if they land among existing upstreams(?) -# neutral-upstream goes to the datasource side of the neutral-upstream list. -# No 'neutral' option provided so that we avoid the need to think forwards or backwards when adding stdin vs stdout shellfilter does the necessary pop/push reordering. -# No 'neutral-downstream' to reduce complexity. -# downstream-replace & downstream-aside head downstream to the first diversion they encounter. ie these actions are no longer referring to the stack direction but only the dataflow direction. -# -# ---------------------------------------------------------------------------- -# -# 'filters' are transforms that don't redirect -# - limited range of actions to reduce complexity. -# - any requirement not fulfilled by float,sink,sink-replace,sink-sideline should be done by multiple pops and pushes -# -#actions can float to top of filters or sink to bottom of filters -#when action is of type sink, it can optionally replace or sideline the first non-filter it encounters (highest redirection on the stack.. any lower are starved of the stream anyway) -# - sideline means to temporarily replace the item and keep a record, restoring if/when we are removed from the transform stack -# -##when action is of type float it can't replace or sideline anything. A float is added above any existing floats and they stay in the same order relative to each other, -#but non-floats added later will sit below all floats. -#(review - float/sink initially designed around output channels. For stdin the dataflow is reversed. implement float-aside etc?) -# -# -#action: float sink sink-replace,sink-sideline -# -# -## note - whether stack is for input or output we maintain it in the same direction - which is in sync with the tcl chan pop chan push concept. -## -namespace eval shellfilter::stack { - namespace export {[a-z]*} - namespace ensemble create - #todo - implement as oo ? - variable pipelines [list] - - proc items {} { - #review - stdin,stdout,stderr act as pre-existing pipelines, and we can't create a new one with these names - so they should probably be autoconfigured and listed.. - # - but in what contexts? only when we find them in [chan names]? - variable pipelines - return [dict keys $pipelines] - } - proc item {pipename} { - variable pipelines - return [dict get $pipelines $pipename] - } - proc item_tophandle {pipename} { - variable pipelines - set handle "" - if {[dict exists $pipelines $pipename stack]} { - set stack [dict get $pipelines $pipename stack] - set topstack [lindex $stack end] ;#last item in stack is top (for output channels anyway) review comment. input chans? - if {$topstack ne ""} { - if {[dict exists $topstack -handle]} { - set handle [dict get $topstack -handle] - } - } - } - return $handle - } - proc status {{pipename *} args} { - variable pipelines - set pipecount [dict size $pipelines] - set tabletitle "$pipecount pipelines active" - set t [textblock::class::table new $tabletitle] - $t add_column -headers [list channel-ident] - $t add_column -headers [list device-info localchan] - $t configure_column 1 -header_colspans {3} - $t add_column -headers [list "" remotechan] - $t add_column -headers [list "" tid] - $t add_column -headers [list stack-info] - foreach k [dict keys $pipelines $pipename] { - set lc [dict get $pipelines $k device localchan] - set rc [dict get $pipelines $k device remotechan] - if {[dict exists $k device workertid]} { - set tid [dict get $pipelines $k device workertid] - } else { - set tid "-" - } - set stack [dict get $pipelines $k stack] - if {![llength $stack]} { - set stackinfo "" - } else { - set tbl_inner [textblock::class::table new] - $tbl_inner configure -show_edge 0 - foreach rec $stack { - set handle [punk::lib::dict_getdef $rec -handle ""] - set id [punk::lib::dict_getdef $rec -id ""] - set transform [namespace tail [punk::lib::dict_getdef $rec -transform ""]] - set settings [punk::lib::dict_getdef $rec -settings ""] - $tbl_inner add_row [list $id $transform $handle $settings] - } - set stackinfo [$tbl_inner print] - $tbl_inner destroy - } - $t add_row [list $k $lc $rc $tid $stackinfo] - } - set result [$t print] - $t destroy - return $result - } - proc status1 {{pipename *} args} { - variable pipelines - - set pipecount [dict size $pipelines] - set tableprefix "$pipecount pipelines active\n" - foreach p [dict keys $pipelines] { - append tableprefix " " $p \n - } - package require overtype - #todo -verbose - set table "" - set ac1 [string repeat " " 15] - set ac2 [string repeat " " 42] - set ac3 [string repeat " " 70] - append table "[overtype::left $ac1 channel-ident] " - append table "[overtype::left $ac2 device-info] " - append table "[overtype::left $ac3 stack-info]" - append table \n - - - set bc1 [string repeat " " 5] ;#stack id - set bc2 [string repeat " " 25] ;#transform - set bc3 [string repeat " " 50] ;#settings - - foreach k [dict keys $pipelines $pipename] { - set lc [dict get $pipelines $k device localchan] - if {[dict exists $k device workertid]} { - set tid [dict get $pipelines $k device workertid] - } else { - set tid "" - } - - - set col1 [overtype::left $ac1 $k] - set col2 [overtype::left $ac2 "localchan: $lc tid:$tid"] - - set stack [dict get $pipelines $k stack] - if {![llength $stack]} { - set col3 $ac3 - } else { - set rec [lindex $stack 0] - set bcol1 [overtype::left $bc1 [dict get $rec -id]] - set bcol2 [overtype::left $bc2 [namespace tail [dict get $rec -transform]]] - set bcol3 [overtype::left $bc3 [dict get $rec -settings]] - set stackrow "$bcol1 $bcol2 $bcol3" - set col3 [overtype::left $ac3 $stackrow] - } - - append table "$col1 $col2 $col3\n" - - - foreach rec [lrange $stack 1 end] { - set col1 $ac1 - set col2 $ac2 - if {[llength $rec]} { - set bc1 [overtype::left $bc1 [dict get $rec -id]] - set bc2 [overtype::left $bc2 [namespace tail [dict get $rec -transform]]] - set bc3 [overtype::left $bc3 [dict get $rec -settings]] - set stackrow "$bc1 $bc2 $bc3" - set col3 [overtype::left $ac3 $stackrow] - } else { - set col3 $ac3 - } - append table "$col1 $col2 $col3\n" - } - - } - return $tableprefix$table - } - #used for output channels - we usually want to sink redirections below the floaters and down to topmost existing redir - proc _get_stack_floaters {stack} { - set floaters [list] - foreach t [lreverse $stack] { - switch -- [dict get $t -action] { - float { - lappend floaters $t - } - default { - break - } - } - } - return [lreverse $floaters] - } - - - - #for output-channel sinking - proc _get_stack_top_redirection {stack} { - set r 0 ;#reverse index - foreach t [lreverse $stack] { - set obj [dict get $t -obj] - if {[$obj meta_is_redirection]} { - set idx [expr {[llength $stack] - ($r + 1) }] ;#forward index - return [list index $idx record $t] - } - incr r - } - #not found - return [list index -1 record {}] - } - #exclude float-locked, locked, sink-locked - proc _get_stack_top_redirection_replaceable {stack} { - set r 0 ;#reverse index - foreach t [lreverse $stack] { - set action [dict get $t -action] - if {![string match "*locked*" $action]} { - set obj [dict get $t -obj] - if {[$obj meta_is_redirection]} { - set idx [expr {[llength $stack] - ($r + 1) }] ;#forward index - return [list index $idx record $t] - } - } - incr r - } - #not found - return [list index -1 record {}] - } - - - #for input-channels ? - proc _get_stack_bottom_redirection {stack} { - set i 0 - foreach t $stack { - set obj [dict get $t -obj] - if {[$obj meta_is_redirection]} { - return [linst index $i record $t] - } - incr i - } - #not found - return [list index -1 record {}] - } - - - proc get_next_counter {pipename} { - variable pipelines - #use dictn incr ? - set counter [dict get $pipelines $pipename counter] - incr counter - dict set pipelines $pipename counter $counter - return $counter - } - - proc unwind {pipename} { - variable pipelines - set stack [dict get $pipelines $pipename stack] - set localchan [dict get $pipelines $pipename device localchan] - foreach tf [lreverse $stack] { - chan pop $localchan - } - dict set pipelines $pipename [list] - } - #todo - proc delete {pipename {wait 0}} { - variable pipelines - set pipeinfo [dict get $pipelines $pipename] - set deviceinfo [dict get $pipeinfo device] - set localchan [dict get $deviceinfo localchan] - unwind $pipename - - #release associated thread - set tid [dict get $deviceinfo workertid] - if {$wait} { - thread::release -wait $tid - } else { - thread::release $tid - } - - #Memchan closes without error - tcl::chan::fifo2 raises something like 'can not find channel named "rc977"' - REVIEW. why? - catch {chan close $localchan} - } - #review - proc name clarity is questionable. remove_stackitem? - proc remove {pipename remove_id} { - variable pipelines - if {![dict exists $pipelines $pipename]} { - puts stderr "WARNING: shellfilter::stack::remove pipename '$pipename' not found in pipelines dict: '$pipelines' [info level -1]" - return - } - set stack [dict get $pipelines $pipename stack] - set localchan [dict get $pipelines $pipename device localchan] - set posn 0 - set idposn -1 - set asideposn -1 - foreach t $stack { - set id [dict get $t -id] - if {$id eq $remove_id} { - set idposn $posn - break - } - #look into asides (only can be one for now) - if {[llength [dict get $t -aside]]} { - set a [dict get $t -aside] - if {[dict get $a -id] eq $remove_id} { - set asideposn $posn - break - } - } - incr posn - } - - if {$asideposn > 0} { - #id wasn't found directly in stack, but in an -aside. we don't need to pop anything - just clear this aside record - set container [lindex $stack $asideposn] - dict set container -aside {} - lset stack $asideposn $container - dict set pipelines $pipename stack $stack - } else { - if {$idposn < 0} { - ::shellfilter::log::write shellfilter "ERROR shellfilter::stack::remove $pipename id '$remove_id' not found" - puts stderr "|WARNING>shellfilter::stack::remove $pipename id '$remove_id' not found" - return 0 - } - set removed_item [lindex $stack $idposn] - - #include idposn in poplist - set poplist [lrange $stack $idposn end] - set stack [lreplace $stack $idposn end] - #pop all chans before adding anything back in! - foreach p $poplist { - chan pop $localchan - } - - if {[llength [dict get $removed_item -aside]]} { - set restore [dict get $removed_item -aside] - set t [dict get $restore -transform] - set tsettings [dict get $restore -settings] - set obj [$t new $restore] - set h [chan push $localchan $obj] - dict set restore -handle $h - dict set restore -obj $obj - lappend stack $restore - } - - #put popped back except for the first one, which we want to remove - foreach p [lrange $poplist 1 end] { - set t [dict get $p -transform] - set tsettings [dict get $p -settings] - set obj [$t new $p] - set h [chan push $localchan $obj] - dict set p -handle $h - dict set p -obj $obj - lappend stack $p - } - dict set pipelines $pipename stack $stack - } - #JMNJMN 2025 review! - #show_pipeline $pipename -note "after_remove $remove_id" - return 1 - } - - #pop a number of items of the top of the stack, add our transform record, and add back all (or the tail of poplist if pushstartindex > 0) - proc insert_transform {pipename stack transformrecord poplist {pushstartindex 0}} { - variable pipelines - set bottom_pop_posn [expr {[llength $stack] - [llength $poplist]}] - set poplist [lrange $stack $bottom_pop_posn end] - set stack [lreplace $stack $bottom_pop_posn end] - - set localchan [dict get $pipelines $pipename device localchan] - foreach p [lreverse $poplist] { - chan pop $localchan - } - set transformname [dict get $transformrecord -transform] - set transformsettings [dict get $transformrecord -settings] - set obj [$transformname new $transformrecord] - set h [chan push $localchan $obj] - dict set transformrecord -handle $h - dict set transformrecord -obj $obj - dict set transformrecord -note "insert_transform" - lappend stack $transformrecord - foreach p [lrange $poplist $pushstartindex end] { - set t [dict get $p -transform] - set tsettings [dict get $p -settings] - set obj [$t new $p] - set h [chan push $localchan $obj] - #retain previous -id - code that added it may have kept reference and not expecting it to change - dict set p -handle $h - dict set p -obj $obj - dict set p -note "re-added" - - lappend stack $p - } - return $stack - } - - #fifo2 - proc new {pipename args} { - variable pipelines - if {($pipename in [dict keys $pipelines]) || ($pipename in [chan names])} { - error "shellfilter::stack::new error: pipename '$pipename' already exists" - } - - set opts [dict merge {-settings {}} $args] - set defaultsettings [dict create -raw 1 -buffering line -direction out] - set targetsettings [dict merge $defaultsettings [dict get $opts -settings]] - - set direction [dict get $targetsettings -direction] - - #pipename is the source/facility-name ? - if {$direction eq "out"} { - set pipeinfo [shellfilter::pipe::open_out $pipename $targetsettings] - } else { - puts stderr "|jn> pipe::open_in $pipename $targetsettings" - set pipeinfo [shellfilter::pipe::open_in $pipename $targetsettings] - } - #open_out/open_in will configure buffering based on targetsettings - - set program_chan [dict get $pipeinfo localchan] - set worker_chan [dict get $pipeinfo remotechan] - set workertid [dict get $pipeinfo workertid] - - - set deviceinfo [dict create pipename $pipename localchan $program_chan remotechan $worker_chan workertid $workertid direction $direction] - dict set pipelines $pipename [list counter 0 device $deviceinfo stack [list]] - - return $deviceinfo - } - #we 'add' rather than 'push' because transforms can float,sink and replace/sideline so they don't necessarily go to the top of the transform stack - proc add {pipename transformname args} { - variable pipelines - #chan names doesn't reflect available channels when transforms are in place - #e.g stdout may exist but show as something like file191f5b0dd80 - if {($pipename ni [dict keys $pipelines])} { - if {[catch {eof $pipename} is_eof]} { - error "shellfilter::stack::add no existing chan or pipename matching '$pipename' in channels:[chan names] or pipelines:$pipelines use stdin/stderr/stdout or shellfilter::stack::new " - } - } - set args [dict merge {-action "" -settings {}} $args] - set action [dict get $args -action] - set transformsettings [dict get $args -settings] - if {[string first "::" $transformname] < 0} { - set transformname ::shellfilter::chan::$transformname - } - if {![llength [info commands $transformname]]} { - error "shellfilter::stack::push unknown transform '$transformname'" - } - - - if {![dict exists $pipelines $pipename]} { - #pipename must be in chan names - existing device/chan - #record a -read and -write end even if the device is only being used as one or the other - set deviceinfo [dict create pipename $pipename localchan $pipename remotechan {}] - dict set pipelines $pipename [list counter 0 device $deviceinfo stack [list]] - } else { - set deviceinfo [dict get $pipelines $pipename device] - } - - set id [get_next_counter $pipename] - set stack [dict get $pipelines $pipename stack] - set localchan [dict get $deviceinfo localchan] - - #we redundantly store chan in each transform - makes debugging clearer - # -encoding similarly could be stored only at the pipeline level (or even queried directly each filter-read/write), - # but here it may help detect unexpected changes during lifetime of the stack and avoids the chance of callers incorrectly using the transform handle?) - # jn - set transform_record [list -id $id -chan $pipename -encoding [chan configure $localchan -encoding] -transform $transformname -aside {} {*}$args] - switch -glob -- $action { - float - float-locked { - set obj [$transformname new $transform_record] - set h [chan push $localchan $obj] - dict set transform_record -handle $h - dict set transform_record -obj $obj - lappend stack $transform_record - } - "" - locked { - set floaters [_get_stack_floaters $stack] - if {![llength $floaters]} { - set obj [$transformname new $transform_record] - set h [chan push $localchan $obj] - dict set transform_record -handle $h - dict set transform_record -obj $obj - lappend stack $transform_record - } else { - set poplist $floaters - set stack [insert_transform $pipename $stack $transform_record $poplist] - } - } - "sink*" { - set redirinfo [_get_stack_top_redirection $stack] - set idx_existing_redir [dict get $redirinfo index] - if {$idx_existing_redir == -1} { - #no existing redirection transform on the stack - #pop everything.. add this record as the first redirection on the stack - set poplist $stack - set stack [insert_transform $pipename $stack $transform_record $poplist] - } else { - switch -glob -- $action { - "sink-replace" { - #include that index in the poplist - set poplist [lrange $stack $idx_existing_redir end] - #pop all from idx_existing_redir to end, but put back 'lrange $poplist 1 end' - set stack [insert_transform $pipename $stack $transform_record $poplist 1] - } - "sink-aside*" { - set existing_redir_record [lindex $stack $idx_existing_redir] - if {[string match "*locked*" [dict get $existing_redir_record -action]]} { - set put_aside 0 - #we can't aside this one - sit above it instead. - set poplist [lrange $stack $idx_existing_redir+1 end] - set stack [lrange $stack 0 $idx_existing_redir] - } else { - set put_aside 1 - dict set transform_record -aside [lindex $stack $idx_existing_redir] - set poplist [lrange $stack $idx_existing_redir end] - set stack [lrange $stack 0 $idx_existing_redir-1] - } - foreach p $poplist { - chan pop $localchan - } - set transformname [dict get $transform_record -transform] - set transform_settings [dict get $transform_record -settings] - set obj [$transformname new $transform_record] - set h [chan push $localchan $obj] - dict set transform_record -handle $h - dict set transform_record -obj $obj - dict set transform_record -note "insert_transform-with-aside" - lappend stack $transform_record - #add back poplist *except* the one we transferred into -aside (if we were able) - foreach p [lrange $poplist $put_aside end] { - set t [dict get $p -transform] - set tsettings [dict get $p -settings] - set obj [$t new $p] - set h [chan push $localchan $obj] - #retain previous -id - code that added it may have kept reference and not expecting it to change - dict set p -handle $h - dict set p -obj $obj - dict set p -note "re-added-after-sink-aside" - lappend stack $p - } - } - default { - #plain "sink" - #we only sink to the topmost redirecting filter - which makes sense for an output channel - #For stdin.. this is more problematic as we're more likely to want to intercept the bottom most redirection. - #todo - review. Consider making default insert position for input channels to be at the source... and float/sink from there. - # - we don't currently know from the stack api if adding input vs output channel - so this needs work to make intuitive. - # consider splitting stack::add to stack::addinput stack::addoutput to split the different behaviour - set poplist [lrange $stack $idx_existing_redir+1 end] - set stack [insert_transform $pipename $stack $transform_record $poplist] - } - } - } - } - default { - error "shellfilter::stack::add unimplemented action '$action'" - } - } - - dict set pipelines $pipename stack $stack - #puts stdout "==" - #puts stdout "==>stack: $stack" - #puts stdout "==" - - #JMNJMN - #show_pipeline $pipename -note "after_add $transformname $args" - return $id - } - proc show_pipeline {pipename args} { - variable pipelines - set stack [dict get $pipelines $pipename stack] - set tag "SHELLFILTER::STACK" - #JMN - load from config - #::shellfilter::log::open $tag {-syslog 127.0.0.1:514} - if {[catch { - ::shellfilter::log::open $tag {-syslog ""} - } err]} { - #e.g safebase interp can't load required modules such as shellthread (or Thread) - puts stderr "shellfilter::show_pipeline cannot open log" - return - } - ::shellfilter::log::write $tag "transform stack for $pipename $args" - foreach tf $stack { - ::shellfilter::log::write $tag " $tf" - } - - } -} - - -namespace eval shellfilter { - variable sources [list] - variable stacks [dict create] - - proc ::shellfilter::redir_channel_to_log {chan args} { - variable sources - set default_logsettings [dict create \ - -tag redirected_$chan -syslog "" -file ""\ - ] - if {[dict exists $args -action]} { - set action [dict get $args -action] - } else { - # action "sink" is a somewhat reasonable default for an output redirection transform - # but it can make it harder to configure a plain ordered stack if the user is not expecting it, so we'll default to stack - # also.. for stdin transform sink makes less sense.. - #todo - default "stack" instead of empty string - set action "" - } - if {[dict exists $args -settings]} { - set logsettings [dict get $args -settings] - } else { - set logsettings {} - } - - set logsettings [dict merge $default_logsettings $logsettings] - set tag [dict get $logsettings -tag] - if {$tag ni $sources} { - lappend sources $tag - } - - set id [shellfilter::stack::add $chan logonly -action $action -settings $logsettings] - return $id - } - - proc ::shellfilter::redir_output_to_log {tagprefix args} { - variable sources - - set default_settings [list -tag ${tagprefix} -syslog "" -file ""] - - set opts [dict create -action "" -settings {}] - set opts [dict merge $opts $args] - set optsettings [dict get $opts -settings] - set settings [dict merge $default_settings $optsettings] - - set tag [dict get $settings -tag] - if {$tag ne $tagprefix} { - error "shellfilter::redir_output_to_log -tag value must match supplied tagprefix:'$tagprefix'. Omit -tag, or make it the same. It will automatically be suffixed with stderr and stdout. Use redir_channel_to_log if you want to separately configure each channel" - } - lappend sources ${tagprefix}stdout ${tagprefix}stderr - - set stdoutsettings $settings - dict set stdoutsettings -tag ${tagprefix}stdout - set stderrsettings $settings - dict set stderrsettings -tag ${tagprefix}stderr - - set idout [redir_channel_to_log stdout -action [dict get $opts -action] -settings $stdoutsettings] - set iderr [redir_channel_to_log stderr -action [dict get $opts -action] -settings $stderrsettings] - - return [list $idout $iderr] - } - - #eg try: set v [list #a b c] - #vs set v {#a b c} - proc list_is_canonical l { - #courtesy DKF via wiki https://wiki.tcl-lang.org/page/BNF+for+Tcl - if {[catch {llength $l}]} {return 0} - string equal $l [list {*}$l] - } - - #return a dict keyed on numerical list index showing info about each element - # - particularly - # 'wouldbrace' to indicate that the item would get braced by Tcl when added to another list - # 'head_tail_chars' to show current first and last character (in case it's wrapped e.g in double or single quotes or an existing set of braces) - proc list_element_info {inputlist} { - set i 0 - set info [dict create] - set testlist [list] - foreach original_item $inputlist { - #--- - # avoid sharing internal rep with original items in the list (avoids shimmering of rep in original list for certain items such as paths) - unset -nocomplain item - append item $original_item {} - #--- - - set iteminfo [dict create] - set itemlen [string length $item] - lappend testlist $item - set tcl_len [string length $testlist] - set diff [expr {$tcl_len - $itemlen}] - if {$diff == 0} { - dict set iteminfo wouldbrace 0 - dict set iteminfo wouldescape 0 - } else { - #test for escaping vs bracing! - set testlistchars [split $testlist ""] - if {([lindex $testlistchars 0] eq "\{") && ([lindex $testlistchars end] eq "\}")} { - dict set iteminfo wouldbrace 1 - dict set iteminfo wouldescape 0 - } else { - dict set iteminfo wouldbrace 0 - dict set iteminfo wouldescape 1 - } - } - set testlist [list] - set charlist [split $item ""] - set char_a [lindex $charlist 0] - set char_b [lindex $charlist 1] - set char_ab ${char_a}${char_b} - set char_y [lindex $charlist end-1] - set char_z [lindex $charlist end] - set char_yz ${char_y}${char_z} - - if { ("{" in $charlist) || ("}" in $charlist) } { - dict set iteminfo has_braces 1 - set innerchars [lrange $charlist 1 end-1] - if {("{" in $innerchars) || ("}" in $innerchars)} { - dict set iteminfo has_inner_braces 1 - } else { - dict set iteminfo has_inner_braces 0 - } - } else { - dict set iteminfo has_braces 0 - dict set iteminfo has_inner_braces 0 - } - - #todo - brace/char counting to determine if actually 'wrapped' - #e.g we could have list element {((abc)} - which appears wrapped if only looking at first and last chars. - #also {(x) (y)} as a list member.. how to treat? - if {$itemlen <= 1} { - dict set iteminfo apparentwrap "not" - } else { - #todo - switch on $char_a$char_z - if {($char_a eq {"}) && ($char_z eq {"})} { - dict set iteminfo apparentwrap "doublequotes" - } elseif {($char_a eq "'") && ($char_z eq "'")} { - dict set iteminfo apparentwrap "singlequotes" - } elseif {($char_a eq "(") && ($char_z eq ")")} { - dict set iteminfo apparentwrap "brackets" - } elseif {($char_a eq "\{") && ($char_z eq "\}")} { - dict set iteminfo apparentwrap "braces" - } elseif {($char_a eq "^") && ($char_z eq "^")} { - dict set iteminfo apparentwrap "carets" - } elseif {($char_a eq "\[") && ($char_z eq "\]")} { - dict set iteminfo apparentwrap "squarebrackets" - } elseif {($char_a eq "`") && ($char_z eq "`")} { - dict set iteminfo apparentwrap "backquotes" - } elseif {($char_a eq "\n") && ($char_z eq "\n")} { - dict set iteminfo apparentwrap "lf-newline" - } elseif {($char_ab eq "\r\n") && ($char_yz eq "\r\n")} { - dict set iteminfo apparentwrap "crlf-newline" - } else { - dict set iteminfo apparentwrap "not-determined" - } - - } - dict set iteminfo wrapbalance "unknown" ;#a hint to caller that apparentwrap is only a guide. todo - possibly make wrapbalance indicate 0 for unbalanced.. and positive numbers for outer-count of wrappings. - #e.g {((x)} == 0 {((x))} == 1 {(x) (y (z))} == 2 - dict set iteminfo head_tail_chars [list $char_a $char_z] - set namemap [list \ - \r cr\ - \n lf\ - {"} doublequote\ - {'} singlequote\ - "`" backquote\ - "^" caret\ - \t tab\ - " " sp\ - "\[" lsquare\ - "\]" rsquare\ - "(" lbracket\ - ")" rbracket\ - "\{" lbrace\ - "\}" rbrace\ - \\ backslash\ - / forwardslash\ - ] - if {[string length $char_a]} { - set char_a_name [string map $namemap $char_a] - } else { - set char_a_name "emptystring" - } - if {[string length $char_z]} { - set char_z_name [string map $namemap $char_z] - } else { - set char_z_name "emptystring" - } - - dict set iteminfo head_tail_names [list $char_a_name $char_z_name] - dict set iteminfo len $itemlen - dict set iteminfo difflen $diff ;#2 for braces, 1 for quoting?, or 0. - dict set info $i $iteminfo - incr i - } - return $info - } - - - #parse bracketed expression (e.g produced by vim "shellxquote=(" ) into a tcl (nested) list - #e.g {(^c:/my spacey/path^ >^somewhere^)} - #e.g {(blah (etc))}" - #Result is always a list - even if only one toplevel set of brackets - so it may need [lindex $result 0] if input is the usual case of {( ...)} - # - because it also supports the perhaps less likely case of: {( ...) unbraced (...)} etc - # Note that - #maintenance warning - duplication in branches for bracketed vs unbracketed! - proc parse_cmd_brackets {str} { - #wordwrappers currently best suited to non-bracket entities - no bracket matching within - anything goes until end-token reached. - # - but.. they only take effect where a word can begin. so a[x y] may be split at the space unless it's within some other wraper e.g " a[x y]" will not break at the space - # todo - consider extending the in-word handling of word_bdepth which is currently only applied to () i.e aaa(x y) is supported but aaa[x y] is not as the space breaks the word up. - set wordwrappers [list \ - "\"" [list "\"" "\"" "\""]\ - {^} [list "\"" "\"" "^"]\ - "'" [list "'" "'" "'"]\ - "\{" [list "\{" "\}" "\}"]\ - {[} [list {[} {]} {]}]\ - ] ;#dict mapping start_character to {replacehead replacetail expectedtail} - set shell_specials [list "|" "|&" "<" "<@" "<<" ">" "2>" ">&" ">>" "2>>" ">>&" ">@" "2>@" "2>@1" ">&@" "&" "&&" ] ;#words/chars that may precede an opening bracket but don't merge with the bracket to form a word. - #puts "pb:$str" - set in_bracket 0 - set in_word 0 - set word "" - set result {} - set word_bdepth 0 - set word_bstack [list] - set wordwrap "" ;#only one active at a time - set bracketed_elements [dict create] - foreach char [split $str ""] { - #puts "c:$char bracketed:$bracketed_elements" - if {$in_bracket > 0} { - if {$in_word} { - if {[string length $wordwrap]} { - #anything goes until end-char - #todo - lookahead and only treat as closing if before a space or ")" ? - lassign [dict get $wordwrappers $wordwrap] _open closing endmark - if {$char eq $endmark} { - set wordwrap "" - append word $closing - dict lappend bracketed_elements $in_bracket $word - set word "" - set in_word 0 - } else { - append word $char - } - } else { - if {$word_bdepth == 0} { - #can potentially close off a word - or start a new one if word-so-far is a shell-special - if {$word in $shell_specials} { - if {$char eq ")"} { - dict lappend bracketed_elements $in_bracket $word - set subresult [dict get $bracketed_elements $in_bracket] - dict set bracketed_elements $in_bracket [list] - incr in_bracket -1 - if {$in_bracket == 0} { - lappend result $subresult - } else { - dict lappend bracketed_elements $in_bracket $subresult - } - set word "" - set in_word 0 - } elseif {[regexp {[\s]} $char]} { - dict lappend bracketed_elements $in_bracket $word - set word "" - set in_word 0 - } elseif {$char eq "("} { - dict lappend bracketed_elements $in_bracket $word - set word "" - set in_word 0 - incr in_bracket - } else { - #at end of shell-specials is another point to look for word started by a wordwrapper char - #- expect common case of things like >^/my/path^ - if {$char in [dict keys $wordwrappers]} { - dict lappend bracketed_elements $in_bracket $word - set word "" - set in_word 1 ;#just for explicitness.. we're straight into the next word. - set wordwrap $char - set word [lindex [dict get $wordwrappers $char] 0] ;#replace trigger char with the start value it maps to. - } else { - #something unusual.. keep going with word! - append word $char - } - } - } else { - - if {$char eq ")"} { - dict lappend bracketed_elements $in_bracket $word - set subresult [dict get $bracketed_elements $in_bracket] - dict set bracketed_elements $in_bracket [list] - incr in_bracket -1 - if {$in_bracket == 0} { - lappend result $subresult - } else { - dict lappend bracketed_elements $in_bracket $subresult - } - set word "" - set in_word 0 - } elseif {[regexp {[\s]} $char]} { - dict lappend bracketed_elements $in_bracket $word - set word "" - set in_word 0 - } elseif {$char eq "("} { - #ordinary word up-against and opening bracket - brackets are part of word. - incr word_bdepth - append word "(" - } else { - append word $char - } - } - } else { - #currently only () are used for word_bdepth - todo add all or some wordwrappers chars so that the word_bstack can have multiple active. - switch -- $char { - "(" { - incr word_bdepth - lappend word_bstack $char - append word $char - } - ")" { - incr word_bdepth -1 - set word_bstack [lrange $word_bstack 0 end-1] - append word $char - } - default { - #spaces and chars added to word as it's still in a bracketed section - append word $char - } - } - } - } - } else { - - if {$char eq "("} { - incr in_bracket - - } elseif {$char eq ")"} { - set subresult [dict get $bracketed_elements $in_bracket] - dict set bracketed_elements $in_bracket [list] - incr in_bracket -1 - if {$in_bracket == 0} { - lappend result $subresult - } else { - dict lappend bracketed_elements $in_bracket $subresult - } - } elseif {[regexp {[\s]} $char]} { - # - } else { - #first char of word - look for word-wrappers - if {$char in [dict keys $wordwrappers]} { - set wordwrap $char - set word [lindex [dict get $wordwrappers $char] 0] ;#replace trigger char with the start value it maps to. - } else { - set word $char - } - set in_word 1 - } - } - } else { - if {$in_word} { - if {[string length $wordwrap]} { - lassign [dict get $wordwrappers $wordwrap] _open closing endmark - if {$char eq $endmark} { - set wordwrap "" - append word $closing - lappend result $word - set word "" - set in_word 0 - } else { - append word $char - } - } else { - - if {$word_bdepth == 0} { - if {$word in $shell_specials} { - if {[regexp {[\s]} $char]} { - lappend result $word - set word "" - set in_word 0 - } elseif {$char eq "("} { - lappend result $word - set word "" - set in_word 0 - incr in_bracket - } else { - #at end of shell-specials is another point to look for word started by a wordwrapper char - #- expect common case of things like >^/my/path^ - if {$char in [dict keys $wordwrappers]} { - lappend result $word - set word "" - set in_word 1 ;#just for explicitness.. we're straight into the next word. - set wordwrap $char - set word [lindex [dict get $wordwrappers $char] 0] ;#replace trigger char with the start value it maps to. - } else { - #something unusual.. keep going with word! - append word $char - } - } - - } else { - if {[regexp {[\s)]} $char]} { - lappend result $word - set word "" - set in_word 0 - } elseif {$char eq "("} { - incr word_bdepth - append word $char - } else { - append word $char - } - } - } else { - switch -- $char { - "(" { - incr word_bdepth - append word $char - } - ")" { - incr word_bdepth -1 - append word $char - } - default { - append word $char - } - } - } - } - } else { - if {[regexp {[\s]} $char]} { - #insig whitespace(?) - } elseif {$char eq "("} { - incr in_bracket - dict set bracketed_elements $in_bracket [list] - } elseif {$char eq ")"} { - error "unbalanced bracket - unable to proceed result so far: $result bracketed_elements:$bracketed_elements" - } else { - #first char of word - look for word-wrappers - if {$char in [dict keys $wordwrappers]} { - set wordwrap $char - set word [lindex [dict get $wordwrappers $char] 0] ;#replace trigger char with the start value it maps to. - } else { - set word $char - } - set in_word 1 - } - } - } - #puts "----$bracketed_elements" - } - if {$in_bracket > 0} { - error "shellfilter::parse_cmd_brackets missing close bracket. input was '$str'" - } - if {[dict exists $bracketed_elements 0]} { - #lappend result [lindex [dict get $bracketed_elements 0] 0] - lappend result [dict get $bracketed_elements 0] - } - if {$in_word} { - lappend result $word - } - return $result - } - - #only double quote if argument not quoted with single or double quotes - proc dquote_if_not_quoted {a} { - set wrapchars [string cat [string range $a 0 0] [string range $a end end]] - switch -- $wrapchars { - {""} - {''} { - return $a - } - default { - set newinner [string map [list {"} "\\\""] $a] - return "\"$newinner\"" - } - } - } - - #proc dquote_if_not_bracketed/braced? - - #wrap in double quotes if not double-quoted - proc dquote_if_not_dquoted {a} { - set wrapchars [string cat [string range $a 0 0] [string range $a end end]] - switch -- $wrapchars { - {""} { - return $a - } - default { - #escape any inner quotes.. - set newinner [string map [list {"} "\\\""] $a] - return "\"$newinner\"" - } - } - } - proc dquote {a} { - #escape any inner quotes.. - set newinner [string map [list {"} "\\\""] $a] - return "\"$newinner\"" - } - proc get_scriptrun_from_cmdlist_dquote_if_not {cmdlist {shellcmdflag ""}} { - set scr [auto_execok "script"] - if {[string length $scr]} { - #set scriptrun "( $c1 [lrange $cmdlist 1 end] )" - set arg1 [lindex $cmdlist 0] - if {[string first " " $arg1]>0} { - set c1 [dquote_if_not_quoted $arg1] - #set c1 "\"$arg1\"" - } else { - set c1 $arg1 - } - - if {[string length $shellcmdflag]} { - set scriptrun "$shellcmdflag \$($c1 " - } else { - set scriptrun "\$($c1 " - } - #set scriptrun "$c1 " - foreach a [lrange $cmdlist 1 end] { - #set a [string map [list "/" "//"] $a] - #set a [string map [list "\"" "\\\""] $a] - if {[string first " " $a] > 0} { - append scriptrun [dquote_if_not_quoted $a] - } else { - append scriptrun $a - } - append scriptrun " " - } - set scriptrun [string trim $scriptrun] - append scriptrun ")" - #return [list $scr -q -e -c $scriptrun /dev/null] - return [list $scr -e -c $scriptrun /dev/null] - } else { - return $cmdlist - } - } - - proc ::shellfilter::trun {commandlist args} { - #jmn - } - - - # run a command (or tcl script) with tees applied to stdout/stderr/stdin (or whatever channels are being used) - # By the point run is called - any transforms should already be in place on the channels if they're needed. - # The tees will be inline with none,some or all of those transforms depending on how the stack was configured - # (upstream,downstream configured via -float,-sink etc) - proc ::shellfilter::run {commandlist args} { - #must be a list. If it was a shell commandline string. convert it elsewhere first. - - variable sources - set runtag "shellfilter-run" - #set tid [::shellfilter::log::open $runtag [list -syslog 127.0.0.1:514]] - set tid [::shellfilter::log::open $runtag [list -syslog ""]] - if {[catch {llength $commandlist} listlen]} { - set listlen "" - } - ::shellfilter::log::write $runtag " commandlist:'$commandlist' listlen:$listlen strlen:[string length $commandlist]" - - #flush stdout - #flush stderr - - #adding filters with sink-aside will temporarily disable the existing redirection - #All stderr/stdout from the shellcommand will now tee to the underlying stderr/stdout as well as the configured syslog - - set defaults [dict create \ - -teehandle command \ - -outchan stdout \ - -errchan stderr \ - -inchan stdin \ - -tclscript 0 \ - ] - set opts [dict merge $defaults $args] - - # -- --- --- --- --- --- --- --- --- --- --- --- --- --- - set outchan [dict get $opts -outchan] - set errchan [dict get $opts -errchan] - set inchan [dict get $opts -inchan] - set teehandle [dict get $opts -teehandle] - # -- --- --- --- --- --- --- --- --- --- --- --- --- --- - set is_script [dict get $opts -tclscript] - dict unset opts -tclscript ;#don't pass it any further - # -- --- --- --- --- --- --- --- --- --- --- --- --- --- - set teehandle_out ${teehandle}out ;#default commandout - set teehandle_err ${teehandle}err - set teehandle_in ${teehandle}in - - - #puts stdout "shellfilter initialising tee_to_pipe transforms for in/out/err" - - # sources should be added when stack::new called instead(?) - foreach source [list $teehandle_out $teehandle_err] { - if {$source ni $sources} { - lappend sources $source - } - } - set outdeviceinfo [dict get $::shellfilter::stack::pipelines $teehandle_out device] - set outpipechan [dict get $outdeviceinfo localchan] - set errdeviceinfo [dict get $::shellfilter::stack::pipelines $teehandle_err device] - set errpipechan [dict get $errdeviceinfo localchan] - - #set indeviceinfo [dict get $::shellfilter::stack::pipelines $teehandle_in device] - #set inpipechan [dict get $indeviceinfo localchan] - - #NOTE:These transforms are not necessarily at the top of each stack! - #The float/sink mechanism, along with whether existing transforms are diversionary decides where they sit. - set id_out [shellfilter::stack::add $outchan tee_to_pipe -action sink-aside -settings [list -tag $teehandle_out -pipechan $outpipechan]] - set id_err [shellfilter::stack::add $errchan tee_to_pipe -action sink-aside -settings [list -tag $teehandle_err -pipechan $errpipechan]] - - # need to use os level channel handle for stdin - try named pipes (or even sockets) instead of fifo2 for this - # If non os-level channel - the command can't be run with the redirection - # stderr/stdout can be run with non-os handles in the call - - # but then it does introduce issues with terminal-detection and behaviour for stdout at least - # - # input is also a tee - we never want to change the source at this point - just log/process a side-channel of it. - # - #set id_in [shellfilter::stack::add $inchan tee_to_pipe -action sink-aside -settings [list -tag commandin -pipechan $inpipechan]] - - - #set id_out [shellfilter::stack::add stdout tee_to_log -action sink-aside -settings [list -tag shellstdout -syslog 127.0.0.1:514 -file ""]] - #set id_err [shellfilter::stack::add stderr tee_to_log -action sink-aside -settings [list -tag shellstderr -syslog 127.0.0.1:514 -file "stderr.txt"]] - - #we need to catch errors - and ensure stack::remove calls occur. - #An error can be raised if the command couldn't even launch, as opposed to a non-zero exitcode and stderr output from the command itself. - # - if {!$is_script} { - set experiment 0 - if {$experiment} { - try { - set results [exec {*}$commandlist] - set exitinfo [list exitcode 0] - } trap CHILDSTATUS {results options} { - set exitcode [lindex [dict get $options -errorcode] 2] - set exitinfo [list exitcode $exitcode] - } - } else { - if {[catch { - #run process with stdout/stderr/stdin or with configured channels - #set exitinfo [shellcommand_stdout_stderr $commandlist $outchan $errchan $inpipechan {*}$opts] - set exitinfo [shellcommand_stdout_stderr $commandlist $outchan $errchan stdin {*}$opts] - #puts stderr "---->exitinfo $exitinfo" - - #subprocess result should usually have an "exitcode" key - #but for background execution we will get a "pids" key of process ids. - } errMsg]} { - set exitinfo [list error "$errMsg" source shellcommand_stdout_stderr] - } - } - } else { - if {[catch { - #script result - set exitinfo [list result [uplevel #0 [list eval $commandlist]]] - } errMsg]} { - set exitinfo [list error "$errMsg" errorCode $::errorCode errorInfo "$::errorInfo"] - } - } - - - #the previous redirections on the underlying inchan/outchan/errchan items will be restored from the -aside setting during removal - #Remove execution-time Tees from stack - shellfilter::stack::remove stdout $id_out - shellfilter::stack::remove stderr $id_err - #shellfilter::stack::remove stderr $id_in - - - #chan configure stderr -buffering line - #flush stdout - - - ::shellfilter::log::write $runtag " return '$exitinfo'" - ::shellfilter::log::close $runtag - return $exitinfo - } - proc ::shellfilter::logtidyup { {tags {}} } { - variable sources - set worker_errorlist [list] - set tidied_sources [list] - set tidytag "logtidy" - - - # opening a thread or writing to a log/syslog close to possible process exit is probably not a great idea. - # we should ensure the thread already exists early on if we really need logging here. - # - #set tid [::shellfilter::log::open $tidytag {-syslog 127.0.0.1:514}] - #::shellfilter::log::write $tidytag " logtidyuptags '$tags'" - - foreach s $sources { - if {$s eq $tidytag} { - continue - } - #puts "logtidyup source $s" - set close 1 - if {[llength $tags]} { - if {$s ni $tags} { - set close 0 - } - } - if {$close} { - lappend tidied_sources $s - shellfilter::log::close $s - lappend worker_errorlist {*}[shellthread::manager::get_and_clear_errors $s] - } - } - set remaining_sources [list] - foreach s $sources { - if {$s ni $tidied_sources} { - lappend remaining_sources $s - } - } - - #set sources [concat $remaining_sources $tidytag] - set sources $remaining_sources - - #shellfilter::stack::unwind stdout - #shellfilter::stack::unwind stderr - return [list tidied $tidied_sources errors $worker_errorlist] - } - - #package require tcl::chan::null - # e.g set errchan [tcl::chan::null] - # e.g chan push stdout [shellfilter::chan::var new ::some_var] - proc ::shellfilter::shellcommand_stdout_stderr {commandlist outchan errchan inchan args} { - set valid_flags [list \ - -timeout \ - -outprefix \ - -errprefix \ - -debug \ - -copytempfile \ - -outbuffering \ - -errbuffering \ - -inbuffering \ - -readprocesstranslation \ - -outtranslation \ - -stdinhandler \ - -outchan \ - -errchan \ - -inchan \ - -teehandle\ - ] - - set runtag shellfilter-run2 - #JMN - load from config - #set tid [::shellfilter::log::open $runtag [list -syslog "127.0.0.1:514"]] - set tid [::shellfilter::log::open $runtag [list -syslog ""]] - - if {[llength $args] % 2} { - error "Trailing arguments after any positional arguments must be in pairs of the form -argname argvalue. Valid flags are:'$valid_flags'" - } - set invalid_flags [list] - foreach {k -} $args { - switch -- $k { - -timeout - - -outprefix - - -errprefix - - -debug - - -copytempfile - - -outbuffering - - -errbuffering - - -inbuffering - - -readprocesstranslation - - -outtranslation - - -stdinhandler - - -outchan - - -errchan - - -inchan - - -teehandle { - } - default { - lappend invalid_flags $k - } - } - } - if {[llength $invalid_flags]} { - error "Unknown option(s)'$invalid_flags': must be one of '$valid_flags'" - } - #line buffering generally best for output channels.. keeps relative output order of stdout/stdin closer to source order - #there may be data where line buffering is inappropriate, so it's configurable per std channel - #reading inputs with line buffering can result in extraneous newlines as we can't detect trailing data with no newline before eof. - set defaults [dict create \ - -outchan stdout \ - -errchan stderr \ - -inchan stdin \ - -outbuffering none \ - -errbuffering none \ - -readprocesstranslation auto \ - -outtranslation lf \ - -inbuffering none \ - -timeout 900000\ - -outprefix ""\ - -errprefix ""\ - -debug 0\ - -copytempfile 0\ - -stdinhandler ""\ - ] - - - - set args [dict merge $defaults $args] - set outbuffering [dict get $args -outbuffering] - set errbuffering [dict get $args -errbuffering] - set inbuffering [dict get $args -inbuffering] - set readprocesstranslation [dict get $args -readprocesstranslation] - set outtranslation [dict get $args -outtranslation] - set timeout [dict get $args -timeout] - set outprefix [dict get $args -outprefix] - set errprefix [dict get $args -errprefix] - set debug [dict get $args -debug] - set copytempfile [dict get $args -copytempfile] - set stdinhandler [dict get $args -stdinhandler] - - set debugname "shellfilter-debug" - - if {$debug} { - set tid [::shellfilter::log::open $debugname [list -syslog "127.0.0.1:514"]] - ::shellfilter::log::write $debugname " commandlist '$commandlist'" - } - #'clock micros' good enough id for shellcommand calls unless one day they can somehow be called concurrently or sequentially within a microsecond and within the same interp. - # a simple counter would probably work too - #consider other options if an alternative to the single vwait in this function is used. - set call_id [tcl::clock::microseconds] ; - set ::shellfilter::shellcommandvars($call_id,exitcode) "" - set waitvar ::shellfilter::shellcommandvars($call_id,waitvar) - if {$debug} { - ::shellfilter::log::write $debugname " waitvar '$waitvar'" - } - lassign [chan pipe] rderr wrerr - chan configure $wrerr -blocking 0 - - set custom_stderr "" - set lastitem [lindex $commandlist end] - #todo - ensure we can handle 2> file (space after >) - - #review - reconsider the handling of redirections such that tcl-style are handled totally separately to other shell syntaxes! - # - #note 2>@1 must ocur as last word for tcl - but 2@stdout can occur elsewhere - #(2>@stdout echoes to main stdout - not into pipeline) - #To properly do pipelines it looks like we will have to split on | and call this proc multiple times and wire it up accordingly (presumably in separate threads) - - switch -- [string trim $lastitem] { - {&} { - set name [lindex $commandlist 0] - #background execution - stdout and stderr from child still comes here - but process is backgrounded - #FIX! - this is broken for paths with backslashes for example - #set pidlist [exec {*}[concat $name [lrange $commandlist 1 end]]] - set pidlist [exec {*}$commandlist] - return [list pids $pidlist] - } - {2>&1} - {2>@1} { - set custom_stderr {2>@1} ;#use the tcl style - set commandlist [lrange $commandlist 0 end-1] - } - default { - # 2> filename - # 2>> filename - # 2>@ openfileid - set redir2test [string range $lastitem 0 1] - if {$redir2test eq "2>"} { - set custom_stderr $lastitem - set commandlist [lrange $commandlist 0 end-1] - } - } - } - set lastitem [lindex $commandlist end] - - set teefile "" ;#empty string, write, append - #an ugly hack.. because redirections seem to arrive wrapped - review! - #There be dragons here.. - #Be very careful with list manipulation of the commandlist string.. backslashes cause havoc. commandlist must always be a well-formed list. generally avoid string manipulations on entire list or accidentally breaking a list element into parts if it shouldn't be.. - #The problem here - is that we can't always know what was intended on the commandline regarding quoting - - ::shellfilter::log::write $runtag "checking for redirections in $commandlist" - #sometimes we see a redirection without a following space e.g >C:/somewhere - #normalize - switch -regexp -- $lastitem\ - {^>[/[:alpha:]]+} { - set lastitem "> [string range $lastitem 1 end]" - }\ - {^>>[/[:alpha:]]+} { - set lastitem ">> [string range $lastitem 2 end]" - } - - - #for a redirection, we assume either a 2-element list at tail of form {> {some path maybe with spaces}} - #or that the tail redirection is not wrapped.. x y z > {some path maybe with spaces} - #we can't use list methods such as llenth on a member of commandlist - set wordlike_parts [regexp -inline -all {\S+} $lastitem] - - if {([llength $wordlike_parts] >= 2) && ([lindex $wordlike_parts 0] in [list ">>" ">"])} { - #wrapped redirection - but maybe not 'well' wrapped (unquoted filename) - set lastitem [string trim $lastitem] ;#we often see { > something} - - #don't use lassign or lrange on the element itself without checking first - #we can treat the commandlist as a whole as a well formed list but not neccessarily each element within. - #lassign $lastitem redir redirtarget - #set commandlist [lrange $commandlist 0 end-1] - # - set itemchars [split $lastitem ""] - set firstchar [lindex $itemchars 0] - set lastchar [lindex $itemchars end] - - #NAIVE test for double quoted only! - #consider for example {"a" x="b"} - #testing first and last is not decisive - #We need to decide what level of drilling down is even appropriate here.. - #if something was double wrapped - it was perhaps deliberate so we don't interpret it as something(?) - set head_tail_chars [list $firstchar $lastchar] - set doublequoted [expr {[llength [lsearch -all $head_tail_chars "\""]] == 2}] - if {[string equal "\{" $firstchar] && [string equal "\}" $lastchar]} { - set curlyquoted 1 - } else { - set curlyquoted 0 - } - - if {$curlyquoted} { - #these are not the tcl protection brackets but ones supplied in the argument - #it's still not valid to use list operations on a member of the commandlist - set inner [string range $lastitem 1 end-1] - #todo - fix! we still must assume there could be list-breaking data! - set innerwords [regexp -inline -all {\S+} $inner] ;#better than [split $inner] because we don't get extra empty elements for each whitespace char - set redir [lindex $innerwords 0] ;#a *potential* redir - to be tested below - set redirtarget [lrange $innerwords 1 end] ;#all the rest - } elseif {$doublequoted} { - ::shellfilter::log::write $debugname "doublequoting at tail of command '$commandlist'" - set inner [string range $lastitem 1 end-1] - set innerwords [regexp -inline -all {\S+} $inner] - set redir [lindex $innerwords 0] - set redirtarget [lrange $innerwords 1 end] - } else { - set itemwords [regexp -inline -all {\S+} $lastitem] - # e.g > c:\test becomes > {c:\test} - # but > c/mnt/c/test/temp.txt stays as > /mnt/c/test/temp.txt - set redir [lindex $itemwords 0] - set redirtarget [lrange $itemwords 1 end] - } - set commandlist [lrange $commandlist 0 end-1] - - } elseif {[lindex $commandlist end-1] in [list ">>" ">"]} { - #unwrapped redirection - #we should be able to use list operations like lindex and lrange here as the command itself is hopefully still a well formed list - set redir [lindex $commandlist end-1] - set redirtarget [lindex $commandlist end] - set commandlist [lrange $commandlist 0 end-2] - } else { - #no redirection - set redir "" - set redirtarget "" - #no change to command list - } - - - switch -- $redir { - ">>" - ">" { - set redirtarget [string trim $redirtarget "\""] - ::shellfilter::log::write $runtag " have redirection '$redir' to '$redirtarget'" - - set winfile $redirtarget ;#default assumption - switch -glob -- $redirtarget { - "/c/*" { - set winfile "c:/[string range $redirtarget 3 end]" - } - "/mnt/c/*" { - set winfile "c:/[string range $redirtarget 7 end]" - } - } - - if {[file exists [file dirname $winfile]]} { - #containing folder for target exists - if {$redir eq ">"} { - set teefile "write" - } else { - set teefile "append" - } - ::shellfilter::log::write $runtag "Directory exists '[file dirname $winfile]' operation:$teefile" - } else { - #we should be writing to a file.. but can't - ::shellfilter::log::write $runtag "cannot verify directory exists '[file dirname $winfile]'" - } - } - default { - ::shellfilter::log::write $runtag "No redir found!!" - } - } - - #often first element of command list is wrapped and cannot be run directly - #e.g {{ls -l} {> {temp.tmp}}} - #we will assume that if there is a single element which is a pathname containing a space - it is doubly wrapped. - # this may not be true - and the command may fail if it's just {c:\program files\etc} but it is the less common case and we currently have no way to detect. - #unwrap first element.. will not affect if not wrapped anyway (subject to comment above re spaces) - set commandlist [concat [lindex $commandlist 0] [lrange $commandlist 1 end]] - - #todo? - #child process environment. - # - to pass a different environment to the child - we would need to save the env array, modify as required, and then restore the env array. - - #to restore buffering states after run - set remember_in_out_err_buffering [list \ - [chan configure $inchan -buffering] \ - [chan configure $outchan -buffering] \ - [chan configure $errchan -buffering] \ - ] - - set remember_in_out_err_translation [list \ - [chan configure $inchan -translation] \ - [chan configure $outchan -translation] \ - [chan configure $errchan -translation] \ - ] - - - - - - chan configure $inchan -buffering $inbuffering -blocking 0 ;#we are setting up a readable handler for this - so non-blocking ok - chan configure $errchan -buffering $errbuffering - #chan configure $outchan -blocking 0 - chan configure $outchan -buffering $outbuffering ;#don't configure non-blocking. weird duplicate of *second* line occurs if you do. - # - - #-------------------------------------------- - #Tested on windows. Works to stop in output when buffering is none, reading from channel with -translation auto - #cmd, pwsh, tcl - #chan configure $outchan -translation lf - #chan configure $errchan -translation lf - #-------------------------------------------- - chan configure $outchan -translation $outtranslation - chan configure $errchan -translation $outtranslation - - #puts stderr "chan configure $wrerr [chan configure $wrerr]" - if {$debug} { - ::shellfilter::log::write $debugname "COMMAND [list $commandlist] strlen:[string length $commandlist] llen:[llength $commandlist]" - } - #todo - handle custom redirection of stderr to a file? - if {[string length $custom_stderr]} { - #::shellfilter::log::write $runtag "LAUNCH open |[concat $commandlist $custom_stderr] a+" - #set rdout [open |[concat $commandlist $custom_stderr] a+] - ::shellfilter::log::write $runtag "LAUNCH open |[concat $commandlist [list $custom_stderr <@$inchan]] [list RDONLY]" - set rdout [open |[concat $commandlist [list <@$inchan $custom_stderr]] [list RDONLY]] - set rderr "bogus" ;#so we don't wait for it - } else { - ::shellfilter::log::write $runtag "LAUNCH open |[concat $commandlist [list 2>@$wrerr <@$inchan]] [list RDONLY]" - #set rdout [open |[concat $commandlist [list 2>@$wrerr]] a+] - #set rdout [open |[concat $commandlist [list 2>@$wrerr]] [list RDWR]] - - # If we don't redirect stderr to our own tcl-based channel - then the transforms don't get applied. - # This is the whole reason we need these file-event loops. - # Ideally we need something like exec,open in tcl that interacts with transformed channels directly and emits as it runs, not only at termination - # - and that at least appears like a terminal to the called command. - #set rdout [open |[concat $commandlist [list 2>@stderr <@$inchan]] [list RDONLY]] - - - set rdout [open |[concat $commandlist [list 2>@$wrerr <@$inchan]] [list RDONLY]] - - chan configure $rderr -buffering $errbuffering -blocking 0 - chan configure $rderr -translation $readprocesstranslation - } - - - - set command_pids [pid $rdout] - #puts stderr "command_pids: $command_pids" - #tcl::process ensemble only available in 8.7+ - and it didn't prove useful here anyway - # the child process generally won't shut down until channels are closed. - # premature EOF on grandchild process launch seems to be due to lack of terminal emulation when redirecting stdin/stdout. - # worked around in punk/repl using 'script' command as a fake tty. - #set subprocesses [tcl::process::list] - #puts stderr "subprocesses: $subprocesses" - #if {[lindex $command_pids 0] ni $subprocesses} { - # puts stderr "pid [lindex $command_pids 0] not running $errMsg" - #} else { - # puts stderr "pid [lindex $command_pids 0] is running" - #} - - - if {$debug} { - ::shellfilter::log::write $debugname "pipeline pids: $command_pids" - } - - #jjj - - - chan configure $rdout -buffering $outbuffering -blocking 0 - chan configure $rdout -translation $readprocesstranslation - - if {![string length $custom_stderr]} { - chan event $rderr readable [list apply {{chan other wrerr outchan errchan waitfor errprefix errbuffering debug debugname pids} { - if {$errbuffering eq "line"} { - set countchunk [chan gets $chan chunk] ;#only get one line so that order between stderr and stdout is more likely to be preserved - #errprefix only applicable to line buffered output - if {$countchunk >= 0} { - if {[chan eof $chan]} { - puts -nonewline $errchan ${errprefix}$chunk - } else { - puts $errchan "${errprefix}$chunk" - } - } - } else { - set chunk [chan read $chan] - if {[string length $chunk]} { - puts -nonewline $errchan $chunk - } - } - if {[chan eof $chan]} { - flush $errchan ;#jmn - #set subprocesses [tcl::process::list] - #puts stderr "subprocesses: $subprocesses" - #if {[lindex $pids 0] ni $subprocesses} { - # puts stderr "stderr reader: pid [lindex $pids 0] no longer running" - #} else { - # puts stderr "stderr reader: pid [lindex $pids 0] still running" - #} - chan close $chan - #catch {chan close $wrerr} - if {$other ni [chan names]} { - set $waitfor stderr - } - } - }} $rderr $rdout $wrerr $outchan $errchan $waitvar $errprefix $errbuffering $debug $debugname $command_pids] - } - - #todo - handle case where large amount of stdin coming in faster than rdout can handle - #as is - arbitrary amount of memory could be used because we aren't using a filevent for rdout being writable - # - we're just pumping it in to the non-blocking rdout buffers - # ie there is no backpressure and stdin will suck in as fast as possible. - # for most commandlines this probably isn't too big a deal.. but it could be a problem for multi-GB disk images etc - # - # - - ## Note - detecting trailing missing nl before eof is basically the same here as when reading rdout from executable - # - but there is a slight difference in that with rdout we get an extra blocked state just prior to the final read. - # Not known if that is significant - ## with inchan configured -buffering line - #c:\repo\jn\punk\test>printf "test\netc\n" | tclsh punk.vfs/main.tcl -r cat - #warning reading input with -buffering line. Cannot detect missing trailing-newline at eof - #instate b:0 eof:0 pend:-1 count:4 - #test - #instate b:0 eof:0 pend:-1 count:3 - #etc - #instate b:0 eof:1 pend:-1 count:-1 - - #c:\repo\jn\punk\test>printf "test\netc" | tclsh punk.vfs/main.tcl -r cat - #warning reading input with -buffering line. Cannot detect missing trailing-newline at eof - #instate b:0 eof:0 pend:-1 count:4 - #test - #instate b:0 eof:1 pend:-1 count:3 - #etc - - if 0 { - chan event $inchan readable [list apply {{chan wrchan inbuffering waitfor} { - #chan copy stdin $chan ;#doesn't work in a chan event - if {$inbuffering eq "line"} { - set countchunk [chan gets $chan chunk] - #puts $wrchan "stdinstate b:[chan blocked $chan] eof:[chan eof $chan] pend:[chan pending output $chan] count:$countchunk" - if {$countchunk >= 0} { - if {[chan eof $chan]} { - puts -nonewline $wrchan $chunk - } else { - puts $wrchan $chunk - } - } - } else { - set chunk [chan read $chan] - if {[string length $chunk]} { - puts -nonewline $wrchan $chunk - } - } - if {[chan eof $chan]} { - puts stderr "|stdin_reader>eof [chan configure stdin]" - chan event $chan readable {} - #chan close $chan - chan close $wrchan write ;#half close - #set $waitfor "stdin" - } - }} $inchan $rdout $inbuffering $waitvar] - - if {[string length $stdinhandler]} { - chan configure stdin -buffering line -blocking 0 - chan event stdin readable $stdinhandler - } - } - - set actual_proc_out_buffering [chan configure $rdout -buffering] - set actual_outchan_buffering [chan configure $outchan -buffering] - #despite whatever is configured - we match our reading to how we need to output - set read_proc_out_buffering $actual_outchan_buffering - - - - if {[string length $teefile]} { - set logname "redir_[string map {: _} $winfile]_[tcl::clock::microseconds]" - set tid [::shellfilter::log::open $logname {-syslog 127.0.0.1:514}] - if {$teefile eq "write"} { - ::shellfilter::log::write $logname "opening '$winfile' for write" - set fd [open $winfile w] - } else { - ::shellfilter::log::write $logname "opening '$winfile' for appending" - set fd [open $winfile a] - } - #chan configure $fd -translation lf - chan configure $fd -translation $outtranslation - chan configure $fd -encoding utf-8 - - set tempvar_bytetotal [namespace current]::totalbytes[tcl::clock::microseconds] - set $tempvar_bytetotal 0 - chan event $rdout readable [list apply {{chan other wrerr outchan errchan read_proc_out_buffering waitfor outprefix call_id debug debugname writefile writefilefd copytempfile bytevar logtag} { - #review - if we write outprefix to normal stdout.. why not to redirected file? - #usefulness of outprefix is dubious - upvar $bytevar totalbytes - if {$read_proc_out_buffering eq "line"} { - #set outchunk [chan read $chan] - set countchunk [chan gets $chan outchunk] ;#only get one line so that order between stderr and stdout is more likely to be preserved - if {$countchunk >= 0} { - if {![chan eof $chan]} { - set numbytes [expr {[string length $outchunk] + 1}] ;#we are assuming \n not \r\n - but count won't/can't be completely accurate(?) - review - puts $writefilefd $outchunk - } else { - set numbytes [string length $outchunk] - puts -nonewline $writefilefd $outchunk - } - incr totalbytes $numbytes - ::shellfilter::log::write $logtag "${outprefix} wrote $numbytes bytes to $writefile" - #puts $outchan "${outprefix} wrote $numbytes bytes to $writefile" - } - } else { - set outchunk [chan read $chan] - if {[string length $outchunk]} { - puts -nonewline $writefilefd $outchunk - set numbytes [string length $outchunk] - incr totalbytes $numbytes - ::shellfilter::log::write $logtag "${outprefix} wrote $numbytes bytes to $writefile" - } - } - if {[chan eof $chan]} { - flush $writefilefd ;#jmn - #set blocking so we can get exit code - chan configure $chan -blocking 1 - catch {::shellfilter::log::write $logtag "${outprefix} total bytes $totalbytes written to $writefile"} - #puts $outchan "${outprefix} total bytes $totalbytes written to $writefile" - catch {close $writefilefd} - if {$copytempfile} { - catch {file copy $writefile "[file rootname $writefile]_copy[file extension $writefile]"} - } - try { - chan close $chan - set ::shellfilter::shellcommandvars($call_id,exitcode) 0 - if {$debug} { - ::shellfilter::log::write $debugname "(teefile) -- child process returned no error. (exit code 0) --" - } - } trap CHILDSTATUS {result options} { - set code [lindex [dict get $options -errorcode] 2] - if {$debug} { - ::shellfilter::log::write $debugname "(teefile) CHILD PROCESS EXITED with code: $code" - } - set ::shellfilter::shellcommandvars($call_id,exitcode) $code - } - catch {chan close $wrerr} - if {$other ni [chan names]} { - set $waitfor stdout - } - } - }} $rdout $rderr $wrerr $outchan $errchan $read_proc_out_buffering $waitvar $outprefix $call_id $debug $debugname $winfile $fd $copytempfile $tempvar_bytetotal $logname] - - } else { - - # This occurs when we have outbuffering set to 'line' - as the 'input' from rdout which comes from the executable is also configured to 'line' - # where b:0|1 is whether chan blocked $chan returns 0 or 1 - # pend is the result of chan pending $chan - # eof is the resot of chan eof $chan - - - ##------------------------- - ##If we still read with gets,to retrieve line by line for output to line-buffered output - but the input channel is configured with -buffering none - ## then we can detect the difference - # there is an extra blocking read - but we can stil use eof with data to detect the absent newline and avoid passing an extra one on. - #c:\repo\jn\punk\test>printf "test\netc\n" | tclsh punk.vfs/main.tcl /c cat - #instate b:0 eof:0 pend:-1 count:4 - #test - #instate b:0 eof:0 pend:-1 count:3 - #etc - #instate b:0 eof:1 pend:-1 count:-1 - - #c:\repo\jn\punk\test>printf "test\netc" | tclsh punk.vfs/main.tcl /u/c cat - #instate b:0 eof:0 pend:-1 count:4 - #test - #instate b:1 eof:0 pend:-1 count:-1 - #instate b:0 eof:1 pend:-1 count:3 - #etc - ##------------------------ - - - #this should only occur if upstream is coming from stdin reader that has line buffering and hasn't handled the difference properly.. - ###reading with gets from line buffered input with trailing newline - #c:\repo\jn\punk\test>printf "test\netc\n" | tclsh punk.vfs/main.tcl /c cat - #instate b:0 eof:0 pend:-1 count:4 - #test - #instate b:0 eof:0 pend:-1 count:3 - #etc - #instate b:0 eof:1 pend:-1 count:-1 - - ###reading with gets from line buffered input with trailing newline - ##No detectable difference! - #c:\repo\jn\punk\test>printf "test\netc" | tclsh punk.vfs/main.tcl /c cat - #instate b:0 eof:0 pend:-1 count:4 - #test - #instate b:0 eof:0 pend:-1 count:3 - #etc - #instate b:0 eof:1 pend:-1 count:-1 - ##------------------------- - - #Note that reading from -buffering none and writing straight out gives no problem because we pass the newlines through as is - - - #set ::shellfilter::chan::lastreadblocked_nodata_noeof($rdout) 0 ;#a very specific case of readblocked prior to eof.. possibly not important - #this detection is disabled for now - but left for debugging in case it means something.. or changes - chan event $rdout readable [list apply {{chan other wrerr outchan errchan read_proc_out_buffering waitfor outprefix call_id debug debugname pids} { - #set outchunk [chan read $chan] - - if {$read_proc_out_buffering eq "line"} { - set countchunk [chan gets $chan outchunk] ;#only get one line so that order between stderr and stdout is more likely to be preserved - #countchunk can be -1 before eof e.g when blocked - #debugging output inline with data - don't leave enabled - #puts $outchan "instate b:[chan blocked $chan] eof:[chan eof $chan] pend:[chan pending output $chan] count:$countchunk" - if {$countchunk >= 0} { - if {![chan eof $chan]} { - puts $outchan ${outprefix}$outchunk - } else { - puts -nonewline $outchan ${outprefix}$outchunk - #if {$::shellfilter::chan::lastreadblocked_nodata_noeof($chan)} { - # seems to be the usual case - #} else { - # #false alarm, or ? we've reached eof with data but didn't get an empty blocking read just prior - # #Not known if this occurs - # #debugging output inline with data - don't leave enabled - # puts $outchan "!!!prev read didn't block: instate b:[chan blocked $chan] eof:[chan eof $chan] pend:[chan pending output $chan] count:$countchunk" - #} - } - #set ::shellfilter::chan::lastreadblocked_nodata_noeof($chan) 0 - } else { - #set ::shellfilter::chan::lastreadblocked_nodata_noeof($chan) [expr {[chan blocked $chan] && ![chan eof $chan]}] - } - } else { - #puts $outchan "read CHANNEL $chan [chan configure $chan]" - #puts $outchan "write CHANNEL $outchan b:[chan configure $outchan -buffering] t:[chan configure $outchan -translation] e:[chan configure $outchan -encoding]" - set outchunk [chan read $chan] - #puts $outchan "instate b:[chan blocked $chan] eof:[chan eof $chan] pend:[chan pending output $chan] count:[string length $outchunk]" - if {[string length $outchunk]} { - #set stringrep [encoding convertfrom utf-8 $outchunk] - #set newbytes [encoding convertto utf-16 $stringrep] - #puts -nonewline $outchan $newbytes - puts -nonewline $outchan $outchunk - } - } - - if {[chan eof $chan]} { - flush $outchan ;#jmn - #for now just look for first element in the pid list.. - #set subprocesses [tcl::process::list] - #puts stderr "subprocesses: $subprocesses" - #if {[lindex $pids 0] ni $subprocesses} { - # puts stderr "stdout reader pid: [lindex $pids 0] no longer running" - #} else { - # puts stderr "stdout reader pid: [lindex $pids 0] still running" - #} - - #puts $outchan "instate b:[chan blocked $chan] eof:[chan eof $chan] pend:[chan pending output $chan]" - chan configure $chan -blocking 1 ;#so we can get exit code - try { - chan close $chan - set ::shellfilter::shellcommandvars($call_id,exitcode) 0 - if {$debug} { - ::shellfilter::log::write $debugname " -- child process returned no error. (exit code 0) --" - } - } trap CHILDSTATUS {result options} { - set code [lindex [dict get $options -errorcode] 2] - set ::shellfilter::shellcommandvars($call_id,exitcode) $code - if {$debug} { - ::shellfilter::log::write $debugname " CHILD PROCESS EXITED with code: $code" - } - } trap CHILDKILLED {result options} { - #set code [lindex [dict get $options -errorcode] 2] - #set ::shellfilter::shellcommandvars(%id%,exitcode) $code - set ::shellfilter::shellcommandvars($call_id,exitcode) "childkilled" - if {$debug} { - ::shellfilter::log::write $debugname " CHILD PROCESS EXITED with result:'$result' options:'$options'" - } - - } finally { - #puts stdout "HERE" - #flush stdout - - } - catch {chan close $wrerr} - if {$other ni [chan names]} { - set $waitfor stdout - } - - } - }} $rdout $rderr $wrerr $outchan $errchan $read_proc_out_buffering $waitvar $outprefix $call_id $debug $debugname $command_pids] - } - - #todo - add ability to detect activity/data-flow and change timeout to only apply for period with zero data - #e.g x hrs with no data(?) - #reset timeout when data detected. - after $timeout [string map [list %w% $waitvar %id% $call_id %wrerr% $wrerr %rdout% $rdout %rderr% $rderr %debug% $debug %debugname% $debugname] { - if {[info exists ::shellfilter::shellcommandvars(%id%,exitcode)]} { - if {[set ::shellfilter::shellcommandvars(%id%,exitcode)] ne ""} { - catch { chan close %wrerr% } - catch { chan close %rdout%} - catch { chan close %rderr%} - } else { - chan configure %rdout% -blocking 1 - try { - chan close %rdout% - set ::shellfilter::shellcommandvars(%id%,exitcode) 0 - if {%debug%} { - ::shellfilter::log::write %debugname% "(timeout) -- child process returned no error. (exit code 0) --" - } - } trap CHILDSTATUS {result options} { - set code [lindex [dict get $options -errorcode] 2] - if {%debug%} { - ::shellfilter::log::write %debugname% "(timeout) CHILD PROCESS EXITED with code: $code" - } - set ::shellfilter::shellcommandvars(%id%,exitcode) $code - } trap CHILDKILLED {result options} { - set code [lindex [dict get $options -errorcode] 2] - #set code [dict get $options -code] - #set ::shellfilter::shellcommandvars(%id%,exitcode) $code - #set ::shellfilter::shellcommandvars($call_id,exitcode) "childkilled-timeout" - set ::shellfilter::shellcommandvars(%id%,exitcode) "childkilled-timeout" - if {%debug%} { - ::shellfilter::log::write %debugname% "(timeout) CHILDKILLED with code: $code" - ::shellfilter::log::write %debugname% "(timeout) result:$result options:$options" - } - - } - catch { chan close %wrerr% } - catch { chan close %rderr%} - } - set %w% "timeout" - } - }] - - - vwait $waitvar - - set exitcode [set ::shellfilter::shellcommandvars($call_id,exitcode)] - if {![string is digit -strict $exitcode]} { - puts stderr "Process exited with non-numeric code: $exitcode" - flush stderr - } - if {[string length $teefile]} { - #cannot be called from within an event handler above.. vwait reentrancy etc - catch {::shellfilter::log::close $logname} - } - - if {$debug} { - ::shellfilter::log::write $debugname " closed by: [set $waitvar] with exitcode: $exitcode" - catch {::shellfilter::log::close $debugname} - } - array unset ::shellfilter::shellcommandvars $call_id,* - - - #restore buffering to pre shellfilter::run state - lassign $remember_in_out_err_buffering bin bout berr - chan configure $inchan -buffering $bin - chan configure $outchan -buffering $bout - chan configure $errchan -buffering $berr - - lassign $remember_in_out_err_translation tin tout terr - chan configure $inchan -translation $tin - chan configure $outchan -translation $tout - chan configure $errchan -translation $terr - - - #in channel probably closed..(? review - should it be?) - catch { - chan configure $inchan -buffering $bin - } - - - return [list exitcode $exitcode] - } - -} - -package provide shellfilter [namespace eval shellfilter { - variable version - set version 0.1.9 -}] diff --git a/src/vfs/_vfscommon.vfs/modules/tarjar-2.3.tm b/src/vfs/_vfscommon.vfs/modules/tarjar-2.3.tm deleted file mode 100644 index 3bb1d96b2831652e8b235f912ccaf265947c7199..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 114176 zcmeIbX?Gh(k}mA8;B!l zABC-tf_%z<`LKC+>)zel&E}nE^P}e0_TBA|Lb&_hA*pC^Ho?$8+S;mk_3!YgHaGv9 z{%A02btdg`|9EQDu`z8A-UcU_|9f}t%+LS!?R)p`-@`=X)4X&4&b`~s+xKs8f7HC! zymuduf0H@+H=qAyo9*S=|D6r`tzr1SHEwqY;fK-wpc}Tgw(f3(uYUd}eAjPxhm-C` zc>aIC|6w+oBTyu*_ggut}WLZAK=4w!_(RL zcr@wmgrB;tPFN$ou7^*;>v4bD4NBMJZYLa#Ix~!=*B^8zVK(Ux55nziR?r8N5r)huwb9moRcse}nT`jIU$ai8qkz7SFc}~a4t_G4joTPBTF1~L z-Z!R4HnfQr>9)8U_D`e|!JHn>CZW?GciU4SoN!7BAsRNUG)M9xvXmA{Lq{NpQLm@O z(G9K6s}{z4fFdLnjycY23qx(S+ug~e&(4)_(IDt$*lCT0B!VM-IvNc?EI@Dc*XVBkY z5B*+fkGriYmsHC}$wr?l;b0P5<6Ges==>8*?nx-N##+8GZiOQ-;xHV^613h(!{dMs zIyyz+=@_&$2BuGdDl86f?{y!8W?cu9ohb&ah_1Xwcrsn>aFGwe&VZ5dvfDjoTf+k^ zqybiXnDmd1$t|Sk0mk;Ki|)Fu36Rn~9*j=7T1X1V-4P4UhP~ENAFOk%B+uFRPBCmH zgbA?{6xlbXqs|D-vOj#)olN@&pv9f=LjXa>lTJes^ww>NTj{l z6y5!bqKZ8fK;MoEp`#sfQ0hZvT z-NL#X^@I#tv*~E>xHUbzMINQN?7jiVnE)ZOI3_1xgGXV~B@KeLt+Sh7I1@5ALgg~+ zuSetQ;p;=L)#L717QqnM-|vDm^rsW)U~)K`4La73;w42VtpzL13v)xp=H;A!Km4*tTpOn8S8! z(tWrN(0cth#zl5^gt2t7PC!0DGg#IT+XyE>@3#|>jAo2Sliy(zTMcmEsHO-UX36skooBn+QcNt z=0sLY_Q4Itk>|5A0VJ~OMG*`{AGqEKtYD3z$#izynD!wt0GgT72bmCfA-3A?u#LX@ z!~RkKSE;0Mkh$regZ=>SN$7Q7Q@%h0J3Esu$bUAJwkFQ9A;0Oa5}F&^TNTY5gBO!` z*w8>!0K3zt(1Q8LWU6G;9^4|W^rw(Y!Cko-Vl5s+%)pipbc|boMutM15Ff35u+yoq z+3^g-%e5^9&?YKuDk_CL4q2x&qnM;(&g?j>MZlUHTN};$4mue?O;%TT$O&y=e21C zGgeuuLFOHUGhy51d$Rk~{%fGA`vxnz-KXfKY=T<@_9+U&SU1@B8YD8#?qGB9n@Oe!(IuVtK_ZFCcJN0lQNb@Wi zkzi{Ml(o#~^O%SQ)~2I%>6hjBVef^v;rRf_*_DPk3>HX$>i}$;71{b@cX>&N{9NUI zAZ##t4a7YcY1;O9>;m=b#&&l@_itf^RJ5YgRfKHP9rV_%F|aS8%0*29L7_W5`t^GnN)zLKKBbIF&^P{r8Mh_jwJYc^H-jidfz_z%u5p=F*$XuQ{tk zb=5ez*oRTjD;5oF+;n9}=QbH$AC4$)sT>ZL^wpoAVWZ@N$QU=bdXeO@7`O|oiXlpu zaC{N0Ca8y{?YgCNSzw_J-lq~KMa0%VWliqJ5Ee};6mga92`|ISv<)S&c|aAnq;dZh zR9C9yROnR*)$K@uCd-N(lZsIf8VwjdHX>nycz_KisSR;=VcGrBcnk{X#z;QFjj0nv zlXTU&)2G}<@FSmDp5xs+jx26a)eH}No9uC15vNLXlM%K~-Np?N@PD#n!+bW=QURht z8$d$nnvj{CJ_=uPm6442A;)+Q*=2YDB-bD9hA+PiTPQH@PG{p`I6XUCQ1q*+qOmO1 zR0v}DZ=%dVNNq5pSPO!Mj7}NrXasDINBhv!V$C8z=;Z;{RDv&uU3Y#^3;>Vy_2HvX z|El!pt58SL_%MwtHFKICf|9x|XtrsMA=vMe@snG~OqbxT>m;t0US^ud;;G@{mPhh}+u1p6O(1ws$?mnV z-z_g=*=&IXRRFNQ%9{X07t}bT2!p?S#{VK=R<{rS(-k1{*Toh>z4#l@65d5DZO>U* z2K^rOOo-grL&Xe*N^R^MVg}wHf%DO% zOnFzfunwMVPNonxv3zP`-%X;@(;1eWE4DtPZnwY^#yXTG**$_0fHEkW73+{T$adKw zh2O&#w8H%^X96}t!N`jGp;J9ekgw^ekW)0cpR);jp4puoTs1=yy{qFQN(Jtb>cT3@+0FOu}U^r^I zqKQh>I8jB2((Vz4Pr(Q zTTq5uPz$;=wAxmO1%9?H`$}o0owmjY6BjbbD~5ycVkiu-D4DPvg_CCZ(B(SURCZYG4{zLWvrLcAIBd`o%IyF2~{= zjA*R~xnM1Y)qHKNI+NItHdd9n#HWd?l3l`<9SwlqTHe^sj*+o1H5{dJ^!%vQ0Cb2k zRB{?i@9$XK?p}UqN7}gcpwF3$q>5?aJBtt7Pem?{HzI#M)1T7FtMrh^L2rHEo zg2B=dv!?2zG?H}BXm+DT*p3vs)Al;6xOrLmnKS~{pt5sXyt2}Xn!3>^u^LNNO~aa3 z5&p1_ilE)hfWQX$sh!?DtCM!UymS#~E`CuW_L);f*-uP-@d(59savX%C30?Fat?AB z$uLdIfW2CFCh&6@22oyVaA!vZ1J#~EwsF%Hc_0GC0YDGs0d2yS)Xd~r782>}7^b;C zIQZ$=eCd3lvjRU=n9(=-uL`wEqUO_@&f`W9Ttoq6BYd6jNpbwx@<2zrCvtZNGDJ*J zKuOOs8Z2HJI1u@;F!&mUm-65WD3rmna;zt7FwXX{AD$PP$IgzyUSLEZ)xs3o{87)9 z-P2ymLbdv^!#lcAJ2O{_Xd%Ls*quopqnG3&Yy3Q7cn6UXQ=IKdZS|>pI% zU?6CTj_@6T&eefLU;wih)+m{fBY-L;L5}m&a?x-mC&M;KdjvX??(h#LBMvl2jp#Jw z$*0=m6b4iq73C6wO%H{Y=WUprUQ(fGk=@X+=i%f3ZhU;y__*`z<3H_u z{Qb_yKkvHgSGN(dgB3zWE^iO9MV>-sgG3I+Z`y}x>&!7Lyhs%=QH}|Xj44^CF@4l4$cKVmmr9 z^8q&t5I50YeK?@|A`DgB^WBhVM+b^8MdHd2JfNh#NL8;F`60s#%vSi;tgz0f#IZzF zYdL()6*l+@nW&;dBS8syXph6ePCVW**LLD)Nfc_6^r zOvvEkygDz8Ez*2q&{mB&jxd}$ghZi^r}6RgR^!**#>bPh-RgeXU1797(`74@!&RHY zdeSK_RXl4@p3?*O3yE`G&jU=!p-LUNx3nRAcV_s?iVr|zO0;`jMuOXKfejbVMmHZ z$h>lzk{w%u!08>+?W~zS=vMjo)EDHsp#L&0SdI00)5g&WOpk*rATq~t+JENxVQz(8 z%;Jd&etu)LpNBKz!!e)XZJz$pm`~}wCOcN`S$hCG@2VVd#{#RM&F+yH5}_(&46UaPk(XPk!KklllAPf-G!wJ^A7?bIJ zA&e;*`t;yY+%`b{3Rp!~P^jW*CcJ5|Sw}M?PI+k-Mz7j7d!zyien_VxIQP*qf(Pzn zv!Qz+_A?Br6;{63Q^v3-{qBjHisNF~v-cjXh+6}U0Oau)A)2{4!;vY?={MQ(2sVc? z%?;cFU}1z~FD;`eM-0AZ9Ujwzxo{oBy_4!3Otor&WEpyiZEWCm>lj{x6dp;vG74W) zM{w&B<6-#UP&c@DL!D)I2_Rji#5f`&kSX-h0mQ)w%9r@93 zdqE5GV&YJ!@|=a$bx7o#I)Cq)5dsEzO2e?)Dmh5=b+$pBM4GR&{auwe%7z1JixO|v z2^>)&)?qZ_8C`@$z~7^DAf^hv%yVWRqZEpAxAsml5+s>DP(e;ZP?If%W(SwbiPV5m zxKXeQ3$D&>jLl?ikzW^PN*j)6(57{B$BkVUdo0ve*58mnV(7(QC_kRiZA+gEc>err zy5p65vy(%@b^&m}^t%y0c7j^&R{<7RL7&HPMLC^7Lm)vCDqZ@W@Ek5><8XSnxedi- zt5OLFa2Z!;>>cad|)CL8f_zvuE3Fc}h3G&J*;_a7qic z<5T?kaVSRRr7j0KEku8{K9&D9w_Et{(^gZS-D_>PZp(js+q`=>ywG*Tc`1B^oxlwf zM{IC!J;48EevZURsr?dXXkmJC++A27n)*v^qjk`4yCV^tZ)s;$ovhP+b=3MRHgbOH zLq?z}81BdmAd2A0dv3+*e4?CBKoy8eJ?A}Y`}Af#XILg^3seR09Nz?lG+ciZeCL7Y zeuN+La5t>Hc(b*&qBN|O$~V$$p+a3At%R(2HmrqszY>6G5ZiS4xD&PteJ5b8dk0sr zYb#5+sZ5!&bpcqxCU|v+u^tITm$8ybUH?>&m=aJuqoaCp?&_sk#D-2Xs%Xlw;VP4n zSUsQjdWqobk@PAWjMONlGP;EPBJ{aSW^>;9{1;!ImFurCeebYRF0lZrTE8-x`y#$@ zRmx~(CsGomBQ7LUaO=VeZVgOr#?3&=v-O(n1yrKIn-LEIEvMUwZ}V|xJW(kuAE5(! zDQ?5U%5nHD>mw4pQ}?1Su87Fgp<30d5GCv_@2?i%ajIb_|LXY2q_J9nz6U$j2?Udz zPO@3bdDh&F+3pBL`tAcEJ59D=UREI~v_PAjB);|y02>0t@td1L<^FtXSd<@bSkl0R`h^>FezU!p^zd3#3^?5>1~JCzIb91wrcg*w$$f*zX?n zhhhdc!!UW1#i&Bl$1miX*x7L{D$~Bqz!vPB3V$ilfp(lCYJUC#H6*NPxYmOQ4}u;2 z;K)}^bT~LsH$b789ofs(b7yvpqnA+In(q~IFKP=p$Umf@5uzdyC_LD+cEvzpZO1~^ z6%L$zXwkgnaO}cfA%TBt<&E#*Xa!fOHY~_$189KVPP*e)z@{D*i&?@uFk@XbOz3mA zEv5-^+7=^=8Yf~eHxL+bc=C|ZbtLxMe|8ZVJA{b@5g#nCPVupL4C$k{v5fc_rYn@{ z4-F`v1v)9NeEjjp3JAV@>;qP06NSLsT86z_hCTRhR3caLuhAT=-k^KmGU!7GQf!KrvnxEKQaPhc7(u9&VOo3ENnOq!Ko?SjbOCW-f8&jblYR`)FWAm z76j)Yt4YFUq(*Ci!7kN`BWMlCJ7RDsXbh%1qYxh5rX}^%4qj#9|MKXkAD;a1A3Jb; zIlq2^ufrht=sP;4{rBG2KmPE;YHRJaS&|12)P@#ALvt>} zXGUvcs@g3Qo=!sK7wm*l6*MQOBYp zWJP%?{45?q=<{`XXnjQlC-6B^8jX4Q3s3kxJ4_UaioF(p8F?Yt?sLSF&-P(WLNpNZ z;HSN4u<<4yPSU}7+kPRF0V2-n4((;rL@+MR_5#8n6f!4Bl_nIyYqxN)`ByqKZ(!KI zp@X+cRFEbc&|q7-L6^hB5tfW2d+~FWaeKe~5vNztDRlCFCbr}oP@rg;S+2#)&E_1` zm!DOiM?o~(iC;uUCJe#ELvHC z$el49@Blwqo@SY8^bJ>zb<h+=gdYy>mhupR=p~^-OctHY5U9H`V*(E2DZ?BgOn(s zWEeDjTLW+)XSOQN;~91?EG~LLBX}1pOB2NuX#&2&a?Bj_3<(8D z0E!_iGgEOeiirqr?rd2c)pL#9OIRzuPJ^1;{k$8CTRRV}!oyP+)s%sJ3=k?M2rieJ zd}?w!Sy@v&u2+V1#Bue=hTNcW zX|C{2MFY_U<+@`cRYF0@b8pf;kZ?9fK#@hW*ns93z(jD1#a%&jQ1a1vA>;bx3EyNX51<~Xzv|~#i2gmXxcd0JO?C2(?|+XdrJva))HyYciiX7 z3O!~XEzx2gZ?7Pk{=U`17R9 zfq5`$CJDva;gI>6Cz9w+ETZq?nO;0JiA2N>Ozj!RgPIac4SuA@q@XGY*g7hpsF;B) ztbYNbN{A`WFnimF-R5Nh2~~WgKnsw8vo$m)Y7um<^@5Y2@1zO@vyQQWfEy~FUFF#3KL;GUn=%q@xa-XY%f z07S2UzyNPNfP0wd2Qzn|2FzE(2~{5$iTzo3)I-P_oURbHVsTFN&ql z5AeW(Nng#^7*Y47JQaed7?(UEvQl)ar`T+t>_AdO;zqI3!8i{K6cgJ@Pjq4;14R@Z zD$`iZMu@;i@hM?RO0?+)^q=4ZFK^6eS z^m3KZx&dW889<<%i&HYJ_(&!g?IOuUM-q`CntX)>9;p}P%Q_g0_8H^MlrjTGgEU}{ z%7h{tG(x{&`@i(iZ|X4FcT8`n2NBFmHDtyMkQmw=hSdf#HGpoI&`q$Cw)aYq9Vs%X zqt=^1DhJ7$&z43Oxx-Frw5KxRD9t&4MIThj8emaAD$ztcqeTZ<)DPzjAKAv78NVXZ zX!EGQqFeJDkxuA@NwVUnh8Hq35*3CA?3XatUug+06%DidkaUP1o$QKHgc2xYSVl7K z6f~Gfhi&o#a8f2GQ*pP`lhpYh=9mc2 z-h}Sd0UXw7^TC#bb89AXc*y`+(TL-Se`DaX=ZAm&n#e?Yyv_DOzkv;5bK0J6PW#83 zpKWa%Lf^+UTdH4(+W9UCH(vt}$K|i~=$ec~Lz2s~aNw($@xy8{!9lipkam9?NSTGo z=w;FBUbG_4&)$PNoR`V%bMuH_;Ti2wIG?5I(hU2P42!JLW)D}D0CK^D$s@CVKN;ZAJY&?VvO{MjRHHgw6ye|!7m@j zCix5^L3tKzFc?uBP=THvVmFYi^(jhbBmBZFLz+C}0Bn=z8Qiwxx$`g2zI~W9bGBC? zkH1TV+=KA7iEMh9xoRs-lM>M|5RugYXCA_I?Lyu|O@5t=m8<1}tqN|>S@K9R?f-ak5LJ6pjmfz=h!A$rZBDN$9R3~c~&-Z z8O1Lblwq<_RHn&y6w7*sZ@>x+N5rM4 z;t{WiV44J{?EOmFXi!k}n~T{b7jQ<|t3Xzo-?`{j@IdoPa?IH1`@It?H4-I|-9%yP z1evUE$N$iRdt6aI-Oy2XDRM>PC6`bI0A!^3N;KtugT|A6NlBY>njo+PN&$2OWyx}I zn(-NvR}Fh0J;N61$RV}@0^~gZbGF~@z`kONK@n`R!M%Wngj*-bpO98glFl*hbaq;)T%16-bwTL6hD>6$5al!R=b7PXyf zRNBROO}K)-Cg~l-?adT7Z9QYe#mThkFYQ$sGBfHn@ybX%kx5o04fY0(HsfqElXq_M z)pT`n2`P->rXLlM16CJFT`ew?J9R8BHD{|>T(s<5vAAT(uCTbEDRODRC~6ERBL{FN z%Vd>J2-#L$s7U?=r^G~?^&KMCF=|4^}auzbf zE7&NOe~hm*d_{yzxc!PD6BL6V>*Eg8m{NN|H^m24=kM7KF=ooj9`fEuxnQ9htpKY&0b+MiB~h z%|R%0HXmfQEJa_yVqO$U1Q}iJY-2kwE6RIKic$hT~Hr|}0CUqtF- zaYdgs&O}(ll~8a=2Q{}dzZO_w+b{P<<2|MeMSwMaci;goHqTT0%O6yt!3re0l)r_d zsXB0#IEPo(EfjB6AP^NR=d>-IxIIbxDonKSMS-Xyhme4n4r#no0nj()c$`VyR3H(s zMdcyfyP=s{5NM8Gie**t&>yEGJ83`a4u+W5S#2=2+!|kDe2)b@co-h6 z18gOYNaol~`BKur$uJ87;<*ZD&>)rB;Rs?g+DbjXSYuO}%dH6&P9$Oxsv?qa(I{;@ zIvx1e2)sZjY~@%>u%WrW3KotVH*UzVl%jU(Z8;^}sUK(V*5veS_2Y2kONfQ*;qQM( zFg%ARt?OjyJFW%3uo+tSbw`x)lLW7VAZ}TpvHPNz3&%i5BQP+Z zZ4wtWs`1H2vL(!sB}X4mXQ^_n{P>^6@#2>Zl$d8}e$M0@QyJFCB9|pOYzktO(fqx$}Q%N>akfWyWeg-$YRn}!DYe{Z_*nNiiwT}DQbO-}Jb+m_5rz?rI zDzoHLVZtJoZ5Zvc-yxT|!v;~NQjf_EhaZ}!eqeB{oBzuO@%Q9A@m+T68 z^J28vGQ4SmlclA(0@yr|FHeS!*v^?p!krNzz2# zu^W{67BD}F+d)}&kUfd$Vs%bjU7o;WbY=9?Oe1Qof~iLyh;)(6e9v~9Yo zvRL4O3uSQ#SP5|{DsL_GWA~(x>BRvP2NNhD1aoaaMyWfN~>NAea zNc>u)z_V~P(QDEim>BsMC7CvejZSH{JRr0l>Rqx}Nzf>;D~lh- z&Ss&3f>85!H!W~7AL#B(QP1aAaO{NR!(!hFDFmuFm`!kNm0apk={CT>6Uq5xCZm5l8~7 z(XFprX~5uTdN<9lCdtsBAHT*02{=w+dUjj6$~%0+_N~h-9waj}`3dcs4Z=(5erN@j zYQA^KQMFKj&p7fjiSnUjtJSzGldG^GlM{=8g4j7vIfg(AyzxcEjB#^KU@VE*aNqaZ z=R@!gJxh-nhdZxNV`G;a9~xE}6nHMj!8pr^1T3^@tJBaTw+L_tgrLeEOMx53Mau%9 z*as20+;w!Z=f{j`jjFR3yYDC=Gj?Jd}aWzl0X}j2vL&0 zl&^4su(;#Lco~B+;jqzmMMkKiWMTRi60Phx2rq#O^_~TypeG8TlAQaz^ zu)%RlaKRHnb#@r|{w4h?DZfg#+Et4aELI>K=G3E|Rd;OMsSKauwise=;X8E-x&9N< zJ>~~y3>w5v!izDEA#p~DORdOu1qFDbsW53bFz0o}4HJj1DjwLI@61ffdMYiw7@kRT zKV8^S!qu>uMgz*(U!d)Y#K`?Nv-03P1lBVOrZl3_3Wx9b7ZNbhUiOG8Pc&&ot1_>U zX*OJX{N#JDZsjQ63{@UnF2L@7E}e5v#rZ$D3ePTS4}zaOJ*W9g{fM-SkVywu?ZR6q z`&IdK(WVx;hB4_a)5CBRNgiaFWn!#P7HtNMIZmoyCeguf(2lgHUFTurxV&aegO846AW}=W`$z%!CbMM_k}w;XR2-ve8_ZY${7~bXvRbg_{B6E@kAB(74OX?Fwd~C8I9m0FLf>i#d~`o4vW{6y#|? z%JfxJ+m_sk6gB8diWkdcQZ z6E(ik-u5lT$0r3_+9C^Lk?s@!m}h$t;9Zj-3VtZ%jEL6 zXhL(wz6SHfYyv;;|_^vljpp~1yVON)SI##9+jPsRq!AI-N(=!2jlZn>Lg zx`S)X{$w=Z4aJl|QC;_Md@sbpMD~>>2T8+(_T$2ZB&|*R(dI7DSm0vV{#52wk+&hI zHa-~2$|fYgB`C3L=@&D!B~pVMl#H5pck(|%OqD?(JEu8I9eq}t+z&b zO|7+q;R)5YjVQa=Sr zo;B*H82H&{oDVqFdwB>H+`hmQ{f{!dq7E zx+QC)IF5^^#Qj0%0xl11pb)QS%T_D|5QLH6E3FTCsGXieb_(h4uEr{zv5VM)Dd;{e zJawd2UZf6YH7}GvXkD-y#n2jCj16Xld@jg5EhxZ@T_>!_48*C`oU}+fCs*cLmPmMF zqwaEzCTCZ2q#BU}R@aAygDW1QE`ytXVrbz6J2Lh?~NG=zg#X2TR&Fm9W|1lSBZ{DAvq4O<1nTt5LH=PAoZcm#7uAJ=Zf30~YM zR>|7nS_&p4^T3UvI8}K(vrkoRd#m{=xDh!N*bjtR8f8w;te8qVS^2jI#uGILhK>VK-iKk_wbr8pLwoE+_s2Ds4!JLk*E zI=p?@ST@(Ue9*VVTSs<33V_M_3U9pe$t~KE5JJcs6%$>k4az*IGCY~;CY%yv&>frZ zRnN-ER6fPlMQ=Zx_P=Z$h&s`mjZq4z9nftbm#Cqf#lPx*y}cuy8NOmM1PRSba5p{AwO({-XU$1hXhd;d(!7M(#P>o z?dkM;*lsih>Tf21Yj?l7-3F5)J(G)Y2UB^03A<&UAxYr`yp*j3_jvM(ST*Ztq7oqk z8aB&vDo9W%LR8a-iZ_*?1LMUc#cP&N~~ZX6y)G1 z8K!ewY~;#Np^&96@Kg%1pkQ9Wqea)DpeT-)a1tcO<7tEv1rpy!dq&-G;;w%-G?+0y zuZgIt$9%T0!>z+b8EHOWu zKH-Iu7zxi6W0UJX@Dy?o-@!d%wx3Ty?1oz$k)?l``r{u(aRVf2@BNSOe*6mb0X>CQ zAMU|v;8nY9dds{F?`S)&ea$#R&WD|5Nm!!frS`xczvP78KXiX#5*)G2Y?Q^`JzU)& zRhcc;_L*=h3S_*9o;k@8KZH?2{ltm&1{Dy76ycP>t7OT{cyuRc4FkysFp+To`x|#! z=0V_mA7FQI1<^D#I1Z$6^B3ZXvq6a)dBHSoOB7tDV}`M08-xioJ)B4Ih3Wtj{b`(k zXJ>W{jiy^3xjv2eF$sDk7)c1%oj$Yt-ztWy1u_Qu*dZj`J9$Pe(GqljB##hR1~A2Z z;i#13CQMwxOU>~FwQ>Hq6`G}MNa*vZ9y2B|k&&f3F|S5?)RdeI#KU>r>R8{dOVhA( z&=U*uhB0c@S!fN!YZvb1X9gqaQ?AtES)aU12mkI`kj7T;?ILJu%lJx+W1{sA-C@M| z&!5trFEnh5;b)MHe{J*#;TXe{3$Pc)fsbK{nQuM!LYy%z`9-)xC zgN`O;q#;Mn5Ba7)#MUZfLsMY?xTRMTvcT^Qm!wOW3fT&-UDFh2!cuG|VAEl^wU60` zA^vru)zgY0L@FpR$loy)oy#7*lK^dQQL3(9%|CoEqYyw+{ z-*dIIBgBx=!ovvBi~6gF;bDZU`S&gUBy?MUZ}O|o5`QGeV6_w(;KG1p7WxxN6|Nqp z-b6rf_@ezpCy9ZhH{t+@KRR8n{0!6o31t0j4oxxvTc-yTtWqIbV7i?Inh0AOh!R#} zbc>81sCht#;#63X6`hPRAOR)01IQ%mN|iS`vt78s7#9|lzzB#CHoBQumODO046-oN zB4SGAvE?CwR2xnnIAS>>vC+M505cg*#(9mP#uSM#2~v(7fhEGCRYtd--^9m7*Rqxh z89;ZpKkjI@W+PNYxPc_oT<*|aJo1#)uonBJP(Xkm;`%o4o%5Lze5QI*Anvl2rS-h6 zseEOZqq!Kxo})3O0WM zlD*Lao;fEso>$X%5tc%=c;VxJb;rVfRf7QcDpr!aa_rh2>^E|=733; zQ6mt=gFBSqPK#$i9|t4>C3z|X9Uw`rW=1Ob!h?JIjMxCNkR^C!qQaX!O_i(2&njr~D%JDMv;dN|dZXk1|Jx_O$j8X%N z5Bb+6g!6b%Hjm&<2`Zg#YU^&oI|N1Ln{k8Pte+#qk>b&yq6G(olQtsa>)&68)vC#LwI0+^8cQOtD8a96Z_Ah|~H)H`QF)|ERtUZFC4UBqN zxqg2FDV?S5;F@4VX8wSwf6?C6fwu4D!&tLOi3jZ+imgjWv)lO)ffe2_bk22 zIHjWTON>?Whvoz3(9)nIdRQ&#-IDVP=~l*7v?VCz2V2>s3b&dF85Td@)F9{#YkN& zuWU{eP9!$vW;lkF_|Z{jhMOZ4#QszFQ+&fTVhA@g1n-lF;|V1$s0li-b+?z0aYJ}v zo?WJ&k($bZX;}W-44OJFgAn>e7BZxm)4K%oZ4^AHq&E^lM9w>sw~|_he7399k-oWx zr~L_K<1FAton)9VD08mvz^WuZ)o~U{fr|PPr_X&kv$@e7ga9PpOa9`AZRt(dxX~EK zzhX{~*yTJazZD(i!}H$ZI~P`pE*%Q{*P6>6N$jiNN(3O@7I}wV+s#(bZT9i7gSzF~ zf|KHUm&2bM@KriMbXimyXlz%n)sK%p&h?kwaJq5RtZy$SH_hCDZz#8M6CU(tX5iFO z&P~+8zJ(^r>5w@zm^qnMOA^McQhGRF}FdhxzNm zQhVP6hz)Mofn2)K(ka(}x1ralADx)Wc%<%$i2HE4Ta5<7t<_K@qy)?r$Nm_%+`@&b zKor$<#xBYWFl}-PfFg}7L|o1HSvyHO*A6UF8buHlPK)f3U6T|qNgkphRoW(TxvkO# z&%h)*Zblf%C>^JYzK@bxkC2tC(mE|RY;iioF_~`(-gaJzp4+Z#FiQe7Ugi?fYgQ*T{Fxra> zU-Z8A#b$=Pi%MVgzV<~*P%(LMQR$1`1Ge|u93@vS-1h?7;>L=z?`!DNl1sH*^sL`G zK}0*L#XpHCmR6A08Tx~6ry%J5v@f>zgYJ+H-5_+!Rjm@WGZ1)QOO7jgHcwy@wFc&P z_S6%EubM0$vPt`tj_npnka8?lp7T=6p4!X~&k)its*zh?^jDV6A(w_1Hx2Z_J*E0% zDC>>j!vUMuh)1!L>Y{jBlq@TEY;p!`w5VbE8GG|H^-6H`@vqxolWrB2>$vI1OVeE& z(q2{(?X-$QbdE$SSWJ89PTR$OpD>aBUZ{18JtiWB85VO%7GK~jU~$SiIn$A+@(^3f zD&|E|S-XJ~&h8C2M~nWA^iVHF6uCKpCO7EbbQ?Py?IRIOrZ}3e85F7wmSRRggSnaTult9z9*vvZ; zc4jy$$Vjt&BXS;((sziyKfW+I>EjXZnu0paHKD<4oTG8;HLrzVDCX68GqHmq%q|=- z5G3jE1+yi?uW6w^+sq$tCPqWj;q}L(&P>lEH?#9pIf2tfna)+S_X%liMrRl)-kHM) zcbl2TI#aoNP`TjNQrsYw%;8-r^}@%!kCWl!tk^?o28;UTrD@3_Ol_wFcC}>eiLZm6 zvvV==1IvVXyu7@e6Gdr|cB7JAPr}pku5_|if4P1ZDK34BkH|R?PS! z7EQ&fQI`C*8eCu&humX}?R2^J^Rq`kJ+ouUM$&y6dS1Lx3ww(f-j}sZjzquo<=T_{ zHY3N8rz5BIeTbOo33fC1qwMo?5PE>xf%YwGLR5$F1pmc+eUP@f{b5JLDm_9@>>B(I z!N>}INm85GCeGIs85%LbG*dc0C?!5Bb;a#ODWgvdwy2GXD&NkMf9*T6$sUpq0m!xtt% z@acob7pA5>K!YLtHw?Jcj0F1;F)leKI^wOY;o=30@fghqYJLs6^u&6@ z?rZF)$RrFG4(Kp__*mm2W_r2Eh{GcXSEyHGW=I0Ip%O`;G;9QfM(F72S}uW1ZO_JI3zs{Ao#{^B{gJm$j<)8V6Yjg544sAvSx=Bl zPo{?m06<;d1de$H$pAVEB1nM1@xl7@tGH~CyxnzBeZbhPnH2NmkGNwnAj$}MlBb3D zi$^rs1fe5Y=qTc3dGC%&y?0kLSP->+_$?9@4L-u&R<%WHTnUItu_Ta*;vou{XsWj3c|wN3A;Xw99!ia@)J9k91z|DOZrRd7X#wq_!PoQIY#S_R1tWs!|uLzoaW ztS0}>QYH&3sB*3b$;T)MYm=5|UH2dx(gAi&%Q_Piug5IC$uOOCRd1tkSCoK1C-zny zNk6bV5iAj4HDcjO4ShbdO}!glL1(#JSQ#6Ikzj2LUD82lUaeHpd|Gwv$js^?H#8;T zIq7MO{Z)`wvF4|?aqZff`f56)2M2bP*~>uRm*-@uD)=%(ygY-*o-)4J`ljflcfR<7 z_sEh$cuKS&6i}1hdnTWQnw1K+{OGuQE0f2;C6{kU?1CC1{&vxp{$%os?a6p9i44bzqUpvn@rlWC*s$5WBP{ISw^;RDJ#&u3~O<(=eFpP;W7OtyOstm zizrn$zXG(4U`hf5uN7PfhW*-(#6*UqVyH>IrX$=7SWGuLA6byV7wmy_VSi_&f^@EV zLmd`mIa*pu_IE~>JB1pigh0ug<-_HdnWAAk)rIi2(h^)WOClJy5DIfPElE#u@$M}Q zK8vf!Uc7KM(a)j`-6Av96lE9p^EPj=nO;UnjQdlfUxu=oC{|$h80|vrzJK@|4aKg~ zL1LaFK_pDdtW%@c^^VgXSPBt(1)WKsd=eF6WC^4oPV<_c zjnMuCanPbCA6;2IZ`$qr?(rY9(frYCu~roBK?0o3<%~}VODw+M+DCkG ziSbxXpK(Q!&-+r%5AcMps1bKN2p2DrlV#$Nvwq%-TD22p*U^%9(e8oEuA<1MTw0$- z;YU>Jly<=+g@y_iG7p}wBZlBbFV+i^F}&wo42F>D5%DL~%P*Sh!v!2Ud*^wfY?c*+ zc~R%wq$DKB&wxu_kbI$wgS!rtGfqpUovBov$<~@~2I)2#amYj!)(K*w9Z|@I@_Efm zSb7>Jwa`=;2=+%d&APuYNTgcWTD0F#oZk;_9RggkNglDiZ$f3(4c$6xcfOOj?E)Te(XL^ zwN9bX7xP8twBe!Qiq$AXYS&Uw2;XuSgYs=jl}f@1#yDl%?~(L{0!yqB)<~o3YYc4) z#|(OQqpJ`5x?V7k`~^Hw<&oqBM>5bH6&C$hfEnwKV_AI?Ok9`--Uf~j3l)7|7ss4b zPC66&WO~NBNus2%$P9bAWsk7L96%afsDjx(mReh`LQ>)Z~ZjDULqoSV``&3o2e+=c-VX*tfi%*tF3}y z>OLpKY+m|&L1B&iykuc<-(aj~q+5;`Ij49z6vlf1_Q_+bqKSkWOxY5iyC%YIhRslT zz{xj{$%c9hFU%uMWke+oNQqW4#MD!HKrT~8MwMGG*x1?ZBVH2K5S&8hm1{q!sL@YA z_9t`;k%NXE*D@e9OLQHz6QcZLJU%TPB;SGoNny~DZIKj4Alibqt(Aoc^?{tCzl0leBEm$2l8Ep;Sl~s5UEA|1y4(Vz1C|v> z4~2W)9tlRs_hcJ&7Qj^FdTn~Ei}FUPhs&}iD`yi62q6w!Kk~FVFs){2ONI|aPQ51) z%4n;=TMHe>mFL}}UtB43D{O#>V6~M_iv*FOb0zgDI88kkxk`>Btl`S!=iI@fE>t;!>$R;`c_JI1#2jGJM^1qU z?0Lvy+mp$`x-H0<7Pr15^ss3vCarerYsteY_k}@5oJ}4m$+|O1#Sv5wG2awghHVJhjKnbD?O3)kFjT?W zWY(X`L{Uzt2*)DG1%_SjZQkbdIb;&u#IWyoTc+*6+|lKBF1(n3JyEZ27?QzPtq|?e zF|Mv)09ItdxxE42&OJC?bF^npscuQeM}`FXK5%r7$4bCw}=Li>O5qB7x-gQ6yl757mYr!)cX#R$)Hg~jeq zCWz!)`KQ3)@&26V!gg{YL`FN_>m!DCqJATM4=-0Sn~O7}9ezrMum)GV!*z0X9%qU> zR!g0Dp&igiJ^3dh+#F)qWFQqpkb$W}E7G>}_{Z<0N#s3^a*>Rt_^aj^@IzQ!B>@+i}$=OtUE% z$F+KJbRC6NZD^I*$vWCPo@$^34Ipr7Kx@DVB{!N5XmQ6QIrE%Ix8=PoZI^dIlr;LQt zWxuNULr8%ne_e&&Q-9d*!xq8xxSU^Ep2*-MN1WfA2iyGIz*dK}Z5wn0$CcJJ(c$Fy zro!L3={z99Oe8Uhj_pI(HsN8)2e11`2o0qAi-+OG^Z(xb;RO;`5E?E*yFT?fBo_FY zPvNP&tDuq;osQjOsIH|!u(-SC#Do)T2+%rZ`g2Y#R|cJk z&lz=97d$)10Iyz=)uif^A+BR&I+Fp>VQ~Vox|XjS zuXZ1=?2Y@s$zrXjy|6M~TwM2?CqFId`}?PScTo#JJ^J}id*A-}-8YY8JHnKYT5SYP zj3zv-DGe&G;?2u0FC!E&%j`6p)1zbG#HVOKB}TUn@^+M z;~Pk{KIHY*M#$H~yU(>{HHWv4X8{Wo4sR-6=S63C%33vUG46JQJ9~f8d=P+M*>PY)k&qsUC0rjVpo8H1a0{UE zMFKB+e=}!k;dDsr?UMsETZGct7D4t;tbo!BN5#Sd z4hK)staa46cW18ink$-;aGU|bLT|XInr%1UUxlJy zQJgyh7Sx@DUBr`KhX@4A91K+;LBT077q;{^U}hA3?@j?l3A+Mie3zbgT4T)WBD8~( zjwWwnH8xTUUt_yM=m3sYZHv)+$VpRBuHf;2kPeFXaO7!)dw2HxDb>6-z|Dfky@bHE0VFd984J8|7`+DfBCdak`axF3;H8pziWB9Dzx=YavE>o?Z!KndfobR|W4f zvzlNzJZ{XYpb;i=cswgkB4N1-r8=5Gu5ee6sCb)UvCd_N#&T(R>Dy@1YgS-g#)(@M zvjvdqm_Om7YA$SeJ{DZ{2ka!`heI_gG?4U|GA8C`ULu4nC@<4GwymZ_Ea-!G!=C=n zT{K#dHb;~H(o}rwIH8zgVq}myo=ED_2NLm=-kwK5Y#~vda^ezDT$V?zze2h%lkg%4 zag9<&)a*jok~Z=nG(RgdRq3LSID)Hm(M)qAT@2e}gR}A3V(bVI8_yA#23;5CM|Ro> zO}Iv~5&uM`%^&bDtY@)@;tpu6M)2R<+JJrzbQK!BXb#wZng{;6s75Lcd(s?Nu7&SB z$0ipC6{?$b4WTKMd8Ee}IejZ9u4WaWMMfIdxVw2zb+LP)HyfiJoO_CDw!QI}Oz$DI zoWWNxm&$2oS^#_nK`(XaDMM0j2AElx4s;`IqG_?4@XNhBMKP}yz7_QnD-7lxD8s64 zI9yAT^KuYqIav*iezB$ zL@lqSJs3q{{e|t{10F?r+X#<EhLp0ATXL}?2FGFJ41|$P4%`Va*nt*K+)`T9jqR@iwyMgdiABVIT zowj?tC94GLvmd|taVMiU&Lvtzo)s7$*7~7S!SmYUIzJbck%Tnd{(#d*$>%Y}Vj7euHhTGBfU3if`v-?pIRFUZ$CseWOomFKBSdfaFms8w&X=f>0 zAvnKoVQ2RK$vic(2sabY%2q9^JQr&G?VHD6?fvP;pP%i0|L5NA;H_ax47IWu!*^RpH&`Wt|Las|4X&+QJ){(*3AZJf=tc5VIkB zfRV3KHp3W?a15$G(3;8MHGU!+4NR8L;P2iB5+Dtd3wrsTov1`G1t|jIH_E3cUNmVL zl!inYbcvbq|GBK9HfDia#cSA&%Vna0naFnz8*R&co2}qELop4*OQ#~2Nl^*_i2%eF zoxc_vQC2{$t$7KWV{u>+!e?7sTZN|i;0#Agxb<5DF!O4DXv>_Xr$}-M^lpX*)Eh#z zs}SkGkqC&nhP+?Flp-ql1AO3&t~ZQXS^)-5|A;+W^5)qa^{CJYW8M-X%Mohv(-!W9 z9fY4@xa{?ymC^RS`e#Z1(u#N6sbPvl^}QrVUk!)T>G96y=Ij2;K3&A&AHLbd9`e}- z8X(RppK}%LVKlr)klAl(k>3oPIE9gKIB2egr!F2*Qiw5I9EY55iN%bs0J0(E2suI_ z^x%9Rx+)b4rZLsSov>vQ3ieIFWCY^9pneBO$B6OcSv)v_%H+_M$1Ta`2$80A zDw<>OG$O}hH!rD;k~bVlbsz5H|15cE%3kLL!v_m zIeMwc&Vdit=<4jpn`NXYMEOSpkSqfYU&*cWa>1a;^G4J{DurPS1>u&$&^o~REUt3` zFY;b@cE0B#2*nD8U(3tn?CNEZ2mcic!7cfb+WwL{qk$trt2ni9gkR_;MC4&w zia=-Z!RbQ?p<={YDH%N6gCx|(`^w(yA-e7%CS=4V`QlCUk?gXH$DJKyn~`PB5?oSs z{3G4heO=eRGUr=a!lKIaOu_34cZebm2?1u&=kWYM%#in(#cbv-p(xk@Pa48MSnj5B zf7lpR*q@9({q*izwa8+2C1cV&J=PyivRs zpwlfLXkbh6v3UgJoHIURpMs>yj%(ouI84ZeoYoepIo^k3ZnbgKK}!c&Md)Y%KP~-j7#-Gr8T!C=T93lF=xBDd)`it-Q86H zD~ucSLnIcPji@8!7%>M<&-FbJn}-bxief?I5)e#5_2nAy?8Kf8qU(;@$f4$Bib#9@ zMsBE=!~L=SVmIi857)zs*goe%N+T#{G}O29dpd&g5f5WyxG;!bBi8g-SEo0wDZciA zj?8{sM)PA#F(`jds>6L>desi2ci280MyXQ77R6L<1^n=4z!p9E^>lb4YX?e0;-QWzU8()Uox9{ElZ2QiqbK4vX zXEriHo1rCgI%?>gN(coY5N$Nk1zR{P_Use0*!lEVUP^*>L#}gt!Lv{TzB$SexLTrk-vFI8=Jfx^JKNcIOz^J8X5XwCFgb%Q z^j`zD_j@NvVq+&6>*Y`XWZX9gvd|te&#_*-Fv}=JI5{%v}~q* z?CAY08Z48pv|zAkBSwMBSuZTl@uCPEiQ{;_2Q$y6-^^jwQ6}U~p`x(ibm7q^ss3Lq zfAr2DHw);<8rvJUH*3GXbF0M$np<1|Gm>Ft}DMS1}fJ7*MEBS z!+$*f`E6UAueWIZH}7maD+tZz?K^k2o7-DkcRs@R``7D#9*-a5$@W%rtFd*vv32(k zvavSoZWpHuI$`PogCsc$Ye-z+c6Jenq57Em5Hx$n`X846u#9>9l+8BpBDHaA%o=#U z)QDx98_kW|^2E`y;_|9D-`ap8O#uZvv6{lN$> zLUJy+bBPfZ2J0D)OK}viDv~Ok{*GD$8qfY0*_E-ScDgXl!s@`wP8{TW4MP2C4l;MF z29g;fTZ|7A7C}P4?Fi$QPBzA!9l2A5@x{EahlgmZian+gXZ|m_d(V?lLg#?D8B6&E z&5m01fukOU5vn1hoObieZ|jn3>HF-Aq++*oJasJbRkFvUC894 zB*Rq^j%I0{k#df`12ZpaoAH(e;c#S=%f|qwLetvEksrLWq*8y105_z%w`7GFuFxlO zLsJitv%2m;V44BPy&?=v{QMAW>>s&JU*|dzBLDHw+b=wLFQ9|}-@kizUjB>BAGF-O zyLIpG?Pl{1WWwh5{kz*Ag>d)1^nO7j|L*diO?)>0-#q^L>z|%HefH$XADCO?0{mU# z^`ia%?tM(MeVTXfY&9YF-`&RkzYSFYuYMDm{NH^3pTuZh+zKPi_z%nfrRKn$0B!IO z%RkYLb+Qw1b@CtHgTi?Udbuw0+hL%B|5N09uK-+`|2LcWX&JcY|L=7gDjTbq|GDf+ zl@+h>a1sA+Ht)hJq#yA7JKJ~fZ{NGS^$}FTEp83h{Qn9_e#@f88-F1v%LO#t3c{Lf zjr1z!70-~!aiF=*Ye^AUi%d*W7MDDz>JtG6H*yb&P7pbs-jL>QMU{c48>%Gm3{HFu z?amez=#dxGucx85AQwejDamRR?{K3&1hpwO-;kIMSVwsr4%LZZKrdjYJAYVqwaOKg zFP^GL@DDiBc_9737Rv?;FQ{ko;iMbybIySA^9}UIvm+_V>pjGY%ymUoiAC$U@xzbL z9^a7o65VJW)Oc|;H8gg|b0*6L1|;&4`voFK#>1)F@Y=p5FJpZ|#H;G)hsEm+5C(%A zf+V5|Y4tVC$rU&Q5Rg4X`~Gwd9j!-2*MpttfhQ`LW-lTPaM-2h3f;=@dli>W!a8^1 ztBju0`IaPlUF`#6po0G^b-u?wufG4^y$yBodjEfqbFiqXs`*D=D0m`v7gf3P^DEE) zHf#ac^M7SLzfFaz`5$#g??>@BfELMrw{J)BFS!1HZ+jd1e{+lWpKJN=ZD#apbu=u% z1QKyUL4WGYO_KCkq&kyJ#E&D8d~eV!%^&cDyR~UI z+rEFT|NS=fi0}z0ZKo3GcB*GVbZF8=Bs!G_7NqmDg2T(MR*{$vJKVAaRZdvx0P!YI z5LYZvL9Zi7-AF>=bQV?nD^J{JxUvU_ff}#{hfgGkL2f*BhVXT{9}n6cctEQnlto;! zz(az4IH;qOY(P+0<$Oqo=f5ncILqzY*w}#79(AZhxqr8&R@T}wm~$FJK)C5IJGwZ zGi^W-2vr#OXG&$=IqHg3E6YMuH4j@D8zNyRQ+q)Tnc=I*^PzJ9Qb2&w(aw$(3PyU4 zYZROB$?6h~+Bf6<#$ECMlJm&b%~dGl?H0F<$p{XteQZ>2eqgtHwUXqKK0+_Damj`V+zwfFp{&)bafy@Sb3h$kOhL=4N1s|Ya7Iw zVG_xG82N$}Sv*Q-mu6KXIEa!c)lRdR8u*skCeE!joOo%&hH)X{%XpCE=?hC_pS|)r z8nwq&G?}Y3|ITZ1o2af+euJ627VX}faNygtuEx3Z|IJeJ;kW8{k^F}sHXifJ$MnDL z+uQdc|25@k_*(yaD|BC}(zX02`~9{2$Lqn~i~Of@%AN{l*xWL?$z&r)M#}cN(OGdM zXk&1FS&B;KqNwrDDOTFh6Iw2mD7}VY=31K6psK4$lTpk~Vx?r$@r!jRuAa&D>zmnq zwKRV7v@_=%N%;c<#B8DV?HEM3QFh-GF$oD0SN2 z$Fo({jwsEkR#Da*SXB3Ds7&Z8Ty+ea^?|hBkm~>nD_s|v17o5!f6i;1e0q7TI^Gb% zq>ApO*cI156}3GS*t7f>$TtV|?ep5pE-vgvtR3!^hO`SA95S{XVdAJ2k~idTz3hfb z`7A`r%z=JD4XjG*dSY#9;j-D`SO`I$HEyyunH@9f02x=Nzp^YpK2yCxXN+uEaa>i? zb$L8()}=k8GPVloxri!uUL+?gR!vbX&QBGFk(!{QahCR&twk6SFz4aQD2A<+eior# z(DdR_Ncf*8AMvG$C|U7U+u89a*etJ&AIxm?>UXn1iW!nMsJT0s7BZ59>! zKbgU1Z`|$fPdW{`$>T~I<$U2Qpa0*!+vLgcwg2ZlF5mZ)i{_tcq~EpAtIz*!Isdz! z|98dw#q}4>zoj{b&VnF-WFToc4^8l`fw}tp-?@LC|M#uYeWi*Q&Hs0D-Tk|HfnI(7?}=b|z5cH>m2Xw} za`XQ#tN$b1=W@mT-*;|H{O|SrztxmpsnSLB|4Sbk_Fqqa+x`D8u8+9h|F1NUZ(I1X z^Zza!;OguDe)D?&f7=*0e351LyKwm)cY?QAzc2;spy9!F(!vk9jD!PZvg%YXfcwTkuM z^oN5{t21ej`=?XGkBw=2aC4Yo{U7e^%&-6U{g1b{?_;6y(e>ZiX#!E25AQd(@%UF+ zlYjH|U$(VguKnNHpx+vX?^@$_cM!fG9S*u-du!{#M)>@vFT=O}c6T`GZiK!6``!2Z zVKfZW<8FA?9(2d6lklqlq8}RJcsf1Z-Q46aV#>z!#d2-A)_4yewi}+##;2o6cQ^dl zZFRyLv2{Is6kd({({50_9(Oz8WYn2qF1`MsI|;K%e|Qv5XX9>zBSb49JUi}B!b$(= zcp477DADcB2B9?xt#CLRO()ZF>ooL6<1oUM$6>A4noPUndy|va0JFc>n+;#|yW_{} z)=>ihJnp~jjwb+7Ys&V*VSm^f_q&sgARTr$j>2?2>P-S#CH;BPpN7YeWl|W=6B~TM zuv+0|YtZlT$szg!q^HLM`u1oz?GC4y(XfM2wZi1I+wP;tSs1oXFzw!GfEU)I&QTxn zwKk3A3+>U#3EDvgOcb!$4Ziz7J8iXJw2r!u8lQ1C{n7A|j2>+fn&Zh-U>f?03pQ<; z4~8WJZG}O9*zI+@oqM4>?8K+mX=op}#;rD>8P;m+p*8GaIKyeHKP2qBfh*cj0)&-X zV#i}0`d~7`l)0of+uAP*?Lsfp@u2Zb*2#1f(ANnT0|>&&Pe!wG8*Hh%^hF0fg z3-dif5uys`9M`plskYkf?qt$u=Zd&!5co3ew8nxG!GS&WbUVGTQH&_7%c{a$E~ zyR9j=RLf?`MxQF;U=ds6d*LPU{39&xStz!~TD~#vg%c3sFdWGiwBCrrkj}B9JXha4#k3U>CWJ~* zVBeXJIwKIv{_tgYGVLD$7k9%qg794NVYu7v_4@5Ty15%(wJ=p;EjJs6MBJNA(cLd7 zs?b9L^zEP!JUT%wO!9QxouC!al@QkY8?15CogR;fzQ8uF@o*JbH|`%DVGB;$E$q8d zPtdS6n~n}nThrrvq)`gX?rTt-2>>FSV{!&EcoHUE;vh)dI=lIqD#y4CdZ@Mpkw_g%rZKvRJj9?p-Yf@;GN8X^l=DMHkoxX z$@jo!8nQip>7SluvI`HuvMqrJl3=zGALYZTNnq{u-%$;AFpF* zz5Z*XBD=dnSi0CJKp%h^Bx?vZf=;pZl%DSHavUgeI7`TUIvxSZ&?z@WAjh1{PEQAY zGDHyoULAKaS+edhuPQwY`(zbqwZvPxn@ug+Z*@8+BPKU#@2n=e4+Jn1W|#+Pq)w}7D1R3NiE3- z8H@wZS7m~c$gUSfFc5s8dLxj6HHs$F*=b|ihs1!<%oIOJgg^_yYP-WW`sxq+C;eZf zl8%GKO?eLb!*I_+ultJf1sd4hopgczv!S##agq)BO}R>FZftK=G;<1COxj^n15#nw zoj!#YtUnf0C8PG>9&x2Vg;WaaN@j??cnUECEFa()w=f!+3SmNcv<^W|r$T1OGaxVb zwiG~{sIaM^6zVu+oz9G6l8QOA)36o?*4)_IXnyQNCjqF*?&=P?pbhXR0w0WqD`AT$ z^ka6~;pha#$?q{l($ZF^6B;6{jZS@E`r--ZW6LSI7XepFk_loPOCx=<$<_-XRc|~x z5jlzLOvxOxp;iYP%&FLR#xD3zmGiI$4?87Iu%ce$lVyC^ z`2<_88@iBJ4adUy^3qGly&@WYJ39Kd3tqas1nPZ$XRkl(jY9V|7H|^$-TnouEY%?M zjzO8gcKM#q& z50{rNmaE3IyX$c7bPs1oHY`?`-(d^9JcLhc!stX)BHUXb{_WJmogmG#WCVikIbhZ@ zpU*=g7Fe5()}>#Tf_VCABw0HDwvKtGaIr?@gZ5$O(0 za(ZGbmL{!D*Yl|n#7hE#S{%8^Fi|8Is;?#DGWg4h!Z2)LCv9{F0|jPPF~Qaew3RM| z>BHC+fEi1RE+LA-B%I48gZ_KLrTeso**p%*GKyHUQP)r%yL%|I@!DuyUsLh(hgnxG!G zw(FKoWdVgYXrD@$6cJm8lr_nXAuO6yDB>#H6IzCyX$&Q>d5kKuq;dZxR9C9yROnR* zRd%Fi4p@r zwZVvDEf5wmI%TYr5uiC99YRx!HH!m6FORUN()jYRE9VEsVBoR7K711DpO+qe9_lC> zAEtSwX3ohdUA?&k1w)ikGO#%f*u={#ef~{ z))eS;K7-9u8f58gbJ-H_X{SOp*zLY_dO@1LEER=_?d~48CJ;QRWcOO&cgxGzHd{bJ z6#%TSG82I4f*KbTVet3B=wC$4>h?i@x-y9Tb+Ls|FaE}8Io?Gi?Z8P{q>UoL3XK|) zXoF(uK8>tx01N2>%?Y5i2h$VEDT@T2ilT9bTvbk^qD)cvAq#y1OjnixDn?D4((j07 z5HcW8e87)(9O{M;7NHf0NDDP#(C<;tgvbpZDrP8DYJ+o#8TfDn%14tjWl%IL)*)?>?Xp7(zsD_Tg@;|p z?~pn~5yULOX(?--0W26Llr>2AcxD3>O`O(c6a3Vu?V>`_B8K|h8RW@oPo&~GggAzs z1S2a!G@FR%juKO{Yc*c~OdBPQHGiYUP81Pp2tF6BDJZ?Mu_1f|WCwbc%~e_-j3!fz z70YI8w%Q)4;@O?7nkENX#YS{Aqq)<838MO;Jr0#ZijQy(| zLJ8IGZq6pPXW6Yw>^%`+89~#^Ef0HLHdIfvuUhUh8ywEpXjLTdKMt z1vS#J_qP#HTt>d{okB|xqZ@s3_=PN0aPCj{`kigQRFyaeq7LD z=>!s~fn{I`MTQ&|iYU6f`{P$nzWnYhvzX4&^Gi#E+dRY8FP2GiIX35DL~A|J1$!y1 z=6hq+iNuDqv8u!+K221W=SQUmfJ2NKd(OZ~+Y`tX zok39p0Ib_&sb)P05toBXQdrtNxF3W?@LMA1Gj?Tb{I$1g%8){S4^4?g@t@V1ZaNLMtyv*r~)2OqPb2HB}d- zk)(S@vl}hKcBIgqw%1w3&C5#9q!Ew?m7UY(m7Pw|)D1rg)mW-(8P>dt(1&$Y1ny=A z1UA4=?fmXVow)1erHi<7@rxp{ube8%eq!RAM+mMj-BOJtk!$mUYmkqT1klwX=?$}DtZ9MP=0yv4%uIJq><35bRw$*0R`M4Ur>DSz<|`B!Yjf1Us`&D4H_#e$>h&y^Na7^qFtE( zRDCH4O(s|77HHLaGK*c*%9M=P<8Sh3H5Y3gXd9w~QU0MAC3*&Ie@pdqeQ_Zc2Qf6~ zcGGX8&70)AB)|B}5M`L9C9{o31Bys3I+~>=*E#Fwz9C}g?b(>-EBux*aA*mS@Err4 zs{@I^2FzYqqhvyk15_yqa-5%*i-t2f8@7SkBjAyAhkvjbaiTeBM5iH5KGz_dF7Y_a?H`loRW1K%SY~RG8i@JSg17d zM7ROKiWx^PjW(dyv!4uB_{!soi%{nrV$*TYRH0GCAlVE{qRp3(?c~hN2V@pNZi2n~ za6tJY3{~X$ZpgEv1BI6Yapij+P|{wcs@L=Ukl{I2D|~HMSf^9sSR$&m9KPlX8~lV! zR8cg=+FdNcBtZ(nq4tC&>Inr-s|R+zFot_p_C^&sx<=G(zz~qLsX~b^A52&|J3}bU z9ViG3(29FQ-CYTF8Ai@UT;z5=U~d8qa%u%b1A4`<(@?b_9Gt#5lEKIxUPX z(tKj0t(tM1VL0~@5`;RR#)o^Y#xMJg4<{G<)%~)&!fbt|%T^{IS8WRGN$ZH70z5W= z2qSYbZxQTJIuQ_M)W<9`4c1>cCz}M;Wj{^h(y?Q+)XaYd7>=WA*cApZpnA)Y)JihK zNT=hj?BFZshz8MOd2UBg>pD0z=8=F-2*=ZAA&2G2EhZ3-VTK1;GB2@?94cm^vP=Lx>`N^3~LZ}Saej%aZ%gWWsXbsEo^Q%xCcBD{*%qyoU*|8-M zoZd0r&YIbS?v;;EeM7Db_^;D~)mWc5ZJeCJ^fH6*^DBe> zGMEt_4*3jj^Z1wMd`|B*;aIh2?E&n(t8%~{3#|Os4mR5T<14(}PEG z+W_|Kz$&_eLKROl;Y|Z(9nFk5<)v8|y=vR+kqRj2A)Sig+(*j@9=MOqhVnr0Gfb%! zRz5pW!f+t{9*CNX<6_ve4<4#5kHlV?h3}~oxOIu~F#J!b z+qm~bon`hpK)OnaaYSYyOX#!15CJHFCK~9>N-}`2SfI*(pFs!zU4$^#`ZBQqX=Id;KU*(Om;XvA=#G7>jM^uP)n2mTw z7sn#QKcI6UmI}ShQ)Zu|6pC`U_D(bsAelW-hn%LMCR+;4K3pm%QUgZeM!_m9u)4G{ zHj}kQdR zoQRWB`vuO>!u0I4yRbeq^%vSk>!{y$M$BrnM06HyR)s1e*>YcEVPn?=)EJ-iIsDwVkEZRF+K1 zx(rx{&EeI3jP-~hx{Vc0>iVYw#T0?+86MS(YgaF=A{aW+sG=!{hO115V)cC8>m`J% zN7SomFk+*W%J35Mi{R%ziOpsE^Iv>>R_?#T^1a1QxyA;lYW>D&?wk0^T`98_PNXOZ zUbF(q6x6zKf?ESon~@nvdA42?UO*)Zv>EXb&~mz+_%@$sMiUjo@)`O-uSIQGSSb#_ zWqm}1ckEu&#SH2MWT;(zomd!p^1a1=6emiKb7AlgaOlf*^H#uyq;)4!cMFp_qZqFihHH zF{;q?@e8>oc6VKi%Cs*tumwA(!e2^sz#YeknxDTw4GAk6uJ!2AqhLorIPz5!9S%;^ z4N!1qS9rO4?#xbc^b%@Y^SwguMQuR``G*)ZLR2IIg$D=Lt{5n+?O4dV!hy3-Et;2n z9Q&|WNZ_AZdEps7d2VwUg@%vcu<6Z)KOi)lifw#CSz z#);U=9Rvm(pFL)D9g)5E=Pm+chcJ;K;)CVYDLxjDA${~VmKmSIbcIs=p$*Dcfli7m zAAb0u4g_C5^a(4l2|_?_ErZ@YgC2Z0DuJu;*Jut_?@tairXs3mB@lX#0Oa58s3guL z6wKKB(Bg11>5G&b#8WS;yY=(~K4L`+&kZ_ThpF8BCZJ79z#;5oFyejx!!tiAz`454 zl*I6kQ$s(6vE_B#=hCT0zVg+NKmPC|LJ<_lWr?Dp5Y(G6w=hm!2hut_-nKeWH(>!7 zGQf!KrvnxEKQaPhc7ni7u77GuENnOq!Ko?SjbOCW-f8&jblYR`)FWDn76j)Yt4YLW zq(*Ci$u8B3GiVJ+J7RDsa15q9!w??brY-f<4qj#B|NP{~@4xx}KX&2za(Vp%U57#N z$+vV$`>%s9e)#_TufBNp)tA5sumGIOsBe;i#D`$}MbO=-4Qb9JpPEw{J~LbsQ`LSE z@pKU)y=oYkj?-JXGA876+*40R z9gAAxY#{Jd|5&zIJPTa`^Gz`+HG>KH0M;;t2d4u`iM>r8FisqbV_u0hSIqoJibdB| zvKDkwJYs}JUxZb38Bem@YJtFeKcnK_;U}KH!Bs;JX|tJDF96Q4aeAsiKvt9&LeJtM zgg#%Fht^jFa2h^mN~19kf8hy#V26n^qGGSbUxr=?w)+&ZGH>sfKjQK#I0aAM&BB&^0}2=|E6crjz15r>_4QZP*HHk? zcH$S2kvWFqCZHQkgy5XyT>Bor|9Z*|O>WV?b2Eg76#3|Dakb)7WpM?x4r<_tmyaXm z1I{=O>uWhIGLEa>$ehSLVRQTwep7~ZL!Oqm&VHd=(G-LaTcj{dDHg4)gUFpReBc3o zvOLW))97pN9P6f`>W0Wn8e2@B>0luBT8$m7CVJ&9SJN#;-G;XUGN{DWYpJ>cX2S>i zFTX{BRz#`rdwzULvvX#{p!E>`s8+oyyxq_EjI{m7U;7i6tp>8teT|eTz+@OSn0bj( zik`E&#{pG9xGgf!1gkR>=SAd4AU&6(pic7HmS`3n8?q6QZuur@i5iHvPrb?st8)rC z!%a@%G)9g@I%%uV#1jz2cz$XaGD8j=!iygai6L3~!+jH?CteaqpuB*Wl;fM`5HT*V z>no37X*i{~Hb-?;bGn{B7UJDiHNqZ9I|`j(crh-#x`Ah3efRVrCU~L4V*DYd*z7kB z&x$*;GAZ zG75<}+}zo+IIBI4+)Gd^zD|>x<9^yD-q22AiHkVG_VTs@j`Bt7DPt-hHy&N5aw7+C_2jP8OkvRMT|d_zgTijUr?^$U z#cOR7TMCQD_p1C`tX{;In{5)d_8V`MG@*C7S=eggU{&AZq7a&qmx}1i1W@`>Syv^8 z3h8)7s8A)JYs6P`f&-|#opZ4hcFz{3Clnu|WR7DZ7a)90al~==2t#hrxHMOIx1xb) zf^yw4p(;l~$@5^+J(6%X2SAZTv)F*<7>tR-Ef#kL&5b__J@Yi32OoT1trr1;wyT_2 z8L_{eYqzjbvu4~XJZK-Bh{d5k-)Lf-Y@QR6qG=|DQF}{isH`Q@o^#wiC50X{j~3~D z?|Bhy1Z8m5i=9G!f&n_^BPhMCB*zO{M$qYC2B#*;h6CeBsi!~%O#FFL=D<7{HIszm z>Tt^Z%p*y3Cl=9n@k%eAnnWUk15U{`Y;%ml6 zqp!2+Fbta&Zwc7a{E-+;7?gZP44qOmUguWNdUNC2_=)&jf*ovAtf9|eQ-;jWQ z$fK^WQ8uMvCDM9V79|4mOUbG83RyZ?P6A*&X(%=>935%dgg@g3O(9Te%uiDaB9~jV z#LC}LxZfa89P-sn!>aePDv3WZKGS=BbTC~48VF*uV-K4J zW-l&44SK1g9pHSEvFGAy#7-T_DlCdy_PTc*_Bcl8X94c{SB8ABF#nM z94gbk%ti?FWP>~4rYu-bBI=oC#qB1kjv7nKgrVAmLK`29+ZIcfTTkH3pPH0mI6#m% z0Aaw~STu-0e@`|O==0*o48uS24@Of;vg#45WQrz|A?HWx1u3?U2BSlUMKcS{fB_^8 zSg%ffx6g4+54MuVwpVDm4Wx-LJYyOgMtCDEI0)tctil#{mD6&8yt{FbU`J8^g zB+zIkslTKr^lK4l=(kC<;-`ievN94#h6n7IW3Io{65L!GnfE^N5Is8D6$1|?w#J~0 z{M#wcFrmo1+Yf07kqwirDW%9aLghAK(fsrFyH>}Ox5?FTs=#4oCyqv%YT5ajx{HF+ z&~k;7bBJ<%Y)_DS=MM8+OLn93z}?-fEwdw%A}!Stxhx#6$zfJxkb3w!-@_ac;c=bd zo%)Q!fNgHua@KCmB%UBiBP$xo;S^(?J*E7sR|F<9>TR}<`VFv<&1rkOIqjcr{$Xq5 z7$yQNvtaKirbfZoi=O(f|r3unX%89(0^s~yClM@e9?iIj0iW-pso zRsI$6m-ZgiN4fZ!V203 zwy5Kz8TRDSH)wMI`4EC1YDYP>*i->81P+tw==7AfOCn>$KQIdLbZKen9S^^Jf}2D- z2odE~u*qOXaY6-rdJJwLiSAQi%|`f{iHS7d#u3OSk3h(_<5Bg`&%S<~lzFySK#zY& zP~D^Og-LmO{<&&9P4gJhmJor}0A(J++U;`TW6hVHOQNggiLDB3FWJx-uS3d9xlCAY ziyQ_N2%)u0*&$QO=}R+WtiaYpSbFvz zaij>Qd~nI$tzeD@1w{W0k~uL9#8lWDFj2Ee7kw8VY1T@D39>=IcShAoViB_YE=*}5 zT~-cmCe?%rLht^U$og>;I)*?I+NYEj@tuT4bp~LbW<}A&{tcRF4khtz%AA7m5$F+6 zCzOiI@oYw#OvE+l0b31PL_J#ojeg?_z|{wAz*1HDgDnkC2O1Nz7AzE;OqTQ{g#|Lr zZ+Qv18Zban01KM~;|=Fu^8N_Q;PkG+;2^TVH6UADNHaKDnoH`H2`uOC3TRG%Dbp^7 zqQSV89$h#ecLyYLtGJUX2Phu7iIK#@qIx~sa-^jY`2j}3VI>8U^;iz%bBCib zwl9lXXf^ijYPcp?LB*3K65?EEx}LV4(eC16+VYp!TL#PwyGoT+m$sbUfe=D#&FjUBuD|Pi=?g=m&sj67MGecZ!9iacHvlDvSf-_T+npCG+`7q zf|H>GsFUT($`*uVt1eh1|AJCwwA3M<`EvRr&2@mi(8R7-O-QrKM2vK>m85EnyNmcA zml&B5nMW366x%;W^)?x1vmE`Gt#r}V57u^xOSXNIU*zEB%|vo+evh^*}n#d`ciA&5n zCBsK?6zH0hP~vQ!&T5Q`9*4#3E0S(9I`kQ1yDaz0J59Y(8hpxJlC-=+0+y=I=jQ94 zzXr)U$vVqXqCzW4c`-u?VV>Ms*h2(Sbut;xII?g;c`BAgv(O_6{g+Gcs6d2@pV~8w zmPS)A;3f0Im3lV$O$liMG~$HB)^NuZ36YOB)`E-YIW!9~W4RTe4>Z+h;42~Fu5+KDqc-4o&+rq}(X?VyvD zh~c_TCa%<)G_WqcMh?UM!%wtC3F3qvxGAJsCIcRwB9;Q`{Wo8KjXQ8~9U#o-#BT{s z{%8|29;OF_0$WKlk~KE#zm&A$WRL{{@$?2OXd{)?;S6Fk+DbjXSYuO}W3LGnjwE74 zszQ>l(J0M9x*Yh|5WIjWY~@r-u%WrW3PzDTckalv6r*G*^zcqi2gJec-CHOBl+WCvy0L3k3u#p+zRx;%kj>dNSanMTxF1?#fh93Wu86gl19 z)kucn;ES9mY5>7g8x}1M#M6W~tR~A-mtL*YI6n)W@cQdwqKV3t4TxB;gqw%Xscuqr zV}0N(OB>TwmBqpvTquiEz)px;QE6+L9=pGWEHBQaIGK>a0JD|u;^49l|0isK(Ec>~ zg8iDX;L>^;LJ}E@oIqKV#6W=edHdeqWz*9kh{kqxH`)+-&@YM05H;K}L!_n!;MM@?OZ-~Iz>9D)(aYEz;{2--ugEeJ2@9VxWEoiy5S8 zNzf?3mBn>qceBtyL8$qMn-;j3kCZ!8)bq6!7(3$lwAgn73J292%qF-SORf$nboMTx z6dMNFmknj$;Pn#nu7-%<(3W^hj-T_;aEQmaqf81zbm;J20|^6ln+fmXWLfG9fat3+ z((rp6g^0wsT}2KYPjNqirMqS@h~$Lh1!I)X^=io$b^>`Z24RWpOr%f+5NB{TTrG<% z6}UW*aZWN;!&~3C(twShN#rz(o1|RdJAH*~7;pl^B=EL#m3BD8cGhJU52Bfw`~-K+ z2H~ZYA6kK>n)41h-4+b+6-V|bQ9cxHwHmoHsR|1+1+oYzh|u%IW(e278{b6COE=d9 z=8}jF`M%e_d<1XNv-FrzxXb!9GIqWBp<$Il0q1hGjgyRsz=DgmI}I#yR{=R71XcD} z3J)o6S{4AtK8nC4*U`Abs{Uc@)<2gwnAMa)>(u6Uc}@?R`rSY^PtJ1WGXvP& z2{K}Lr?h`n5x<%xqztbnI4z*VpI{v>7ZTZBHYAfQCTf`SxpR*5^E;3_k3h`WFDk-o z4+?^AZG$M-nC`|^>~D?>f20S}hZ~SRNXAGaehf-7!gcDC0WRY%EWVO<%gu&~t@V)G zalFRlyld;>ZfHK(T3-*p=U|Vc)F~p$Ihvbry zrW=?DQIZauFL6z=IQ_@ttEBIhOl#&Kvrz3T>wRf zc$@(i+*!ptXLAWU>3Z4Iq7EUgL=Xy3Q%9-BcrtDy-dz474;fm3LyRcX>cb28k=K3K zf+Yk1#rG31II;v6JQ2EQhk@^2(yx;8t7NNvwK&0I1;ky#crLfa5OWXT zsZ+=$qmb^gJ}_g@Aa)j>k8uo%GfG^YMY1a(z!OclNxOl$$SZ7^o^(~=z}}oQGxh7a zwDf#yt#A0b`DmDj8ald*OKPi|uStd6FPc zeE0LLsP&OIwI-wCuC0*V=20Rn^V=dClw|8(mDxuR8iCkC?e79@?C#l4(tk|`NYoGq308)pL&tnI*mdPq-XC1uh25(gG#CD%o<_Ic=F=>PKX#(BY)>}02joB4T2*saIo;6#3b2hu1n6A zB{@2+Wf%nqA2h`VxnhD|b?uTaZS2C$fRRfXx+E~}^9sF!8EDC{%P4?@JKmMf)azz% zE;!g^a|8kF6a25=! zqO7QeB8W42YUl*PND`2wF+r%QZO|nhCZNfvfh$>IgOlEow~w-+L@TyByw`!DKm#0- zOyMmnH|mnKQ5?s0R^tAkYXO%BHc$w0vu!ID0?4AsB9``tJk(AvK|3Ak{=SAcU9gMT zgDL2~EIf6jR$jyo=1wn^Kr~*kd&|%oTZ|26h65lco+3Wvyj6+Fz55{B-(-r&7m}IsXiHi$-VMY1%wAGXq7A%`A2a@^VsURqT5@|Pe8Ot$Uvna^U`*6hDPP) zAh`;d7kZD!Gj$XISMOrP&f2xKd3Uv^LB}WPpEMPg1trQhELU_`X zFciB)tOc5PB)NmNOEJ6%!IJcUQjz579z|R6WYKUiG!9vs7G@UK5j?Yt7~w>W4KEZu z9BORK5O=0xaAwaDLdtru;bGq2;Ls3>uRRGy2C0IAh`is&ut$qXP9jp=7vcHV7X73I z?M7qq>|&|CdHFVzZjIyUnGLiw_#eO#jLWG1TcZiK;YkkireNTLUgh^7IOtxJ3_KnZ((JF-)M&1IM@IozG z=8u)Z$rM4Mlt6>-*fhC%Rz{ZcDL5Q`2jM&LqID$7NpChrDdd(ww|!jvhH@Gelh;*< z$Xpa;8g~&%N}n1K6KQP~F6#_=3+L&j zbSb!dl-Js-kw`P82pZ5#S{7%4f{G#6Yy)z(%e~jY6O&s!W*vjYLEPiVkBxD#1(%-O z!1rF4)jKoW-fy&~QJhPgY~BPX>3Yl*GjDh+qQ$#e*Ib=>^Ob=fVd-^+(Tlc8hb{(U z3^7olW%6{vVxUZ>S5X0bD=X_e2X zG<(zyChkaRQ-ihR)0&8?dT3~T9Zn)H%1HD1hE;Dc<@|MY;U;+uLW;#hz=V@hj1qk5 zW>JR`{^mXS7}Nvr!g%4{+UtRAq)+<1^u06iE2hj*#yLkwM6#j%Xyz66z<;zc;9WFhB`s4qhe8 zrpALnIk^}}c7cf`5BPXvr)B;KPWLhF4z5j_h6d+>9CH3b+_%r}loId191wZYUJ&rlnunOmV*x;lj(lYsuQzx zq(@E3@IW|R)~(L<&AK!VJ0E%?VcsxitvU;hhIsA5o&3zk2>g_5fOv8!?~)sVJ1V5P z)qDF0!P+vq5~HGMy+e1HG5+(XbPfy+TVi-EB;#KjJpy@cd0w2`N3~}2)J2IQzk1yI!bdeZ_dM8eR@S_X&%1<~UI0J9U*3cvqkahY) z!73G^1*Y3cLla?3!&<^hjFpl312m85o}3CRu%gQ{CL}{i&IPiFx>My%PHY!47^A`h z5*Psy5J#sKOS8wPh-elrGA&m&D)4QsJq3I!bSV_Z4s zy>mTNhS5|{3PdhjSz3?fsw(SN^R;3ZnQQ?&hW4Uj6E^ME?mJgRKN%dgUs6p(;>-nPE|MH1co0yIlv#xa1t@ zbe&|GEDDz27bI`sQ1c3Q$^H_xspY zLEtxX8yDm%`ZtaH%z}=?CQ&006NG!8;GBzR03RnL;VF4y1f3vJu4YCmc-Dh@`ij^D zv5_SdW}?EIJx!IX(9jAMNm*&eHQ^vC*LYVpZIX5ffCze&uDK+P^5#(W6P3?L@Xob+ z3Uax+ngk?Dk14yE;}Ih7OHj_saUWzjTPhicG{+s#!;AqQTurQjQ&}1WJ3Ix? zq_?@A6y*%-oeo@U0qCjakeAIEM+q`74@%oEP8YMg6Ta;BT9h@JCEuIb+GvI(ASuPm zz=zkdjk$@;mG(s8MKnqcC_Lm}mk=(aLD@QjHlPEN7)ZPUQ3`XwQP;xd(G!*v&NJk~#pt8>qk)2IQkaNjfXB%g!XhUdVfAasH zhOJMfY=83XJ18<{)yp@h>7A)D=-B(>HvII@qEg%DN{M?QRl&lc-3#v@j)sk&zW!^V zzztadN{mc{6>Cr6jsv3}cCO#~Kul+8JGkaO52$nmd6?>uNbS8rE5+Y&s!H!f8&g!t z#CF?!e3|PJZ!||4viqstWS&yd=q2VV*+}yVb82bQ5j?Dx^lr(Zg?YfvluO#Kh!<*Q zc*#Z#9{hUM#P93s*3i*uw}Z1U-XUICX>a9@ffmaHg*OK-OGNJU4K-M012nUl13MH} zT<6h%Xw9ouNvzSKl*$RIAJ}Vyir0d-Wr}dctRC8=7R;t5L72oO*$7PnNdq8`Ak4}& zyBuAAdM62l98#(gfp2PK=)#zmsjXLxuX#PFo8l`T8NvuNfS%yWT<{Fh_zP>7b8qtduXmRB;T=_?YMax)wQRQ%{DGsDdx3Ni^$_fvSoG-3cZGX(I& zb0I-Z(21?Py@Z4t!V9zZGMSCkR0>SP^519B)Nvby;3smLAz_`~f0(mT(4dmuNB|Ky zZ;9TDY8mj^u3|^}<{F;%Czy@1fID@fVZNcvRl5VLl6YvxRU`%~=u4D7clpfLMmY!v zkX$tRiyyY7w{znbW*Gm989ri{^Qinrc#u!edx!5_SSh-6=-9u|Wb(+OU;S3%3Guc_ zJM5})wt8u^Uky8`TdplIDeiYU{J8^Pr6a_uMWunpc6Dz3@Z`f>f7uV`8+Xn6_Iz^J z%nkU4avOKyk8frME*<6EgdOZ#aN_Ozn(rpAq|VU$GHPz4oZF_U@ReYFsyQ{DnjJ9H z=;oG4Tdk1lQg`K~0lKl&-uDP%gBx}rmoBt)%9Z79=r!s`C#EtUse4-EK3wirqk(X1 zH53sk4d#Y({|Yzr!iB1U6xDdfF3KA)F}XB=B91HsT+R8cog`gq2No%fB8Up7Me@k5 ziHg@m57Ce+ZIif=SMh>pV3KP$LyTmUj!Q+~M@iJjk(H~`IxRMAaXQ2?nX?3MJFi3s zZ`U=La{(GJGn42&FBH+ms4ijRiWx+Qgbkej*=QCe)EHO9CPc!|JBZg1LZrp<1Y{^T z&68u7_<^r0SN;+sJor9dGi*Dolp)cj`0is;CSHQOQt4lkxA`YREitNdO!Qvo@cg??-Z|@=`fpT>PkMiQ; z0SH?w0I!OsWCd0Vv%RYDRqtz`ZDz2$s`ORwYoDcb7n4Ujd#`bQTqvXns`%Z?o zxUu5u`yRTs${tnY2&o*lv*oDaTUfH7~X7iPG%w3<&~6HFE2V z{>pMgHxmvf_V?t7xVX>AZ z@de5P5~rk-D;;Sn53!}JLS7V=wL3WB?A~#6wCLYRHuXY8k-HOUa)a(&x3R;~J|eN? zoulcRA*R}3De{%6?BMT+%bin|Vi~(+p+>8EJNCNY3L?`VP_e$2TSyeLTWtS5Sw!Cp5;5Ycy`X z;#Kww#k?ACQ}$s9u?t5G1WEdP!EDK3Zd#}>HuJ}uiO>*rcxCgbGt=|P&Fnl?PT+J? zrgPQoeF7Sr(G^C*cxFVxSUih&0VKRJN6niMGU{Sxk zHZJ)HQ`_l)T`d_0;_IO2?A%QJz%n5oFE6g=L{XZg-Opr~o$$20E1j&>U#wq5j7#6* zBT^2;_`sfRD=CM&%=KXhE0Q-^hv<4}@u~ZezN{ww~i3PPvV2tRU_^rz5zx7%ofMYQ<4y7dXE85DJ?m zNBB1w&=nxLe(PDLi)`Wvi@66cQA|Lv(=N|<{2OQ;E?3ank6ttK5!ZpEnc=Qu99+UZ z01}E}f)tqJtko8-Vtqvg(mZV=o!?$^ZV<0Q?!NA}#cthzyC*OmjyI+AO0em)R({?@ zb#4Ww?{0fnYyZJy7C$KRdF^k|>|D=>oVE(LOd7xqnuy?J3u$!u@q*Il1;bI|T4;p; zgyIf8+|wsl){S-M)=DNL>1rF|v121~>~$3Do$1-#itXW7#`l1i}?rh^81%HrX3Og5~ws<8Jr! zpT1njWnJSjsH3iEg18bV{kNnS!;lNhLw@lI0!!z)$GJa(xQ9L=oVXb@+i02d4mKA# zGeq;@(E+3}0U(RUcAOF?j%eBZU|sY=x}BZb4B%+1PC&5$guI-CY6p|4lmv+fd`ajv zzF{y-)PZ)PGyq;_4NViLnysUYM@*qg4}O&QIdYNtVf!+({*Xdi#0tJM;ofLYeE_rU zW$y{XQVGgIG2W9+>VolG<#=%@d+h=HQt-^M#4Eek-HDgTVhogfvIJYh6Vo|L096EBgdq=toJ0FOSEf2>^ww5suvJn z-8{ks2rA5)+lK|WCg?BPG!?r>N%9wJZh=u8Qjcx6^X1x4&z}7F%nl_RN%LvwY4JiG z>$ED=>KWQ+4raiQ5nJ${1*QVXfK5OE-$#jK}ha)2F=(28W$g{9q10@$xK2LFDx)x$84yb7Kccs#TIRFRcqF@;i;vVrEK!b85 z1=S&3!wzYC?Zng$pP2x`r;i$+nP~e64TkVvFyB%y66i<3xa64dh?icAMOoL=1VwT; ztd}aWs)6AamLewL^g$F`Uvk{9Dk0m5_~xlH&nRa@U*mD>h{z;om#+Ae-I*5~2gvyF z+IP4!3wku>ehhzW%m@BPA_ciFy6YCATufR`{l^6~j&|v!Tu*N;m^l_0HhbKNG0ZNZBQ{C#wEFAdv>rIP>`xrt}Q``pftt z9K(IzAk-Qgu@IKeVM=J2NHF5QglHeaMvP-R19@l5kI5d=UgBPKii46)hHYUvkTNae zWWp@nW*lAW4lpzn{zZ_^06@B6i!~h&8o%)5dfG*wj6(u8QArcM5y;Oz;eAVJDjX-I z9YJnDnI6M`A9Zh;G55}8c#N&ea>7IY;!o_CIBAB0EM3T>VCd0r< zo+I9GA<VpzsJZaa#3u(Fb)%RaI ztG8(~yr@$6b}>SXoFy?rxGJ%PpeK1nPxrY zmZBv6CPizpy9shE*8I>l?p-?)UrlH1pui3?dl~4uvPY7tk}K22%QMK_DPfE4Z^}M; z0gP{W4-6?pmqZgl0W{eqxZ;Kyn{a@hoY|xOWw|C7AY6vc_L5Crgk%K-sfXxJESfPh z8&g3^h2jqZXa(04iqTTZJ%OXP099rLTTL^$-r8Ir<{WU$KY5JypSlKpX6s#n>ggR!ztmhDBqbuMI#%5Y?%ofu~85> zyJD2g%y>TE#&JP~5&L~+QnC3J4Jz~F7sE!5O@>HypCj@8nxrEX)`hneGAfcRUv*Xh zq~Pp;qrM0WNzp|Sh6O83R@lJ`Lsqot=K z28iOkMnvcAoM(;$bUSNw1YSpy21zzCJ+VM--z*ukw2#CfQ`y z(x9ajrS9eTfwmC~$-%(s1h<2MU)zb6$dJ_RG$+?|gi8X;Nkhwl0crRGJ)kZO=nOQF z&NVxzj|EAJmX?wMoq^$wp#~{IP|{}kaQkJpWEeknBYdH_1P{xS2nH5HVa}E%=}9i$ zy@ADMaTVdk3wIOUB+8>(WM`V9?BagjlkH67S z=qes0;wchD8Z3yc9bXEnz)lG9C#H_b84KB*%X|`KMLZs zkLlqC4M-3NE%*`Q9Hx(08?j;f5$G-`4GhodNT`fG-U#2&2n-6(7d9mz>Abxx#N+^^ zMU3eZT0(_g2Z1qgkBiA^9w}Vk-S^eUZ5v3Zo<~L6^_pi5zgsy#z!1WEPmKJ zM0jwC@K{Y>aRrjE`%=wM-~_Lz5qCR?_Aa55CDM?idR~%R#fh@JX-T_i_rT3pQDjpp ztxu!yBPw;unqZPbLj?<22T!*VBj}J_;Z-f=1g1IYA*@DuFi7tPe+0*)M>^T1D- zWyNHk*SR(+hX~Ru;Kmo^PUzy~tpnwZ%aUnlDphB)wPuS!woC>LGS7r{f{nf+!fEh)2@>#812+x=NS;eLh5iWyC%1AkeRa?lS*YgTxr2(0^m<~W9_Zjzx zi&Z$)lh#qcEqk~kcBe5vEE>#}K3`c|iZVq24xV6gW?ofDh)#PWrqR&rgB7!X14(#O zQ0zSu`)Mrqp^Eql7bg%{TWi1EnXcOAG8N}DKMCw{nexdCSQp`V5GyTuzL_bG*D13} z8o`CG{V1u(@4!fY1`>%g4UlVwK&tf)T1Gx8PDm}#W(MO9lqBVp7+mMHR2-%Z8u7X+ zGZAkm0uv*rV_Ok8Nf6WJLdV*ot9`7&rPiHufCC*IC&zSX1S9gm%`*yV4H%415mDT7 z;6yiTSBv9bp;Z`#EqD@$<7B|uS&BUe3xau^mmcv_H2O1Os4$d~FDj!t3x}{X%0)&p zjud8_054MbHH2vsr&XWz{KZ9SIyQ=nJY?=kq9z>qAv6?fNJpVD^9FHuQ&bq6OOO26 z-%GX5q0kr8J?6OKk=+W_C_`%3Qcw`zQV#?3ZA+C(!i&WyW#sqB*+PLO)(C6FQFRrD zHicsbx#J5G1g|0jU)S5_k$!+jqC8Wa;7kUZqmD)YmBEaa<5*IjG$w9L8{P&QEmU;A zE}k{1oOCAk$@GkMlSD~jkqPp0%O1xPQ}}3bpbBP(*lKOL7fF!^m@gyNM2d-QWFu7^ zo`-a=+AAXAV-KuSjVBJEYlMA!(X>HhV(lVgqI+PZ7w6xEncSlh9{hnj5g@u8QeMYK zf{6tyJ-@?AN3g8A&VuYqHDU-*foD1zc_HgwQMvJ%U0wA^YYKiZ1aAd>fv>F$^;(d& zT^AMbd04|W6RH)iF6Y@Rb>y-xor5kXh}VX98RFEi@lkBVR}g2(KX=E;e8pDA${?Hx zS;=*ClB~H?IC-p@=FMV&C4`zmFJPh3WV0mp$<0F~Z!B$;XEPOrjEBu9#9CS^ddlh$ zOx@>Vn9WO{FDR^Go7XHX{ud0@jCjlWB4reBio$%4Kt6eFRWy-MgDG3WbKgSvy|5Vy z4>-E!G1*YBJnTV*w0VvTbhLCtF4@gDIz@~D`1sgk?eZm`~8UjWzGkHoM1lCeG=xHR zoDN`il^6yc*)~aG2BIx!+ge$WP#?%C`V06WCnQWbD0u`g8w=dPz_mRcqRTBXI$&FI z_E5Oz?U5jad{44bX8|lV?%JlaxhQXxdbllXvU4`Efe@j<{Uc9{6Vqx2wq*D);M98( zV2rj3w6)N2+7T}}=bCFh3R zjL-{r_umaL-yUqpU~&cEihX4Gd<`I_D^=vaH(NkGur}(6*c0e33^M`3oit1;YMZn} z>@eY)TR?b{q&{>xOLfeo_|J)3X}4Y-++vbhYHeOmP48f4$H#YO<{B9vy+PMG=DVDl zJu7zk2JNTi^VZ`NZ95JgOp}b0ec(Qn6ZlTsZj~p(_#|imn?6zsl#!yIIQ5PnT7c&v z32jdn2m7`lV_MkxuHeI_shG6dsk0;xr`#6?32ipjPym(o<|g4ZpY6?zqI(Xim97aJFP^U3kb)m&>&DxK94BLn(i z1#SjhvUHI3#9ZI$rzRSSCA`s8$eye_kyIE#^$_z-p=H>Hkc>zS1Ky4$3j;wFm`!H= zsVo%bgo0yi zzs!e)T?bOA2M8r*#nHVLnApHgK*jP^;Ihc+?S{C@3LRngC3P_6W-$LZ_-i(l4+@EK z{{uR_nW<#MowX}BLdkEkjIiz8Dyk7!a?{$~`MYwxZ#&W$t4JtjNX^L^;y>Iv#;DlD@xv5LT0nx0SXEG9;jT(a59W--xepe+2DCY2BDl#oHD7284A?21 zk;qpm`g5|t6Mpj zXqIYT5uT@DRXDzD3N2Jty+lhrF5iVM^_XmoF6?p-K3%^+7%&SJQs}7zvnmmg_6q6Pa=3?D0EuEt_8( z7}1apZG-;VxOkejGaTvO)$w=kIt_?pCXkq%hTDWuPeM`n;8h=qmH||M@i;u+`>)OK zpCcgzN5f5Mx0miglz;>H6fVU3I#i;fipdP8Kh+ilRHJf+}v9jc&fbI4Sy6KlN{7H11 z5^0)S%z6$-s_yXR8hyUkjaIw!Rrbam(`2(&)LvK_FRrfpmh#dd@!pS0SDW*AL)j8d9ZUd5XiE-y0_G0O}no70n1XJXa}9}(W!7PdFS zI{6B1Vliq&Oh^u1k_~^nTtiN43BD*f11=MDGY9EpOmb6@DJeC$ z!;cX^p&X_?K>ny$!up^f2IFZXzMv~3wp70@nuX?UhXEOJ?kDsvA^XLN8K^w&;$YSp z27|%st#x86@ZAw!&WJE@8f}X?)gU=cz@Kp@`l34?b_agQ4*$abVLSbbiC_e4y?H@Y z4w)aC46*ZZm~h~;DjJ&kG|D~BK%!Y7ueUZr9u!_Zt}Uybx_vqe*jQQfYd{-ZpM<>g zsUWPyh%;-b{jw42td&&6$!xfDH~Y=@$@5qWD>zmt^J%nGgK{Ix3g-cQ%1^&_fBSC! z`|c+X7q!`c{mH{vF*S*&2M>2j;~+j4r-#tT4sQUKTY-1VsxEE^?skKFVSm?WEXs)@&UdAFp-85^<7*K-4`~vzu&}*G%!~W|zGYEkvt+&sP z&}?y(PPRB?|HKL?y>M16EW_dCDVnuTIuCc|I& z&A0crpW>HKC*5sRuY^?Cgd;d^#W&uBfMEjZ8TStqUJ9i*8esC6r2KaVM}i^%nYL+ z?i4_jpev({@6z*5Ym8N01a?r;(d2ck#zt!43$QEr^y9qKSd8B9O`L*q1y=;bT2Q=) zhfOOy+&S#06zuh^S_?)obn z2a{meLh$Z9zH*FZn#XzHba>ZU)ijpl)5ff7G_re+PiMtNgTM&I~uU~7ivGVVkN1~cZ{@qU9k;8dWfK87ZBu5?lI6;9KtP(SF;h-qI8!8Kgf3* zQ1axn#Sf@3+A058=R7dj~vDg zf>LBf2ZU-he9X_4!Xo^;VSy0IH?57O*gpU7wY~pt?EikfVSnrJbVh{+k_l7B#M;bD zgpdX0W!lHaYD&n0K6vNq`F}q^qXlVmH2F_Wakn0}5qkf+NbL;Or4OXIDZRZ6fe4R; zbxMg#gW|S4Y5fh-eHn!pjS$xpWk}5~ge++zk3#bgWuhuw^x@!tlP;QRZKR7~du-!u z{6SEFPx&c8M+UL6hlnxgx-dVo(?)2*XHg65zfoz+AHsSTdnj_iyocu22J~})tI*(8 zYruZeI`G$3HBxEVljf*$Eqv>_E4ewSP~D}^22GjF&pgJ=>GU{pHLEaM7Zt5mZzGuUr%58Qx>W3-V~Y*_}N_eS>uuZbbN zcvAzyLAub$VeCZY;Js2Sk{ZENpuCdyU=)S*7q)+oL=@$1BRm1f#Y_tqt5PeHItDt( zJ)AzAPVPy{(=a)kz}~t+bE`hqBHqBnJqw@;OZ`s{}6@_N5@k+ z00`lS7r^sj_{$-V7iK^@y)dxch7RP*?qMHFkRpY671C1=1P3Pza{C)`2-X;yEB`)& zeYi9oLLlB<7`}M=7m2R|&*ptH^ex0$3cgHuttT>&=$2_NJ z{KRxtl_6k3Dl#v}xb+feDO(}9zHVV>R{Y64HnIqr$)4rPD2$XZCI4WDzPoaS!c6o$ z7i#?d%db8^_|p$RJv;dBFW)}<=E;v={AsT41vl`VPRCZ~N3}_0;&JQjbpz?7D%vXD zx5H-msf9Q?qw#8;reTjs?QlMWJ0W<=B=&qDVsUG;jf&wg9sc|v3QrQpU>l#57Nfe| z(r#v<{~h4hUHs3y0M+^eA#AL_ArW|%`QdXoM*BWmw7tMUJP>||`LaGK9 z!nd@AH!!99QK`5xj}9SbL-qh6Uv>2W$DkHt3zo_R!yu#*z4{D}=xqQ2(jcjzm*3ru zN(7U8B0_zme0t(Vla@hgNQ7~hm>HO#%PMMPmT{|i4ZCrqhNIfo5$V4X2?)7{ykEhRB3$=9eBdRnH+NaQKO>rd0FRc8boNF) zDm3($w{OUHgj)Qxh5J?q;U^d_dp&4nw0*DsMe?$=;+=77m?BbrCrQUw!|`-_y1Tjg zs{f)--)%Tyi$|0cVlWlw zA?I6SG2<%?*#L5a?3)mJa6S)Rl?nwDgzDi=ShcoSacu7cnDkzA5LF`xn|R4~Hf1bN zXh49pgP7_*yzh`ucNOm?#aDu?W`b;W$R3q-wjl}e;5RB2?3)9V8Ho3S`W>8{BKVGH z@oH571%R$RZb_a*h%}{B(Hwf`5g;}}hAXODFQ+GTKLG;@gF1_nVO?OUcq-R{n#My;A?@eP zDvaap3mk;uvSN=tsPfq@WN(0nHq2D#Lg6o#2RKegM%FiK!v?UtoXZeSk3H`8WpA>( zi|M9>XT}2m3qB+|b)ch{isT&fuWNL5_T$Ym1QVkClL1hc5r8k{Hg~zWPvm(+YC)C4 zv;~83`(J1s;d~a?B!L!rue-b7aTA1Mg~G4pWm0zaGRULy3WZ=7f~3l%_gL(G1&fTt z{qnVblu6Brz>|zeGle^j!J{D$e$U(=i`}~SL+rjP0xrJ9-c0ApPwB1c*J*A4kvgLd zM}$`KHs1(8(@luL!?F|yosADpAA$%KGtNrMIP%a3vGv@4bU|JC8b~ZX5-aDIGIC5ZdCjzA1H;jG zY?~toV0`EfqgTJ*k3|Y&XW2I%{DR79G;{8xtdZ6$4oODc>+#Q?q$%a%X0vkj3E_Fn z5x9a?Q)WguAOd0}b#d1_B`UTi5oHm_BjoW@7&Q=nPdaV>lgiBqo5w6?fE z;>|VYs2kZBS~>#Bg8sT2JJ2+#Ff+|mv4sf_$*O3H*oGbEjC`1R4DNx&F<+)Sjqm{M zb^l~`!n65@JAc-4VknLcb0-3rfB<~n9zJ;R;17bt3IP3ACfDu0$nN2c6sWSCnOUvb zMr<}=k8WF5uJr~p_y-mMte1@HDx=>x)|z0#N?qP(kj|EjW6g10Fu(^X6Tz;Y9*lYi zgt|+qU~a&N=dT}ZJ%7D(`26+O1N@(dy=*GOp!o*Opv?TzvDM#W;uv;jTP|bXPhY`Y zRWDRpbK7+Ov>^*~v5#Bg?JU|IXk}o9d1HMD#A34%bR0Qm%!$)^{s7445yAqZSkTB0 zL|tHgxdwbiAq7x=8nuxw&CwJ=_56)AP%nmu46)}gc7tB{a6LSa?Q<>UJ>p+RLwzg1 zrz4m%@h~=qt9|H)Voi^AcY5QR&FcW*$Sl%jFn@(52IkMniMW|dFU4V?4%>$-Y8+rf zzN!`Zee)sKH5RU^AckIq?4UDQzRF%bhpsIl%F>tDiBN2^lG^RrvOuO|KJ$L?v6Z0n zdm~~OpyrPC*#?Wx(j*I5n7zLoUA*moC2aY=`--ZBttIwn3AV|qQpU34D8w3trOvAKC)*$j+x`Cb-s_6Eq= z$S)_|>G24e#EJxg?Y~|FO~ZbFz1AML?{D)934qknEhArr$c*^5-$N(10N;QPh_EVU z3;<_wOCUT_&dPRheP_a{McAC4ssD*D1chSug?L9At=5En&Pf zKqrkk{{MbwJ7dQj-p$DD>oprpPGAfD*MRN)-dU2^*hxlu`O`lc_00!aXpfNRT(91k zWe_5*3{lge2WdpV7V-3-XgfRD__sV+1P^ADU5FF)h=~!%*r+kFD7Hs@u0rOXrqVH0 z0ZDX4EqqTlJ6AM8+YlrpDa{LdJB&FUy-G!+Z{}{FkW*vWu;X12I9$g;e-8$uO}{#|K}gve*S$R;HDtOy~g&&&PH>y_RBj3Kyz#B;m*znVe13k z!v1%=*|aAiG`Ds>-nzfNeZTqegXY%95AWm6);k@=g2v=dpbxfwmA)1X;kSIOcP{_d zk;A`R{{MbUAp9HmUAh0i_|uc`|KqEl-W6CD?f>S^wv&R;Y~J75*=}xcZS8!}Y(BVu zyZ_%6^e=B`d#kzC*t*}?dhk0DeHwPrj^hO#Z}m_~GERjxB)s&q6;WBBoSK3cG?mHv z@0NeJjCK5k%{Ct(&va|d8hF0ch-I4_&5ir=#LueaRE}pju#FB1ZjyAW@l@gYBKaMYjVLng;+AhRS=_xLnnv*qZw9bmj)%jUSdD;L}_rks~2@!)h- zp~sx=OvWZR8G1%gXoc`FWGTPw+ChsxaJ;8ug!0Z|S{EDIEyu;Hoh0NIr5Sb0%K1G? ztK#9{O#?bG535VHmtNfnskvtiCWnU?Z>Ex)&>9jzYe$MYB5zF3g|$mKi^ER91@SXH z8w*E`DGWwuTu2OD@IrtLypY95NrosR1krMABmWmQnhF26=#Qz_Bj77Fjb7yC(`EdLGgKhBt`&&D={QnA|zN6RQ z#0YL&(Idq8cgz2&2HV}RO&0wlU6&`j0T)sKZuuScdfUwZ76??*e+qr?aDX?a|Ih`< z8*b_UJ6wbXO;xV{Tu!Y8m9P1D5&egr2dj{Nn%f`mY(MyT`{9Ev(EkTJWDUQHP3GU6 z{}=C1hM+9B0g)AiH31Dh$$4QmByt=%uk(&r1XCmXR+PmhDXn^~z^Re6Ln2Z{j;9B# zx!6%<;Q5m(3A8$kU#VT7qXIpWl=@vk)E4C0Z7U_2jN*lQ)Q6xprREzFrvp1S9TuQE zaTw4G*y--?mR+rK1?97+>IMEi4&5F}Kd_p!!NLpbnS40u#@n&8!T1RjdgJMyl;mA2 z;yCEKqN>EAb=>*>hi6~ik(eT7v_8~$4L3D3cE^)I%l`%-@{#+3A}-29=-Tkqzb7wa zeU6Ct2GaMAcTFJl3D-4A6dUe1(9kwl;B0^x*)z27PuI}VdQ@~hz>Qv)qH<}*Dvkk8 z+SFX3TlwX?;-<^7&fUH%v*&VNlU&>u`xPNjN&gi;-`OZ`&i_A#74Vk-zq19nq@n8d zM>a6HpLQ>)cav8)UVj_|-LC&lApGWKtJi3I%o`4s7Q7^EE&E>ptTq*+yR&VjN2EOuH*b&wS( z4oKjgwMNh6#_@<(FC8I4h)Nj<;lQmHE*`0cm!jQF0;tRl28QD<8ixRi5EqCT@MWHz zu8KVv0tQE^!I35~NlZ4#m0lpD_Ugy5>E8eh|F%Ud_kV8x-IN=BB;bN!DsN&9T)6+Y zA4Usca|gTr{>PvKIRAgRbN^QV`*lzfAu~|g&Lz0l*9*iev*@U35%K4B^&wp9sd6wI^xv>R;1ZpgmDEGkE zblO^5CUZ$ch_=UB<36sM6ori$ka1W^71-1~9%zE9cH%_re)LC;&(J3{R1U&DG_NtK zd>Wt}#`Cn)Q0)jKB!nn*-Dl6xxD^RU03sKcPZeebSex6M21vO-b zEF-szt^rU1L1ibqyHY3^>N%`YY`!O}OE7BRjPV?I#Y0cdBUd+9p^Ud%WE+zaT#Wl* zRBnD?w|dW&vEF*oz0Ijussu&rOWVylvd;H^--N?5(5u*p#A~KUwu<(r z6vfHx@x*P!d8)BS5E@VDx2@$%^|iMA^Q^azY{51b!t;*j>L}Y_ zR7#LA&os;wXt>A;Qp?&ryiJ7e${l5O43XiKY1~m*L5dl~2ulGHyWcHeV4QJ*YT9hg z!nGxT*aQ)`W7t?Uo4bo9sX?(00SXjiAeJcPjN~A&S}jab)PY?}vf9v?!W18j-fc5Q zAbCu@bc`dSu>N@2&Sh-u#?wtt-&Zc!YR-FHD zmQqf?LC=fiKOFe;m{&e_{=0pD`(wy|_nWu!-x~n>4XWJAf5Pu? zFavYTsyC!@3CNXo~A3S}uOm5ZXrKc`q}Q%_*IQlj)40-0NBQp4VECQU{$ zH;I*!LCLRAqPTjoNdaRsyF8etZ=QC>`w#Yc)9AtI1+|w6v=6)botK@6$RfHZTj9Cq zMy7O%J`quxwf6%e_M+5jypLzAsvU_&Dq2NZb6`>B(NLMtRk-OKHtPdvy&+dX6n469 zG9QeI*8DlIaq{W)q3Uo$keMpFlVVrg|5VftP~gCFo*>5{)VEJ-FS@ur8Hq4($v323 z$l#E%

    i;t&qGSck2a5OvGqGY-SGh18P83TGtb6O9hy%4(GxVsQ7>qE@hl`j(-Y44)Y(`#TaWr}~v#GI>Y*n+biMia`ENFOf zBf_oCB3eNH_u4Ef^?#Cs&EB}%J)CqJa(~MkXqKtUjnDt@Ka}{-TmR1l!}s;=>h)*x z@VD#z=Ij4p=ivvp{y%RA_3PDMy#AKl8d?j&0GbWWxO}}vOQmkS{yPs51$4XqB{061 zpVwLcHV~lk7G&V&>;K^6TmP^3vfOixUbX&jvF&4DH(vkyI}-nW%l{(?-`khP>#rB_ zy~VbVW4`(NBLT=Q{g3c_pI@$8|KDc+Z{NRN|M$7-sqMwVFAJ z|GM9|KI9=zZS+-uD|*tyt5(PSpIL`#(%#v;9t>D_4-@<_a^*duBd;V*Ee4O z`^*A*d;W7B*uHI<%h&(iBm%(Tw@pg^A@?B{)7K-ehoh`9~{|Dd(p#Qh$zwaNfuD|}!1mAEtH(vjphda0Vf8P+;H>`H``hVLW&R)O8?*9Py zdE7An^MkGCt^9w(g?z)}*IoZN-~Df}{yPu0Z_oeVa6xZa?dtXaxsM$CuO@Fn0dBtk z?@RvITmFB;#e9R}*I)lPrvNu!|E-6&{QnIW^9`z8z5ciI{~LhypQg(7*Z)`C|F`o0 zuZBNYum7$5|En#=Z_v?o*Z<9T|E>K08!YR!yS#e+Z{`1M1M{D-;Pu!4%_+dG{Qpmg R7`H>dg}^NY{^cR?{{z8OAMyYI diff --git a/src/vfs/_vfscommon.vfs/modules/tarjar-2.4.2.tm b/src/vfs/_vfscommon.vfs/modules/tarjar-2.4.2.tm deleted file mode 100644 index c2c8464e6a2f257f32e9e4cc6ed438836126c073..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 118784 zcmeFaX?I)4u{P?jS8L@D+)rBsY?6w=Nt2B@@|C9(zww}DE5|u6#lr;xAc+tJ7!0Cl zhUd56=c%EGy*D^WvYg})iA55-cXxGFb#+yBRdr+5nf$FYY1xmhwTEk4AH3tw=Ela8 zM~^-zHa;liQ~t>>Hy>?0dAPZ;x%J@j2b&uYH_^O!^p4@E?QTBB)IZqRsD1eF|7D|w z{_FnbaNOxlyOY7m%=lw%)*ap)C!qi1hYzdt-+K7u@x~Jn8lOo2tq(RIKiDAs-wRFt zm(%}_(fUr~|ICMj&ZzjVGwJq+#rNaAVZYeg*m$&7eE!py#kYfQe>Cl{72E&kyYF|3 z@u-*`_KO$YVSlnbElvkVgQ8U&&Sod=^>zM5PFb5B-D%uuw0?yT`z@Z&Cnw`+zg_&; z@AQfla_egGQE@sM%=(4$^`ze`j>o+@=CVH+_NT>sIv5=kC-X_aMF`PLQM@=DOpD{e z!Qrgf>!U?~e?BZa)1p)CjmNX;Y|=R?_Q#WAj44lwmHp0i)}P#;9(RVA{r&y<=xETN ze70%>wSd6G!K?mc3KVr_?624xj5?D+f2!m4*A9x=WV}Bu&?&{w(O_15_L3Yca6t6zP%z&ek7oVR3=;e>}tk9Z+Ye z-|(sS4B{2t@$oUbL3>OSm}wWj_CG!8bdNd*{im%@IhVnB^i+_AzKF}obS4-r2FeLG zX_*e75;!}>a4_oc_xrv3MSs)_-`b!>_pmeRbb-rarLkIcMm>Ntnso*vVy<71o-GwW zVH*930zaINF=vw0rrY>Mv7L=Gn+#jOB*VP){e5MQe$nZ@ z>R`qPXhK%utOH>?m};ln?N6rz4lay~{=hGzUS}dKQ8?CT1VUN<^bI zsZeN>>AZW$=LeJiiA-7`1fv(KVj&-#^v7&CAMJOJ2auZ+<#>|b$Hc6a3pl#) z*WKB;H-?xTj9&Gpv%vwluw8s3%uZU5ihKS2{XuttG42(o9ZZw_%7q4a$aV7>#`*q9CGW>XnpdN`gBdp3?DERmopk9$BFhJ=s@&&doZ8b=Ug(|I40 z{1rBsmQd`M!O2O#XUfkM)BIWGZ)bD_vW>y&K;5wT322Z-jTX~>zxa!6GI&|h1u=L; z60A|qQ)abmcFOh52OmFq%u#=p+1$C)aQ5qsN&92SS;|@poDswr1UzRHL|#md&k)`Ql@16g}T=hYZW0_C2rpmh*Ib|p$# zN)PTVjy$Kz6p+ZG7Ync;`XKSfkOV7KN@nwu)@%S}0np5qKPZDB2eHTYM_r6H7!8gG zzsO4p2W6Y?HW&}!o)!E3Q>qr|pxvJK!T$4+^fh&94aH42lwxyjYon%{6UbqT4x1X7 z3SjpJ)K@@%5L0!c?(jZ&WiW#}3gOCa5Nq)S8V2@ypkvYjG%^+9g!t&}L7L7)%1-8B zUM_8EfIjiUx}s8q!?0wT-pSCk{FVKtonne?)?|ur(3+*kniv zBch0p`ALt^35#>12Z$73V+~DhwS=fx(iu*tu>l6s=zs6ec4ycW(0O6j24UEb$RuneG7TJ$x9DEdR#RLWJvaf9m4 z{8%(Y?6R|CX~rjYBQ?_*r+8_E35hNglzQ1dq+uga$RAD>zr`AsUiBWchOYLtm~OIph>AAF zdyormpt`^Y9=Z^ts;g4j?Ceo%<;D)R6U3u_DT*)q6S0V;YKB2U*DYT3( zfQ0@wrK~xBR(zf=KZ@LKs6nFxAi4Q$r}*O^iw!iG^k?(Qs5rm42QrK0A0LK9E@Vj2HoaebRv7PN>~(|Fr9ThdsB|k}eziFUI>~e0%~G3B04ci8eIyPO*sk zGnl1>$y+~%rUV-iJkt*EKf7Oi&Ni)9@e^L)MhcgLbSYvWb_=xR-TerOJe;L{VOcAE ze8iuqf6{L1rtLW1_v29?sxN;PUQXcu^_aQ&%(h_;+nG$DYj6$Dj!(b<0t+7`^bbse zCc-CcwavgL-Odbrbv}m!RXSwrWR)4Mw{=hv9~^c^2ECwgzauY-G;6mHJ5wktwA=SP z*a+|30rPEu7s-Qnw{5KQZUChRZ(LCM!OvY2gn>ir`-dRv3lQn!yoaKh{|#sf?;_c@ z>oP3}Nl}VLSdA#XA-Z(IhCOZwck3=a6cD+)vtz0=0+UWRU2`=p!vsk?&Z4GGt|DiaKDvcyZbHk1p&>dlERW$}AL|e*G`3RlY2lqNHW2YB z?~Ne<>7AzjEIU~b->gq(*g?coOILAJrJm2Rlo`$mSq1JZUt(s=vF*k z+9CVpfK-|fJFqkN`mhL~eu!y_NnpdJMtTOU07{sDuov*10VuXTJ=LZfs(;)yhTOe| z_qi^(HLGuurtAn>8rBi~wZzbTD!M;f%(!cdk?}LVopk>Ejov@8Y-n)!RP;sR=e4yp z**ze2V5r$trSsuR6no(@IJ621!KV3G{5E_dCbTFsq)Nu(f4J0Bc1?GZBM3fAA zXt=dfM=9Z6FhXYy}4!@D7(bD_A2S@?L*-O00_w;KNdd$lwwE z1ky%5VRU(kT__d|G1@=I^r;>JM))FUN=`sAm{1-cLkH`?6Lu`dA`R_~qg% z6MGEK6(x+~p=6is&ACf(p-|fttCf&pp25RP{SGsS5E~cEVu>x&dfkU@h9AqR9S4%_ zEE7r4^t=5D7O!p)x@_C+bm8jA*;L2w_sV6S2dY443b-T0_b`*XiZ*C7K^z>Lin>;e{Er4&+g54??&lTHw+DE6As&d8-vRQ@*N*cUV)sP4i4;*vuiQcO_?Bfk9&|+ltDonH%G%i z{&6WY^<3j&>xdG0!*<)M7|*%1-Tv{bXJ3Bzl{sNECLtV`w#IJr0;@l76BTr<&*7Nf zf3ORdQ?Z;bk7bt=YtqNE%9rqMl&ch&aE}M4qW6||)@~ac`?jWwfpk@+A;Cu2!YSV) z(v+bgRSTdvLqo$x5^*l4pOm$M@~|IZ%TZ*(8Hr^A8wA4DPRRkN}SIcS$RAn>QUfr>PKxl9LoWB3071l&hwSz)vn47{optl4!4d z+HQ;bpr$rhJ8aEi#c~9GV6*Z_IO0lPOjKSr5(Vu9{=fm`{P{(-HNL6zT!$BS<{#C2 zBdYj)L#eq|$QBi}l(piEbmt1w$HoZ8(w&ogIB+4#gaS$?m)T%_6FMxA)5z~K95tNs z-g^i9hj%BkoI?H0VUT_ZJ@A}Ww=Oy}x zC}86KCbNu>D1}58@RtE}B!AO?UPYY>pZkm9AjwH(iVJWL1DX*CP+?4qbhiay$oSW! zA*GV)HbOP1H`rKGLgV)yoKS;VBBvaVH(bB|y2@StRXfwS=-nkc4WW_-W=d*F^HLK^ zC=`Tju=3<<;kWQry5(~Z)c0Y>h;c{ViYl5|FuJL8md$g0d?B6<@qnj}+i%?~9~h;i zB6))%Q}X z5sWY&w&q8*1|L35OVu|hm>w1&#@F<0)Wr%KmzH3{JW+lL!csJg0mhx-T;Z9)?OR5Q z(T|#9v9#TVzwC%+7z0J@FF5hWh@ROgTK0YM;eWM0JZ^p1d-36)+8=(`{_v+Aw^y4s zagG#KOwL+3NS|UiKZnH$ivnirYybz{MHwo-ArezJC_d|>x#1?h7JO~FWP{f@E|^5XeTohM8YLc)Y4@vO4Hyr^C8X~euna? zjy2U4lOX}@4iDLq2cO+rDw+aFwtu=!;)c@p6jnAkOhIn#&|+$--Bj$J932R}Mj4@e zh1{V>`j-sax=Dvg7UvEk(WvujeYo9e{j$^gaC)&*Kkh=Bm)&q|$WLPi|5E3G;Tb$& zf&M0Qu?QWA14eF;c{HXkur=RZI47F~=&}>1aV^*tBn@5y>myJAPMF~l{1gJ4dX&Zh zc{b_iA|fNQbNZrL>oDb+AHXW^;T)ewD>_|74A@BnJa6uDf)Rn^3`j_e*z4(ex5j>m z{h|yX4G0d$&q9RhBEakf`3d^o1b^v{!BO?^WEZkyPP>IG!n+tL=XI;M&)*GQo9vus2re z)vjO>UftmhFd1bd?FA=&Rg}tdu3b65?H)n2UxqWH!!e)Yt%A8Y<#Pra`j*#t(H+8v zzAVuNq0KTBw*ImBXyCt)vrvRxBC>EUVY~?S!7O`CV@3NATZ2NC7RUjX9FA8%L0ESy1d57As8%*R;{gC7zmrpC zbI=L_u88(wzx9kUH12G`c`xO0L4 z(g>eS#aHbyg8anoTl`PaG{|>~Cfn=?ia8^FBWIbkO(Qlkh0CK@v?F?ydHew05}aw= zW8R+(W}III&Os~w$AKgM4geed4}#xmv4=2Y?K6v=J zvgUT%?f6=8u95^R&!*LqusUc@ws5QB4juGG0-lS=gK5R1I0Pj0&U^ujY1M(A8l@ZF z+Gcx=3KQL`$-k9=&>++#*)&4S08Ms5b4&(kas+E$_S8sMRJxNf5N`}s67!MR_Z$?N zz%GM8K`M*_f|P{1&r%u%-Cr0$W+!Me53TZMoPxU1L7l0CD_$bTE5cFV$~^T~cgAj# zz7pZ9v}y_{Awa+^WNsV!qG($n%vZn-m`w z_;d9_i6w~R>%benjw@s1B3=Fv8a*!K282mRQii4@#Pq>OCBP|!oe39Pr}roPhy8(q zQe&hx*ET=7i=#^Y3sWebJ^x0$)d-NW+>1WXT~vto;7*g1NLV&AOTdscAkk{?i;EC& z^gG9lrKcP4bbx>W*?CUoWK|A+C9C0#iAWaz&w*{D=Gkd=3Ge`MchWiCJ=7VT^Qgd4 z+Suz%2i<~g7*1kM#M69?TqfqWaCg)d&wXKpbSmtrn(L$f7|Hy=ktfZrrkv4rkR{mp zSpK)U)xrNi?rh3;k2_nP2l9VD-F)<@c&W=#xGw!iFoNq^z{a8n#bUba%#ObdprbId6w&Jf5qZrFbvxhV z7R`{N{Xrkc+$uP)0pMEz;zS}|%!TP7Z37y*l|F23ZXkY2VA^R{_p_H9#mo8D!;Ot% z3IF4-TR7C*=IrdH9eh2KDd%fLN2(R7$#Te;>EDhK1T9YY*G6+;JEv+&B0=hFAXj}s z`1jZ_{d%WZdii=|V@bu6A{xQONbJFaI!2B~h^`oSXB|D8O2%EZ1nNe2#^@CrYE0+I#@EI&8!M*yTQWvv-7gyA#;A-#s&}dmRf5WN#72P_SIwCT z_)4HnCDy+_MiM2XQNToj&*u#LZOSVP=3b$iNo%0ec>=m)B)H&S)+)I)<4=-_kDb-k zVR>)8P;E9P4x92ru9MCl1sd_|iW8Dw@)O!`3MiBhwsvzwbYxipstn8O(=|vD z&~!P_4Ev!fKe{V6^+(N)s{3U#**2S*6oX?w-!5SWao4Qr$~RJXQz2%WJ8Cm!(`IRZ zZ3f!abQm^YX_ailF#KdY-l2*HCC!jTHzBp8805z7h-N9aL)x%={e!_s9IEDGrF^pF z+O<3Q10^!rZMO{)o5Ea9g`H;MClw5^jx$8V&qAPF7fYIK_Vnq~!VYY3Y^>>bIG@mn zLt&Y=;9A{z^Aj9(6pfAQs8Hwdwz316XN+`CPh-T|dB?7)1L zltp!b22Ttkx)5;Hg`-ui+7^&K?N43-k!rz^N@^4T~ua#0$&SS4Mql(Q-G&YOCNstp#p+m zK6IojqKO?~ZY9CqeZwB&KkAShQ9qdOYU)O?G)lPhp@6}^+d)H^LXr7%cVLjn%oWad zn+IWx4eRtp%w~gj@Ehf??84C9%E)^9knUh`CPb01eBg zMzAH5E<`0F55ykDXNZ#n9C0Fy39cCJk0wd4-A~Ax=JSG2?2MCFbB%kk}L(2LX<^MeabF<_?@w%IA);ti+8{r&r6Zx zNf9P@(Bm4HN$JSM_(CA_~bA_}wT`-kx<3@v$2bk{1aJ#;h=E|+p!+ll3)$z9qbGsXv}wxhkcSvtb&Da_@r`>m%^I{opjF7S#CBM zBtO1`&s#P`3>gl5+&)JY0YArKC;Wu-Dg<)K0cbMQdi>*z7$=j81k`sq5-}G%_4@s) zd}(6^{3>!es_Y$bD)V3!Vfedt6vs!UW8OtD`~k`F^F6ptkds6__(>`{Y`uoEP3N;# zE7-EXP?iBH^bE)LwviA_j#K}AMWHH@5qWd>aTxeFhET6zvc9oH)JaB?mQ2u`VFq89 zv)qwgjdO4bsT5Y@j2li&MV@fQyCGxgpgrSXp(7XGuSPqQ1GWQkrXqJtt!_GHEoH5@zV%Y2_#997Qi?Yq`YWT{g<2>K>1qPNO@3$n+beX zQaMM-)>6i2OTH~H1{JhEv`8G;buDoj`m7~XD-c=ig1?0zTj6tYm-SzBE!Z$EH7P_n z(j;f@k3MzEqvbHba+E;calIr`_H21C(9|;2MbpP^3w9TDR?(P>-}B={?Dwk7SNu_Z z7ImDtV-m3O$M^k_i8ipvfn^?{d;I|FAbOhUhwJ2V1TQjI1@xFp2qTI%P$r8LvloND zB_RgqSL_7hSALT+Ni7rs&=KXN&m}z~+NLLn-lDBRIcKzHB@Ad-JjXMBn4=sIaSu?K z%Vobp(+VMVQJa7rf<2&|6qT`CAfcNbPvJ2*VK6r#xvHzE!jP-3YF%tY6r<5GzzVtM zoIw8ai?6gE&alau}WJWd#XLq3lvcvrm69@8zw%sS#Z zY+|BCvNn`{(k+`O@g+rbNrXi07SjrkDmyj=tvS#+G~b>bbI%S6F1=8;YdbtD#xt)$ zi!Pf=!*f+_=T?0D+nWj(TWWnH*yb=ciK=IikL36N=r(SqV6q*;VMgVcM8;$74z-{iJc zLV1!qdSfuV7c#Js%jjw51ET5(yti@REIqAA$OXM3H*`2h0E^VXfm@+8O2I@>iSLM| z0@Iw)WYZCTa-3HgAw;u^F1eVZi>D-+g4q0Mli(~@%V4RijOIfwu*^r7vSJ<9la%`f z2r3~YQj}BOgJ2A>Y@+=)(6ZrX=g3nqKf`XYyNi^~TsToaEScJt7$i%H14icXbAOqdxMa&i zi}R+`=;$^GV%QC*z-IFHmr}sy6lFE}g5+{|l}~K*!~MK9g3#9J1c3T)@pbYBim?U1 zB)h>vmw+}V$>*k51F(897RtIwhy_Z%p zqnyznSbdY(-x8CNgW=p(<6O&6lh|g~9AZzXeCnXi9?v9#;RZKi+2`2=x1`vr=EhP2QzE2~{tmCI%gj&Q*)R+2-#8 zCqjGRU@vb1!omIiku(tou0f=HmBB3x=V_>3yR&=NhAxMSklhX92}(>fJz;dF)&O zs>LGe1~AB!F)#35WDX9P;t~!ES3K$&2ERviujMSQGzra6{3DK!vRenk@gB3IS&(MP zM2QysO^HHgh(X#oy!qEg&pky&Mhl^`X_g`M0)%Ao3@ic+Fe;W?sQLiTjy2`@7C-rZ zXWitJsYN8;B^MlbUKjZi<`aHgGt=}JKU~ebF3DDXQU7JWP*{+_O>{NrQ5Q>)nGv z3p@V$tUFtu4NlfS*;qS-+Xb@FsyM@(O4X*)-skWly5Q9=PajeJNs5+cN0Bv1bdz0t zo^UrmjY_0Vv&^SeM2RF*SIkm!@@e7e<@a~~VBzvhJnueUD99UWS0&|#)8!{^!Z4O> z?v*vjHzL!Bw&QAOv80F98lG;xRr%^0Aam#C$czPc;h#%|QXD5^PQmbWHahiq^ZLEg1;Wg8neViH6%VpJ|=; z)TUZ4BVoA;#3i!KImmxHzWo)qY09JI`ewwkc?#KGa==*9V`Pyo>uNc!y)G`YW>w9i)CLXzhl^wZu zN~^&TaGMfNNkx55MJJ1d3nGeS$=ssEbAocO9~CWjHfR)Px95HOIs2`>dQDqbx!lk# zN(okn7F*8)VxDS6*1$z9{XW<~qnko9I+AN)%pDM#vfH<|hmmAI1mzcV0yy>SAi>$1Y~djc#xObc7}7TCc|;$ z{)~{61EeG3)1W3;4LAQ{LyHpVB)nyfbHPHO^c;~dC(ak4Eh>Wmcz45Oc*1mw^DlX4 z3r$jHeE?)=s|aRE7zK(fPF2BtrF5S}KRx#_)+B&6)Y$+~jMTH^Q5Ww?a3TUeJcN!4 zK@dX%zOtqJ`RQWO&MFnmZDwlnDxPJf=zvmCJPS8jAY4O`oxMlQBsJot7&S6r^pY8$ zOq{@4@ntp{o_6{k+V8;`Yi4sk5iycq!WDt5W+@=UTevaQ|LNNvM1D()tQ14OGztwOCn85X0$ zUflCjL+OiBqfy^5!gp26G^pyTwiT&y)eGgIr>okRbdRf=o0}paCA2p&7Z*6iqE)9W zvzstulmDuStjKs@n~9+DuQVtc>ueJ%ZaK2wGRvegDqSiZGW{~Ft-u(GujGNSI78yKExrWP%UirX1aR$fg;rdhIy6TPdw~rv6eqQ>EE<#;w>vmkmKSwPFfCqv#vv~E z?F#_C)A~O-B6ni>oamCyssPmuP6TFCcDZKA%p@5bCq;l%*C#vWg>ZN-kb9m&aBzJ^ zBQIvNa6)N4phdHA?T0{;`pykxtMF;O0JJ;@;W|9-v!=#iDp7Ad0y#if=%HNHG&;jg zXQQ!{I$03<8OOEyg9`-YGU?4+72ck(`t$9tM-> zNRvs0vq3}5Y4SEiTYBVIwR*x9AYO~Kb}fzw1vtVUT1A~UeAQT&v!vQgHi}X z=tDQ!OEWxJVON$PMaD2SMCfO%7*HPyWDoJjw}q0}o5E$u#X5 zhfC(NR=hy!2y8Vu{#EQFHNb@AeVhXyk0HC9+GH#!9+R`R#Jnt*7#1RDi2vcw`F!!0 zOq7^sYkn@|H* z6u;Ix)9hj`Qxx;y69R#gLF{2wb-7HTakxPu}t=G^41jd+b|46|RaF&DUAd zpWYAcJ%h~$c9bRqI}=HJ;=>e2*=14)#Iv{&>0q^bIC6$TX@@;2?vkjWpO8W#B2k-V zYnA85yqG9}8uwnz0VOO9TzRf=s)EJU2$LHujTn2hTxpRb^ZR&=Rs315-dm6I!daV8#cs>{tg{CdJu@RT@+X93$DNyMz5*vP&~X zA9xqHz%t?o7gyrn03psB=$d43i)taZujp7oC0)1^l{FUG4vD(RBTe}ZLF!B6qs;$f zhbPD-=Pk*C5zLk|Z!ZU_f%tyZ;1OpFzcuj8opPb0MCRhlLbzrLhA?4EhVqV9#Vr+F z@fm!?v~DE~Pl-K5<2>{tlp#a$9a9E0Aj1-wTu%)1($!X3?IEs^p1~y#Iuj1S(JQA{ zB)EwiMh0s#^8XZT*a?0be?b6B*?tig1tu;C&v(_mQ_`NWIXf=$Q7@aV0wQrdR}ZEg zVI2J>jv}JkV(dk+TVN3QzHGNKk)NF(P&16b=G=Nw98dErAc+CZX-7$;KvThsZ1hO` zL5>O-k|Dabl%Q50>P6aEb+CD$JV?A)dp+wQQvv?r>xqPYs!9a4QKz$D+WE+*#jzt& z2-N;?KE-8watTp3*t^71=vc+HEji0Mmxm1`{TE$Hq~-)T5lxM<%J0nN>ai{(?xfxi z4j$eS%%-$xfYH+luJiDeD$&|;O_NkQJHb6CGgN~V#SA58_pttsU@8h((6tmTyD#Ss5szMQ5HMs4RsgE)t<8EK_@}f;r z?G-IjDAzY^pPbsYFAcmLmWu$IsvEvzCfjjlSk|@GEjeo@^Y;x)B0_|HoLx}vOpGh# zd3`_7lJ8Pv@C{Zu7ey>7>4$tUJn^N-qKuWkqRglWu^T}4E+9%Ek?tz+G!|kh41axO z=xDkaKq*i8vak6D?@h5}`!l)*>qKtDYQ7eyQykVXURu}{ zm!pYcBVvFBVWSMrLourJ+m&~oLWFW$yohLKSWhZY45Qdcb#*U8h!8IPkP#@AZXj%7 z7T~6VL&&f3oHuCp`zIOkbwjZ#hM3sO{%|~=tgtrr%4%`1*nG6Hx?236KjDTW1NbLF zbNIf(+-zJ$fKK%(?)SpB7esSq%8~Z$rb2Um$;x!th!md@q&S!n`YvPHU*Ya{$$|<8h|wM{c^xg} zY@u0Pwu>w6X_mV6v%o6gD#@)U)C|3@>7>D>K?WgeK$PBhU^fYI+>0hVtHv<4Ceuk5 z6)of^ic_g2Dy|64l>m0R<9^qH9|`Ej@3``qy-~8do{VH!)#O=_>D}5Z9IDP-sZ;!R z)N2QipFr4P8B2PqRe`{*_edJ)ia+Zd3@ib_;Sdokst&v2CMSI}r?uuaH*4{YpO^Hc7fy@sRjC1 z{16S7TYTa?1J2=;q#{kMlO4 zE}`JPbJ=rM0Wv-3)kPqC$UU%>{Fi)(IY`7ua4h(0R(`@ssNA?4?BnFsyt`ZyM3-=^ zrWH`|#&yg%Mh}@KBg?!XwXRYCPr`^pYMhT%QExm>anUP9=OtV1n3-r7uJp(}VH;KWTFA2+=v zE}T+9GB)R@4)gq8vCrT5X|QMP-3!8Se9GcWZf&k+b*kij{Ih7JMjXmWF2s>q9S z=wV~=n2!KJ;pWZtflh(-(%CnDrn3cZ%SzcbXjDg?i z8~qw9`Wx;8L3&^A_RSYtTt!u}9VWjc(~%c(<{AWx1Qa?~+1a5mL~NnKNTJOoPEENg zH26DRdNI>e^M5V$#~mK^`w}z z8CGT|Kpr8+Gcu2PB@)zyLD(7!Z`#^VLnER?YpA|(ykWmZvM`p(Vbxs~J@r<5J}G93 zg+a$@ZQgH05Ah=0We(wNVJ&?B!s38?gYK*X6}!wVXg5;QRUZxMWDsbpLL-gK)O!lH zXMHHJoPCRz5g=)&sdMGnap&it{N&{p_)Udm{F0vv@{*1N4cPD^`%6THg0R8`s7D@H zd)1*yZf&_6maAJPTtdVCJ`R?wFKEFipTFvVYS-&H9V7_;;ourGAZs5chqVs_XjnlA zA8VdNq+GO`=isx8^{_sWrB(B4x*7V2!9Bpq;38zCVoJ$v$!5o1rqI(9t;fFe5ecev zv@EyWyTpz|r^iScmb78by+tqDA5(|W%XHkrjp{Y;qcAQ_8>x)Y>G7r?rrHi+vCohj zz+59(nR3-~xcODN&>Y=9JO0c<{7qhq+YH7PN^{0tK)%e#!PhSl96FaoII?}tO<{0z zXgT>A!ay%pzMy$4N7e!v{Ds{X8UTv}gw7M`bj8f4M0sQ`IB1PN2|x*?d4ENKg|f?A0L352zH z0Amk-(L&O-Ks1O?ZhtWz1Wj1hA|x&wCP3N<@e%e0-VL-?JcEC8FrChkm?U9k%aqIryodM{YR4TeCwE#+roHhy0! zDamu#!?n4h20;7cO;nMm$XD0VTAS$Ojdj)Ju!m6m3I74f??6XQmE(MWFW)vr`14tF z=2bE#e8j#XT2P#Z5^ItB)gHp%!Otjk==3-dG>zVEzei zd{I$=EOrSunf-=5jVT0>>I2Y$>s8?lv^oV_yS($-HuA&{G85FM0UN zttSZaA=Z~Hh~#&byN%-i6upbg|goqD{!Rus?nC4JNGK<$9=2Xc{wGOc){ zWh0WJ(aG!FZ0^$_lTb-b*~UOH40-IwR}`8TED(nOBR2-JrkC`vr}?2H+*uEB&EYLO zC*Q_l3Gnd^JgT@ACAvb%jwo^!m#k2(h$ggT#~EefCk1Vn~K8fi{xxu4Ab)bzt3x(2lHSu=KB)GMve z;}+qxVlT2R+POMXi*qTGb`MK1*mPHCc3*ZBw{$Q4B(eCR|9oeEJDZWLXpVG*UO#;* zvuWDgn(`L|_Xfi>H=8RucrS`I6g%Vr(xJgB(jz)8{}nvmdSAeA=R+0-vw8+`8Ed^$rbu#H z-T_@<``V=wqRNQRg`vz$n;eCGN;h^t|FUDX5-CIDTGI+~EE)s%w&z*DGN}?N&>Poo z8blG26!EX^3yvHKHC5M-TuX`L7OkhT`Gzc`G>~c=x*b1?12iUbPuRB#mM_Ck0&S#%^CBz#@#9F1gd3pnQ;i* zQp;c;rn(V@(8C0i_%rUc(oUN}wbV@+?u%v^3*RPdl+6Ve0h_0J-q7t#w(w6wlEq6= z1^$q*<36(B@ogG19eIWdIC}rk5IammhD`lLl&b6C83oz9tl_M#g(|B}43`-g4hnxt zJWvb=ih@YqqAivQDn+ZFtUc^#jvIN<>&|I7iRY(zOT!cp9<|AJbgg?fD5D z4*fD__1kb8u%I8_=orWEI7x1?5~iat($lBuOj(BCSkx47&cHkgc4saN#iIm>YRh!> zt7YJaSk2f0qW3n6&C>0c%wf@R=FHS64ei@Y>})eu16R(z1O&yw+YE1Rvve|1XnXgH z3JM%Tuiu7ZeEMevYOEBw`jufuJRT}*wMvc zl!^A$ktB)Q5{=1b1vTU{BQs|h+q=|VmPRQP3$sdEy=qTOOV}cvv-wqIX=!D`WEJbN z^aMU+*1cLS;svmpaQ@5SWYvPN<7l8)7i~8fQs0t4kSd^lRiyee_67bveqnfom(8Q5 z^;QCUb0vg^PX;5X9Wpm`h28Ex?+3-p$Q&4->P;OK_qaP;t53_daYhMvY$<Oq7Yq5tzC1QX-794-dqA?_cpz>|J=z$%2wy=*U|qdXDOP@Ie2RQRod1uopy zI$^gD|BkN~8o{80vyeDvEyLP3uhHJ!oEaITL)SOlv zB2j|;HfersQfrs4?GR^}iZEiFpzZQF29{mrGUld_&(eDWH2X!E=X8Kt6|Q;7VNTew zOPz*WH<(036AdR8zoSiE|LAeu@nnr>vjvi^CAfp>s1|w|= z-vNJ|kYpC8HNO;xi}K^%@__ zrcKF?T@7_HWN4Cvg@g#IeuBCD6p2c9H=kP#C4rWRfVh!{V?LbQpzKo#%V|5ZSi-cW zmI0*7=716AOu8jCK?4U0L_-{PX*Sm#Lq@BNq%2nw1lJ+}!-O64a*!RMgqW8vO6x96 z7qh!teA(acP}SrWao)|w+GY{;BXj!2HIK)kkIF+iJuJ2waqnX9&E6+Zrp^??NP}v$aL9Fo_&59Y7tX zIV4K^{;(6PCvd7N@5CB2A5ENyEj~U>&4@Reqk!xc18y=;dC}x0<|=mpq!Z@U;-mw5 z_*%5Pr7kSy0e@JkXuBbvy_N7KJ2CT%zg{)*2TI)r20H2YaPmAsN&bw|-pgG>tr$-k za@iv6PT$ai)op<8KufWM!HR1xThOd0yoLwD8UsqJRFIavw`96)ANEc$?Qlx|zKak0twHg3sg5 z9xaFX3xdT=aQ+m2q0{EXpYN-!TW*&rcKoU4=^!fKIzl zkqy6yVcT3IU=pwK2^&GDwd&3iN^NK^aQR9t5P4I@Fa6+upTkPWg@?kNsMCuY%&c_Y z$ut58ppwl<1d&*8$=k|j3F_IeIuzn>Zr$m4!qzwmx!WX5rJ~Bt9(r&o;-JdPnCJ!i1z7}*eypyEO4=uAB-xzU+67W z$SACTDpeZrG#3^+0qOP9ZoeA!@GjpDlO#mqwZDt#!vmx@2AhChdOa%m@c6^jKG`YG z*Y25f?d9~IITP?3+O6F~@|QUSNF1uMk^US^sQ&h2Rfox@#F2C?6V?W0Wg%)q{(B`7 zpKF1%=jP>0EVc?kwAYF_jDzvF#onx^&+gL7gwu#`}aPD8d?l9~zV~R3Q#?H%2EbbbyP0k|=5!di-)K0rDb@Pf6Mh!!C z&(tK+fys*3WRJ^eRVGiu7}4h(NW~~;DKSmR%CFM*EG}vZCdN^o3w>i>(FOe_X6m>p z!D?7AXjwK+FUF(>Ev+sEIK`4r$|vfay=2r=iy~SP_O;JHu}~ak*(sbuW^>7@nnEJb zC%v-QmxL>*Z_7-&lIsu2B+ws>k~)FsnOw8Atqw>>7k^&9jB||1%2GVYwp!i;*_8nT2a675qufLo*+$^lcE>S@>L+3V!mF&L^KiJ9Y$6#XkHp{47V zZFVk&dZ~fnnEH<)Z660Xa9Uts9IH<2o8ntl8hz%q+cU+3b($MYeqO%$NsLSIp4^uj zO{HKchaG;|$>qk4jb+yP0OXA`N+ifq;p!#5G@63 zRw$(yh(vA-)}lT_;1E{LOs;5zXO2e}9HEc-Vmn;L({bw z4@Q&cJAn}FMhT0Hj96z9NyFxIPOPeZSXBsEiBSMVvobfrQ02Yi!~G9KuNV0MCBo(Q z;`JVHo|6+oen1ZiSvk615JYK?7C>zm`0=#6FN3T!k5=RQOni3~ z6UfbjBiaZkr?MKSW?Xmj3a8_8=gAAiIMb=ocbhvf22IFM9&e2#Lgj?a)lYam6pT1nh)wGidq@q$Z zVqAr&{#&wiA+KO!cN26XHN3i8ocmYUkT51x5I5nHg_Z;iVsUXJh6X-5*oCel2xQaH zk4xaV0a^)U_zS&}E@$6dh6t?HsGZONnq0bJ>HyQ3w1j8}ektHJ0c2=*mXc!J5+VS& z7Y+)-r#Ob}99%qQ#d@YGpuNwLukgeEWoCmBRk6Sod}b=V$(-g8Zq>`46NRM~RC_`m zHoH`U@wZxdaf*6vfSnXPr??EP3fNZwMPVnp@HsB73DjQVH8%Pe2VA-+Bl0q2)h@9H z1?T)&t_ZjAhGiuJEBT{n7ydbbMMRRLP&a*3TpFzX6+BhYGUXl-XshlBVLHF+t`?_Z zN#_y!ixy4Is!@^rg*sN?=7yGIi|zbQ_l!@fM}@Wuf)VvQu2VT?|tg@P%71Aiup1Rx{_<8Po0mXI{m_-)O> zr5(`=6<8hD zied}2)qqzxmr-H?jeu2gwMYrjaMc^CaEnu$<5D(qbwI?$!o;kR}yOK@AZ+tr?lED4g1_+JTh_s#7szgEz z^3FxXf#IZ8Oi)EKprM3BqK!zNVBI@Fq61>QZ zgAphW*r-LIrU+*T@60dab|80pn4ZR4u~&2YrDqXA+)u}duu=Y-rq}WKRdia{g}{-j zI*C9FAKei-Jsi(*v*uw3a*~K;)F3fIQR`a{(_q1?psPk^a>Z89LW$L zoqfcEo4Dgu6eczbY=i1-Sq9WCO5T|10I$C+x@F1-wRiB|4EOZ{d9fh$3Kx{ityL9V zDm7vo5hkRPgccIj2+bpJVqv?4Bin$wRt+Z*PZq5Z52IQ*6GF+m!#M*-(FMMC-j@wp zuR!D&;>IH*iO06xj@;qp`wr_?Ga01pAe5*FFV`S!iJs%kOyZImIiwDS z{`Qb)tk)EZ?}ea#Bv&`_Hwn1F^}={VQ%jZlkOP1xt~rDZ-D!OF{g=MY+ccRARI7Nq z3L#$1k_sU@pt(w%_##Gw$2#5uMMbsUe(}|J&v!fX*%;B(IO=P*+u;w5c1ym{qkUDl zIZ`kceW={qTD<~FhYSO7w0!(O0OxgZ1$DGx3V<9=E<4GwsMMtkta6c!PoWA38kS=e zQmMi@txGxlg4$x7W8LVw2iuSju<2QWr*NN5xOpJ@6r-W(eP}r%rIli=qO;bW4?nfi z`&K`;9@n;Is60;xab!nUE>LmJ3ze=XD2zD1P$SB6Sf(wKrN=iz7#n zq}lNE)39*u(04f=mqYwIzWhX(Q7GG#r>e5@vYmq8LD`0s3Kes0dCNv-zII>np2m^o zf&}|N!wqvn^tghZlO~}P$LaBzeYJC^0oSa2@bi*&p5wCyj~L40V{-3h;$q5dRM`Dc z4wi6Zw)iSl;uA&c3IHhV(TtMoQRn(tXV(?1^UDldP}6$-*KWv{+%*eOPHeKHn_$yJ zQqIe%kh*LEfFw5MB+xuO8;xM2AcLk8V)UiU7*+PIH9yuf^ESMVSFx+kM}b>=G(Ng0 zQqD^xgNd4+JFVjs-wvK+dqw-+9F`e(5Ga+2juASAY_l8gxsTa)&!+({sE*>MPdq6$ zzub>fg+S9C$1vN^^3YQ<47t-U=gjS5av~ z3Tw=cv!GyKFUfWpHaK$Bbi{aKq?kf%pimWl!$#>M#5NcoBIx7#9C7losmYp)by~^R z>2#eHg?2>^o2<=VTW)%`1CVwOhs<^H@RxR-O)81f$MmGzq$I3t&X}5BTHi%dBOyfG z3GRl)W^N~2qF~bK(~^0!@i+`|jX?i&T7q6MI=t)zOu*4n(8Lq}+|gZ|FXg`W+}mSl z71maHe#z$eg)%QfDoc7BEN*ImM#E@YxlZ^7E}q4&0M<)39L7(Sp?$inu`8NK1Qz1i&NnIJAt)&lLXnAdJ0kzN zqA0mH(PJMZf}Do>v5L^n%L(vp&{|fBj5I_Fy1oao7mHZPC>G&TCzbF@wN{1n%HH{3 zQb|C!pQtZt8%!KB2vp(OP>pA;%7;NClwN$8`v zUk|n&Nt76Oy5IOJCc;qrmU)4!CSm;}bvbl*fec)45pc|`FDqGrqjsA?7sn`EFE7;j^&*t zx%knZDW|P!CrP$y=w9Cm#+sQQs9eS(0PsNq5@{>3QpcTxL06!yN!n>ufurADWi}CU z>D$tjrBHBs1<0U$-@9){1byxfswl$Tq_Tq zFI3A(6ah#miFy^9RBwdv;73Khg%HUfJKOQCb9fKfPsJJ{wcQuur63gFK@;VB{76$- z3wG@`)`=~{N?W#Xn79qv0}8xQ`w4FqE97QXJYdG*oI~zPg+9V13oYTb96F&`0ncN3 zq&dZrP^1zE;YVPa=(c4=d?ILE%?9Nf`V}nbYx=Ki3KHED+sc^YCyn3n{ivk!^^4G5 z1+jb_vY|Dgk-8<~g}w~QhvnLy-z_FkpOel=)=4RdbBKnWZ3IX~BA zXKido^kr-fP;zMbW^QhJU$v;?!v>1l4fkk2V4=cU1a7H{E}{Xfp}Z2v;e9vAaNsPS zQE9%2uu)Avtxpk8L^bSbr4zy5Lh{r|H$)0M0RHpZ#NrFrAsE};kZ9hut;>3OR7*I% zSx-DZiK`(0OTSOHmAluFGz}zg;U)!zF|Kuwji&-(2N>o$0gu42Vpz1uN9qvVW@8|X z7#rZ7pt&bT8TZjR2=Q*n;Y><#==#Jw9g)K3E)4JGp~wD`rm6*-Uo#&Pjk)qsLK>Bch@k)l3|YH~k#QChvJZ=!rI%>b0%gIyh#CMi zrBI`mnU3ZDv!e<^$xowrHbi`TOYjc$UoJzV{mOs|*@Q7Tv@LqU-0Xt=z#4mU@)^l; z9b`SvPG`~yC&-KRwLouWnNkTQC7BpG;dww=220ipPhMK?&&!z-egwsd$H`TO(3gd8 zbxa9PI6_c&)QQd4crQEdj&`~$pK}L#u^b!AzlrTd_B;ge`_57%nBgn;Xe@QCz%1 z-;t!=bNEL4HPG2L?z=ihlzkK|@}=2G*w*!hu&mHhUWf@sq|RMG@)An}2}orbk(mcp zhoCJSv2LCPI&n4DmWP}kPK5$S>*_2*MEZWQlGr!+BKa$+Az3TVWLA=Fm3xLRaWn0M z)|nL3K5}2veodcA!9lJGeN9~rdM!C4ULpupAL1XN=IQ1S^{LM&JDM$Uo0Y8JWF@m>FWjtqQ&QcT4`l+~@d>UI zVp3n&Nm4%+g6j7nV2GOwUm1RWfyEJ~cOk!F^yo5j)!ym|nQW4)pb(n6gy4X5X^{%n z1lPsuZ{8ok2yy=6-tRW*rKCPLV(9k?UmLC4>zzqlaV zbQoV_fm)Yz83T4bHWO}2;(sk_g3tm2I`bhgs}vQ&uzor3)h>eKRLPWIQ=1luyW&>j zl2KWE+bl^069KM%ly$S{V;(oBl#KSG%myxI2p}Z)6c$`ce8`ik99}TX#xHq-;&m{C zcN`-G`i-%|m#>Q%wynd?l4j^{wIo_w)*}mcX^b=Z+JZ0O#arQqE%4|<%=LNH&>H#Rn(MNe0xBwsPUwK7RE3)5~EknP8>o_+b?2cJ>P2g?w)zKw3Y?w8#X32Iw^=+IcC`5s ztEc8YOL_5ev8){~v;LgLw8P)1sWtQ_A=rxx_{>p93?cG4Wmdwn2fz*r*2ePNTa z^3P`lzGWt*%9drtE|OBD*6%Xn?*^mp0InP_hwRuEu{E9bQ~G&v=qj-X)Q z8Z#2kLIC_doloyxWe!9hiz{(OGRIHE7r!_ipbj{Y?GHXHUT*)_`u8tOWlp%f><0C1 zs3u5#m?3z6CvKnwUwEz*(ALzquqJTqb(Sd$K4bO`z@ZND2zIi4@dft!? zW3keeD6xq+_*WQgy&xTcUL%S6%wWD8UR@RoU{yFP zFy@uT5$O)!CE1Ltm$CJipr>xQBxZpJ5I1}~vT5U+5$^wGIi4XgWmz;LrA}~=Da)S3 zF`ohw!7v)oW)UOYcsQt4GPN^}QCTm~>(uBd@dXotLU~JN<$XRoK zz!!@OzQePmPdA1|I$RH{5bBAov6Emj0Xsx^$@0ry5JssB>w_G40SCaB@E}XFDY;hG zA3bDt9E2>8{^->TGcod__8z~RJlBCFGHFpaSM-9%*XrcUZ+^TKn(v;o#WlM6@!3y* z+Wq>6Z@>Ji)S>J&$DJ;ckjB$^)L5Ez`g$^2q84n^$lz7A{=j^mc=n6!I&qCQw!{E zxF3h*qcla)-U+=R;7;@$=6zxX$-En^gb3AZ3atfU2}k|Os6X@=7=#KB_PX(}P|-=k z;k^66{REqSV+a=n`U;}Ka6T4M3`BvO9r}NRnd&%E~+xrFuC(#2RcOmk{FgdvzbRKNoOaH$2 z@#95(4qku!xWsN865sAVeprHo9G_1Q3C_Kr2EX7gCtPdzFf~coNu&6w-!DAf;?vEi z1<)(|9UMtw&IQY#&Hdxk%|PSBIOF)+$w@bv>C$tC>Z43UL?~bM9#8o6qz;8koyqaS z*YK;BgkAEpn9Do6sdYKdh7GeMG$r?10n?4(hAf$a(jJUElLEe5y7L0u!FU}_?k z2Z>d*ToB~eDIP!E8|cQum-)fHwus4P!~oKvJ2-b2VGZ6wN^GZiu!Z)v>ty2!VmJo* zR_I)&*qfm4T0BaqBgW!y9i-^T)z4PmU0LSw*-gQ_4pk#8hbOIh9W=6f4o~Je5edsp zI5o_Ri!h4vH<=dSxz5zsE>180HlFTp)?i)ciCamN1rXn{INU|A(GpFPAe++HE)q;} zD+$5iCw7)>2&O(RHP879FHQl2USz)VlGf%cM*6+3+J<~wTz|+RpvWEHXF|Uuaag*( z`m7sj$01NDDt^%K*5KOUNlgzaidg5D>2?ZJjfQuhyo)8SVZpe@9vL?9E4fz515wSv zw;n8ZMiw|FgF|j{(4s3kBBH58EMKWCA}Is@7SVhoZLBc<`G2o$|95NW_p2@Y*+fbL zUT8hFt@LDG)d-;r3c2GtwymbbEEt0~L7)HkBXpW+o8#$!YSqfsVha^EUgy%zSY5_I z8LQIM%NQuQGAkNM_R0HBRv!bG<;PYv{h_g#8?mYY3K#RBjaCdJ$SK4jNSV80bUCE~~0fFms-+PTkDPphZC^zVT@N zvD#vfi~aco{owFdOtY=Ezb1AMp(O=h!FepFw{ZdR5fr^RpqJc<#ZlnNVZGe7VjW$J zTZX?peweFyjpA!DFIjj5bvzivj%j5K7&NWYo28k-J%q~{QN_hOS%x@8Z4|gq?iakf zi5>F>736UBVUZ*03|YeWOT9=56fbmiD*Yij4Zd(3s(9M57;kIEGoW0Y)Cd49^&$nL zV1wK*jt3{x`%=5On4V4HWfmv1XvLDn3RU&ed>&sBh)0dOIk>i&ku~TFzkxW00 z42Uk^S%o)YpGApyp5VIy6}}QUp3tz*3+_tKUi|Ro5AB5CNK5pHGDmPetPCD}42D)c z8*y)IYpdK|N?oYK5W~XHPe;Gh&e5u3!W!;>zyYun)R|#14a_=|MIKPcmMRmPcL@A`^&d4zIpcJ7k{d}d%*=YI6Hm0~uUjY@SJRio zU&kGv-S7j~mqTYVULD|c?6GhqPN$IZ#WOcKO#mb2OPhVvfWu2Hsz7Al#2tfud|V<% zeZQsE%trql=+{;JuS|e?dx03Xt-mFyvR2;ZbA4sYi19xAC=fG`!m&%TFqD4v+L_R3Douy zlyB(^Pf!@Z4~iwwe!K@Y8@dNX?y{Q)I0Uw|cx{#fsqLNAc;Y5*t3!y`1=QJ*;0nm9%uxM zrtkA=9a){QlAm{QC-SiP34YA|eHdwUg)jd_YB6=BV78njiJyu*_8m(44ExK);cRx& zUSB^Q91WN+fMkL7O>8Njpr*jD@DWyP6x&=EyOHceiQU^z|j)&}O z-648L-vSgN)JPa0lo9o`m(fJ3{6#ElDcDYrJE!idT_{OBb`JK2O^^`ER3xH9V=<0# z0pOI8dg^n4e1IiA=}4_qC_Lg(i05l5CeH(AY^KaBmXWx+IZr{$d48{G2&uFpuNcr` zLls)+W2jF$#8EPIb3AlOCG*Agq;hu6N!$gut`L)2XAyGEQpKnn3Np|b;#;f`8vM+hTDv!IO$=BpK-YwIlq3b^z zf_<5Z`wAsDnQ~8rlE;m~W$xLuh0SqoXVE#p0WNMo!xrSDw%gxvK@|B5*qwM<)baj4f!&r0 z#iZVjzVGG~5=&VdbO|KUeT?%(+KRqs_oZSw%q0L$*n{+KfxWwFpmd*uYp5 zR|7_P`1N{lJU`~S{Nsmz)^_3~mQJ~@fGo_k__TQZ=+UE3!saE*h#OeHe}p@6`DZ3j zvghVfwXRyBE9C-RYmNQk9FdO!aeBG0QVV0~B!!wwO?j4J(9ll;ro1Us41i$S&34E8 zyTqhxn%Iv()0eLwZM=N_aPQ^ojYs&82e|CUIDoyf0DOGe9K_j|zsKYNrumA?T=Uac za6L7%7gpTQoPOI9WMAy8MhN?(1D5I)fWkb1b0RA5Qcy%_F+)z2Nd>!Ln8LE!1s&4J zWC3(jaB8_VB3!XaQ^Of|QQFYi47DftH!80kjrLfHf`4%cjKD8fivjY43ci@EY`=`|5jb2!1B^;`bQ0AX!qWp3r)b^1* zxsl73rV-s0_9^$Tgn>`xoQrQzY(T+p4vJ4p{o-3hm?PfT^?%}@Z*=DfXBf?Rk00(F zN;V)i;D?R)&`PDpjs_v;nNAFS2aE8R)=!4`kv;*~d)_2pL)4r4wYbY?RMiPtO0NYGzw zdFv8mpSrmiFn9l0Jb3WSvtSiphHzOw1vV;ADb0EuyODV>Vl6~xLzcsYLL!(7 zY@jXDj4dnMCcoq-?INkiz(=}e=D)EyFJ)NFN983T*fgZM^cDOGW$~M%1PQqTiE&?c zk(KiA?;md27D(W3Ci-5l7!aw@3*$Dxt%LnD)ppo+4cBo7j1crQS1R>OnQ(_4fz6Q^?Xikzjwvm5R~!I3kLzxUxKS@)Y`%-hJa z)2cml*MJM8kBBk3%i`q+ztzVLam7PxYwh9M)_UWYcM8tt#>V4^4?ie2K2QeopIe)o z_DxZ2ZajRl@nCD~!RF%+HaDI;Msu`(44S~;GS+*T&P|8-=SZLZ-JSpUrhwnJ zeDl-H@zqc7WB_!sX#HLlK791S=H{b^k8juiyF&k^ z{cLS)J^Gz&zAcytav5DQ?!wS6v`h!e5fmGUGvQTRh+7J!t#R1&$?xv`?#|Z6=0

    ;-T0W@ZazZw@6Lp8;QRll z720mDZLU3#Z~U-9PFCoIhxZE^YJLj7?HGIzWd zN_3*Ej!zR_IYPgcqTS}$Zp&3gh^3PlFrE-BEB07upC#esKFScK#46`WVa1LGWbG>kCse2avHs-IqpJQFgg_ExG_nD>F@6Rr@Hmp1+77BvOhAsblNU(A^7j^TtVyG$NyRw zsFnXz+TP(bZY=*dA3UJ_e=GmrArTgIRZIU$b*Tj}U-Rol@}G7d$Sj}DttSt+9zEH5 z{AdI6{}KMZmH*d7?^`v?@3DrWD|ak$D=1cEYhm{Q1tt zyZQeA1pfHj{r{a2;F6B&>5n2%i2Cba^4?7z-I)G32D+vHO)&iCZR_bj?v3At;cs9q z(*IP;H~sJ7!;Q_y@cwLVeXzN;_3**1{`clYy}_Fri*E{vgqa}kx66QEc)MpPkisK{CT6oCI1(E_*j-}_-nWGKLBJC}U3 zb3MypkdrPVv8gmVKc0VOi5xrnisVn&;gpq)a>j}WfcJO;xMb1(lIUZl%{h$JNsebp zjlc24Y>vB_aG0lwQV7sQ*%nl+!(d1%m-`)I-9ZL)YEB!)T!IWS_L5k*L!(rUTSW$5MY^nmC_?8t20{or($?0QG88-K+#1G$ptn^1;6w>n-l~K}t5NRA z4+GiYJHOvVh%4AD??e*j;#WpR`%y}x<2@kcZ6w;MH$@m4-!QsY`yfmskY48x4n~ax z#4$Rp?Isbvw}T3?1`F|dcTuLDY6+5O7r~4R@ zpa=+p8l(Y*-S6&P0M0<5hIZSq3|cAhHbu(g1U?q6KJKbX>`=Tzzyg&Rs3nRy6FCiJ z?sktlxH{ROp|eNoj?kIHA`DEQ?6Qa)*brWx?Kx^QP`aTs7;$Z{T^J@&a)+5FC|t#( za1N=%iP%8KLh0>D#n{2utO0T9TcfGBHf)#_BEC!pIi5bXy8X!`e@9d8xQeEgm#WYF zEp8L_@06c_a<{78J5vsPo7UA>bN;_xDhm7tBQMhbkPt>QPd=M!|7|_kdIJ6Lfdq!# zp8vi9vTyjxt^OzbeXZK2vWe_Ti44&Rp?s_VU8Vo2p0cZo88){>Z!+BonvtSb&?@TE zF3P4cqdh1$rbWeeLDl%zR4Z-j5iM70l>UZb=2n~3q^X-}lR?dmYNgb;@f(Avu3oHD z!B|gj7^dr+r=6if{SGe#-5no^Spw?=H7MpdqC=>oSeb}7#PJ_{;koBpVswf<5m=h~ z`c8p-ub_46))({2hH5&pVcBwEQ{AIsGGVCVrgK^@*z`=a`L*uBAo0w6505_FG+l3Ae9b1ktfoo{q z(7W{l9+t|p^eJ-(`T;d)D81{6wH0eisKXf&g0z;~bay&GVcro1mzbtG#BRs#4|@~T zs0#C{BiHruwBD5djLX<7wC8+a0-LjwHLK?+Hs_}f!$|S3>71=SacvPs1k5U23CFOP z(w{lh3%XuB3rPvX-9%FB!thhoX!}lGMO4XNvN9q8aJ0)p9LK+?nJotSp*Nr zKd;ZC*8ZnBSl^%Y`+L(~OK#Y>p;ehTzw!D1gU63}FmxOLnd9--`0Hx=v%K@$jeK+Z zKYF-zOaHe+`ZeEPOn)ms3}a+#?ZIYCYvNwB*Sy({>HqMtM!IQn<~c{Tmteh0X@{J*vT-WSg; zrvI(|_r7TGTaI%b`rq1rza@o!-LbEt|8JxJ-P(V@F4bf2i|K!B|3xhQ`~G$n{ePSF ze{27}FOI9Fzs4iHGZ1d9|8L&rf4?*2U(r!L{Vo4{9q}+%ynmg?H>UpsT=aJ9|G5ro z-@47^^nW*nfI$D+`p=u2DE3!zw*Ko|llEF2+_?Ua$IRW9 z|FPR1{*B82c&^%Q;h$@*oqvZ$m&GZws{|}`8*KPdg&1m^1t*=l2HOiZDjrnHoQLl-&_Lx{~K-p55a^n>g3T77!8489|8bSYKln! diff --git a/src/vfs/_vfscommon.vfs/modules/uuid-1.0.7.tm b/src/vfs/_vfscommon.vfs/modules/uuid-1.0.7.tm deleted file mode 100644 index fbd43f3d..00000000 --- a/src/vfs/_vfscommon.vfs/modules/uuid-1.0.7.tm +++ /dev/null @@ -1,245 +0,0 @@ -# uuid.tcl - Copyright (C) 2004 Pat Thoyts -# -# UUIDs are 128 bit values that attempt to be unique in time and space. -# -# Reference: -# http://www.opengroup.org/dce/info/draft-leach-uuids-guids-01.txt -# -# uuid: scheme: -# http://www.globecom.net/ietf/draft/draft-kindel-uuid-uri-00.html -# -# Usage: uuid::uuid generate -# uuid::uuid equal $idA $idB - -package require Tcl 8.5 - -namespace eval uuid { - variable accel - array set accel {critcl 0} - - namespace export uuid - - variable uid - if {![info exists uid]} { - set uid 1 - } - - proc K {a b} {set a} -} - -### -# Optimization -# Caches machine info after the first pass -### - -proc ::uuid::generate_tcl_machinfo {} { - variable machinfo - if {[info exists machinfo]} { - return $machinfo - } - lappend machinfo [clock seconds]; # timestamp - lappend machinfo [clock clicks]; # system incrementing counter - lappend machinfo [info hostname]; # spatial unique id (poor) - lappend machinfo [pid]; # additional entropy - lappend machinfo [array get ::tcl_platform] - - ### - # If we have /dev/urandom just stream 128 bits from that - ### - if {[file exists /dev/urandom]} { - set fin [open /dev/urandom r] - binary scan [read $fin 128] H* machinfo - close $fin - } elseif {[catch {package require nettool}]} { - # More spatial information -- better than hostname. - # bug 1150714: opening a server socket may raise a warning messagebox - # with WinXP firewall, using ipconfig will return all IP addresses - # including ipv6 ones if available. ipconfig is OK on win98+ - if {[string equal $::tcl_platform(platform) "windows"]} { - catch {exec ipconfig} config - lappend machinfo $config - } else { - catch { - set s [socket -server void -myaddr [info hostname] 0] - K [fconfigure $s -sockname] [close $s] - } r - lappend machinfo $r - } - - if {[package provide Tk] != {}} { - lappend machinfo [winfo pointerxy .] - lappend machinfo [winfo id .] - } - } else { - ### - # If the nettool package works on this platform - # use the stream of hardware ids from it - ### - lappend machinfo {*}[::nettool::hwid_list] - } - return $machinfo -} - -# Generates a binary UUID as per the draft spec. We generate a pseudo-random -# type uuid (type 4). See section 3.4 -# -proc ::uuid::generate_tcl {} { - package require md5 2 - variable uid - - set tok [md5::MD5Init] - md5::MD5Update $tok [incr uid]; # package incrementing counter - foreach string [generate_tcl_machinfo] { - md5::MD5Update $tok $string - } - set r [md5::MD5Final $tok] - binary scan $r c* r - - # 3.4: set uuid versioning fields - lset r 8 [expr {([lindex $r 8] & 0x3F) | 0x80}] - lset r 6 [expr {([lindex $r 6] & 0x0F) | 0x40}] - - return [binary format c* $r] -} - -if {[string equal $tcl_platform(platform) "windows"] - && [package provide critcl] != {}} { - namespace eval uuid { - critcl::ccode { - #define WIN32_LEAN_AND_MEAN - #define STRICT - #include - #include - typedef long (__stdcall *LPFNUUIDCREATE)(UUID *); - typedef const unsigned char cu_char; - } - critcl::cproc generate_c {Tcl_Interp* interp} ok { - HRESULT hr = S_OK; - int r = TCL_OK; - UUID uuid = {0}; - HMODULE hLib; - LPFNUUIDCREATE lpfnUuidCreate = NULL; - hLib = LoadLibraryA(("rpcrt4.dll")); - if (hLib) - lpfnUuidCreate = (LPFNUUIDCREATE) - GetProcAddress(hLib, "UuidCreate"); - if (lpfnUuidCreate) { - Tcl_Obj *obj; - lpfnUuidCreate(&uuid); - obj = Tcl_NewByteArrayObj((cu_char *)&uuid, sizeof(uuid)); - Tcl_SetObjResult(interp, obj); - } else { - Tcl_SetResult(interp, "error: failed to create a guid", - TCL_STATIC); - r = TCL_ERROR; - } - return r; - } - } -} - -# Convert a binary uuid into its string representation. -# -proc ::uuid::tostring {uuid} { - binary scan $uuid H* s - foreach {a b} {0 7 8 11 12 15 16 19 20 end} { - append r [string range $s $a $b] - - } - return [string tolower [string trimright $r -]] -} - -# Convert a string representation of a uuid into its binary format. -# -proc ::uuid::fromstring {uuid} { - return [binary format H* [string map {- {}} $uuid]] -} - -# Compare two uuids for equality. -# -proc ::uuid::equal {left right} { - set l [fromstring $left] - set r [fromstring $right] - return [string equal $l $r] -} - -# Call our generate uuid implementation -proc ::uuid::generate {} { - variable accel - if {$accel(critcl)} { - return [generate_c] - } else { - return [generate_tcl] - } -} - -# uuid generate -> string rep of a new uuid -# uuid equal uuid1 uuid2 -# -proc uuid::uuid {cmd args} { - switch -exact -- $cmd { - generate { - if {[llength $args] != 0} { - return -code error "wrong # args:\ - should be \"uuid generate\"" - } - return [tostring [generate]] - } - equal { - if {[llength $args] != 2} { - return -code error "wrong \# args:\ - should be \"uuid equal uuid1 uuid2\"" - } - return [eval [linsert $args 0 equal]] - } - default { - return -code error "bad option \"$cmd\":\ - must be generate or equal" - } - } -} - -# ------------------------------------------------------------------------- - -# LoadAccelerator -- -# -# This package can make use of a number of compiled extensions to -# accelerate the digest computation. This procedure manages the -# use of these extensions within the package. During normal usage -# this should not be called, but the test package manipulates the -# list of enabled accelerators. -# -proc ::uuid::LoadAccelerator {name} { - variable accel - set r 0 - switch -exact -- $name { - critcl { - if {![catch {package require tcllibc}]} { - set r [expr {[info commands ::uuid::generate_c] != {}}] - } - } - default { - return -code error "invalid accelerator package:\ - must be one of [join [array names accel] {, }]" - } - } - set accel($name) $r -} - -# ------------------------------------------------------------------------- - -# Try and load a compiled extension to help. -namespace eval ::uuid { - variable e {} - foreach e {critcl} { - if {[LoadAccelerator $e]} break - } - unset e -} - -package provide uuid 1.0.7 - -# ------------------------------------------------------------------------- -# Local variables: -# mode: tcl -# indent-tabs-mode: nil -# End: diff --git a/src/vfs/_vfscommon.vfs/modules/zipper-0.12.tm b/src/vfs/_vfscommon.vfs/modules/zipper-0.12.tm deleted file mode 100644 index 99b9a9a994c8ccf07ea53f27a3b9b6e5d5f8c0c0..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 9440 zcmcIpdpwlc{~r}C%66f$i6=9KzPYxENr}{wib|488Z*y~VQ%Jm#<*t7H(ey-+OQhZ-{IA&0RA z2$Ri05iuM0N8IQfgu|yXP$41^q5_o1Kp7^;YBWg17NQt}f;r%opNP%D**pZSWn!}t zz7Pp!VpJ*=h4T?EU&O-^u|E_Fh6F%@+Mpc~vKQ*VSEJlr{M@1 zf(vPM9AzM6E}tRbGmHf^dLWI38V937jLqjEOg;yy$How#0Y>AZvJo1FnBZK(m~S>@ zp*&PbgF;0Zo5!L86`^P!g z79ut{m-r%Q5}S#Hd(mk)-5&`joXO)0xik(t3`M-yJSHE(=t8yt_lbl%!wKM9xSRy& zAXF#>uGE*RL3jlh`ALRNkhMITAMhw}Farht+M zkyA!qH4qMHD}yaWB1YV5I9;;%+u%S+d?r{x7va#yK0ZDQ;=t~{ zG#Lx&6rs z0f+lypfEtF`G^=r=rkUX0?Upj5D57KAsb{nCsa-f7^h2;0z>II5^jgs50!*ODswm} zj|Jd>V&{V_Sb&&;i9!??33*6(q8MR@=T zydbRbSOAYWd~ttK3?w)xz9Gs;B1-~W5VbIk+s1ti_}Tfb1`ckv;rVIa4^dHZ*X4gq11 zwj3di#{&Iiu+|bx^chq;-^fQmruZQ9$s!DN2>=YJ5OiD^PX+?TD;Nu-;Ro_NP~nYy zUdaEFa}h;O?;%qe27@W$aHOpr@e1IBUhYNb^FR+pVr_J&>FZFA+VRv z1kI1&2MB2Yz)A*W1+pQbgtsWzLL>u(OJA^^lxLVq97|{tJ}XjQ2_I813(Q9u#=zx} zmB7X$!*DtIkqF8G&K^1g2OA9~NbQmn07EdOg8y6v`SvjYF?2qc3z`^)5cLHq4Pb4A zVLk|86Z-l?r6ZXpWQkzS1D*$o7u_G`A;=#-;s-hppcSA-;cJ3G%7`G9x`OCOC{99M`3IHq)^gatSi#f(-)>K4ZfOM6lArgWV1u*zL z103cHVlar_7y#Ca@(>(QCJ1ciq1=Nnm=NS_)PXp>3DQe~B4_Pf(1e%nH3#dpaKzSfQ;%!q? z;BcsygxLWA2jd{?X&`pEm@f<@c%VFul1nDS7XY~#fDR&oC{WZ(F%gCaKz&nFNxGPV zw3QT&KEh+e;sn1Wf`>{TxIdsTn1GF=h@GpGGQHM3FOmwvM07fef|Ip3z#7PO1|#u6UJaBQ(r=pl`Az0e z*{7UYiy<;Yz!nKuLK=hMYT$G)1og@WNCw~=q?QDN_z3%aPnZO2iGmbfgJEw)KlP zmb#fJ1DJLaUxVZ$ZZ;W+Unn4KJP`=A^!8CefFpy@|sQa)r0AIp~IHoZWFIoP}7`kj{L@_Cc+z8702O0gpZw7Fq0cF=p zA(z4gp!se2467)V@&63Ga0^B79ePx8o)iTYEc!?8lQUahHvCUOf7*gH1K2lkQ}%Yss3qj%brxH9QD&=cKQwE!`0TOyv)s&b^-n(aY~Ov@`gpKt{=cf1-tNmd9?taj zG#b5`q5dZFX6LiESHmhzip6}5iTVOygQm9AIUhtU0R;z)wwr{4y+WV=W2c?S-hy5ewlsAW2DE6ZSf)2 z9cwf{A9!bFZN02ocdkd;&Cz?R9dvtt+~1PiYPO?e4^~e76#T_H_G+46R^pTo7NLU788zFVWLdHA6jPe=;|^JO9;B>F%CF9G zb(#451uoL;8?+@3jq?RPo`Dlh9N=IC+0M`wOsnSQk;t2XE4t6q1OyT_T|zK`;{Ty5Wz zVC~7@-C0l)_^Pfrqh+It882DcvTCQ={jCnYN^J)#-e=#sap7N~Z(}maHVdo_H%%YO zn>0(qE_S_VSj>L(P-9K@fk0-c@6(%;y7#TWb0Q5p+IFXqHS49@6|0~PemRrJPd>A2 zN|Moe4Yh;nvoG&#KAY-nnJDmbTDLsn<5T4=O~)v+yWRcR`*RJS9?xp7yY5x|a1uX0 zT6=_6Zs@N$&ZM>=-i_6^mU}Z#Y@|PTW!&Ap^GR*~j>uKx{(AbQky4j2HbWeCuhU5F zn05YX^R+7`J5R}-XmG;wC#p(l&S^GBV`3uv0gJAwnO-}ml_xe&yJfaL;g1x$|63Lk zT{5k^$oi9`0Y+7Ad2T=rbvAf+<}Qt@yD7;mJ0Kv1-ul-?@#5w#QON174W$>}a@ni% zpB-)^>sacw7@wbhMOk~j)wQ0cR1X2oV@%7qxrNPL3xmVzGDUSJrkR?X}VK zn*{+&+T&)se`s~7(ktAMbw!X6bA_I?CA>BTD-4dQ+*$cM(^24I7uHo3;HMmAJHgLX zck<1&a_7BeT1u@MTA$XmHWXkNE~;$bK~>q?8bmeMX;|F3IKg49&62_o!aZ$F4Mu^1 zSF3{`hck|b#qDlAU9>bzIjEv%_oMpgecL|0Q>mqme>6J#!QHRgfu?b{jW{PaZnRbs zRO}~L{!p8oenD?n&CK3_w=})PS-8Z54BU6ujk*2DPD7h^TXu?yW*t7CcXtm+|aE{ z(PN9A2*eSsDF4<4EANOKFih=qC-S#7#xTDX` zj_`4+uJYciS0Aqxp>1`sBXy!#>UbSgGc)yVbw;KutETzgrn7H-x>Y?y@6LVUz4Nnq z?LM((OIb$w`!g|xI%TP^x}$Sc_BAx_S1)L3HZ5*hmHFA{x!TtgN7~e8m)baqEF;R7 z@w%+;ln4BJ(bUOx{wT}ko`&6@>yF0MIVP+-=54znfFZVgv^&>(!?vCnr-&O1bjr=i zZ^yPBnR|Axu6pF-vFfqps}XkRJvD9LcNI2{y~kHWH${$3{j_%U-T7}4%icF~N)55^Df_K&(t10-4Q0Za(9_H<8 zhW|Ffqnj9is&W0Z3+3mjJ&S9CUoT4vcd84D+Wa^=l6P|I`nX@rHfMjo?#G{_QzG5Y zbIz8YZ1^+Pq5Jx|$MkN|;t#Y=-_a*SKlJTl9CxL6%oxu-Q_^*>yU*?VjkVuLmCW4` zaLdK=(yxU!XPISL`QCV@VEv)frPg0(Sf%`VS7YV17ZsjIobM+*^Pc!9c7(T5muh;T zUbgRUme`GD{NPRbjqrlVs%aTh8Y^p;T1~V0y{NMKT#7;4nRu^{!Ct5DuUyczUHtwc z_D6X~T>RAL1q&j(Yg{x@ugFf@+&JHfPMNp8BS!Z1rc|sKU5?nWBJJg&=S#B>&3lcv z1>9?&FsHZD@JxD1)lu`L(i+=K3kqz+TKs&Moxv}DKG^4|7Np6Fz8b3?b4S6Yg+>rR@m_Z@W$3v{r{bN4K8Ro%;PzFKH7ZTgDqAD)dT$Fx_c zPWY<@zo+#z)M9_l!=|rB*&Tag?(AY!#Hc^GDm+~heP`2|D5b!f@r`k}b7r|4a)TWz zxsln=u=)GzTt0rv{P*gQJrfLc%bGuBzUX9!P3d-Pu{N@ zsv72`1g}w1G1dNa5o6vh``@>JeO6nTtHRrgw^prr;okY(*XA)NR8zEhKWwWv)b1FQ zxJ`F_H19-@@uh;vcPelD7uQF}S~K=qeyBF-SsK0EBGNF@n-;>V7mX*zj=+Iq|pX#Pl=)f91_fpq><2jn;LAf=` z2aK*huHx-0+Tm8MqOIz$9T$2y{RGL}<9b7TyT;mT_OkL?D_1U>cS&jgIh}D=j-0yP zvHFx!`qF|I2{R{Br$=yl|7xu)W0fR-&NuPq=9+2#u=#qBzazuE!T$RFU)|MeI>-)9 zxmdoirszWgCQ>pFtu{Pt)uQw2)(n@i)`v3mUt5K6IC`!7pHy#s-gVJ1AtUqnim5y4 zFP+v!FYEO)^8Y>H%mmB1eA>$`C0#Q>`Lt~Ccmgxbh^FgbeqPw z7|}JGp4qF8t&6I9nj5jYX-Q;(*)z(X!^aMq|&%A0?=P(1-CM8#A yr4gE>;dwux{)3+X`4li%o??;>5=D9jP8Y+=lct=jv$6_YGy?o(g3m5>`0GDv5jMsE diff --git a/src/vfs/_vfscommon.vfs/modules/zipper-0.14.tm b/src/vfs/_vfscommon.vfs/modules/zipper-0.14.tm new file mode 100644 index 0000000000000000000000000000000000000000..fcb76636a0670797560a57e80a0d00bf7c4fb42d GIT binary patch literal 9910 zcmch6dpwkB|Np4Aw#4daD|CfI>sYJJ6gH(zDU?u5+-B}!n3K6@oDWZIN@q$3gi4f< z5{lCHXp;(U(!r^sT9VEbI()C|o*9Q`c=q@FzOV1}$Bg^FuFv&3zCZ8l(-_e2qZQ2J z115`&g8-J$8#vP0fX%}gxB&14I3MRSaE2jRjr)mM0-OLiTmxTuidbwRiwodhCZP{_ z0^rXis8l3M$O9anh${pE-bg5X#D@~b^g9t~En*9C0T&ap{Bd>=5OL8yf(L}&m=NHB zLIFk>;tZh0;W79;h5;X=`(j?Wfj=%FSUfIZ^4Lf{76G6J1jfOoPcQ-)3OS@P-yGj++7@HN016LN8$pZvkz~T#OVYDz1GGHfi3@#8r z7ivn5C%qvQd5Rw!g0)=C6M7OlmVraRaadd&=`VuM_?Xb!5a{xG1i?aU2#kqCufSD& z0K+8|u;@bQGQv_%bHJft1OCGJd>Dq15GWMsE>A;bpSI*Z!2N)xCI}4$Gh9hq@jw*5|o{-c&OgdvvIB$L;>wZG+=HHjNxJdE))s4 zAS6uI+p^oN{_AZPz_s7ugDHtlL;*ukq`gSSV)Pn)(2_+!+iJ)KRzMqyk-J2`snUZ( zGda1TC4*Hc_X&vQ5T$q^00(r83$qw?3aG4r#}}|5K(m8nltrFo z(=h^f7Xz<5fqQXqE(9D`1aMq0h>UDrKyRJ()eEfYL8??CUAcS&6Nn^;SyK|5jpe-v{7VXhl$S874KWj)Vm1r-ONRx2~+C89FUB&RNJ)qPj zihS!a?SW^~$a3u~yl>wArz%9~(@%f40ONYWe%Id)F&NYO756u10GOsUus};hz-|V! z02jbkgrdy=NW5J0kqbOwvH8kE2;X(f4O6PH5 z-vk4)2(E(bafSg51!7aE6G|J2%o$+-XTv}Yp0oWOfFwz5lo5nNBv;x0 zH+9Cy2qq&(;vt>K;lK_{0J2IEJ%bFCG?oS+L(Pix-^d6C0O=-Xu(0F6=deOB7*AmUPvA@PU0EJD zAlXR2z}~=s)ED^TP+?cu1Q{GwHI0nKsbmDxTU=6u24E%cZPpy&>r}t~XrrZ<|sD zq~E012qA>RzB?!Z@1GVH7X4CJf~{a73Jbgi_tk?1V8S*BFZpg5Dz&owfoc`YfOk0eQ9Ra?G?y~NR$Pc~!8%{g^W10S zX(DAhXf6af7IGfxbkwlmZ!|;E?#F2c*HwNf!{noY7Q`a4s|V06K!`lyodjORd9d^` zb^vOps1+iz0kwmpwcdFXyd%L|Ke{7{If*~cWx-_-Q2PdCko}o)6ghp}X`borR z<8aglOdt=3+y-_PkpR++|1#>b&2vcFsKvzCY){B{QH7yy04q>Rs^n^`waUs6I77Zc z(il1<`mmiM-;lI`14lLJ0dyn*4B#XZHb3}IoH&r$K$4B90s&;XBPvVT!qXN{fBFDs z$dW?)rC9t8WAC-6TN4#Q@{U^Ja0H$ZJcms*s$r?g=D)v3h zR&spI0G>gRIdVlX_>vJXpF~_3E3yK6OA%dt*l;XhIC$|PZNJgf5y~M4$8fp~AX|d8 z0)-x)CMg(r^+F^9O2?%0VMM$8#>)MHR9b!HG?@<#g#{@YGed$VRdr|u#UP{&T`4!K zkqtxE30ir;BI1k1IV5Q)Dnu^|;k za{dnx9UUVd)dzngfBhivDr5CObF++Z1|Av~CYi8&JDHaJ4+HHR;6wkv(_14jry&6M z4LzsYuNXdJB85Wvo|3?JcP;8!^Xcel3WcRkp=iRV(k4cV5EvL6n*5AzM{r0({)SEU z;<_H9?&`QNw1__wA~mnmuczq;v7I|@={hTCy}7gI#vwmFr{TkXd#kD9!KdgQeEPMK z_d(exlKrCA;Of5D=jzG|t6bG@TZV`KHbGr)Ox%42OM_t(%+Gxt9KZ4zR4iqbzXi&*_+^Wm*|?~{2}hax%p z)0GPX=F}Y1x_0ljUA|@X_C2|uxi6;GgeT72c%j~+jEPis|~S+i_1z2lo!E}Usu zQpF72GxL#^`SQ1p%l6FMTe0`g<4;6eCapIqKXE1XH%IL*U!w8p=L4Y^FP;v?)7 z?q(O&54+Rq*qPM${N|Xpg09Cr zvn2hqMhA~}JX`i~eR1a(+mi>CnUrRybsmaY$Az?ISElDSwkq<*WPhrQQ{{d%`*(HJ z#ispp9x)F$shmAkSGs(Xvt}pUzx}j>MQoq3fJ6||{MX9azxCnJl#L~ti z9qFMVKi*V1zN}(`d4)n&*?GMcpYJaTzZ$tCc5$pj$n59^d9ymLZ60m=;JasGi2s`l zzZ}o7b8xA^^7Bvl7G1;AHY8o~nbi8@lS8%X`DV7Z=~zm>gFT;Gb^OwUt8A-MusqUr z=i&1y8^_-5tS{|u(NeEy)lEB^($Zp}e(|CGuGYYh4wnyPo+vN7^KRp-gzkp6*NoxW zei7#PZ>71F+1&eWewO8J*Wkrl6z81bZ~suJbo$Z1bAP-&!^f?#E$oF-vSnL}+Xf5E z!x0YmLPCOqE(bIwuB=Wt!aH4+NZX)1(!Z>}y(Rcr&B@E<>4stZGE9`TlrlPgKV8OH zYOwIe`l5Y|(Tb&OvF##_w&L@-FNGB2_e-ofo=R04LTacT#kAR0&ZiC;ctmL{S8VZF zHKprni{2CcEFWw2?fOn{pWAJop0nZT6@Faw75d)Dkji~Tj(>FN*3w4iGQNvdaA#St z=XVj7<2{Wu_TQ|#@KbD$sX{{Xq^>p3f5|2;{V{S&40U8|f*;jH?e60Di{qB8U1**2 zcFgWXrZOX2$2DPzC!0MEBX%e!6yz=q{?4zYXJ>tN)c&3>-l)p(arL9p@8A70#n))Z zUncA`9v)^2{E`D&rBf^8lP*nr{$%HK3m*7-6ueS)zFy!^pyaB(bj5D4kUgWb_3()D#dS6}Zv~_(wWe=*@bm98 zqjdMD8MCZtYnMOLvdKQ*&>&Eut`;4<%?}|N8+Ww{B~5BLZhO&f4*Bh@Mw=$z`S*R}hnxAgAQ(MH2Z1#TdQEu9;AbbHg9YV!y0COl{7_cR#Y zi)x!Y%;|ISmvs?*i;|Xm6IvsSlaIU(h|W9+eFrC<}z@nyRV;JzT>@1OApt@MNRLS;?$pyeB4+_)c79{U!%LN&G(jm z&aBkN@Ra)Kd(2YxDWg5oEPVW%OR>_P6~w$#mwFs>u4jDEFD!1ZCVvZ#*<1Hpm&x6XG*nGf@SIO}nI z&GdVxM!#J*1N4l$txr8Twq0dsqV>!6BY5zq{e{jt5#A3pXfXn#R`X5C`c!9YX12x0lsi{X#iUhv8 zh>Nv5HB#2kHh*qzylT8&dBTy!jh=}`+r8E~pZ&?v=c4Hmuy#eZ)1;{BU%I=M{I+-1 zTM+)m=fZvR>Z-q3A7wQ*t9sov%5rwQRlOrHL1#;GN>*XvOy5hWvx1KTjw2fiBKd}Vac8j&Atyp2bS-aawiF5cAyd<}p#uokgvT#J zcw@KG@ZKl$N0UugZhv8lH6$OKZE`08Ia`z+0UxV}` zT-NRTNnd?|uS4wh>ld#nd>z?G@nY1hT%)>ziYpZ;6yM<#$_&cLAt;{VYU@QyR$71k zI*dY52-~xgS7$snx~lpVh*Yo6YTznFdwlPI?Zo2KYqn`jjM*7;EpGO8zdi1jw^tQ0 z?>|fAJpUYMdrGl(x!ci3meidfvIIAB-^LLl1(Tq1-L(0wYJcCFX{Tg%I9ao0ejuAY z{rQ2%<(r;#{-GO}oN{XAw5{}KHqKGYKY8kTH~JKgpJ&R$o<-(&&V1`ws#R=tKHc-? z2j`PlDpL(p6-(YbzGi~v=`hkWX`0fW?t~udUurwz&&Ed_ z+oih3#$wf^SaGKfx literal 0 HcmV?d00001