From 801a80bc5da864f906342f3cf30cdcfb4d1a5956 Mon Sep 17 00:00:00 2001 From: Julian Noble Date: Thu, 3 Apr 2025 05:55:21 +1100 Subject: [PATCH] update vfs tomlish --- src/vendormodules/tomlish-1.1.4.tm | 2 - .../modules/commandstack-0.3.tm | 1028 +- .../_vfscommon.vfs/modules/fauxlink-0.1.1.tm | 21 +- .../_vfscommon.vfs/modules/metaface-1.2.5.tm | 12822 ++++++++-------- .../{zipper-0.11.tm => packageTest-0.1.1.tm} | Bin 9248 -> 11509 bytes .../_vfscommon.vfs/modules/pattern-1.2.4.tm | 2570 ++-- .../modules/patterncmd-1.2.4.tm | 1288 +- .../modules/patternpredator2-1.2.4.tm | 1508 +- src/vfs/_vfscommon.vfs/modules/punk-0.1.tm | 83 +- .../_vfscommon.vfs/modules/punk/ansi-0.1.1.tm | 3 +- .../punk/cap/handlers/templates-0.1.0.tm | 65 +- .../_vfscommon.vfs/modules/punk/config-0.1.tm | 972 +- .../modules/punk/mix/base-0.1.tm | 5 +- .../modules/punk/mix/cli-0.3.1.tm | 20 +- .../punk/mix/commandset/buildsuite-0.1.0.tm | 2 +- .../punk/mix/commandset/debug-0.1.0.tm | 8 +- .../punk/mix/commandset/module-0.1.0.tm | 6 +- .../punk/mix/commandset/project-0.1.0.tm | 170 +- .../modules/punk/mix/commandset/repo-0.1.0.tm | 38 +- .../templates/layouts/project/src/make.tcl | 15 +- .../_vfscommon.vfs/modules/punk/mod-0.1.tm | 327 +- .../modules/punk/netbox-0.1.0.tm | 15 +- .../_vfscommon.vfs/modules/punk/path-0.1.0.tm | 21 +- .../_vfscommon.vfs/modules/punk/repl-0.1.1.tm | 5 +- .../_vfscommon.vfs/modules/punk/repo-0.1.1.tm | 240 +- .../_vfscommon.vfs/modules/punk/zip-0.1.0.tm | 761 - src/vfs/_vfscommon.vfs/modules/punkapp-0.1.tm | 478 +- .../_vfscommon.vfs/modules/punkcheck-0.1.0.tm | 114 +- src/vfs/_vfscommon.vfs/modules/test/backup.tm | Bin 0 -> 41364 bytes .../modules/test/tomlish-1.1.1.tm | Bin 46279 -> 35335 bytes .../modules/test/tomlish-1.1.1.tm.x | Bin 0 -> 46279 bytes .../modules/test/tomlish-1.1.3.tm | Bin 0 -> 41874 bytes .../_vfscommon.vfs/modules/textblock-0.1.1.tm | 7408 --------- .../_vfscommon.vfs/modules/textblock-0.1.2.tm | 8520 ---------- .../_vfscommon.vfs/modules/tomlish-1.1.2.tm | 160 +- .../{tomlish-1.1.1.tm => tomlish-1.1.3.tm} | 2110 ++- .../_vfscommon.vfs/modules/tomlish-1.1.4.tm | 6172 ++++++++ .../_vfscommon.vfs/modules/zipper-0.1.0.tm | Bin 3894 -> 0 bytes 38 files changed, 18811 insertions(+), 28146 deletions(-) rename src/vfs/_vfscommon.vfs/modules/{zipper-0.11.tm => packageTest-0.1.1.tm} (57%) delete mode 100644 src/vfs/_vfscommon.vfs/modules/punk/zip-0.1.0.tm create mode 100644 src/vfs/_vfscommon.vfs/modules/test/backup.tm create mode 100644 src/vfs/_vfscommon.vfs/modules/test/tomlish-1.1.1.tm.x create mode 100644 src/vfs/_vfscommon.vfs/modules/test/tomlish-1.1.3.tm delete mode 100644 src/vfs/_vfscommon.vfs/modules/textblock-0.1.1.tm delete mode 100644 src/vfs/_vfscommon.vfs/modules/textblock-0.1.2.tm rename src/vfs/_vfscommon.vfs/modules/{tomlish-1.1.1.tm => tomlish-1.1.3.tm} (75%) create mode 100644 src/vfs/_vfscommon.vfs/modules/tomlish-1.1.4.tm delete mode 100644 src/vfs/_vfscommon.vfs/modules/zipper-0.1.0.tm diff --git a/src/vendormodules/tomlish-1.1.4.tm b/src/vendormodules/tomlish-1.1.4.tm index 9967747e..7a6d5205 100644 --- a/src/vendormodules/tomlish-1.1.4.tm +++ b/src/vendormodules/tomlish-1.1.4.tm @@ -4259,8 +4259,6 @@ namespace eval tomlish::parse { literal - literalpart - squotedkey { append tok $c } - XXXitablesquotedkey { - } string - dquotedkey - itablequotedkey { if {$had_slash} {append tok "\\"} append tok $c diff --git a/src/vfs/_vfscommon.vfs/modules/commandstack-0.3.tm b/src/vfs/_vfscommon.vfs/modules/commandstack-0.3.tm index a45eaeaf..7884214c 100644 --- a/src/vfs/_vfscommon.vfs/modules/commandstack-0.3.tm +++ b/src/vfs/_vfscommon.vfs/modules/commandstack-0.3.tm @@ -1,514 +1,514 @@ - - -#JMN 2021 - Public Domain -#cooperative command renaming -# -# REVIEW 2024 - code was originally for specific use in packageTrace -# - code should be reviewed for more generic utility. -# - API is obscure and undocumented. -# - unclear if intention was only for builtins -# - consider use of newer 'info cmdtype' - (but need also support for safe interps) -# - oo dispatch features may be a better implementation - especially for allowing undoing command renames in the middle of a stack. -# - document that replacement command should use 'commandstack::get_next_command ' for delegating to command as it was prior to rename -#changes: -#2024 -# - mungecommand to support namespaced commands -# - fix mistake - hardcoded _originalcommand_package -> _originalcommand_ -#2021-09-18 -# - initial version -# - e.g Support cooperation between packageSuppress and packageTrace which both rename the package command -# - They need to be able to load and unload in any order. -# - -#strive for no other package dependencies here. - - -namespace eval commandstack { - variable all_stacks - variable debug - set debug 0 - variable known_renamers [list ::packagetrace ::packageSuppress] - if {![info exists all_stacks]} { - #don't wipe it - set all_stacks [dict create] - } -} - -namespace eval commandstack::util { - #note - we can't use something like md5 to ID proc body text because we don't want to require additional packages. - #We could store the full text of the body to compare - but we need to identify magic strings from cooperating packages such as packageTrace - #A magic comment was chosen as the identifying method. - #The string IMPLEMENTOR_*! is searched for where the text between _ and ! is the name of the package that implemented the proc. - - #return unspecified if the command is a proc with a body but no magic comment ID - #return unknown if the command doesn't have a proc body to analyze - #otherwise return the package name identified in the magic comment - proc get_IMPLEMENTOR {command} { - #assert - command has already been resolved to a namespace ie fully qualified - if {[llength [info procs $command]]} { - #look for *IMPLEMENTOR_*! - set prefix IMPLEMENTOR_ - set suffix "!" - set body [uplevel 1 [list info body $command]] - if {[string match "*$prefix*$suffix*" $body]} { - set prefixposn [string first "$prefix" $body] - set pkgposn [expr {$prefixposn + [string length $prefix]}] - #set suffixposn [string first $suffix [string range $body $pkgposn $pkgposn+60]] - set suffixposn [string first $suffix $body $pkgposn] - return [string range $body $pkgposn $suffixposn-1] - } else { - return unspecified - } - } else { - if {[info commands tcl::info::cmdtype] ne ""} { - #tcl9 and maybe some tcl 8.7s ? - switch -- [tcl::info::cmdtype $command] { - native { - return builtin - } - default { - return undetermined - } - } - } else { - return undetermined - } - } - } -} -namespace eval commandstack::renamed_commands {} -namespace eval commandstack::temp {} ;#where we create proc initially before renaming into place - -namespace eval commandstack { - namespace export {[a-z]*} - proc help {} { - return { - - } - } - - proc debug {{on_off {}}} { - variable debug - if {$on_off eq ""} { - return $debug - } else { - if {[string is boolean -strict $debug]} { - set debug [expr {$on_off && 1}] - return $debug - } - } - } - - proc get_stack {command} { - variable all_stacks - set command [uplevel 1 [list namespace which $command]] - if {[dict exists $all_stacks $command]} { - return [dict get $all_stacks $command] - } else { - return [list] - } - } - - #get the implementation to which the renamer (renamer is usually calling namespace) originally renamed it, or the implementation it now points to. - #review - performance impact. Possible to use oo for faster dispatch whilst allowing stack re-orgs? - #e.g if renaming builtin 'package' - this command is generally called 'a lot' - proc get_next_command {command renamer tokenid} { - variable all_stacks - if {[dict exists $all_stacks $command]} { - set stack [dict get $all_stacks $command] - set posn [lsearch -index 1 $stack [list $command $renamer $tokenid]] - if {$posn > -1} { - set record [lindex $stack $posn] - return [dict get $record implementation] - } else { - error "(commandstack::get_next_command) ERROR: unable to determine next command for '$command' using token: $command $renamer $tokenid" - } - } else { - return $command - } - } - proc basecall {command args} { - variable all_stacks - set command [uplevel 1 [list namespace which $command]] - if {[dict exists $all_stacks $command]} { - set stack [dict get $all_stacks $command] - if {[llength $stack]} { - set rec1 [lindex $stack 0] - tailcall [dict get $rec1 implementation] {*}$args - } else { - tailcall $command {*}$args - } - } else { - tailcall $command {*}$args - } - } - - - #review. - # defaults to calling namespace - but can be arbitrary string - proc rename_command {args} { - #todo: consider -forcebase 1 or similar to allow this rename to point to bottom of stack (original command) bypassing existing renames - # - need to consider that upon removing, that any remaining rename that was higher on the stack should not also be diverted to the base - but rather to the next lower in the stack - # - if {[lindex $args 0] eq "-renamer"} { - set renamer [lindex $args 1] - set arglist [lrange $args 2 end] - } else { - set renamer "" - set arglist $args - } - if {[llength $arglist] != 3} { - error "commandstack::rename_command usage: rename_command ?-renamer ? command procargs procbody" - } - lassign $arglist command procargs procbody - - set command [uplevel 1 [list namespace which $command]] - set mungedcommand [string map {:: _ns_} $command] - set mungedrenamer [string map {:: _ns_} $renamer] - variable all_stacks - variable known_renamers - variable renamer_command_tokens ;#monotonically increasing int per :: representing number of renames ever done. - if {$renamer eq ""} { - set renamer [uplevel 1 [list namespace current]] - } - if {$renamer ni $known_renamers} { - lappend known_renamers $renamer - dict set renamer_command_tokens [list $renamer $command] 0 - } - - #TODO - reduce emissions to stderr - flag for debug? - - #e.g packageTrace and packageSuppress packages use this convention. - set nextinfo [uplevel 1 [list\ - apply {{command renamer procbody} { - #todo - munge dash so we can make names in renamed_commands separable - # {- _dash_} ? - set mungedcommand [string map {:: _ns_} $command] - set mungedrenamer [string map {:: _ns_} $renamer] - set tokenid [lindex [dict incr renamer_command_tokens [list $renamer $command]] 1] - set next_target ::commandstack::renamed_commands::${mungedcommand}-original-$mungedrenamer-$tokenid ;#default is to assume we are the only one playing around with it, but we'll check for known associates too. - set do_rename 0 - if {[llength [info procs $command]] || [llength [info commands $next_target]]} { - #$command is not the standard builtin - something has replaced it, could be ourself. - set next_implementor [::commandstack::util::get_IMPLEMENTOR $command] - set munged_next_implementor [string map {:: _ns_} $next_implementor] - #if undetermined/unspecified it could be the latest renamer on the stack - but we can't know for sure something else didn't rename it. - if {[dict exists $::commandstack::all_stacks $command]} { - set comstacks [dict get $::commandstack::all_stacks $command] - } else { - set comstacks [list] - } - set this_renamer_previous_entries [lsearch -all -index 3 $comstacks $renamer] ;#index 3 is value for second dict entry - (value for key 'renamer') - if {[llength $this_renamer_previous_entries]} { - if {$next_implementor eq $renamer} { - #previous renamer was us. Rather than assume our job is done.. compare the implementations - #don't rename if immediate predecessor is same code. - #set topstack [lindex $comstacks end] - #set next_impl [dict get $topstack implementation] - set current_body [info body $command] - lassign [commandstack::lib::split_body $current_body] _ current_code - set current_code [string trim $current_code] - set new_code [string trim $procbody] - if {$current_code eq $new_code} { - puts stderr "(commandstack::rename_command) WARNING - renamer '$renamer' has already renamed the '$command' command with same procbody - Aborting rename." - puts stderr [::commandstack::show_stack $command] - } else { - puts stderr "(commandstack::rename_command) WARNING - renamer '$renamer' has already renamed the '$command' command - but appears to be with new code - proceeding." - puts stdout "----------" - puts stdout "$current_code" - puts stdout "----------" - puts stdout "$new_code" - puts stdout "----------" - set next_target ::commandstack::renamed_commands::${mungedcommand}-${munged_next_implementor}-$mungedrenamer-$tokenid - set do_rename 1 - } - } else { - puts stderr "(commandstack::rename_command) WARNING - renamer '$renamer' has already renamed the '$command' command, but is not immediate predecessor - proceeding anyway... (untested)" - puts stderr - set next_target ::commandstack::renamed_commands::${mungedcommand}-${munged_next_implementor}-$mungedrenamer-$tokenid - set do_rename 1 - } - } elseif {$next_implementor in $::commandstack::known_renamers} { - set next_target ::commandstack::renamed_commands::${mungedcommand}-${munged_next_implementor}-$mungedrenamer-$tokenid - set do_rename 1 - } elseif {$next_implementor in {builtin}} { - #native/builtin could still have been renamed - set next_target ::commandstack::renamed_commands::${mungedcommand}_${munged_next_implementor}-$mungedrenamer-$tokenid - set do_rename 1 - } elseif {$next_implementor in {unspecified undetermined}} { - #could be a standard tcl proc, or from application or package - set next_target ::commandstack::renamed_commands::${mungedcommand}_${munged_next_implementor}-$mungedrenamer-$tokenid - set do_rename 1 - } else { - puts stderr "(commandstack::rename_command) Warning - pkg:'$next_implementor' has renamed the '$command' command. Attempting to cooperate. (untested)" - set next_target ::commandstack::renamed_commands::${mungedcommand}_${munged_next_implementor}-$mungedrenamer-$tokenid - set do_rename 1 - } - } else { - #_originalcommand_ - #assume builtin/original - set next_implementor original - #rename $command $next_target - set do_rename 1 - } - #There are of course other ways in which $command may have been renamed - but we can't detect. - set token [list $command $renamer $tokenid] - return [dict create next_target $next_target next_implementor $next_implementor token $token do_rename $do_rename] - } } $command $renamer $procbody] - ] - - - variable debug - if $debug { - if {[dict exists $all_stacks $command]} { - set stack [dict get $all_stacks $command] - puts stderr "(commandstack::rename_command) Subsequent rename of command '$command'. (previous renames: [llength $stack]). Renaming to [dict get $nextinfo next_target]" - } else { - #assume this is the original - puts stderr "(commandstack::rename_command) 1st detected rename of command '$command'. Renaming to [dict get $nextinfo next_target]" - } - } - - #token is always first dict entry. (Value needs to be searched with lsearch -index 1 ) - #renamer is always second dict entry (Value needs to be searched with lsearch -index 3) - set new_record [dict create\ - token [dict get $nextinfo token]\ - renamer $renamer\ - next_implementor [dict get $nextinfo next_implementor]\ - next_getter [list ::commandstack::get_next_command {*}[dict get $nextinfo token]]\ - implementation [dict get $nextinfo next_target]\ - ] - if {![dict get $nextinfo do_rename]} { - #review - puts stderr "no rename performed" - return [dict create implementation ""] - } - catch {rename ::commandstack::temp::testproc ""} - set nextinit [string map [list %command% $command %renamer% $renamer %next_getter% [dict get $new_record next_getter] %original_implementation% [dict get $new_record implementation]] { - #IMPLEMENTOR_%renamer%! (mechanism: 'commandstack::rename_command -renamer %renamer% %command% ) - set COMMANDSTACKNEXT_ORIGINAL %original_implementation% ;#informational/debug for overriding proc. - set COMMANDSTACKNEXT [%next_getter%] - ## - }] - set final_procbody "$nextinit$procbody" - #build the proc at a temp location so that if it raises an error we don't adjust the stack or replace the original command - #(e.g due to invalid argument specifiers) - proc ::commandstack::temp::testproc $procargs $final_procbody - uplevel 1 [list rename $command [dict get $nextinfo next_target]] - uplevel 1 [list rename ::commandstack::temp::testproc $command] - dict lappend all_stacks $command $new_record - - - return $new_record - } - - #todo - concept of 'pop' for renamer. Remove topmost entry specific to the renamer - #todo - removal by token to allow renamer to have multiple entries for one command but to remove one that is not the topmost - #todo - removal of all entries pertaining to a particular renamer - #todo - allow restore to bottom-most implementation (original) - regardless of what renamers have cooperated in the stack? - - #remove by token, or by commandname if called from same context as original rename_command - #If only a commandname is supplied, and there were multiple renames from the same context (same -renamer) only the topmost is removed. - #A call to remove_rename with no token or renamer, and from a namespace context which didn't perform a rename will not remove anything. - #similarly a nonexistant token or renamer will not remove anything and will just return the current stack - proc remove_rename {token_or_command} { - if {[llength $token_or_command] == 3} { - #is token - lassign $token_or_command command renamer tokenid - } elseif {[llength $token_or_command] == 2} { - #command and renamer only supplied - lassign $token_or_command command renamer - set tokenid "" - } elseif {[llength $token_or_command] == 1} { - #is command name only - set command $token_or_command - set renamer [uplevel 1 [list namespace current]] - set tokenid "" - } - set command [uplevel 1 [list namespace which $command]] - variable all_stacks - variable known_renamers - if {$renamer ni $known_renamers} { - error "(commandstack::remove_rename) ERROR: renamer $renamer not in list of known_renamers '$known_renamers' for command '$command'. Ensure remove_rename called from same context as rename_command was, or explicitly supply exact token or { }" - } - if {[dict exists $all_stacks $command]} { - set stack [dict get $all_stacks $command] - if {$tokenid ne ""} { - #token_or_command is a token as returned within the rename_command result dictionary - #search first dict value - set doomed_posn [lsearch -index 1 $stack $token_or_command] - } else { - #search second dict value - set matches [lsearch -all -index 3 $stack $renamer] - set doomed_posn [lindex $matches end] ;#we don't have a full token - pop last entry for this renamer - } - if {$doomed_posn ne "" && $doomed_posn > -1} { - set doomed_record [lindex $stack $doomed_posn] - if {[llength $stack] == ($doomed_posn + 1)} { - #last on stack - put the implemenation from the doomed_record back as the actual command - uplevel #0 [list rename $command ""] - uplevel #0 [list rename [dict get $doomed_record implementation] $command] - } elseif {[llength $stack] > ($doomed_posn + 1)} { - #there is at least one more record on the stack - rewrite it to point where the doomed_record pointed - set rewrite_posn [expr {$doomed_posn + 1}] - set rewrite_record [lindex $stack $rewrite_posn] - - if {[dict get $rewrite_record next_implementor] ne $renamer} { - puts stderr "(commandstack::remove_rename) WARNING: next record on the commandstack didn't record '$renamer' as the next_implementor - not deleting implementation [dict get $rewrite_record implementation]" - } else { - uplevel #0 [list rename [dict get $rewrite_record implementation] ""] - } - dict set rewrite_record next_implementor [dict get $doomed_record next_implementor] - #don't update next_getter - it always refers to self - dict set rewrite_record implementation [dict get $doomed_record implementation] - lset stack $rewrite_posn $rewrite_record - dict set all_stacks $command $stack - } - set stack [lreplace $stack $doomed_posn $doomed_posn] - dict set all_stacks $command $stack - - } - return $stack - } - return [list] - } - - proc show_stack {{commandname_glob *}} { - variable all_stacks - if {![regexp {[?*]} $commandname_glob]} { - #if caller is attempting exact match - use the calling context to resolve in case they didn't supply namespace - set commandname_glob [uplevel 1 [list namespace which $commandname_glob]] - } - if {[package provide punk::lib] ne "" && [package provide punk] ne ""} { - #punk pipeline also needed for patterns - return [punk::lib::pdict -channel none all_stacks $commandname_glob/@*/@*.@*] - } else { - set result "" - set matchedkeys [dict keys $all_stacks $commandname_glob] - #don't try to calculate widest on empty list - if {[llength $matchedkeys]} { - set widest [tcl::mathfunc::max {*}[lmap v $matchedkeys {tcl::string::length $v}]] - set indent [string repeat " " [expr {$widest + 3}]] - set indent2 "${indent} " ;#8 spaces for " i = " where i is 4 wide - set padkey [string repeat " " 20] - foreach k $matchedkeys { - append result "$k = " - set i 0 - foreach stackmember [dict get $all_stacks $k] { - if {$i > 0} { - append result "\n$indent" - } - append result [string range "$i " 0 4] " = " - set j 0 - dict for {k v} $stackmember { - if {$j > 0} { - append result "\n$indent2" - } - set displaykey [string range "$k$padkey" 0 20] - append result "$displaykey = $v" - incr j - } - incr i - } - append result \n - } - } - return $result - } - } - - #review - #document when this is to be called. Wiping stacks without undoing renames seems odd. - proc Delete_stack {command} { - variable all_stacks - if {[dict exists $all_stacks $command]} { - dict unset all_stacks $command - return 1 - } else { - return 1 - } - } - - #can be used to temporarily put a stack aside - should manually rename back when done. - #review - document how/when to use. example? intention? - proc Rename_stack {oldname newname} { - variable all_stacks - if {[dict exists $all_stacks $oldname]} { - if {[dict exists $all_stacks $newname]} { - error "(commandstack::rename_stack) cannot rename $oldname to $newname - $newname already exists in stack" - } else { - #set stackval [dict get $all_stacks $oldname] - #dict unset all_stacks $oldname - #dict set all_stacks $newname $stackval - dict set all_stacks $newname [lindex [list [dict get $all_stacks $oldname] [dict unset all_stacks $oldname]] 0] - } - } - } -} - - - - - - - - -namespace eval commandstack::lib { - proc splitx {str {regexp {[\t \r\n]+}}} { - #snarfed from tcllib textutil::splitx to avoid the dependency - # Bugfix 476988 - if {[string length $str] == 0} { - return {} - } - if {[string length $regexp] == 0} { - return [::split $str ""] - } - if {[regexp $regexp {}]} { - return -code error "splitting on regexp \"$regexp\" would cause infinite loop" - } - - set list {} - set start 0 - while {[regexp -start $start -indices -- $regexp $str match submatch]} { - foreach {subStart subEnd} $submatch break - foreach {matchStart matchEnd} $match break - incr matchStart -1 - incr matchEnd - lappend list [string range $str $start $matchStart] - if {$subStart >= $start} { - lappend list [string range $str $subStart $subEnd] - } - set start $matchEnd - } - lappend list [string range $str $start end] - return $list - } - proc split_body {procbody} { - set marker "##" - set header "" - set code "" - set found_marker 0 - foreach ln [split $procbody \n] { - if {!$found_marker} { - if {[string trim $ln] eq $marker} { - set found_marker 1 - } else { - append header $ln \n - } - } else { - append code $ln \n - } - } - if {$found_marker} { - return [list $header $code] - } else { - return [list "" $procbody] - } - } -} - -package provide commandstack [namespace eval commandstack { - set version 0.3 -}] - - + + +#JMN 2021 - Public Domain +#cooperative command renaming +# +# REVIEW 2024 - code was originally for specific use in packageTrace +# - code should be reviewed for more generic utility. +# - API is obscure and undocumented. +# - unclear if intention was only for builtins +# - consider use of newer 'info cmdtype' - (but need also support for safe interps) +# - oo dispatch features may be a better implementation - especially for allowing undoing command renames in the middle of a stack. +# - document that replacement command should use 'commandstack::get_next_command ' for delegating to command as it was prior to rename +#changes: +#2024 +# - mungecommand to support namespaced commands +# - fix mistake - hardcoded _originalcommand_package -> _originalcommand_ +#2021-09-18 +# - initial version +# - e.g Support cooperation between packageSuppress and packageTrace which both rename the package command +# - They need to be able to load and unload in any order. +# + +#strive for no other package dependencies here. + + +namespace eval commandstack { + variable all_stacks + variable debug + set debug 0 + variable known_renamers [list ::packagetrace ::packageSuppress] + if {![info exists all_stacks]} { + #don't wipe it + set all_stacks [dict create] + } +} + +namespace eval commandstack::util { + #note - we can't use something like md5 to ID proc body text because we don't want to require additional packages. + #We could store the full text of the body to compare - but we need to identify magic strings from cooperating packages such as packageTrace + #A magic comment was chosen as the identifying method. + #The string IMPLEMENTOR_*! is searched for where the text between _ and ! is the name of the package that implemented the proc. + + #return unspecified if the command is a proc with a body but no magic comment ID + #return unknown if the command doesn't have a proc body to analyze + #otherwise return the package name identified in the magic comment + proc get_IMPLEMENTOR {command} { + #assert - command has already been resolved to a namespace ie fully qualified + if {[llength [info procs $command]]} { + #look for *IMPLEMENTOR_*! + set prefix IMPLEMENTOR_ + set suffix "!" + set body [uplevel 1 [list info body $command]] + if {[string match "*$prefix*$suffix*" $body]} { + set prefixposn [string first "$prefix" $body] + set pkgposn [expr {$prefixposn + [string length $prefix]}] + #set suffixposn [string first $suffix [string range $body $pkgposn $pkgposn+60]] + set suffixposn [string first $suffix $body $pkgposn] + return [string range $body $pkgposn $suffixposn-1] + } else { + return unspecified + } + } else { + if {[info commands tcl::info::cmdtype] ne ""} { + #tcl9 and maybe some tcl 8.7s ? + switch -- [tcl::info::cmdtype $command] { + native { + return builtin + } + default { + return undetermined + } + } + } else { + return undetermined + } + } + } +} +namespace eval commandstack::renamed_commands {} +namespace eval commandstack::temp {} ;#where we create proc initially before renaming into place + +namespace eval commandstack { + namespace export {[a-z]*} + proc help {} { + return { + + } + } + + proc debug {{on_off {}}} { + variable debug + if {$on_off eq ""} { + return $debug + } else { + if {[string is boolean -strict $debug]} { + set debug [expr {$on_off && 1}] + return $debug + } + } + } + + proc get_stack {command} { + variable all_stacks + set command [uplevel 1 [list namespace which $command]] + if {[dict exists $all_stacks $command]} { + return [dict get $all_stacks $command] + } else { + return [list] + } + } + + #get the implementation to which the renamer (renamer is usually calling namespace) originally renamed it, or the implementation it now points to. + #review - performance impact. Possible to use oo for faster dispatch whilst allowing stack re-orgs? + #e.g if renaming builtin 'package' - this command is generally called 'a lot' + proc get_next_command {command renamer tokenid} { + variable all_stacks + if {[dict exists $all_stacks $command]} { + set stack [dict get $all_stacks $command] + set posn [lsearch -index 1 $stack [list $command $renamer $tokenid]] + if {$posn > -1} { + set record [lindex $stack $posn] + return [dict get $record implementation] + } else { + error "(commandstack::get_next_command) ERROR: unable to determine next command for '$command' using token: $command $renamer $tokenid" + } + } else { + return $command + } + } + proc basecall {command args} { + variable all_stacks + set command [uplevel 1 [list namespace which $command]] + if {[dict exists $all_stacks $command]} { + set stack [dict get $all_stacks $command] + if {[llength $stack]} { + set rec1 [lindex $stack 0] + tailcall [dict get $rec1 implementation] {*}$args + } else { + tailcall $command {*}$args + } + } else { + tailcall $command {*}$args + } + } + + + #review. + # defaults to calling namespace - but can be arbitrary string + proc rename_command {args} { + #todo: consider -forcebase 1 or similar to allow this rename to point to bottom of stack (original command) bypassing existing renames + # - need to consider that upon removing, that any remaining rename that was higher on the stack should not also be diverted to the base - but rather to the next lower in the stack + # + if {[lindex $args 0] eq "-renamer"} { + set renamer [lindex $args 1] + set arglist [lrange $args 2 end] + } else { + set renamer "" + set arglist $args + } + if {[llength $arglist] != 3} { + error "commandstack::rename_command usage: rename_command ?-renamer ? command procargs procbody" + } + lassign $arglist command procargs procbody + + set command [uplevel 1 [list namespace which $command]] + set mungedcommand [string map {:: _ns_} $command] + set mungedrenamer [string map {:: _ns_} $renamer] + variable all_stacks + variable known_renamers + variable renamer_command_tokens ;#monotonically increasing int per :: representing number of renames ever done. + if {$renamer eq ""} { + set renamer [uplevel 1 [list namespace current]] + } + if {$renamer ni $known_renamers} { + lappend known_renamers $renamer + dict set renamer_command_tokens [list $renamer $command] 0 + } + + #TODO - reduce emissions to stderr - flag for debug? + + #e.g packageTrace and packageSuppress packages use this convention. + set nextinfo [uplevel 1 [list\ + apply {{command renamer procbody} { + #todo - munge dash so we can make names in renamed_commands separable + # {- _dash_} ? + set mungedcommand [string map {:: _ns_} $command] + set mungedrenamer [string map {:: _ns_} $renamer] + set tokenid [lindex [dict incr renamer_command_tokens [list $renamer $command]] 1] + set next_target ::commandstack::renamed_commands::${mungedcommand}-original-$mungedrenamer-$tokenid ;#default is to assume we are the only one playing around with it, but we'll check for known associates too. + set do_rename 0 + if {[llength [info procs $command]] || [llength [info commands $next_target]]} { + #$command is not the standard builtin - something has replaced it, could be ourself. + set next_implementor [::commandstack::util::get_IMPLEMENTOR $command] + set munged_next_implementor [string map {:: _ns_} $next_implementor] + #if undetermined/unspecified it could be the latest renamer on the stack - but we can't know for sure something else didn't rename it. + if {[dict exists $::commandstack::all_stacks $command]} { + set comstacks [dict get $::commandstack::all_stacks $command] + } else { + set comstacks [list] + } + set this_renamer_previous_entries [lsearch -all -index 3 $comstacks $renamer] ;#index 3 is value for second dict entry - (value for key 'renamer') + if {[llength $this_renamer_previous_entries]} { + if {$next_implementor eq $renamer} { + #previous renamer was us. Rather than assume our job is done.. compare the implementations + #don't rename if immediate predecessor is same code. + #set topstack [lindex $comstacks end] + #set next_impl [dict get $topstack implementation] + set current_body [info body $command] + lassign [commandstack::lib::split_body $current_body] _ current_code + set current_code [string trim $current_code] + set new_code [string trim $procbody] + if {$current_code eq $new_code} { + puts stderr "(commandstack::rename_command) WARNING - renamer '$renamer' has already renamed the '$command' command with same procbody - Aborting rename." + puts stderr [::commandstack::show_stack $command] + } else { + puts stderr "(commandstack::rename_command) WARNING - renamer '$renamer' has already renamed the '$command' command - but appears to be with new code - proceeding." + puts stdout "----------" + puts stdout "$current_code" + puts stdout "----------" + puts stdout "$new_code" + puts stdout "----------" + set next_target ::commandstack::renamed_commands::${mungedcommand}-${munged_next_implementor}-$mungedrenamer-$tokenid + set do_rename 1 + } + } else { + puts stderr "(commandstack::rename_command) WARNING - renamer '$renamer' has already renamed the '$command' command, but is not immediate predecessor - proceeding anyway... (untested)" + puts stderr + set next_target ::commandstack::renamed_commands::${mungedcommand}-${munged_next_implementor}-$mungedrenamer-$tokenid + set do_rename 1 + } + } elseif {$next_implementor in $::commandstack::known_renamers} { + set next_target ::commandstack::renamed_commands::${mungedcommand}-${munged_next_implementor}-$mungedrenamer-$tokenid + set do_rename 1 + } elseif {$next_implementor in {builtin}} { + #native/builtin could still have been renamed + set next_target ::commandstack::renamed_commands::${mungedcommand}_${munged_next_implementor}-$mungedrenamer-$tokenid + set do_rename 1 + } elseif {$next_implementor in {unspecified undetermined}} { + #could be a standard tcl proc, or from application or package + set next_target ::commandstack::renamed_commands::${mungedcommand}_${munged_next_implementor}-$mungedrenamer-$tokenid + set do_rename 1 + } else { + puts stderr "(commandstack::rename_command) Warning - pkg:'$next_implementor' has renamed the '$command' command. Attempting to cooperate. (untested)" + set next_target ::commandstack::renamed_commands::${mungedcommand}_${munged_next_implementor}-$mungedrenamer-$tokenid + set do_rename 1 + } + } else { + #_originalcommand_ + #assume builtin/original + set next_implementor original + #rename $command $next_target + set do_rename 1 + } + #There are of course other ways in which $command may have been renamed - but we can't detect. + set token [list $command $renamer $tokenid] + return [dict create next_target $next_target next_implementor $next_implementor token $token do_rename $do_rename] + } } $command $renamer $procbody] + ] + + + variable debug + if {$debug} { + if {[dict exists $all_stacks $command]} { + set stack [dict get $all_stacks $command] + puts stderr "(commandstack::rename_command) Subsequent rename of command '$command'. (previous renames: [llength $stack]). Renaming to [dict get $nextinfo next_target]" + } else { + #assume this is the original + puts stderr "(commandstack::rename_command) 1st detected rename of command '$command'. Renaming to [dict get $nextinfo next_target]" + } + } + + #token is always first dict entry. (Value needs to be searched with lsearch -index 1 ) + #renamer is always second dict entry (Value needs to be searched with lsearch -index 3) + set new_record [dict create\ + token [dict get $nextinfo token]\ + renamer $renamer\ + next_implementor [dict get $nextinfo next_implementor]\ + next_getter [list ::commandstack::get_next_command {*}[dict get $nextinfo token]]\ + implementation [dict get $nextinfo next_target]\ + ] + if {![dict get $nextinfo do_rename]} { + #review + puts stderr "no rename performed" + return [dict create implementation ""] + } + catch {rename ::commandstack::temp::testproc ""} + set nextinit [string map [list %command% $command %renamer% $renamer %next_getter% [dict get $new_record next_getter] %original_implementation% [dict get $new_record implementation]] { + #IMPLEMENTOR_%renamer%! (mechanism: 'commandstack::rename_command -renamer %renamer% %command% ) + set COMMANDSTACKNEXT_ORIGINAL %original_implementation% ;#informational/debug for overriding proc. + set COMMANDSTACKNEXT [%next_getter%] + ## + }] + set final_procbody "$nextinit$procbody" + #build the proc at a temp location so that if it raises an error we don't adjust the stack or replace the original command + #(e.g due to invalid argument specifiers) + proc ::commandstack::temp::testproc $procargs $final_procbody + uplevel 1 [list rename $command [dict get $nextinfo next_target]] + uplevel 1 [list rename ::commandstack::temp::testproc $command] + dict lappend all_stacks $command $new_record + + + return $new_record + } + + #todo - concept of 'pop' for renamer. Remove topmost entry specific to the renamer + #todo - removal by token to allow renamer to have multiple entries for one command but to remove one that is not the topmost + #todo - removal of all entries pertaining to a particular renamer + #todo - allow restore to bottom-most implementation (original) - regardless of what renamers have cooperated in the stack? + + #remove by token, or by commandname if called from same context as original rename_command + #If only a commandname is supplied, and there were multiple renames from the same context (same -renamer) only the topmost is removed. + #A call to remove_rename with no token or renamer, and from a namespace context which didn't perform a rename will not remove anything. + #similarly a nonexistant token or renamer will not remove anything and will just return the current stack + proc remove_rename {token_or_command} { + if {[llength $token_or_command] == 3} { + #is token + lassign $token_or_command command renamer tokenid + } elseif {[llength $token_or_command] == 2} { + #command and renamer only supplied + lassign $token_or_command command renamer + set tokenid "" + } elseif {[llength $token_or_command] == 1} { + #is command name only + set command $token_or_command + set renamer [uplevel 1 [list namespace current]] + set tokenid "" + } + set command [uplevel 1 [list namespace which $command]] + variable all_stacks + variable known_renamers + if {$renamer ni $known_renamers} { + error "(commandstack::remove_rename) ERROR: renamer $renamer not in list of known_renamers '$known_renamers' for command '$command'. Ensure remove_rename called from same context as rename_command was, or explicitly supply exact token or { }" + } + if {[dict exists $all_stacks $command]} { + set stack [dict get $all_stacks $command] + if {$tokenid ne ""} { + #token_or_command is a token as returned within the rename_command result dictionary + #search first dict value + set doomed_posn [lsearch -index 1 $stack $token_or_command] + } else { + #search second dict value + set matches [lsearch -all -index 3 $stack $renamer] + set doomed_posn [lindex $matches end] ;#we don't have a full token - pop last entry for this renamer + } + if {$doomed_posn ne "" && $doomed_posn > -1} { + set doomed_record [lindex $stack $doomed_posn] + if {[llength $stack] == ($doomed_posn + 1)} { + #last on stack - put the implemenation from the doomed_record back as the actual command + uplevel #0 [list rename $command ""] + uplevel #0 [list rename [dict get $doomed_record implementation] $command] + } elseif {[llength $stack] > ($doomed_posn + 1)} { + #there is at least one more record on the stack - rewrite it to point where the doomed_record pointed + set rewrite_posn [expr {$doomed_posn + 1}] + set rewrite_record [lindex $stack $rewrite_posn] + + if {[dict get $rewrite_record next_implementor] ne $renamer} { + puts stderr "(commandstack::remove_rename) WARNING: next record on the commandstack didn't record '$renamer' as the next_implementor - not deleting implementation [dict get $rewrite_record implementation]" + } else { + uplevel #0 [list rename [dict get $rewrite_record implementation] ""] + } + dict set rewrite_record next_implementor [dict get $doomed_record next_implementor] + #don't update next_getter - it always refers to self + dict set rewrite_record implementation [dict get $doomed_record implementation] + lset stack $rewrite_posn $rewrite_record + dict set all_stacks $command $stack + } + set stack [lreplace $stack $doomed_posn $doomed_posn] + dict set all_stacks $command $stack + + } + return $stack + } + return [list] + } + + proc show_stack {{commandname_glob *}} { + variable all_stacks + if {![regexp {[?*]} $commandname_glob]} { + #if caller is attempting exact match - use the calling context to resolve in case they didn't supply namespace + set commandname_glob [uplevel 1 [list namespace which $commandname_glob]] + } + if {[package provide punk::lib] ne "" && [package provide punk] ne ""} { + #punk pipeline also needed for patterns + return [punk::lib::pdict -channel none all_stacks $commandname_glob/@*/@*.@*] + } else { + set result "" + set matchedkeys [dict keys $all_stacks $commandname_glob] + #don't try to calculate widest on empty list + if {[llength $matchedkeys]} { + set widest [tcl::mathfunc::max {*}[lmap v $matchedkeys {tcl::string::length $v}]] + set indent [string repeat " " [expr {$widest + 3}]] + set indent2 "${indent} " ;#8 spaces for " i = " where i is 4 wide + set padkey [string repeat " " 20] + foreach k $matchedkeys { + append result "$k = " + set i 0 + foreach stackmember [dict get $all_stacks $k] { + if {$i > 0} { + append result "\n$indent" + } + append result [string range "$i " 0 4] " = " + set j 0 + dict for {k v} $stackmember { + if {$j > 0} { + append result "\n$indent2" + } + set displaykey [string range "$k$padkey" 0 20] + append result "$displaykey = $v" + incr j + } + incr i + } + append result \n + } + } + return $result + } + } + + #review + #document when this is to be called. Wiping stacks without undoing renames seems odd. + proc Delete_stack {command} { + variable all_stacks + if {[dict exists $all_stacks $command]} { + dict unset all_stacks $command + return 1 + } else { + return 1 + } + } + + #can be used to temporarily put a stack aside - should manually rename back when done. + #review - document how/when to use. example? intention? + proc Rename_stack {oldname newname} { + variable all_stacks + if {[dict exists $all_stacks $oldname]} { + if {[dict exists $all_stacks $newname]} { + error "(commandstack::rename_stack) cannot rename $oldname to $newname - $newname already exists in stack" + } else { + #set stackval [dict get $all_stacks $oldname] + #dict unset all_stacks $oldname + #dict set all_stacks $newname $stackval + dict set all_stacks $newname [lindex [list [dict get $all_stacks $oldname] [dict unset all_stacks $oldname]] 0] + } + } + } +} + + + + + + + + +namespace eval commandstack::lib { + proc splitx {str {regexp {[\t \r\n]+}}} { + #snarfed from tcllib textutil::splitx to avoid the dependency + # Bugfix 476988 + if {[string length $str] == 0} { + return {} + } + if {[string length $regexp] == 0} { + return [::split $str ""] + } + if {[regexp $regexp {}]} { + return -code error "splitting on regexp \"$regexp\" would cause infinite loop" + } + + set list {} + set start 0 + while {[regexp -start $start -indices -- $regexp $str match submatch]} { + foreach {subStart subEnd} $submatch break + foreach {matchStart matchEnd} $match break + incr matchStart -1 + incr matchEnd + lappend list [string range $str $start $matchStart] + if {$subStart >= $start} { + lappend list [string range $str $subStart $subEnd] + } + set start $matchEnd + } + lappend list [string range $str $start end] + return $list + } + proc split_body {procbody} { + set marker "##" + set header "" + set code "" + set found_marker 0 + foreach ln [split $procbody \n] { + if {!$found_marker} { + if {[string trim $ln] eq $marker} { + set found_marker 1 + } else { + append header $ln \n + } + } else { + append code $ln \n + } + } + if {$found_marker} { + return [list $header $code] + } else { + return [list "" $procbody] + } + } +} + +package provide commandstack [namespace eval commandstack { + set version 0.3 +}] + + diff --git a/src/vfs/_vfscommon.vfs/modules/fauxlink-0.1.1.tm b/src/vfs/_vfscommon.vfs/modules/fauxlink-0.1.1.tm index 5d63ffef..970e47da 100644 --- a/src/vfs/_vfscommon.vfs/modules/fauxlink-0.1.1.tm +++ b/src/vfs/_vfscommon.vfs/modules/fauxlink-0.1.1.tm @@ -20,7 +20,7 @@ #[manpage_begin fauxlink_module_fauxlink 0 0.1.1] #[copyright "2024"] #[titledesc {faux link application shortcuts}] [comment {-- Name section and table of contents description --}] -#[moddesc {fauxlink .fxlnk}] [comment {-- Description at end of page heading --}] +#[moddesc {.fauxlink .fxlnk}] [comment {-- Description at end of page heading --}] #[require fauxlink] #[keywords symlink faux fake shortcut toml] #[description] @@ -29,18 +29,19 @@ #[para] A solution is required for application-driven filesystem links that survives cross platform moves as well as #[para] archiving and packaging systems. #[para] The target is specified in a minimally-encoded form in the filename itself - but still human readable. -#[para] format of name #.fxlnk +#[para] format of name #.fauxlink #[para] where can be empty - then the effective nominal name is the tail of the +#[para] The file extension must be .fauxlink or .fxlnk #[para] The + symbol substitutes for forward-slashes. #[para] Other chars can be encoded using url-like encoding - (but only up to %7E !) #[para] We deliberately treat higher % sequences literally. #[para] This means actual uri::urn encoded unicode sequences (e.g %E2%99%A5 [lb]heart[rb]) can remain literal for linking to urls. #[para] e.g if an actual + or # is required in a filename or path segment they can be encoded as %2B & %23 #[para] e.g a link to a file file#A.txt in parent dir could be: -#[para] file%23A.txt#..+file%23A.txt.fxlnk -#[para] or equivalently (but obviously affecting sorting) #..+file%23A.txt.fxlnk +#[para] file%23A.txt#..+file%23A.txt.fauxlink +#[para] or equivalently (but obviously affecting sorting) #..+file%23A.txt.fauxlink #[para] The can be unrelated to the actual target -#[para] e.g datafile.dat#..+file%23A.txt.fxlnk +#[para] e.g datafile.dat#..+file%23A.txt.fauxlink #[para] This system has no filesystem support - and must be completely application driven. #[para] This can be useful for example in application test packages which may be tarred or zipped and moved cross platform. #[para] The target being fully specified in the name means the file doesn't have to be read for the target to be determined @@ -63,9 +64,9 @@ #https://learn.microsoft.com/en-us/troubleshoot/windows-client/networking/url-encoding-unc-paths-not-url-decoded # ie "//server/c/Program files" works but "//server/c/Program%20Files" is now treated by windows as a literal path with %20 in it. #Using fauxlink - a link would be: -# "my-program-files#++server+c+Program%20Files.fxlnk" +# "my-program-files#++server+c+Program%20Files.fauxlink" #If we needed the old-style literal %20 it would become -# "my-program-files#++server+c+Program%2520Files.fxlnk" +# "my-program-files#++server+c+Program%2520Files.fauxlink" # # The file:// scheme on windows supposedly *does* decode %xx (for use in a browser) # e.g @@ -296,12 +297,12 @@ namespace eval fauxlink { set is_fauxlink 0 #we'll process anyway - but return the result wrapped #This should allow deliberate erroring for the calling dict user if the extension difference is inadvertent - #(e.g blindly processing all files in a folder that is normally only .fxlnk files - but then something added that happens + #(e.g blindly processing all files in a folder that is normally only .fauxlink files - but then something added that happens # to have # characters in it) #It also means if someone really wants to use the fauxlink semantics on a different file type # - they can - but just have to access the results differently and take that (minor) risk. #error "fauxlink::resolve refusing to process link $link - file extension must be .fxlnk or .fauxlink" - set err_extra "\nnonstandard extension '$extension_name' for fauxlink. Check that the call to fauxlink::resolve was deliberate" + set err_extra "\nnonstandard extension '$extension_name' for fauxlink. (expected .fxlnk or .fauxlink) Check that the call to fauxlink::resolve was deliberate" } else { set is_fauxlink 1 set err_extra "" @@ -318,7 +319,7 @@ namespace eval fauxlink { #if there are 4 parts - the 3rd part is a tagset where each tag begins with @ #and each subsequent part is a comment. Empty comments are stripped from the comments list #A tagset can be empty - but if it's not empty it must contain at least one @ and must start with @ - #e.g name.txt#path#@tag1@tag2#test###.fxlnk + #e.g name.txt#path#@tag1@tag2#test###.fauxlink #has a name, a target, 2 tags and one comment #check namespec already has required chars encoded diff --git a/src/vfs/_vfscommon.vfs/modules/metaface-1.2.5.tm b/src/vfs/_vfscommon.vfs/modules/metaface-1.2.5.tm index 4c88cb16..ebcf579e 100644 --- a/src/vfs/_vfscommon.vfs/modules/metaface-1.2.5.tm +++ b/src/vfs/_vfscommon.vfs/modules/metaface-1.2.5.tm @@ -1,6411 +1,6411 @@ -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 -} - - - +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/vfs/_vfscommon.vfs/modules/zipper-0.11.tm b/src/vfs/_vfscommon.vfs/modules/packageTest-0.1.1.tm similarity index 57% rename from src/vfs/_vfscommon.vfs/modules/zipper-0.11.tm rename to src/vfs/_vfscommon.vfs/modules/packageTest-0.1.1.tm index 2f72c19e1ff3e27507484b1e6fa13f6ddc982b17..b84f3fc2194d0a97df73848ac5ad657026112622 100644 GIT binary patch delta 4955 zcmb7|Ra6uX)a{1>1_TFGhGrN*x{>ZKsi9Ml7=~_?5QpxR?va*m_)`K(N=Xlbbcf_9 z>GeL`r~AEp=RBOf_F4OVuOC|N%Cw#v2W0JK>)`mNi4UiU3I!kplzN7m4Np;+J3Rvc zJYE6-yZ`{;xvRUKhr1n*hqbMf{|UG^lEjnYAg2FA8%H@jM6@i_t{K$7WFn{H{!@|2Gy9h+|D`Lx4KH6ev>ng zJv1+d-U)$d-h(Uv+)vagB2ZHJ!@7+&GPgt9lHoV&8?lIMksa_4uwHQtP-^PXREajcJSMl6707piHVnm&j=lC~HkT;YU|f zq|E(YN&N|>8qd4_@1D(mBef@M30c8eBFbJvBJVwR>%=s!RqS+mr%^l`@6Lb^&`TKT z@A@$eb7)-mS4rynArKp~+l$*1`|QvA9tjUfqkrymPJz}WJW{k3qxBVX= z_1q!<#+SB3jJ0ZJFRZRQ!HxD?F%FK7R0`rO@TI zwJ5Pg^M7NxErfAdt0*BO-i4FCE;*N0$L5al?6Ai^r)Koq0;K*F^(zE9V-u(zcIm;_ zmjUCcdB+x+L6-}8h&&%lqFL3EI2Nbpi^>H8;VCM#H0vEK{U9f1J4zgyI?&PEK_yuv z9U9ldg29uR{OP&?AnV*Jj(vOQ!_!IVs!X)dSeAv1<%^2GIuxz!mGllhM;q_1F!2Mp z)gN{iMbip5WXuC(KyiB(jf+HNsXlnA&8N=n4(Q^63hfD{ykgRw_2V6`w%rzx5pGn%KYi*G2iDr ztR;v!U9`}_pd80al8Se`1SYNsO<| zf>gUoM=SQke;`D11%Ll=yrbI)p`z?7486!&fPnCoP~FVG?FHj+_Mg?R*gXW0T?i(f zS!HjgvVbFfPfJWLAT|QgUM}$hCbaNsduSfm;tLhIrP5AAn{2+7WoQ%2+Df`l zIrSC|o%8p&I^juod?lR6{F3}3O^q6x?SKXsmu+S0cbn!}5QQCd0U2MhqzkJS)i3P$K&y&Qd6e-Amw zwxx?HbBF;%vwFNVDYC|=qykgI^g8`;F;5^?H`a4gCKPO&hx@4d{H>h_?Hz+i@9wW~ z%{e(<{6g*W)${_S0(ve>9LlUjWF*bK?VrLr_VjIHm&wbe!z_v1?@R4Wv{tLCjNP55 zD3VbASF%R>y`2FL^<@pbFVirQFMekXLe^>#6)Y9o)Z(*#Gg%GRP>8`XXnMU*mKLFJP{vCzY@A? z*BHuUjumU#5xX!xzWSFtjrDy_lqdI(Q!eg1GmoM!;tGF$4jbiPH_gp7Zi8>gqDqp# zA;P7vV9d?mV6yUNPxY87eKg3<8u6J@+gQlZ>;#**>vAjkA7zs==Af_@@tewed>l^J z@MKkIOay;~&WsICEZy|d{6hu{le;{?jy7egl94y01DBY534iDyP6|_p4~Mw_IN)-W z02jy0bQvh)Y2%hEh0aU0U!}66%=K{ugf-)(q8satr~54v?82F#3Zi8-zQ`N?4Z6wi zbrH!*v@*D}PZUT&m+@wF-39&5fa#s(3f(X4!x*9yZNj8CgibD$!L8G{I1W{Azylg> zS@g*wEB8$EO|*io3)M%_%GdE6>Z9jyh`9Hd+~xY66(tOX_uT)s?gEBdZL0d6X$8DnUl49+ymn;fqQlM9c<^2czwT!g7@N;gtJe{Sh?&alL8f-gO}$QylfHbSZU-;g#0B4-rF0 z#IRVyQ>ULqIt(8W&78qZ#$d+@jXz;If{wusS^SGO8RFbAW?@TMTE)EqiBeE38Bd0q z+(NRd>?3yVBOHk&+k)zIbCFMxfk)sfK2f+Y-4x&l)%LE-TRj>ym^0_(!3}>D3>etP?EPD#NYEfgfO`1WK`K+Z+-th_s?vtJhFTMkJ&Du-<4jE6v=I zp`&S`wWAlOcWoVPl44!C5E}RIV$MTY8W-Nhyb{pxh(ymBIXUI%qq;e5RH0K zRkh=G-%EzHLTN59uKDQzatHI*+Ewdf!K`EgeuM6y=`nL*ht_C3OIeWfKMd$hS zj>WMyY9MV;>A!^)hgnn1HXmj3Oyi2%qc^~oy3I5Z45_`nFGVeVa>yUXzCgPRLvD&O zExe5J2AFlJIf4d)VUxIpTfbu(IW-8O>+ggO9DQxN6%lq$)DdxU(o4Y+|eYkkG_qqMeAUlQG;j#X9NyY2GqhV&A#=Aj3CTFlM5 zf7i^G8C+-6f{Iw9=haTrEd$aO{xmGKZGl1vxYg!KI4X5pV~X?8g1fW(F)t126;q`^ zyt^*!duzoHdkvGzTs0p|`Ozn^!F!?h2sxB9uF;F($UpBTc03Q*l36s)F!G3wx9-b8gRD+9;vWHCEoB;t~R_~S#c!Z%$NEoDmi zfJAhG?F9j^LVk>0h4OI2geBV#&R&9>X6$<&mii`)4rQkCN=m|;8iDEg>ne%h%)QSQ zouC3iTVnb+y9iJg@gW}FfnvIUU56d&Yp~5IlZidLLB29(DL?JD3wqWv zqZ6oLHJ+R*{e&YCEL5;Xc0EdfjcuravumEh3X0il*;VU%?nBWU>3F?A!chxD*K_U@Z74FVW72*kN60Kb*|v zkjJ^-i8;dK*={;@lAnOT`{j}dPX&=3u%sirrQe8X__Ny7TlGpy=?(&m#K@U4t(;jt z1grZ-;^=xLdpyIrwxJ8!X*EC{8$^YRB+^}`??Py>=zj8k?!a2vt;;A%Eh`QyyfSG0 zB0Uj}0k-53Hdd($6RTCC{=2SUlVM@jEvuK?EK{_^!X9W!o1Eu&%IpXydnf6a*jzV) zX38WuAN}AITs1Ic!<)-)?1T)d<_df?^`HGf_VaM#fhOxY+|I9iGsP%M9;Cj8gGo{B zBoWqbq&D?=wo9#LsJP9(p_=q!Ib#z=17T!7&2hWk1nHKWFTIGq=|@2^UnmQyZZv(2 ztlRXGkx!!zx|_1@+j~h^vHJ%(3c85UZfB=&wlhieON_~iM*Qx+qz#|8)M<8lcH<+h z>-`6K*)I^h>9J8`v!tkeZ)!(KxM6?o{8F5)LVDZDxKVuWo=&kmTgfqaGdE-zvm4&r zxUB;>_>#CoRvli%470Ezl$Rv`!B=(tS%2y8er8e>;-24wfB&xm^PKldsR-lqrcCv2 z-xIzk@`eLtBKPZL?B{L|(s;uXx?@KGB5-dWZ25dGab(CG#E8O9*OqU1R6*&N_QfU` zD4U0LC1=A9&hqx+el8i~3=oe<(@O*?t8Qj@11W+gB_X>5q9#V^VZ~B|d)VN3t ziH8tX1`yij31K&ZFZUL9b6$nB6ptUXsOwuEjN@dnl>z%%PVysJC~2jPeQDNMUtDM3 z5hDtP7Dm|;US@iD@riI=LDv#|3Xe*gCA-j>aB>rj1NzdDS|4@zYyTKjd1j=4+cc^| z!W(tMg}UK*q++=jTfU=93MLD^+X_Hx602CR^UhY*F-(3R5#!o-KmWkyPgL0eBtfKK zM72M0=NY{x@W3WN+mMruT4r1~q#Es=1o+6>vc)ZaHVn#zGf#ROCOE~)Ems{GxOReo z=W9t=zb8YYSDXb*lR?Kt=CW1%6)WENlR%m+l%L}LF37~t<(;sxB;dwOywn&g>wE8H z(@!^AJR~q#h@7pOP$m&_#{e&}iD{vYKs*y&V`jtid8>--AKnjv5Br+~Loj3|nWcb9 zTS{CPs5X-(nu$c0l)}Qb!l$5mJDq$`bebgBY?=>}HML5b+S?Tb%?ewFyK~v2KbD~! zQh8ds$7#HLW~rNS1On{C;Dba;;g0Yl{f9|o7YS(=VR=D`aXflph@obUZqo&!Rf)6K zV&ALJqxU1(1#Ohz1Y;dXGxISgqR75W{~cb3?PJnl^*2~ap~gYd;b8&~uHVb(^b9$+ zl+Fgom|@9zFJrrpN2-b=gK_44&nMKk;Zcvr+LEaQN-iU;SCv?)xz3M}Qcv~ z0%5fsG+*>v+KNuo-_{q?K!>ngqcW$-KGA_IyEt$7z60m4+Tz2?i3F4WJGf~=O%w!W zNq06MeX7#=SPA`A;{<;C7odWQc;sA%J!UgShy;hxbZ>d8BO9r0gF5su!W~;90Baqg zKRc-$UGu6Vj86yAIvj;*bC`;MWeA?zT#*RJ+N?l;kKf}70>#2 zS;K!lzwYF8V2W3syIxffl?{fg9Ze?4n&5jGqJ(1744%yd61ccWfhTIO>yv+na6`VY z!LCk{^xJ@=z8Q^1X;`Ja6z;iXzFaBn@t@EkxK`wPG4w*xb@>jA)VxZf9bP|2JC2v! zlyH!Lk-2YF$vLFwJoi{l(f8LTZ0Q=_&qNfw*??5!jqfdf0$nIiMxtK}PS<2|W)3nHAbtU}Lb*@bz zQu70g6~})yRfS|vgZ)>^L7yETw$wMvFe}13>fd!v>Ytvg~U2qM2(Em;2{9B8ExAh-20|5RH;73XU delta 2676 zcma);c{tPy7sm%PV;7e!#S9_DkTtuqT@0CwEi{%v*$uMBk0wQSvW|5SCbC7gB5Rc8 z+6^jXqO8f@aJ$d@KF@vsxbOSC=lpTb`Qv>5`aI9~yL+?Hphk*@&ehGcUXF&y3otN% zOs|{Wq(MtPHKzxG8aY9r3m_0k*vrS+*T)$V>gMa~;)l2_Eh{VYAG>sbSCzGg|Ev-> zb;BO#F}91nU}d%zpGH1R4Jga=c9owst*8tY{4EuQE-{Ks6|gvc^#v1oL85nl<3&z4 z_q9)&Y(wFPF%c)gg0P7RNn%L;+he)F5S(v~`8Gbs&4&AMKqN<#ux!RN-pCyRqf zo0FaKV$V7=33V)4w<7s{F@nTuOHhDJ1n83jLQF;5GbSy#8%v*mX_Mrj&u#(DFWqm7 zA(W7f)4cF6?*;BsSj9OMv(8&Clk~55F|`S7wgb>8xBB@imd5cqIo9Q}Dz#guKK57@MHtYP?f)Ap%ZJQo%2H_DV9)j$dm-5FboZ*H03T2R+Gs5;S+A)z!zhuUx4fUI|i7(43pI+kUx1Z4AG==zLc?=i?j;^rZVju5!ZK>`Q#T z*I1|(H(!Do9j!i5*-3VZEv9w6dBL;4nG7tAHu9ZbmmsKKi&ET;cVCwQFaVoP=D^rx=6&jw<-B>R4p4p(HO?7C$h zH4MI3PJh0vH`kPjSRHqd(q#b)9p!PR%Kc6hw*FB{;K1)~?{GCAdUR}XS;7u>=J)L> zk5|5WKF6JDywb52p=RSx?Kwq({5=2>1d;8)sCb2+hB)eP-%Kg@7Y{3gES4Jhrr~Ui z$WLCLTxxb+Mh8DQN2gO7D!MGESZmrW-hIDjq!7fM!Jv_`y+H+5ONuDq<$#;KPpq=K zWL{Z@SrY7R=4JUOdrRlewKFQl$0=w9Dk^bJ`c+JIwac9N;Ph&mZ*%NNQ-IXE(fw;! zgZo9@hK{^w8K%C&#^LE z@4}C}PCohhS?o~7E$$$3LPaI8MC~`s6MC#mR@`uGd_!jMNFUryzEFtu`0d%BSY!~Z z^;WFN#Nk$KU~GyGIE7o06M#e*-Y0X`IR0@Vufg1a+Cq_s_&Izre0nX=DW3!)>Zbn4FQr1|imZObM7PqnnZ=nX4a%|* z}ZQ(9=YWx~^Lh_X<3E2k3R`SLS>ax*L@D>3mRoTLmYqZ+BZz0b(eF=#b zQ69_Imo+E|rd@7}c|+|ScC@fHr@kVNw5N;nodi1+OdV59uy*H{k$caBTRugF3OHm; zPCH2Nu^vX>o(>(F^!{4&34z@Z-|v!Iz~3aosrjx7S9Gyp!fFjRvO;bZ%G*mE{|-0R zuU9D8$^v?BVFwDs)*=SC6^&NzslzrKEc^uO`mGPony6J}en~UFPO#sQe!VS>_Q$xB z6KaQ+AclFYz-`qk%?Zf*Lw;-d#dgWJ_xSBF2jC+J=jA@@`ExHsRRgKs(NK1PEuLgI zP^#<2yGQ8jxKw@Dd@v11?BbDrfr~A$>4qVZ!3=$G>TtUdYI{7rrE-W8V%*x2? zLl<06K`100mY>A$a zecqWhvF80yKE^wI39?B~=t)(^ipn5#Cf)t%0Hsh2;I14w zR^DJY`dM4-K~e(TK0J88vT?LvBKjHP>_cr~4iz@mSgBqchC`ciBWy^-gF9+>6D_>? zEHQr1rA02v@I`ZpAs3wY>VQYc4o7pn;QO?yCe#tCM;R?4^+j`kE}AYg~8K!jR=*xa8M1ciBYX zaoUjx?cq9rSk>x>QPS|yA1+GoQ0YIB5SmHGy@yWG_Y@#U^K7*$eO?3ipi{(I|Bu_W zpD-c=SL6MQ9nI|h?ZtA6Yf~G)*Z6PT^)W&i*H diff --git a/src/vfs/_vfscommon.vfs/modules/pattern-1.2.4.tm b/src/vfs/_vfscommon.vfs/modules/pattern-1.2.4.tm index 5d76af04..d6a9c932 100644 --- a/src/vfs/_vfscommon.vfs/modules/pattern-1.2.4.tm +++ b/src/vfs/_vfscommon.vfs/modules/pattern-1.2.4.tm @@ -1,1285 +1,1285 @@ -#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 +#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/vfs/_vfscommon.vfs/modules/patterncmd-1.2.4.tm b/src/vfs/_vfscommon.vfs/modules/patterncmd-1.2.4.tm index 4107b8af..ca061a7c 100644 --- a/src/vfs/_vfscommon.vfs/modules/patterncmd-1.2.4.tm +++ b/src/vfs/_vfscommon.vfs/modules/patterncmd-1.2.4.tm @@ -1,645 +1,645 @@ -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 - } - - - +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/patternpredator2-1.2.4.tm b/src/vfs/_vfscommon.vfs/modules/patternpredator2-1.2.4.tm index 457d5742..680ea88f 100644 --- a/src/vfs/_vfscommon.vfs/modules/patternpredator2-1.2.4.tm +++ b/src/vfs/_vfscommon.vfs/modules/patternpredator2-1.2.4.tm @@ -1,754 +1,754 @@ -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 -} +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 b/src/vfs/_vfscommon.vfs/modules/punk-0.1.tm index 11d247a7..04efdc83 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk-0.1.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk-0.1.tm @@ -141,6 +141,7 @@ namespace eval punk { } if {[llength [file split $name]] != 1} { + #has a path foreach ext $execExtensions { set file ${name}${ext} if {[file exists $file] && ![file isdirectory $file]} { @@ -164,14 +165,20 @@ namespace eval punk { } foreach var {PATH Path path} { - if {[info exists env($var)]} { - append path ";$env($var)" - } + if {[info exists env($var)]} { + append path ";$env($var)" + } } #change2 - set lookfor [lmap ext $execExtensions {string cat ${name} ${ext}}] + if {[file extension $name] ne "" && [string tolower [file extension $name]] in [string tolower $execExtensions]} { + set lookfor [list $name] + } else { + set lookfor [lmap ext $execExtensions {string cat ${name} ${ext}}] + } + #puts "-->$lookfor" foreach dir [split $path {;}] { + set dir [string trim $dir {\\}] ;#trailing slash will result in a tail such as "/python.exe" #set dir [file normalize $dir] # Skip already checked directories if {[info exists checked($dir)] || ($dir eq "")} { @@ -179,6 +186,24 @@ namespace eval punk { } set checked($dir) {} + #surprisingly fast + #set matches [glob -nocomplain -dir $dir -types f -tails {*}$lookfor] + ##puts "--dir $dir matches:$matches" + #if {[llength $matches]} { + # set file [file join $dir [lindex $matches 0]] + # #puts "--match0:[lindex $matches 0] file:$file" + # return [set auto_execs($name) [list $file]] + #} + + #what if it's a link? + #foreach match [glob -nocomplain -dir $dir -types f -tail {*}$lookfor] { + # set file [file join $dir $match] + # if {[file exists $file]} { + # return [set auto_execs($name) [list $file]] + # } + #} + + #safest? could be a link? foreach match [glob -nocomplain -dir $dir -tail {*}$lookfor] { set file [file join $dir $match] if {[file exists $file] && ![file isdirectory $file]} { @@ -6775,31 +6800,36 @@ namespace eval punk { } + punk::args::define { + @dynamic + @id -id ::punk::LOC + @cmd -name punk::LOC -help\ + "LOC - lines of code. + An implementation of a notoriously controversial metric" + -return -default showdict -choices {dict showdict} + -dir -default "\uFFFF" + -exclude_dupfiles -default 1 -type boolean + ${[punk::args::resolved_def -types opts ::punk::path::treefilenames -antiglob_paths]} + -antiglob_files -default "" -type list -help\ + "Exclude if file tail matches any of these patterns" + -exclude_punctlines -default 1 -type boolean + -show_largest -default 0 -type integer -help\ + "Report the top largest linecount files. + The value represents the number of files + to report on." + } " + #we could map away whitespace and use string is punct - but not as flexible? review + -punctchars -default { [list \{ \} \" \\ - _ + = . > , < ' : \; ` ~ ! @ # \$ % ^ & * \[ \] ( ) | / ?] } + " #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] + set argd [punk::args::parse $args withid ::punk::LOC] lassign [dict values $argd] leaders opts values received set searchspecs [dict values $values] # -- --- --- --- --- --- - set opt_dir [dict get $opts -dir] + set opt_return [dict get $opts -return] + set opt_dir [dict get $opts -dir] if {$opt_dir eq "\uFFFF"} { set opt_dir [pwd] ;#pwd can take over a ms on windows in a not terribly deep path even with SSDs - so as a general rule we don't use it in the original defaults list } @@ -6808,10 +6838,12 @@ namespace eval punk { 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 opt_antiglob_paths [dict get $opts -antiglob_paths] + set opt_antiglob_files [dict get $opts -antiglob_files] # -- --- --- --- --- --- - set filepaths [punk::path::treefilenames -dir $opt_dir {*}$searchspecs] + set filepaths [punk::path::treefilenames -dir $opt_dir -antiglob_paths $opt_antiglob_paths -antiglob_files $opt_antiglob_files {*}$searchspecs] set loc 0 set dupfileloc 0 set seentails [dict create] @@ -6941,6 +6973,9 @@ namespace eval punk { } dict set result largest $largest_n } + if {$opt_return eq "showdict"} { + return [punk::lib::showdict $result @@dupinfo/*/* !@@dupinfo] + } return $result } diff --git a/src/vfs/_vfscommon.vfs/modules/punk/ansi-0.1.1.tm b/src/vfs/_vfscommon.vfs/modules/punk/ansi-0.1.1.tm index 50ea5082..61a454fa 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/ansi-0.1.1.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/ansi-0.1.1.tm @@ -2469,7 +2469,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu } if {$pretty} { #return [pdict -channel none sgr_cache */%str,%ansiview] - return [pdict -channel none sgr_cache */%rpadstr-"sample",%ansiviewstyle] + return [punk::lib::pdict -channel none sgr_cache */%rpadstr-"sample",%ansiviewstyle] } if {[catch { @@ -5116,6 +5116,7 @@ tcl::namespace::eval punk::ansi::ta { # arrow keys -> ESC O A, ESC O B, ESC O C, ESC O D # plus more for auxiliary keypad codes in keypad application mode (and some in numeric mode) + #regexp expanded syntax = ?x variable re_ansi_detect {(?x) (?:\x1b(?:\[(?:[\x20-\x2f\x30-\x3f]*[\x40-\x7e])|c|7|8|M|D|E|H|=|>|<|A|B|C|I|J|K|L|M|Z|(?:Y(?:..))|(?:b(?:.))|\((?:0|B)|\](?:(?:[^\007]*)\007|(?:(?!\x1b\\).)*\x1b\\)|(?:P|X|\^|_)(?:(?:(?!\x1b\\|\007).)*(?:\x1b\\|\007))|(?:\#(?:3|4|5|6|8)))) |(?:\u0090|\u0098|\u009E|\u009F)(?:(?!\u009c).)*(?:\u009c) diff --git a/src/vfs/_vfscommon.vfs/modules/punk/cap/handlers/templates-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/punk/cap/handlers/templates-0.1.0.tm index 60764f07..aaa595ae 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/cap/handlers/templates-0.1.0.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/cap/handlers/templates-0.1.0.tm @@ -108,8 +108,10 @@ namespace eval punk::cap::handlers::templates { #todo - handle wrapped or unwrapped tarjar files - in which case we have to adjust tmfolder appropriately #set tpath [file normalize [file join $tmfile [dict get $capdict relpath]]] ;#relpath is relative to the tm *file* - not it's containing folder - set projectinfo [punk::repo::find_repos $tmfolder] - set projectbase [dict get $projectinfo closest] + #set projectinfo [punk::repo::find_repos $tmfolder] ;#slow - REVIEW + #set projectbase [dict get $projectinfo closest] + set projectbase [punk::repo::find_project $tmfolder] + #store the projectbase even if it's empty string set extended_capdict $capdict set resolved_path [file join $tmfolder $path] @@ -148,8 +150,9 @@ namespace eval punk::cap::handlers::templates { return 0 } set shellbase [file dirname [file dirname [file normalize [set ::argv0]/__]]] ;#review - set projectinfo [punk::repo::find_repos $shellbase] - set projectbase [dict get $projectinfo closest] + #set projectinfo [punk::repo::find_repos $shellbase] + #set projectbase [dict get $projectinfo closest] + set projectbase [punk::repo::find_project $shellbase] set extended_capdict $capdict dict set extended_capdict vendor $vendor @@ -166,8 +169,9 @@ namespace eval punk::cap::handlers::templates { return 0 } set shellbase [file dirname [file dirname [file normalize [set ::argv0]/__]]] ;#review - set projectinfo [punk::repo::find_repos $shellbase] - set projectbase [dict get $projectinfo closest] + #set projectinfo [punk::repo::find_repos $shellbase] + #set projectbase [dict get $projectinfo closest] + set projectbase [punk::repo::find_project $shellbase] set extended_capdict $capdict dict set extended_capdict vendor $vendor @@ -183,8 +187,9 @@ namespace eval punk::cap::handlers::templates { puts stderr "punk::cap::handlers::templates::capsystem::pkg_register WARNING - package '$pkg' is attempting to register with punk::cap as a provider of '$capname' capability but provided a path '$path' which doesn't seem to exist" return 0 } - set projectinfo [punk::repo::find_repos $normpath] - set projectbase [dict get $projectinfo closest] + #set projectinfo [punk::repo::find_repos $normpath] + #set projectbase [dict get $projectinfo closest] + set projectbase [punk::repo::find_project $normpath] #todo - verify no other provider has registered same absolute path - if sharing a project-external location is needed - they need their own subfolder set extended_capdict $capdict @@ -244,6 +249,18 @@ namespace eval punk::cap::handlers::templates { # -- --- --- --- --- --- --- namespace export * namespace eval class { + variable PUNKARGS + #set argd [punk::args::get_dict { + # @id -id "::punk::cap::handlers::templates::class::api folders" + # -startdir -default "" + # @values -max 0 + #} $args] + lappend PUNKARGS [list { + @id -id "::punk::cap::handlers::templates::class::api folders" + -startdir -default "" + @values -max 0 + }] + oo::class create api { #return a dict keyed on folder with source pkg as value constructor {capname} { @@ -253,11 +270,8 @@ namespace eval punk::cap::handlers::templates { set capabilityname $capname } method folders {args} { - set argd [punk::args::get_dict { - @id -id "::punk::cap::handlers::templates::class::api folders" - -startdir -default "" - @values -max 0 - } $args] + #puts "--folders $args" + set argd [punk::args::parse $args withid "::punk::cap::handlers::templates::class::api folders"] set opts [dict get $argd opts] set opt_startdir [dict get $opts -startdir] @@ -270,6 +284,10 @@ namespace eval punk::cap::handlers::templates { set startdir $opt_startdir } } + set searchbase $startdir + #set pathinfo [punk::repo::find_repos $searchbase] ;#relatively slow! REVIEW - pass as arg? cache? + #set pwd_projectroot [dict get $pathinfo closest] + set pwd_projectroot [punk::repo::find_project $searchbase] variable capabilityname @@ -314,9 +332,9 @@ namespace eval punk::cap::handlers::templates { set module_projectroot [dict get $capdecl_extended projectbase] dict lappend found_paths_module $vendor [list pkg $pkg path [dict get $capdecl_extended resolved_path] pathtype $pathtype projectbase $module_projectroot] } elseif {$pathtype eq "currentproject_multivendor"} { - set searchbase $startdir - set pathinfo [punk::repo::find_repos $searchbase] - set pwd_projectroot [dict get $pathinfo closest] + #set searchbase $startdir + #set pathinfo [punk::repo::find_repos $searchbase] + #set pwd_projectroot [dict get $pathinfo closest] if {$pwd_projectroot ne ""} { set deckbase [file join $pwd_projectroot $path] if {![file exists $deckbase]} { @@ -349,9 +367,9 @@ namespace eval punk::cap::handlers::templates { } } } elseif {$pathtype eq "currentproject"} { - set searchbase $startdir - set pathinfo [punk::repo::find_repos $searchbase] - set pwd_projectroot [dict get $pathinfo closest] + #set searchbase $startdir + #set pathinfo [punk::repo::find_repos $searchbase] + #set pwd_projectroot [dict get $pathinfo closest] if {$pwd_projectroot ne ""} { #path relative to projectroot already validated by handler as being within a currentproject_multivendor tree set targetfolder [file join $pwd_projectroot $path] @@ -489,8 +507,9 @@ namespace eval punk::cap::handlers::templates { set refdict [my get_itemdict_projectlayoutrefs {*}$args] set layoutdict [dict create] - set projectinfo [punk::repo::find_repos $searchbase] - set projectroot [dict get $projectinfo closest] + #set projectinfo [punk::repo::find_repos $searchbase] + #set projectroot [dict get $projectinfo closest] + set projectroot [punk::repo::find_project $searchbase] dict for {layoutname refinfo} $refdict { set templatepathtype [dict get $refinfo sourceinfo pathtype] @@ -760,6 +779,10 @@ namespace eval punk::cap::handlers::templates { } +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::cap::handlers::templates ::punk::cap::handlers::templates::class +} # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ ## Ready diff --git a/src/vfs/_vfscommon.vfs/modules/punk/config-0.1.tm b/src/vfs/_vfscommon.vfs/modules/punk/config-0.1.tm index ac70e97b..5532cb80 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/config-0.1.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/config-0.1.tm @@ -1,487 +1,487 @@ - -tcl::namespace::eval punk::config { - variable loaded - variable startup ;#include env overrides - variable running - variable punk_env_vars - variable other_env_vars - - variable vars - - namespace export {[a-z]*} - - #todo - XDG_DATA_HOME etc - #https://specifications.freedesktop.org/basedir-spec/latest/ - # see also: http://hiphish.github.io/blog/2020/08/30/dotfiles-were-a-mistake/ - - proc init {} { - variable defaults - variable startup - variable running - variable punk_env_vars - variable punk_env_vars_config - variable other_env_vars - variable other_env_vars_config - - set exename "" - catch { - #catch for safe interps - #safe base will return empty string, ordinary safe interp will raise error - set exename [tcl::info::nameofexecutable] - } - if {$exename ne ""} { - set exefolder [file dirname $exename] - #default file logs to logs folder at same level as exe if writable, or empty string - set log_folder [file normalize $exefolder/../logs] ;#~2ms - #tcl::dict::set startup scriptlib $exefolder/scriptlib - #tcl::dict::set startup apps $exefolder/../../punkapps - - #todo - use punk main.tcl location instead - exefolder doesn't work if system tclsh used etc - set default_scriptlib $exefolder/scriptlib - set default_apps $exefolder/../../punkapps - if {[file isdirectory $log_folder] && [file writable $log_folder]} { - #tcl::dict::set startup logfile_stdout $log_folder/repl-exec-stdout.txt - #tcl::dict::set startup logfile_stderr $log_folder/repl-exec-stderr.txt - set default_logfile_stdout $log_folder/repl-exec-stdout.txt - set default_logfile_stderr $log_folder/repl-exec-stderr.txt - } else { - set default_logfile_stdout "" - set default_logfile_stderr "" - } - } else { - #probably a safe interp - which cannot access info nameofexecutable even if access given to the location via punk::island - #review - todo? - #tcl::dict::set startup scriptlib "" - #tcl::dict::set startup apps "" - set default_scriptlib "" - set default_apps "" - set default_logfile_stdout "" - set default_logfile_stderr "" - } - - # auto_exec_mechanism ;#whether to use exec instead of experimental shellfilter::run - - #optional channel transforms on stdout/stderr. - #can sometimes be useful to distinguish eventloop stdout/stderr writes compared to those triggered directly from repl commands - #If no distinction necessary - should use default_color_ - #The counterpart: default_color__repl is a transform that is added and removed with each repl evaluation. - #startup color_stdout - parameters as suitable for punk::ansi::a+ (test with 'punk::ansi::a?') e.g "cyan bold" ;#not a good idea to default - set default_color_stdout brightwhite ;#stdout colour including background calls (after etc) - set default_color_stdout_repl "" ;#stdout colour applied during direct repl call only - #This wraps the stderr stream as it comes in with Ansi - probably best to default to empty.. but it's useful. - #set default_color_stderr "red bold" - #set default_color_stderr "web-lightsalmon" - set default_color_stderr yellow ;#limit to basic colours for wider terminal support. yellow = term-olive - set default_color_stderr_repl "" ;#during repl call only - - set homedir "" - if {[catch { - #depending on which build of tcl - some safe interps prior to bugfix https://core.tcl-lang.org/tcl/info/3aa487993f will return a homedir value in an unmodified safe interp - #other 'safe' interps may have explicitly made this available - we shouldn't override that decision here using interp issafe so we can't compensate for versions which shouldn't really be returning this in the safe interp - set homedir [file home] - } errM]} { - #tcl 8.6 doesn't have file home.. try again - if {[info exists ::env(HOME)]} { - set homedir $::env(HOME) - } - } - - - # per user xdg vars - # --- - set default_xdg_config_home "" ;#config data - portable - set default_xdg_data_home "" ;#data the user likely to want to be portable - set default_xdg_cache_home "" ;#local cache - set default_xdg_state_home "" ;#persistent user data such as logs, but not as important or as portable as those in xdg_data_home - # --- - set default_xdg_data_dirs "" ;#non-user specific - #xdg_config_dirs ? - #xdg_runtime_dir ? - - - #review. we are assuming if we can't get a home dir - then all the xdg vars including xdg_data_dirs aren't likely to be useful (as presumably filesystem access is absent) - #(safe interp generally won't have access to ::env either) - #This coupling doesn't necessarily hold - its possible the relevant env vars were copied to a safe interp - although that would be a policy that would make disabling 'info home' inconsistent. - if {$homedir ne ""} { - if {"windows" eq $::tcl_platform(platform)} { - #as much as I'd prefer to use ~/.local/share and ~/.config to keep them more consistent with unixlike platforms - the vast majority of apps put them where microsoft wants them. - #we have a choice of LOCALAPPDATA vs APPDATA (local to machine vs potentially roaming/redirected in a corporate environment) - #using the roaming location should not impact users who aren't using a domain controller but is potentially much more convenient for those who do. - if {[info exists ::env(APPDATA)]} { - set default_xdg_config_home $::env(APPDATA) - set default_xdg_data_home $::env(APPDATA) - } - - #The xdg_cache_home should be kept local - if {[info exists ::env(LOCALAPPDATA)]} { - set default_xdg_cache_home $::env(LOCALAPPDATA) - set default_xdg_state_home $::env(LOCALAPPDATA) - } - - if {[info exists ::env(PROGRAMDATA)]} { - #- equiv env(ALLUSERSPROFILE) ? - set default_xdg_data_dirs $::env(PROGRAMDATA) - } - - } else { - #follow defaults as specified on freedesktop.org e.g https://specifications.freedesktop.org/basedir-spec/latest/ar01s03.html - set default_xdg_config_home [file join $homedir .config] - set default_xdg_data_home [file join $homedir .local share] - set default_xdg_cache_home [file join $homedir .cache] - set default_xdg_state_home [file join $homedir .local state] - set default_xdg_data_dirs /usr/local/share - } - } - - set defaults [dict create\ - apps $default_apps\ - config ""\ - configset ".punkshell"\ - scriptlib $default_scriptlib\ - color_stdout $default_color_stdout\ - color_stdout_repl $default_color_stdout_repl\ - color_stderr $default_color_stderr\ - color_stderr_repl $default_color_stderr_repl\ - logfile_stdout $default_logfile_stdout\ - logfile_stderr $default_logfile_stderr\ - logfile_active 0\ - syslog_stdout "127.0.0.1:514"\ - syslog_stderr "127.0.0.1:514"\ - syslog_active 0\ - auto_exec_mechanism exec\ - auto_noexec 0\ - xdg_config_home $default_xdg_config_home\ - xdg_data_home $default_xdg_data_home\ - xdg_cache_home $default_xdg_cache_home\ - xdg_state_home $default_xdg_state_home\ - xdg_data_dirs $default_xdg_data_dirs\ - theme_posh_override ""\ - posh_theme ""\ - posh_themes_path ""\ - ] - - set startup $defaults - #load values from saved config file - $xdg_config_home/punk/punk.config ? - #typically we want env vars to override the stored config - as env vars conventionally used on some commandlines. - #that's possibly ok for the PUNK_ vars - #however.. others like the xdg vars and NOCOLOR may apply to other apps.. and we may want to override them from the saved config? - #making some env vars override saved config values and some not would be potentially confusing. may need one/more specific settings or env vars to determine which takes precedence? - #simpler is probably just to let env vars take precedence - and warn when saving or viewing config that the saved values are being overridden - #- requiring user to manually unset any unwanted env vars when launching? - - #we are likely to want the saved configs for subshells/decks to override them however. - - #todo - load/save config file - - #todo - define which configvars are settable in env - #list of varname varinfo where varinfo is a sub dictionary (type key is mandatory, with value from: string,pathlist,boolean) - set punk_env_vars_config [dict create \ - PUNK_APPS {type pathlist}\ - PUNK_CONFIG {type string}\ - PUNK_CONFIGSET {type string}\ - PUNK_SCRIPTLIB {type string}\ - PUNK_AUTO_EXEC_MECHANISM {type string}\ - PUNK_AUTO_NOEXEC {type string default 0 help "set 1 to set Tcl's ::auto_noexec true.\nStops 'unknown' from running external programs"}\ - PUNK_COLOR_STDERR {type string help "stderr colour transform. Use 'punk::ansi::a?' to see colour names"}\ - PUNK_COLOR_STDERR_REPL {type string help "stderr colour transform only while command running (not active during 'after')"}\ - PUNK_COLOR_STDOUT {type string help "stdout colour transform. Use 'punk::ansi::a?' to see colour names"}\ - PUNK_COLOR_STDOUT_REPL {type string help "stdout colour transform only while command running (not active during 'after')"}\ - PUNK_LOGFILE_STDOUT {type string}\ - PUNK_LOGFILE_STDERR {type string}\ - PUNK_LOGFILE_ACTIVE {type string}\ - PUNK_SYSLOG_STDOUT {type string}\ - PUNK_SYSLOG_STDERR {type string}\ - PUNK_SYSLOG_ACTIVE {type string}\ - PUNK_THEME_POSH_OVERRIDE {type string}\ - ] - set punk_env_vars [dict keys $punk_env_vars_config] - - #override with env vars if set - foreach {evar varinfo} $punk_env_vars_config { - if {[info exists ::env($evar)]} { - set vartype [dict get $varinfo type] - set f [set ::env($evar)] - if {$f ne "default"} { - #e.g PUNK_SCRIPTLIB -> scriptlib - set varname [tcl::string::tolower [tcl::string::range $evar 5 end]] - if {$vartype eq "pathlist"} { - #colon vs semicolon path sep is problematic for windows environments where unix-like systems such as cygwin/wsl are used and a variable may be set for either the native path separator or the unix-like system - #Even without the colon vs semicolon issue, native vs unix-like paths on windows mixed environment systems can cause grief. - #For now at least, we will simply respect the platform pathSeparator and hope the user manages the environment variables appropriately. - #some programs do automatic translation - which is a nice idea in principle - but is also prone to error as we don't know if it's already occurred or not depending on how things are launched. - #An example of where this sort of thing can go wrong is env(TCLLIBPATH) - which is defined as a space separated list not requiring further splitting - # - but some programs have been known to split this value on colon anyway, which breaks things on windows. - set paths [split $f $::tcl_platform(pathSeparator)] - set final [list] - #eliminate empty values (leading or trailing or extraneous separators) - foreach p $paths { - if {[tcl::string::trim $p] ne ""} { - lappend final $p - } - } - tcl::dict::set startup $varname $final - } else { - tcl::dict::set startup $varname $f - } - } - } - } - - # https://no-color.org - #if {[info exists ::env(NO_COLOR)]} { - # if {$::env(NO_COLOR) ne ""} { - # set colour_disabled 1 - # } - #} - set other_env_vars_config [dict create\ - NO_COLOR {type string}\ - XDG_CONFIG_HOME {type string}\ - XDG_DATA_HOME {type string}\ - XDG_CACHE_HOME {type string}\ - XDG_STATE_HOME {type string}\ - XDG_DATA_DIRS {type pathlist}\ - POSH_THEME {type string}\ - POSH_THEMES_PATH {type string}\ - TCLLIBPATH {type string}\ - ] - lassign [split [info tclversion] .] tclmajorv tclminorv - #don't rely on lseq or punk::lib for now.. - set relevant_minors [list] - for {set i 0} {$i <= $tclminorv} {incr i} { - lappend relevant_minors $i - } - foreach minor $relevant_minors { - set vname TCL${tclmajorv}_${minor}_TM_PATH - if {$minor eq $tclminorv || [info exists ::env($vname)]} { - dict set other_env_vars_config $vname {type string} - } - } - set other_env_vars [dict keys $other_env_vars_config] - - foreach {evar varinfo} $other_env_vars_config { - if {[info exists ::env($evar)]} { - set vartype [dict get $varinfo type] - set f [set ::env($evar)] - if {$f ne "default"} { - set varname [tcl::string::tolower $evar] - if {$vartype eq "pathlist"} { - set paths [split $f $::tcl_platform(pathSeparator)] - set final [list] - #eliminate empty values (leading or trailing or extraneous separators) - foreach p $paths { - if {[tcl::string::trim $p] ne ""} { - lappend final $p - } - } - tcl::dict::set startup $varname $final - } else { - tcl::dict::set startup $varname $f - } - } - } - } - - - #unset -nocomplain vars - - #todo - set running [tcl::dict::create] - set running [tcl::dict::merge $running $startup] - } - init - - #todo - proc Apply {config} { - puts stderr "punk::config::Apply partially implemented" - set configname [string map {-config ""} $config] - if {$configname in {startup running}} { - upvar ::punk::config::$configname applyconfig - - if {[dict exists $applyconfig auto_noexec]} { - set auto [dict get $applyconfig auto_noexec] - if {![string is boolean -strict $auto]} { - error "config::Apply error - invalid data for auto_noexec:'$auto' - expected boolean" - } - if {$auto} { - set ::auto_noexec 1 - } else { - #puts "auto_noexec false" - unset -nocomplain ::auto_noexec - } - } - - } else { - error "no config named '$config' found" - } - return "apply done" - } - Apply startup - - #todo - consider how to divide up settings, categories, 'devices', decks etc - proc get_running_global {varname} { - variable running - if {[dict exists $running $varname]} { - return [dict get $running $varname] - } - error "No such global configuration item '$varname' found in running config" - } - proc get_startup_global {varname} { - variable startup - if {[dict exists $startup $varname]} { - return [dict get $startup $varname] - } - error "No such global configuration item '$varname' found in startup config" - } - - proc get {whichconfig {globfor *}} { - variable startup - variable running - switch -- $whichconfig { - config - startup - startup-config - startup-configuration { - #show *startup* config - different behaviour may be confusing to those used to router startup and running configs - set configdata $startup - } - running - running-config - running-configuration { - set configdata $running - } - default { - error "Unknown config name '$whichconfig' - try startup or running" - } - } - if {$globfor eq "*"} { - return $configdata - } else { - set keys [dict keys $configdata [string tolower $globfor]] - set filtered [dict create] - foreach k $keys { - dict set filtered $k [dict get $configdata $k] - } - return $filtered - } - } - - proc configure {args} { - set argdef { - @id -id ::punk::config::configure - @cmd -name punk::config::configure -help\ - "UNIMPLEMENTED" - @values -min 1 -max 1 - whichconfig -type string -choices {startup running stop} - } - set argd [punk::args::get_dict $argdef $args] - return "unimplemented - $argd" - } - - proc show {whichconfig {globfor *}} { - #todo - tables for console - set configdata [punk::config::get $whichconfig $globfor] - return [punk::lib::showdict $configdata] - } - - - - #e.g - # copy running-config startup-config - # copy startup-config test-config.cfg - # copy backup-config.cfg running-config - #review - consider the merge vs overwrite feature of some routers.. where copy to running-config does a merge rather than an overwrite - #This is to allow partial configs to be loaded to running, whereas a save of running to any target is always a complete configuration - proc copy {args} { - set argdef { - @id -id ::punk::config::copy - @cmd -name punk::config::copy -help\ - "Copy a partial or full configuration from one config to another - If a target config has additional settings, then the source config can be considered to be partial with regards to the target. - " - -type -default "" -choices {replace merge} -help\ - "Defaults to merge when target is running-config - Defaults to replace when source is running-config" - @values -min 2 -max 2 - fromconfig -help\ - "running or startup or file name (not fully implemented)" - toconfig -help\ - "running or startup or file name (not fully implemented)" - } - set argd [punk::args::get_dict $argdef $args] - set fromconfig [dict get $argd values fromconfig] - set toconfig [dict get $argd values toconfig] - set fromconfig [string map {-config ""} $fromconfig] - set toconfig [string map {-config ""} $toconfig] - - set copytype [dict get $argd opts -type] - - - #todo - warn & prompt if doing merge copy to startup - switch -exact -- $fromconfig-$toconfig { - running-startup { - if {$copytype eq ""} { - set copytype replace ;#full configuration - } - if {$copytype eq "replace"} { - error "punk::config::copy error. full configuration copy from running to startup config not yet supported" - } else { - error "punk::config::copy error. merge configuration copy from running to startup config not yet supported" - } - } - startup-running { - #default type merge - even though it's not always what is desired - if {$copytype eq ""} { - set copytype merge ;#load in a partial configuration - } - - #warn/prompt either way - if {$copytype eq "replace"} { - #some routers require use of a separate command for this branch. - #presumably to ensure the user doesn't accidentally load partials onto a running system - # - error "punk::config::copy error. full configuration copy from startup to overwrite running config not supported" - } else { - error "punk::config::copy error. merge copy from possibly partial configuration: startup to running config not currently supported" - } - } - default { - error "punk::config::copy error. copy must from running to startup or startup to running. File sources/targets not yet supported" - } - } - } - - - - - -} - - - - - -#todo - move to cli? -::tcl::namespace::eval punk::config { - #todo - something better - 'previous' rather than reverting to startup - proc channelcolors {{onoff {}}} { - variable running - variable startup - - if {![string length $onoff]} { - return [list stdout [dict get $running color_stdout] stderr [dict get $running color_stderr]] - } else { - if {![string is boolean $onoff]} { - error "channelcolors: invalid value $onoff - expected boolean: true|false|on|off|1|0|yes|no" - } - if {$onoff} { - dict set running color_stdout [dict get $startup color_stdout] - dict set running color_stderr [dict get $startup color_stderr] - } else { - dict set running color_stdout "" - dict set running color_stderr "" - } - } - return [list stdout [dict get $running color_stdout] stderr [dict get $running color_stderr]] - } -} - -package provide punk::config [tcl::namespace::eval punk::config { - variable version - set version 0.1 - + +tcl::namespace::eval punk::config { + variable loaded + variable startup ;#include env overrides + variable running + variable punk_env_vars + variable other_env_vars + + variable vars + + namespace export {[a-z]*} + + #todo - XDG_DATA_HOME etc + #https://specifications.freedesktop.org/basedir-spec/latest/ + # see also: http://hiphish.github.io/blog/2020/08/30/dotfiles-were-a-mistake/ + + proc init {} { + variable defaults + variable startup + variable running + variable punk_env_vars + variable punk_env_vars_config + variable other_env_vars + variable other_env_vars_config + + set exename "" + catch { + #catch for safe interps + #safe base will return empty string, ordinary safe interp will raise error + set exename [tcl::info::nameofexecutable] + } + if {$exename ne ""} { + set exefolder [file dirname $exename] + #default file logs to logs folder at same level as exe if writable, or empty string + set log_folder [file normalize $exefolder/../logs] ;#~2ms + #tcl::dict::set startup scriptlib $exefolder/scriptlib + #tcl::dict::set startup apps $exefolder/../../punkapps + + #todo - use punk main.tcl location instead - exefolder doesn't work if system tclsh used etc + set default_scriptlib $exefolder/scriptlib + set default_apps $exefolder/../../punkapps + if {[file isdirectory $log_folder] && [file writable $log_folder]} { + #tcl::dict::set startup logfile_stdout $log_folder/repl-exec-stdout.txt + #tcl::dict::set startup logfile_stderr $log_folder/repl-exec-stderr.txt + set default_logfile_stdout $log_folder/repl-exec-stdout.txt + set default_logfile_stderr $log_folder/repl-exec-stderr.txt + } else { + set default_logfile_stdout "" + set default_logfile_stderr "" + } + } else { + #probably a safe interp - which cannot access info nameofexecutable even if access given to the location via punk::island + #review - todo? + #tcl::dict::set startup scriptlib "" + #tcl::dict::set startup apps "" + set default_scriptlib "" + set default_apps "" + set default_logfile_stdout "" + set default_logfile_stderr "" + } + + # auto_exec_mechanism ;#whether to use exec instead of experimental shellfilter::run + + #optional channel transforms on stdout/stderr. + #can sometimes be useful to distinguish eventloop stdout/stderr writes compared to those triggered directly from repl commands + #If no distinction necessary - should use default_color_ + #The counterpart: default_color__repl is a transform that is added and removed with each repl evaluation. + #startup color_stdout - parameters as suitable for punk::ansi::a+ (test with 'punk::ansi::a?') e.g "cyan bold" ;#not a good idea to default + set default_color_stdout brightwhite ;#stdout colour including background calls (after etc) + set default_color_stdout_repl "" ;#stdout colour applied during direct repl call only + #This wraps the stderr stream as it comes in with Ansi - probably best to default to empty.. but it's useful. + #set default_color_stderr "red bold" + #set default_color_stderr "web-lightsalmon" + set default_color_stderr yellow ;#limit to basic colours for wider terminal support. yellow = term-olive + set default_color_stderr_repl "" ;#during repl call only + + set homedir "" + if {[catch { + #depending on which build of tcl - some safe interps prior to bugfix https://core.tcl-lang.org/tcl/info/3aa487993f will return a homedir value in an unmodified safe interp + #other 'safe' interps may have explicitly made this available - we shouldn't override that decision here using interp issafe so we can't compensate for versions which shouldn't really be returning this in the safe interp + set homedir [file home] + } errM]} { + #tcl 8.6 doesn't have file home.. try again + if {[info exists ::env(HOME)]} { + set homedir $::env(HOME) + } + } + + + # per user xdg vars + # --- + set default_xdg_config_home "" ;#config data - portable + set default_xdg_data_home "" ;#data the user likely to want to be portable + set default_xdg_cache_home "" ;#local cache + set default_xdg_state_home "" ;#persistent user data such as logs, but not as important or as portable as those in xdg_data_home + # --- + set default_xdg_data_dirs "" ;#non-user specific + #xdg_config_dirs ? + #xdg_runtime_dir ? + + + #review. we are assuming if we can't get a home dir - then all the xdg vars including xdg_data_dirs aren't likely to be useful (as presumably filesystem access is absent) + #(safe interp generally won't have access to ::env either) + #This coupling doesn't necessarily hold - its possible the relevant env vars were copied to a safe interp - although that would be a policy that would make disabling 'info home' inconsistent. + if {$homedir ne ""} { + if {"windows" eq $::tcl_platform(platform)} { + #as much as I'd prefer to use ~/.local/share and ~/.config to keep them more consistent with unixlike platforms - the vast majority of apps put them where microsoft wants them. + #we have a choice of LOCALAPPDATA vs APPDATA (local to machine vs potentially roaming/redirected in a corporate environment) + #using the roaming location should not impact users who aren't using a domain controller but is potentially much more convenient for those who do. + if {[info exists ::env(APPDATA)]} { + set default_xdg_config_home $::env(APPDATA) + set default_xdg_data_home $::env(APPDATA) + } + + #The xdg_cache_home should be kept local + if {[info exists ::env(LOCALAPPDATA)]} { + set default_xdg_cache_home $::env(LOCALAPPDATA) + set default_xdg_state_home $::env(LOCALAPPDATA) + } + + if {[info exists ::env(PROGRAMDATA)]} { + #- equiv env(ALLUSERSPROFILE) ? + set default_xdg_data_dirs $::env(PROGRAMDATA) + } + + } else { + #follow defaults as specified on freedesktop.org e.g https://specifications.freedesktop.org/basedir-spec/latest/ar01s03.html + set default_xdg_config_home [file join $homedir .config] + set default_xdg_data_home [file join $homedir .local share] + set default_xdg_cache_home [file join $homedir .cache] + set default_xdg_state_home [file join $homedir .local state] + set default_xdg_data_dirs /usr/local/share + } + } + + set defaults [dict create\ + apps $default_apps\ + config ""\ + configset ".punkshell"\ + scriptlib $default_scriptlib\ + color_stdout $default_color_stdout\ + color_stdout_repl $default_color_stdout_repl\ + color_stderr $default_color_stderr\ + color_stderr_repl $default_color_stderr_repl\ + logfile_stdout $default_logfile_stdout\ + logfile_stderr $default_logfile_stderr\ + logfile_active 0\ + syslog_stdout "127.0.0.1:514"\ + syslog_stderr "127.0.0.1:514"\ + syslog_active 0\ + auto_exec_mechanism exec\ + auto_noexec 0\ + xdg_config_home $default_xdg_config_home\ + xdg_data_home $default_xdg_data_home\ + xdg_cache_home $default_xdg_cache_home\ + xdg_state_home $default_xdg_state_home\ + xdg_data_dirs $default_xdg_data_dirs\ + theme_posh_override ""\ + posh_theme ""\ + posh_themes_path ""\ + ] + + set startup $defaults + #load values from saved config file - $xdg_config_home/punk/punk.config ? + #typically we want env vars to override the stored config - as env vars conventionally used on some commandlines. + #that's possibly ok for the PUNK_ vars + #however.. others like the xdg vars and NOCOLOR may apply to other apps.. and we may want to override them from the saved config? + #making some env vars override saved config values and some not would be potentially confusing. may need one/more specific settings or env vars to determine which takes precedence? + #simpler is probably just to let env vars take precedence - and warn when saving or viewing config that the saved values are being overridden + #- requiring user to manually unset any unwanted env vars when launching? + + #we are likely to want the saved configs for subshells/decks to override them however. + + #todo - load/save config file + + #todo - define which configvars are settable in env + #list of varname varinfo where varinfo is a sub dictionary (type key is mandatory, with value from: string,pathlist,boolean) + set punk_env_vars_config [dict create \ + PUNK_APPS {type pathlist}\ + PUNK_CONFIG {type string}\ + PUNK_CONFIGSET {type string}\ + PUNK_SCRIPTLIB {type string}\ + PUNK_AUTO_EXEC_MECHANISM {type string}\ + PUNK_AUTO_NOEXEC {type string default 0 help "set 1 to set Tcl's ::auto_noexec true.\nStops 'unknown' from running external programs"}\ + PUNK_COLOR_STDERR {type string help "stderr colour transform. Use 'punk::ansi::a?' to see colour names"}\ + PUNK_COLOR_STDERR_REPL {type string help "stderr colour transform only while command running (not active during 'after')"}\ + PUNK_COLOR_STDOUT {type string help "stdout colour transform. Use 'punk::ansi::a?' to see colour names"}\ + PUNK_COLOR_STDOUT_REPL {type string help "stdout colour transform only while command running (not active during 'after')"}\ + PUNK_LOGFILE_STDOUT {type string}\ + PUNK_LOGFILE_STDERR {type string}\ + PUNK_LOGFILE_ACTIVE {type string}\ + PUNK_SYSLOG_STDOUT {type string}\ + PUNK_SYSLOG_STDERR {type string}\ + PUNK_SYSLOG_ACTIVE {type string}\ + PUNK_THEME_POSH_OVERRIDE {type string}\ + ] + set punk_env_vars [dict keys $punk_env_vars_config] + + #override with env vars if set + foreach {evar varinfo} $punk_env_vars_config { + if {[info exists ::env($evar)]} { + set vartype [dict get $varinfo type] + set f [set ::env($evar)] + if {$f ne "default"} { + #e.g PUNK_SCRIPTLIB -> scriptlib + set varname [tcl::string::tolower [tcl::string::range $evar 5 end]] + if {$vartype eq "pathlist"} { + #colon vs semicolon path sep is problematic for windows environments where unix-like systems such as cygwin/wsl are used and a variable may be set for either the native path separator or the unix-like system + #Even without the colon vs semicolon issue, native vs unix-like paths on windows mixed environment systems can cause grief. + #For now at least, we will simply respect the platform pathSeparator and hope the user manages the environment variables appropriately. + #some programs do automatic translation - which is a nice idea in principle - but is also prone to error as we don't know if it's already occurred or not depending on how things are launched. + #An example of where this sort of thing can go wrong is env(TCLLIBPATH) - which is defined as a space separated list not requiring further splitting + # - but some programs have been known to split this value on colon anyway, which breaks things on windows. + set paths [split $f $::tcl_platform(pathSeparator)] + set final [list] + #eliminate empty values (leading or trailing or extraneous separators) + foreach p $paths { + if {[tcl::string::trim $p] ne ""} { + lappend final $p + } + } + tcl::dict::set startup $varname $final + } else { + tcl::dict::set startup $varname $f + } + } + } + } + + # https://no-color.org + #if {[info exists ::env(NO_COLOR)]} { + # if {$::env(NO_COLOR) ne ""} { + # set colour_disabled 1 + # } + #} + set other_env_vars_config [dict create\ + NO_COLOR {type string}\ + XDG_CONFIG_HOME {type string}\ + XDG_DATA_HOME {type string}\ + XDG_CACHE_HOME {type string}\ + XDG_STATE_HOME {type string}\ + XDG_DATA_DIRS {type pathlist}\ + POSH_THEME {type string}\ + POSH_THEMES_PATH {type string}\ + TCLLIBPATH {type string}\ + ] + lassign [split [info tclversion] .] tclmajorv tclminorv + #don't rely on lseq or punk::lib for now.. + set relevant_minors [list] + for {set i 0} {$i <= $tclminorv} {incr i} { + lappend relevant_minors $i + } + foreach minor $relevant_minors { + set vname TCL${tclmajorv}_${minor}_TM_PATH + if {$minor eq $tclminorv || [info exists ::env($vname)]} { + dict set other_env_vars_config $vname {type string} + } + } + set other_env_vars [dict keys $other_env_vars_config] + + foreach {evar varinfo} $other_env_vars_config { + if {[info exists ::env($evar)]} { + set vartype [dict get $varinfo type] + set f [set ::env($evar)] + if {$f ne "default"} { + set varname [tcl::string::tolower $evar] + if {$vartype eq "pathlist"} { + set paths [split $f $::tcl_platform(pathSeparator)] + set final [list] + #eliminate empty values (leading or trailing or extraneous separators) + foreach p $paths { + if {[tcl::string::trim $p] ne ""} { + lappend final $p + } + } + tcl::dict::set startup $varname $final + } else { + tcl::dict::set startup $varname $f + } + } + } + } + + + #unset -nocomplain vars + + #todo + set running [tcl::dict::create] + set running [tcl::dict::merge $running $startup] + } + init + + #todo + proc Apply {config} { + puts stderr "punk::config::Apply partially implemented" + set configname [string map {-config ""} $config] + if {$configname in {startup running}} { + upvar ::punk::config::$configname applyconfig + + if {[dict exists $applyconfig auto_noexec]} { + set auto [dict get $applyconfig auto_noexec] + if {![string is boolean -strict $auto]} { + error "config::Apply error - invalid data for auto_noexec:'$auto' - expected boolean" + } + if {$auto} { + set ::auto_noexec 1 + } else { + #puts "auto_noexec false" + unset -nocomplain ::auto_noexec + } + } + + } else { + error "no config named '$config' found" + } + return "apply done" + } + Apply startup + + #todo - consider how to divide up settings, categories, 'devices', decks etc + proc get_running_global {varname} { + variable running + if {[dict exists $running $varname]} { + return [dict get $running $varname] + } + error "No such global configuration item '$varname' found in running config" + } + proc get_startup_global {varname} { + variable startup + if {[dict exists $startup $varname]} { + return [dict get $startup $varname] + } + error "No such global configuration item '$varname' found in startup config" + } + + proc get {whichconfig {globfor *}} { + variable startup + variable running + switch -- $whichconfig { + config - startup - startup-config - startup-configuration { + #show *startup* config - different behaviour may be confusing to those used to router startup and running configs + set configdata $startup + } + running - running-config - running-configuration { + set configdata $running + } + default { + error "Unknown config name '$whichconfig' - try startup or running" + } + } + if {$globfor eq "*"} { + return $configdata + } else { + set keys [dict keys $configdata [string tolower $globfor]] + set filtered [dict create] + foreach k $keys { + dict set filtered $k [dict get $configdata $k] + } + return $filtered + } + } + + proc configure {args} { + set argdef { + @id -id ::punk::config::configure + @cmd -name punk::config::configure -help\ + "UNIMPLEMENTED" + @values -min 1 -max 1 + whichconfig -type string -choices {startup running stop} + } + set argd [punk::args::get_dict $argdef $args] + return "unimplemented - $argd" + } + + proc show {whichconfig {globfor *}} { + #todo - tables for console + set configdata [punk::config::get $whichconfig $globfor] + return [punk::lib::showdict $configdata] + } + + + + #e.g + # copy running-config startup-config + # copy startup-config test-config.cfg + # copy backup-config.cfg running-config + #review - consider the merge vs overwrite feature of some routers.. where copy to running-config does a merge rather than an overwrite + #This is to allow partial configs to be loaded to running, whereas a save of running to any target is always a complete configuration + proc copy {args} { + set argdef { + @id -id ::punk::config::copy + @cmd -name punk::config::copy -help\ + "Copy a partial or full configuration from one config to another + If a target config has additional settings, then the source config can be considered to be partial with regards to the target. + " + -type -default "" -choices {replace merge} -help\ + "Defaults to merge when target is running-config + Defaults to replace when source is running-config" + @values -min 2 -max 2 + fromconfig -help\ + "running or startup or file name (not fully implemented)" + toconfig -help\ + "running or startup or file name (not fully implemented)" + } + set argd [punk::args::get_dict $argdef $args] + set fromconfig [dict get $argd values fromconfig] + set toconfig [dict get $argd values toconfig] + set fromconfig [string map {-config ""} $fromconfig] + set toconfig [string map {-config ""} $toconfig] + + set copytype [dict get $argd opts -type] + + + #todo - warn & prompt if doing merge copy to startup + switch -exact -- $fromconfig-$toconfig { + running-startup { + if {$copytype eq ""} { + set copytype replace ;#full configuration + } + if {$copytype eq "replace"} { + error "punk::config::copy error. full configuration copy from running to startup config not yet supported" + } else { + error "punk::config::copy error. merge configuration copy from running to startup config not yet supported" + } + } + startup-running { + #default type merge - even though it's not always what is desired + if {$copytype eq ""} { + set copytype merge ;#load in a partial configuration + } + + #warn/prompt either way + if {$copytype eq "replace"} { + #some routers require use of a separate command for this branch. + #presumably to ensure the user doesn't accidentally load partials onto a running system + # + error "punk::config::copy error. full configuration copy from startup to overwrite running config not supported" + } else { + error "punk::config::copy error. merge copy from possibly partial configuration: startup to running config not currently supported" + } + } + default { + error "punk::config::copy error. copy must from running to startup or startup to running. File sources/targets not yet supported" + } + } + } + + + + + +} + + + + + +#todo - move to cli? +::tcl::namespace::eval punk::config { + #todo - something better - 'previous' rather than reverting to startup + proc channelcolors {{onoff {}}} { + variable running + variable startup + + if {![string length $onoff]} { + return [list stdout [dict get $running color_stdout] stderr [dict get $running color_stderr]] + } else { + if {![string is boolean $onoff]} { + error "channelcolors: invalid value $onoff - expected boolean: true|false|on|off|1|0|yes|no" + } + if {$onoff} { + dict set running color_stdout [dict get $startup color_stdout] + dict set running color_stderr [dict get $startup color_stderr] + } else { + dict set running color_stdout "" + dict set running color_stderr "" + } + } + return [list stdout [dict get $running color_stdout] stderr [dict get $running color_stderr]] + } +} + +package provide punk::config [tcl::namespace::eval punk::config { + variable version + set version 0.1 + }] \ No newline at end of file diff --git a/src/vfs/_vfscommon.vfs/modules/punk/mix/base-0.1.tm b/src/vfs/_vfscommon.vfs/modules/punk/mix/base-0.1.tm index 69f2f5cb..a4bc3c70 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/mix/base-0.1.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/mix/base-0.1.tm @@ -767,6 +767,8 @@ namespace eval punk::mix::base { dict for {path pathinfo} $dict_path_cksum { + puts "fill_relativecksums_from_base_and_relativepathdict-->$path REVIEW" + #review to see if we process same path repeatedly, so could avoid repeated 'file exists $fullpath' below by caching a glob if {![dict exists $pathinfo cksum]} { dict set pathinfo cksum "" } else { @@ -851,7 +853,7 @@ namespace eval punk::mix::base { } } else { - if {[file type $specifiedpath] eq "relative"} { + if {[file pathtype $specifiedpath] eq "relative"} { #if specifiedpath is relative - and we don't have a base, we now need to convert relative to cwd to an absolute path for storage set targetpath [file normalize $specifiedpath] set storedpath $targetpath @@ -911,6 +913,7 @@ namespace eval punk::mix::base { } #buildruntime.exe obsolete.. + puts stderr "warning obsolete? get_all_vfs_build_cksums 'buildruntime.exe'???" set fullpath_buildruntime $buildfolder/buildruntime.exe set ckinfo_buildruntime [cksum_path $fullpath_buildruntime] diff --git a/src/vfs/_vfscommon.vfs/modules/punk/mix/cli-0.3.1.tm b/src/vfs/_vfscommon.vfs/modules/punk/mix/cli-0.3.1.tm index 3cf64b33..a099c9b0 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/mix/cli-0.3.1.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/mix/cli-0.3.1.tm @@ -412,9 +412,9 @@ namespace eval punk::mix::cli { set repopaths [punk::repo::find_repos [pwd]] set repos [dict get $repopaths repos] if {![llength $repos]} { - append result [dict get $repopaths warnings] + append result [punk::ansi::a+ bold yellow][dict get $repopaths warnings][punk::ansi::a] } else { - append result [dict get $repopaths warnings] + append result [punk::ansi::a+ bold yellow][dict get $repopaths warnings][punk::ansi::a] lassign [lindex $repos 0] repopath repotypes if {"fossil" in $repotypes} { #review - multiple process launches to fossil a bit slow on windows.. @@ -739,7 +739,7 @@ namespace eval punk::mix::cli { } } else { - puts -nonewline stderr "." + puts -nonewline stderr "P" set did_skip 1 #set file_record [punkcheck::installfile_skipped_install $basedir $file_record] $build_event targetset_end SKIPPED @@ -771,7 +771,7 @@ namespace eval punk::mix::cli { $event targetset_end OK -note "zip modpod" } } else { - puts -nonewline stderr "." + puts -nonewline stderr "p" set did_skip 1 if {$is_interesting} { puts stderr "$modulefile [$event targetset_source_changes]" @@ -893,7 +893,7 @@ namespace eval punk::mix::cli { if {$is_interesting} { puts stdout "skipping module $current_source_dir/$m - no change in sources detected" } - puts -nonewline stderr "." + puts -nonewline stderr "m" set did_skip 1 #set file_record [punkcheck::installfile_skipped_install $basedir $file_record] $event targetset_end SKIPPED @@ -935,7 +935,7 @@ namespace eval punk::mix::cli { #set file_record [punkcheck::installfile_finished_install $basedir $file_record] $event targetset_end OK -note "already versioned module" } else { - puts -nonewline stderr "." + puts -nonewline stderr "f" set did_skip 1 if {$is_interesting} { puts stderr "$current_source_dir/$m [$event targetset_source_changes]" @@ -951,7 +951,8 @@ namespace eval punk::mix::cli { if {$CALLDEPTH >= $max_depth} { set subdirs [list] } else { - set subdirs [glob -nocomplain -dir $current_source_dir -type d -tail *] + set subdirs [glob -nocomplain -dir $current_source_dir -type d -tail *] + set targets_existing [glob -nocomplain -dir $target_module_dir -type d -tail {*}$subdirs] } #puts stderr "subdirs: $subdirs" foreach d $subdirs { @@ -965,7 +966,10 @@ namespace eval punk::mix::cli { if {$skipdir} { continue } - if {![file exists $target_module_dir/$d]} { + #if {![file exists $target_module_dir/$d]} { + # file mkdir $target_module_dir/$d + #} + if {$d ni $targets_existing} { file mkdir $target_module_dir/$d } lappend module_list {*}[build_modules_from_source_to_base $srcdir $basedir\ diff --git a/src/vfs/_vfscommon.vfs/modules/punk/mix/commandset/buildsuite-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/punk/mix/commandset/buildsuite-0.1.0.tm index 883e02d2..409796fc 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/mix/commandset/buildsuite-0.1.0.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/mix/commandset/buildsuite-0.1.0.tm @@ -49,7 +49,7 @@ namespace eval punk::mix::commandset::buildsuite { set path_parts [file split [lindex $du_record 1]] ;#should handle spaced-paths ok. set s [lindex $path_parts end-1] set p [lindex $path_parts end] - + #This handles case where a project folder is same name as suite e.g src/buildsuites/tcl/tcl #so we can't just use tail as dict key. We could assume last record is always total - but if {![string match -nocase $s $suite]} { diff --git a/src/vfs/_vfscommon.vfs/modules/punk/mix/commandset/debug-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/punk/mix/commandset/debug-0.1.0.tm index c6c83b69..a3784c00 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/mix/commandset/debug-0.1.0.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/mix/commandset/debug-0.1.0.tm @@ -26,7 +26,7 @@ namespace eval punk::mix::commandset::debug { namespace export get paths namespace path ::punk::mix::cli - #Except for 'get' - all debug commands should emit to stdout + #Except for 'get' - all debug commands should emit to stdout proc paths {} { set out "" puts stdout "find_repos output:" @@ -40,7 +40,7 @@ namespace eval punk::mix::commandset::debug { set template_base_dict [punk::mix::base::lib::get_template_basefolders] puts stdout "get_template_basefolders output:" pdict template_base_dict */* - return + return } #call other debug command - but capture stdout as return value @@ -84,9 +84,9 @@ namespace eval punk::mix::commandset::debug { # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready +## Ready package provide punk::mix::commandset::debug [namespace eval punk::mix::commandset::debug { variable version - set version 0.1.0 + set version 0.1.0 }] return diff --git a/src/vfs/_vfscommon.vfs/modules/punk/mix/commandset/module-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/punk/mix/commandset/module-0.1.0.tm index ae21d348..2bc0f01c 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/mix/commandset/module-0.1.0.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/mix/commandset/module-0.1.0.tm @@ -26,8 +26,10 @@ namespace eval punk::mix::commandset::module { namespace export * proc paths {} { - set roots [punk::repo::find_repos ""] - set project [lindex [dict get $roots project] 0] + #set roots [punk::repo::find_repos ""] + #set project [lindex [dict get $roots project] 0] + set project [punk::repo::find_project ""] + if {$project ne ""} { set is_project 1 set searchbase $project diff --git a/src/vfs/_vfscommon.vfs/modules/punk/mix/commandset/project-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/punk/mix/commandset/project-0.1.0.tm index 2ff8ac06..f670c8c0 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/mix/commandset/project-0.1.0.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/mix/commandset/project-0.1.0.tm @@ -20,7 +20,7 @@ #[manpage_begin punkshell_module_punk::mix::commandset::project 0 0.1.0] #[copyright "2023"] #[titledesc {dec commandset - project}] [comment {-- Name section and table of contents description --}] -#[moddesc {deck CLI commandset - project}] [comment {-- Description at end of page heading --}] +#[moddesc {deck CLI commandset - project}] [comment {-- Description at end of page heading --}] #[require punk::mix::commandset::project] #[description] @@ -29,25 +29,25 @@ #*** !doctools #[section Overview] #[para] overview of punk::mix::commandset::project -#[para]Import into an ensemble namespace similarly to the way it is done with punk::mix::cli e.g +#[para]Import into an ensemble namespace similarly to the way it is done with punk::mix::cli e.g #[example { # namespace eval myproject::cli { # namespace export * # namespace ensemble create # package require punk::overlay -# +# # package require punk::mix::commandset::project # punk::overlay::import_commandset project . ::punk::mix::commandset::project -# punk::overlay::import_commandset projects . ::punk::mix::commandset::project::collection +# punk::overlay::import_commandset projects . ::punk::mix::commandset::project::collection # } #}] #[para] Where the . in the above example is the prefix/command separator #[para]The prefix ('project' in the above example) can be any string desired to disambiguate commands imported from other commandsets. -#[para]The above results in the availability of the ensemble command: ::myproject::cli project.new, which is implemented in ::punk::mix::commandset::project::new +#[para]The above results in the availability of the ensemble command: ::myproject::cli project.new, which is implemented in ::punk::mix::commandset::project::new #[para]Similarly, procs under ::punk::mix::commandset::project::collection will be available as subcommands of the ensemble as projects. #[para] #[subsection Concepts] -#[para] see punk::overlay +#[para] see punk::overlay # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ @@ -56,7 +56,7 @@ #*** !doctools #[subsection dependencies] -#[para] packages used by punk::mix::commandset::project +#[para] packages used by punk::mix::commandset::project #[list_begin itemized] package require Tcl 8.6- @@ -88,7 +88,7 @@ namespace eval punk::mix::commandset::project { namespace export * #*** !doctools #[subsection {Namespace punk::mix::commandset::project}] - #[para] core commandset functions for punk::mix::commandset::project + #[para] core commandset functions for punk::mix::commandset::project #[list_begin definitions] proc _default {} { @@ -133,7 +133,7 @@ namespace eval punk::mix::commandset::project { proc new {newprojectpath_or_name args} { #*** !doctools # [call [fun new] [arg newprojectpath_or_name] [opt args]] - #new project structure - may be dedicated to one module, or contain many. + #new project structure - may be dedicated to one module, or contain many. #create minimal folder structure only by specifying in args: -modules {} if {[file pathtype $newprojectpath_or_name] eq "absolute"} { set projectfullpath [file normalize $newprojectpath_or_name] @@ -185,7 +185,7 @@ namespace eval punk::mix::commandset::project { if {$opt_force || $opt_update} { #generally undesirable to add default project module during an update. #user can use dev module.new manually or supply module name in -modules - set opt_modules [list] + set opt_modules [list] } else { set opt_modules [list [string tolower $projectname]] ;#default modules to lowercase as is the modern (tip 590) recommendation for Tcl } @@ -207,12 +207,12 @@ namespace eval punk::mix::commandset::project { } #we don't assume 'unknown' is configured to run shell commands if {[string length [package provide shellrun]]} { - set exitinfo [run {*}$scoop_prog install fossil] + set exitinfo [run {*}$scoop_prog install fossil] #scoop tends to return successful exitcode (0) even when packages not found etc. - so exitinfo not much use. puts stdout "scoop install fossil ran with result: $exitinfo" } else { puts stdout "Please wait while scoop runs - there may be a slight delay and then scoop output will be shown. (use punk shellrun package for )" - set result [exec {*}$scoop_prog install fossil] + set result [exec {*}$scoop_prog install fossil] puts stdout $result } catch {::auto_reset} ;#can be missing (unsure under what circumstances - but I've seen it raise error 'invalid command name "auto_reset"') @@ -304,7 +304,7 @@ namespace eval punk::mix::commandset::project { } } - + set project_dir_exists [file exists $projectdir] if {$project_dir_exists && !($opt_force || $opt_update)} { puts stderr "Unable to create new project at $projectdir - file/folder already exists use -update 1 to fill in missing items from template use -force 1 to overwrite from template" @@ -332,7 +332,7 @@ namespace eval punk::mix::commandset::project { puts stderr $warnmsg } - set fossil_repo_file "" + set fossil_repo_file "" set is_fossil_root 0 if {$project_dir_exists && [punk::repo::is_fossil_root $projectdir]} { set is_fossil_root 1 @@ -356,7 +356,7 @@ namespace eval punk::mix::commandset::project { return } #review - set fossil_repo_file $repodb_folder/$projectname.fossil + set fossil_repo_file $repodb_folder/$projectname.fossil } if {$fossil_repo_file eq ""} { @@ -378,7 +378,7 @@ namespace eval punk::mix::commandset::project { file mkdir $projectdir - puts stdout ">>> about to call punkcheck::install $layout_path $projectdir" + puts stdout ">>> about to call punkcheck::install $layout_path $projectdir" set resultdict [dict create] set antipaths [list\ src/doc/*\ @@ -394,10 +394,10 @@ namespace eval punk::mix::commandset::project { #default antiglob_dir_core will stop .fossil* from being updated - which is generally desirable as these are likely to be customized if {$opt_force} { - puts stdout "copying layout files - with force applied - overwrite all-targets" + puts stdout "copying layout files - with force applied - overwrite all-targets" set resultdict [punkcheck::install $layout_path $projectdir -installer project.new -createempty 1 -overwrite ALL-TARGETS -antiglob_paths $antipaths -antiglob_dir $antiglob_dir] } else { - puts stdout "copying layout files - (if source file changed)" + puts stdout "copying layout files - (if source file changed)" set resultdict [punkcheck::install $layout_path $projectdir -installer project.new -createempty 1 -overwrite installedsourcechanged-targets -antiglob_paths $antipaths -antiglob_dir $antiglob_dir] } puts stdout [punkcheck::summarize_install_resultdict $resultdict] @@ -410,10 +410,10 @@ namespace eval punk::mix::commandset::project { puts stdout "no src/doc in source template - update not required" } - #target folders .fossil-custom and .fossil-settings may not exist. use -createdir 1 to ensure existence. + #target folders .fossil-custom and .fossil-settings may not exist. use -createdir 1 to ensure existence. #In this case we need to override the default dir antiglob - as .fossil-xxx folders need to be installed from template if missing, or if target is uncustomized. ## default_antiglob_dir_core [list "#*" "_aside" ".git" ".fossil*"] - set override_antiglob_dir_core [list #* _aside .git] + set override_antiglob_dir_core [list #* _aside .git] if {[file exists $layout_path/.fossil-custom]} { puts stdout "copying layout src/.fossil-custom files (if target missing or uncustomised)" set resultdict [punkcheck::install $layout_path/.fossil-custom $projectdir/.fossil-custom -createdir 1 -createempty 1 -punkcheck_folder $projectdir -installer project.new -antiglob_dir_core $override_antiglob_dir_core -overwrite SYNCED-TARGETS] @@ -430,9 +430,9 @@ namespace eval punk::mix::commandset::project { puts stdout "no .fossil-settings in source template - update not required" } - #scan all files in template + #scan all files in template # - #TODO - deck command to substitute templates? + #TODO - deck command to substitute templates? set templatefiles [punk::mix::commandset::layout::lib::layout_scan_for_template_files $opt_layout] set stripprefix [file normalize $layout_path] @@ -440,7 +440,7 @@ namespace eval punk::mix::commandset::project { if {[llength $templatefiles]} { puts stdout "Filling template file placeholders with the following tag map:" foreach {placeholder value} $tagmap { - puts stdout " $placeholder -> $value" + puts stdout " $placeholder -> $value" } } foreach templatefullpath $templatefiles { @@ -452,7 +452,7 @@ namespace eval punk::mix::commandset::project { set data2 [string map $tagmap $data] if {$data2 ne $data} { puts stdout "updated template file: $fpath" - set fdout [open $fpath w]; fconfigure $fdout -translation binary; puts -nonewline $fdout $data2; close $fdout + set fdout [open $fpath w]; fconfigure $fdout -translation binary; puts -nonewline $fdout $data2; close $fdout } } else { puts stderr "warning: Missing template file $fpath" @@ -464,7 +464,7 @@ namespace eval punk::mix::commandset::project { if {[file exists $projectdir/src/modules]} { foreach m $opt_modules { - #check if mod-ver.tm file or #modpod-mod-ver folder exist + #check if mod-ver.tm file or #modpod-mod-ver folder exist set tmfile $projectdir/src/modules/$m-[punk::mix::util::magic_tm_version].tm set podfile $projectdir/src/modules/#modpod-$m-[punk::mix::util::magic_tm_version]/$m-[punk::mix::util::magic_tm_version].tm @@ -482,7 +482,7 @@ namespace eval punk::mix::commandset::project { set overwrite_type zip } else { set answer [util::askuser "OVERWRITE the src/modules file $tmfile ?? (generally not desirable) Y|N"] - set overwrite_type $opt_type + set overwrite_type $opt_type } if {[string tolower $answer] eq "y"} { #REVIEW - all pods zip - for now @@ -503,7 +503,7 @@ namespace eval punk::mix::commandset::project { $installer set_source_target $projectdir/src/doc $projectdir/src/embedded set event [$installer start_event {-install_step kettledoc}] $event targetset_init VIRTUAL kettle_build_doc ;#VIRTUAL - since there is no specific target file - and we don't know all the files that will be generated - $event targetset_addsource $projectdir/src/doc ;#whole doc tree is considered the source + $event targetset_addsource $projectdir/src/doc ;#whole doc tree is considered the source #---------- if {\ [llength [dict get [$event targetset_source_changes] changed]]\ @@ -535,7 +535,7 @@ namespace eval punk::mix::commandset::project { if {![punk::repo::is_fossil_root $projectdir]} { set first_fossil 1 - #-k = keep. (only modify the manifest file(s)) + #-k = keep. (only modify the manifest file(s)) if {$is_nested_fossil} { set fossilopen [runx -n {*}$fossil_prog open --nested $repodb_folder/$projectname.fossil -k --workdir $projectdir] } else { @@ -600,11 +600,11 @@ namespace eval punk::mix::commandset::project { #[para]The glob argument is optional unless option/value pairs are also supplied, in which case * should be explicitly supplied #[para]glob restricts output based on the name of the fossil db file e.g s* for all projects beginning with s #[para]The _default function is made available in the ensemble by the name of the prefix used when importing the commandset. - #[para]e.g - #[para] punk::overlay::import_commandset projects . ::punk::mix::commandset::project::collection + #[para]e.g + #[para] punk::overlay::import_commandset projects . ::punk::mix::commandset::project::collection #[para]Will result in the command being available as projects package require overtype - set db_projects [lib::get_projects $glob] + set db_projects [lib::get_projects $glob] set col1items [lsearch -all -inline -index 0 -subindices $db_projects *] set col2items [lsearch -all -inline -index 1 -subindices $db_projects *] set checkouts [lsearch -all -inline -index 2 -subindices $db_projects *] @@ -620,15 +620,15 @@ namespace eval punk::mix::commandset::project { set widest3 [tcl::mathfunc::max {*}[lmap v [concat [list $title3] $col3items] {string length $v}]] set col3 [string repeat " " $widest3] set tablewidth [expr {$widest1 + 1 + $widest2 + 1 + $widest3}] - - + + append msg "[overtype::left $col1 $title1] [overtype::left $col2 $title2] [overtype::left $col3 $title3]" \n append msg [string repeat "=" $tablewidth] \n foreach p $col1items n $col2items c $col3items { append msg "[overtype::left $col1 $p] [overtype::left $col2 $n] [overtype::right $col3 $c]" \n - } + } return $msg - #return [list_as_lines [lib::get_projects $glob]] + #return [list_as_lines [lib::get_projects $glob]] } proc detail {{glob {}} args} { package require overtype @@ -640,14 +640,14 @@ namespace eval punk::mix::commandset::project { # -- --- --- --- --- --- --- set opt_description [dict get $opts -description] # -- --- --- --- --- --- --- - - set db_projects [lib::get_projects $glob] + + set db_projects [lib::get_projects $glob] set col1_dbfiles [lsearch -all -inline -index 0 -subindices $db_projects *] set col2items [lsearch -all -inline -index 1 -subindices $db_projects *] set checkouts [lsearch -all -inline -index 2 -subindices $db_projects *] set col3items [lmap v $checkouts {llength $v}] - + set col4_pnames [list] set col5_pcodes [list] set col6_dupids [list] @@ -658,13 +658,13 @@ namespace eval punk::mix::commandset::project { set project_name "" set project_code "" set project_desc "" - set db_error "" + set db_error "" if {[file exists $dbfile]} { if {[catch { sqlite3 dbp $dbfile dbp eval {select name,value from config where name like 'project-%';} r { if {$r(name) eq "project-name"} { - set project_name $r(value) + set project_name $r(value) } elseif {$r(name) eq "project-code"} { set project_code $r(value) } elseif {$r(name) eq "project-description"} { @@ -687,7 +687,7 @@ namespace eval punk::mix::commandset::project { } incr file_idx } - + set setid 1 set codeset [dict create] dict for {code dbs} $codes { @@ -696,17 +696,17 @@ namespace eval punk::mix::commandset::project { dict set codeset $code count [llength $dbs] dict set codeset $code seen 0 incr setid - } + } } set dupid 1 foreach pc $col5_pcodes { if {[dict exists $codeset $pc]} { - set seen [dict get $codeset $pc seen] + set seen [dict get $codeset $pc seen] set this_seen [expr {$seen + 1}] dict set codeset $pc seen $this_seen - lappend col6_dupids "[dict get $codeset $pc setid].${this_seen}/[dict get $codeset $pc count]" + lappend col6_dupids "[dict get $codeset $pc setid].${this_seen}/[dict get $codeset $pc count]" } else { - lappend col6_dupids "" + lappend col6_dupids "" } } @@ -732,10 +732,10 @@ namespace eval punk::mix::commandset::project { #set widest7 [tcl::mathfunc::max {*}[lmap v [concat [list $title4] $col7_pdescs] {string length $v}]] set widest7 35 set col7 [string repeat " " $widest7] - - + + set tablewidth [expr {$widest1 + 1 + $widest2 + 1 + $widest3 +1 + $widest4 + 1 + $widest5 + 1 + $widest6}] - + append msg "[overtype::left $col1 $title1] [overtype::left $col2 $title2] [overtype::left $col3 $title3]\ [overtype::left $col4 $title4] [overtype::left $col5 $title5] [overtype::left $col6 $title6]" if {!$opt_description} { @@ -747,7 +747,7 @@ namespace eval punk::mix::commandset::project { append msg [string repeat "=" $tablewidth] \n foreach p $col1_dbfiles n $col2items c $col3items pn $col4_pnames pc $col5_pcodes dup $col6_dupids desc $col7_pdescs { - set desclines [split [textutil::adjust $desc -length $widest7] \n] + set desclines [split [textutil::adjust $desc -length $widest7] \n] set desc1 [lindex $desclines 0] append msg "[overtype::left $col1 $p] [overtype::left $col2 $n] [overtype::right $col3 $c]\ [overtype::left $col4 $pn] [overtype::left $col5 $pc] [overtype::left $col6 $dup]" @@ -756,20 +756,20 @@ namespace eval punk::mix::commandset::project { } else { append msg " [overtype::left $col7 $desc1]" \n foreach dline [lrange $desclines 1 end] { - append msg "$col1 $col2 $col3 $col4 $col5 $col6 [overtype::left $col7 $dline]" \n + append msg "$col1 $col2 $col3 $col4 $col5 $col6 [overtype::left $col7 $dline]" \n } } - } - return $msg - #return [list_as_lines [lib::get_projects $glob]] + } + return $msg + #return [list_as_lines [lib::get_projects $glob]] } proc cd {{glob {}} args} { dict set args -cd 1 - work $glob {*}$args + work $glob {*}$args } proc work {{glob {}} args} { package require sqlite3 - set db_projects [lib::get_projects $glob] + set db_projects [lib::get_projects $glob] if {[llength $db_projects] == 0} { puts stderr "::punk::mix::commandset::project::work No Repo DB name matches found for '$glob'" return "" @@ -779,22 +779,22 @@ namespace eval punk::mix::commandset::project { set defaults [dict create\ -cd 0\ -detail "\uFFFF"\ - ] + ] set opts [dict merge $defaults $args] - # -- --- --- --- --- --- --- + # -- --- --- --- --- --- --- set opt_cd [dict get $opts -cd] - # -- --- --- --- --- --- --- + # -- --- --- --- --- --- --- set opt_detail [dict get $opts -detail] set opt_detail_explicit_zero 1 ;#default assumption only if {$opt_detail eq "\uFFFF"} { set opt_detail_explicit_zero 0 set opt_detail 0; #default } - # -- --- --- --- --- --- --- + # -- --- --- --- --- --- --- set workdir_dict [dict create] set all_workdirs [list] foreach pinfo $db_projects { - lassign $pinfo fosdb name workdirs + lassign $pinfo fosdb name workdirs foreach wdir $workdirs { dict set workdir_dict $wdir $pinfo lappend all_workdirs $wdir @@ -808,15 +808,15 @@ namespace eval punk::mix::commandset::project { set col_pcodes [list] set col_dupids [list] - set fosdb_count [dict create] + set fosdb_count [dict create] set fosdb_dupset [dict create] set fosdb_cache [dict create] set dupset 0 set rowid 1 foreach wd $workdirs { set wdinfo [dict get $workdir_dict $wd] - lassign $wdinfo fosdb nm siblingworkdirs - dict incr fosdb_count $fosdb + lassign $wdinfo fosdb nm siblingworkdirs + dict incr fosdb_count $fosdb set dbcount [dict get $fosdb_count $fosdb] if {[llength $siblingworkdirs] > 1} { if {![dict exists $fosdb_dupset $fosdb]} { @@ -825,7 +825,7 @@ namespace eval punk::mix::commandset::project { } set dupid "[dict get $fosdb_dupset $fosdb].$dbcount/[llength $siblingworkdirs]" } else { - set dupid "" + set dupid "" } if {$dbcount == 1} { set pname "" @@ -842,7 +842,7 @@ namespace eval punk::mix::commandset::project { puts stderr "!!! error: $errM" } } else { - puts stderr "!!! missing fossil db $fosdb" + puts stderr "!!! missing fossil db $fosdb" } } else { set info [dict get $fosdb_cache $fosdb] @@ -858,7 +858,7 @@ namespace eval punk::mix::commandset::project { set col_states [list] set state_title "" - #if only one set of fossil checkouts in the resultset and opt_detail is 0 and not explicit - retrieve workingdir state for each co + #if only one set of fossil checkouts in the resultset and opt_detail is 0 and not explicit - retrieve workingdir state for each co if {([llength [dict keys $fosdb_cache]] == 1)} { if {!$opt_detail_explicit_zero} { set opt_detail 1 @@ -884,13 +884,13 @@ namespace eval punk::mix::commandset::project { set state_dict [punk::repo::workingdir_state_summary_dict $wd_state] lappend c_rev [string range [dict get $state_dict revision] 0 9] lappend c_rev_iso [dict get $state_dict revision_iso8601] - lappend c_unchanged [dict get $state_dict unchanged] + lappend c_unchanged [dict get $state_dict unchanged] lappend c_changed [dict get $state_dict changed] lappend c_new [dict get $state_dict new] lappend c_missing [dict get $state_dict missing] lappend c_extra [dict get $state_dict extra] puts -nonewline stderr "." - } + } puts -nonewline stderr \n set t0 "Revision" set w0 [tcl::mathfunc::max {*}[lmap v [concat [list $t0] $c_rev] {string length $v}]] @@ -913,13 +913,13 @@ namespace eval punk::mix::commandset::project { set t5 "Extr" set w5 [tcl::mathfunc::max {*}[lmap v [concat [list $t5] $c_extra] {string length $v}]] set c5 [string repeat " " $w5] - + set state_title "[overtype::left $c0 $t0] [overtype::left $c0b $t0b] [overtype::right $c1 $t1] [overtype::right $c2 $t2] [overtype::right $c3 $t3] [overtype::right $c4 $t4] [overtype::right $c5 $t5]" foreach r $c_rev iso $c_rev_iso u $c_unchanged c $c_changed n $c_new m $c_missing e $c_extra { lappend col_states "[overtype::left $c0 $r] [overtype::left $c0b $iso] [overtype::right $c1 $u] [overtype::right $c2 $c] [overtype::right $c3 $n] [overtype::right $c4 $m] [overtype::right $c5 $e]" } } - + set msg "" if {$opt_cd} { set title0 "CD" @@ -948,7 +948,7 @@ namespace eval punk::mix::commandset::project { append msg "[overtype::right $col0 $title0] [overtype::left $col1 $title1] [overtype::left $col2 $title2] [overtype::left $col3 $title3] [overtype::left $col4 $title4] [overtype::left $col5 $title5]" if {[llength $col_states]} { - set title6 $state_title + set title6 $state_title set widest6 [tcl::mathfunc::max {*}[lmap v [concat [list $title6] $col_states] {string length $v}]] set col6 [string repeat " " $widest6] incr tablewidth [expr {$widest6 + 1}] @@ -965,7 +965,7 @@ namespace eval punk::mix::commandset::project { set wd [punk::ansi::a+ red]$wd[a] } append msg "[overtype::right $col0 $row] [overtype::left $col1 $wd] [overtype::left $col2 $db] [overtype::right $col3 $dup] [overtype::left $col4 $pname] [overtype::left $col5 $pcode] [overtype::left $col6 $s]" \n - } + } } else { foreach row $col_rowids wd $workdirs db $col_fnames dup $col_dupids pname $col_pnames pcode $col_pcodes { if {![file exists $wd]} { @@ -973,7 +973,7 @@ namespace eval punk::mix::commandset::project { set wd [punk::ansi::a+ red]$wd[a] } append msg "[overtype::right $col0 $row] [overtype::left $col1 $wd] [overtype::left $col2 $db] [overtype::right $col3 $dup] [overtype::left $col4 $pname] [overtype::left $col5 $pcode]" \n - } + } } set numrows [llength $col_rowids] if {$opt_cd && $numrows >= 1} { @@ -985,7 +985,7 @@ namespace eval punk::mix::commandset::project { ::cd $workingdir return $workingdir } else { - puts stderr "path $workingdir doesn't appear to exist" + puts stderr "path $workingdir doesn't appear to exist" return [pwd] } } else { @@ -1004,12 +1004,12 @@ namespace eval punk::mix::commandset::project { #*** !doctools #[list_end] [comment {-- end collection namespace definitions --}] } - + namespace eval lib { proc template_tag {tagname} { #todo - support different tagwrappers - it shouldn't be so likely to collide with common code idioms etc. #we need to detect presence of tags intended for punk::mix system - #consider using punk::cap to enable multiple template-substitution providers with their own set of tagnames and/or tag wrappers, where substitution providers are all run + #consider using punk::cap to enable multiple template-substitution providers with their own set of tagnames and/or tag wrappers, where substitution providers are all run return [string cat % $tagname %] } #get project info only by opening the central confg-db @@ -1032,12 +1032,13 @@ namespace eval punk::mix::commandset::project { set path [string trim [string range $pr 5 end]] set nm [file rootname [file tail $path]] set ckouts [fosconf eval {select name from global_config where value = $path;}] + #list of entries like "ckout:C:/buildtcl/2024zig/tcl90/" set checkout_paths [list] #strip "ckout:" foreach ck $ckouts { lappend checkout_paths [string trim [string range $ck 6 end]] } - lappend paths_and_names [list $path $nm $checkout_paths] + lappend paths_and_names [list $path $nm $checkout_paths] } set filtered_list [list] foreach glob $globlist { @@ -1045,16 +1046,14 @@ namespace eval punk::mix::commandset::project { foreach m $matches { if {$m ni $filtered_list} { lappend filtered_list $m - } + } } } set projects [lsort -index 1 $filtered_list] return $projects } - + } - - @@ -1067,15 +1066,10 @@ namespace eval punk::mix::commandset::project { - - - - - # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready +## Ready package provide punk::mix::commandset::project [namespace eval punk::mix::commandset::project { variable version - set version 0.1.0 + set version 0.1.0 }] return diff --git a/src/vfs/_vfscommon.vfs/modules/punk/mix/commandset/repo-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/punk/mix/commandset/repo-0.1.0.tm index 73b54874..277e386e 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/mix/commandset/repo-0.1.0.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/mix/commandset/repo-0.1.0.tm @@ -24,6 +24,9 @@ # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ namespace eval punk::mix::commandset::repo { namespace export * + + variable PUNKARGS + proc tickets {{project ""}} { #todo set result "" @@ -52,9 +55,9 @@ namespace eval punk::mix::commandset::repo { set repopaths [punk::repo::find_repos [pwd]] set repos [dict get $repopaths repos] if {![llength $repos]} { - append result [dict get $repopaths warnings] + append result [a+ bold yellow][dict get $repopaths warnings][a] } else { - append result [dict get $repopaths warnings] + append result [a+ bold yellow][dict get $repopaths warnings][a] lassign [lindex $repos 0] repopath repotypes if {"fossil" in $repotypes} { append result \n "Fossil repo based at $repopath" @@ -69,6 +72,17 @@ namespace eval punk::mix::commandset::repo { } return $result } + + #punk::args + lappend PUNKARGS [list { + @id -id ::punk::mix::commandset::repo::fossil-move-repository + @cmd -name punk::mix::commandset::repo::fossil-move-repository -help\ + "Move the fossil repository file (usually named with .fossil extension). + This is an interactive function which will prompt for answers on stdin + before proceeding. + The move can be done even if there are open checkouts and will maintain + the link between checkout databases and the repository file." + }] proc fossil-move-repository {{path ""}} { set searchbase [pwd] set projectinfo [punk::repo::find_repos $searchbase] @@ -281,7 +295,7 @@ namespace eval punk::mix::commandset::repo { set ckouts [oldrepo eval {select name from config where name like 'ckout:%'}] oldrepo close if {[llength $ckouts] > 1} { - puts stdout "There are [llength $ckouts] checkouts for the repository you are moving" + puts stdout "There are [llength $ckouts] checkouts for the repository you are moving" puts stdout "You will be asked for each checkout if you want to adjust it to point to $target_repodb_folder/$pname2.folder" } set original_cwd [pwd] @@ -304,11 +318,11 @@ namespace eval punk::mix::commandset::repo { puts stderr "${ansiwarn}The fossil test-move-repository command appears to have failed${ansireset}" puts stderr "$moveresult" } else { - puts stdout "OK - move performed with result:" + puts stdout "OK - move performed with result:" puts stdout $moveresult } } - } + } cd $original_cwd } @@ -379,7 +393,7 @@ namespace eval punk::mix::commandset::repo { puts stderr "${ansiwarn}The fossil test-move-repository command appears to have failed${ansireset}" puts stderr "$moveresult" } else { - puts stdout "OK - move performed with result:" + puts stdout "OK - move performed with result:" puts stdout $moveresult } } @@ -402,10 +416,10 @@ namespace eval punk::mix::commandset::repo { - - - - +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::mix::commandset::repo +} @@ -413,9 +427,9 @@ namespace eval punk::mix::commandset::repo { # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready +## Ready package provide punk::mix::commandset::repo [namespace eval punk::mix::commandset::repo { variable version - set version 0.1.0 + set version 0.1.0 }] return diff --git a/src/vfs/_vfscommon.vfs/modules/punk/mix/templates/layouts/project/src/make.tcl b/src/vfs/_vfscommon.vfs/modules/punk/mix/templates/layouts/project/src/make.tcl index 54bcea69..75624bc3 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/mix/templates/layouts/project/src/make.tcl +++ b/src/vfs/_vfscommon.vfs/modules/punk/mix/templates/layouts/project/src/make.tcl @@ -314,7 +314,7 @@ if {$::punkmake::command eq "vendor"} { } # -- --- --- --- --- --- } else { - puts -nonewline stderr "." + puts -nonewline stderr "v" $installation_event targetset_end SKIPPED } $installation_event end @@ -383,7 +383,7 @@ if {$::punkmake::command eq "bootsupport"} { if {[package vcompare $ver $latestver] == 1} { set latestver $ver set latestfile $m - } + } } set srcfile [file join $srclocation $latestfile] set tgtfile [file join $targetroot $module_subpath $latestfile] @@ -409,7 +409,7 @@ if {$::punkmake::command eq "bootsupport"} { } # -- --- --- --- --- --- } else { - puts -nonewline stderr "." + puts -nonewline stderr "b" $boot_event targetset_end SKIPPED } $boot_event end @@ -589,7 +589,7 @@ foreach layoutbase $layout_bases { } # -- --- --- --- --- --- } else { - puts stderr "." + puts stderr "skipping unchanged layout $layoutname" $tpl_event targetset_end SKIPPED } } @@ -658,7 +658,7 @@ if {[punk::repo::is_fossil_root $projectroot]} { } # -- --- --- --- --- --- } else { - puts stderr "." + puts stderr "skipping unchanged .fossil-custom/mainmenu" $event targetset_end SKIPPED } $event end @@ -803,7 +803,7 @@ foreach runtimefile $runtimes { } # -- --- --- --- --- --- } else { - puts stderr "." + puts stderr "skipping unchanged runtime $runtimefile" $event targetset_end SKIPPED } $event end @@ -1064,8 +1064,7 @@ foreach vfs $vfs_folders { } else { set skipped_vfs_build 1 - puts stderr "." - puts stdout "Skipping build for vfs $vfs with runtime $rtname - no change detected" + puts stderr "Skipping build for vfs $vfs with runtime $rtname - no change detected" $vfs_event targetset_end SKIPPED } $vfs_event destroy diff --git a/src/vfs/_vfscommon.vfs/modules/punk/mod-0.1.tm b/src/vfs/_vfscommon.vfs/modules/punk/mod-0.1.tm index 58906c88..26ed2f2e 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/mod-0.1.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/mod-0.1.tm @@ -1,164 +1,163 @@ -#punkapps app manager -# deck cli - -namespace eval punk::mod::cli { - namespace export help list run - namespace ensemble create - - # namespace ensemble configure [namespace current] -unknown punk::mod::cli::_unknown - if 0 { - proc _unknown {ns args} { - puts stderr "punk::mod::cli::_unknown '$ns' '$args'" - puts stderr "punk::mod::cli::help $args" - puts stderr "arglen:[llength $args]" - punk::mod::cli::help {*}$args - } - } - - #cli must have _init method - usually used to load commandsets lazily - # - variable initialised 0 - proc _init {args} { - variable initialised - if {$initialised} { - return - } - #... - set initialised 1 - } - - proc help {args} { - set basehelp [punk::mix::base help {*}$args] - #namespace export - return $basehelp - } - proc getraw {appname} { - upvar ::punk::config::running running_config - set app_folders [dict get $running_config apps] - #todo search each app folder - set bases [::list] - set versions [::list] - set mains [::list] - set appinfo [::list bases {} mains {} versions {}] - - foreach containerfolder $app_folders { - lappend bases $containerfolder - if {[file exists $containerfolder]} { - if {[file exists $containerfolder/$appname/main.tcl]} { - #exact match - only return info for the exact one specified - set namematches $appname - set parts [split $appname -] - } else { - set namematches [glob -nocomplain -dir $containerfolder -type d -tail ${appname}-*] - set namematches [lsort $namematches] ;#todo - -ascii? -dictionary? natsort? - } - foreach nm $namematches { - set mainfile $containerfolder/$nm/main.tcl - set parts [split $nm -] - if {[llength $parts] == 1} { - set ver "" - } else { - set ver [lindex $parts end] - } - if {$ver ni $versions} { - lappend versions $ver - lappend mains $ver $mainfile - } else { - puts stderr "punk::apps::app version '$ver' of app '$appname' already encountered at $mainfile. (will use earliest encountered in running-config apps and ignore others of same version)" - } - } - } else { - puts stderr "punk::apps::app missing apps_folder:'$containerfolder' Ensure apps_folder is set in punk::config" - } - } - dict set appinfo versions $versions - #todo - natsort! - set sorted_versions [lsort $versions] - set latest [lindex $sorted_versions 0] - if {$latest eq "" && [llength $sorted_versions] > 1} { - set latest [lindex $sorted_versions 1 - } - dict set appinfo latest $latest - - dict set appinfo bases $bases - dict set appinfo mains $mains - return $appinfo - } - - proc list {{glob *}} { - upvar ::punk::config::running running_config - set apps_folder [dict get $running_config apps] - if {[file exists $apps_folder]} { - if {[file exists $apps_folder/$glob]} { - #tailcall source $apps_folder/$glob/main.tcl - return $glob - } - set apps [glob -nocomplain -dir $apps_folder -type d -tail $glob] - if {[llength $apps] == 0} { - if {[string first * $glob] <0 && [string first ? $glob] <0} { - #no glob chars supplied - only launch if exact match for name part - set namematches [glob -nocomplain -dir $apps_folder -type d -tail ${glob}-*] - set namematches [lsort $namematches] ;#todo - -ascii? -dictionary? natsort? - if {[llength $namematches] > 0} { - set latest [lindex $namematches end] - lassign $latest nm ver - #tailcall source $apps_folder/$latest/main.tcl - } - } - } - - return $apps - } - } - - #todo - way to launch as separate process - # solo-opts only before appname - args following appname are passed to the app - proc run {args} { - set nameposn [lsearch -not $args -*] - if {$nameposn < 0} { - error "punkapp::run unable to determine application name" - } - set appname [lindex $args $nameposn] - set controlargs [lrange $args 0 $nameposn-1] - set appargs [lrange $args $nameposn+1 end] - - set appinfo [punk::mod::cli::getraw $appname] - if {[llength [dict get $appinfo versions]]} { - set ver [dict get $appinfo latest] - puts stdout "info: $appinfo" - set ::argc [llength $appargs] - set ::argv $appargs - source [dict get $appinfo mains $ver] - if {"-hideconsole" in $controlargs} { - puts stderr "attempting console hide" - #todo - something better - a callback when window mapped? - after 500 {::punkapp::hide_console} - } - return $appinfo - } else { - error "punk::mod::cli unable to run '$appname'. main.tcl not found in [dict get $appinfo bases]" - } - } - - -} - -namespace eval punk::mod::cli { - proc _cli {args} { - #don't use tailcall - base uses info level to determine caller - ::punk::mix::base::_cli {*}$args - } - variable default_command help - package require punk::mix::base - package require punk::overlay - punk::overlay::custom_from_base [namespace current] ::punk::mix::base -} - -package provide punk::mod [namespace eval punk::mod { - variable version - set version 0.1 - -}] - - - +#punkapps app manager +# deck cli + +namespace eval punk::mod::cli { + namespace export help list run + namespace ensemble create + + # namespace ensemble configure [namespace current] -unknown punk::mod::cli::_unknown + if 0 { + proc _unknown {ns args} { + puts stderr "punk::mod::cli::_unknown '$ns' '$args'" + puts stderr "punk::mod::cli::help $args" + puts stderr "arglen:[llength $args]" + punk::mod::cli::help {*}$args + } + } + + #cli must have _init method - usually used to load commandsets lazily + # + variable initialised 0 + proc _init {args} { + variable initialised + if {$initialised} { + return + } + #... + set initialised 1 + } + + proc help {args} { + set basehelp [punk::mix::base help {*}$args] + #namespace export + return $basehelp + } + proc getraw {appname} { + upvar ::punk::config::running running_config + set app_folders [dict get $running_config apps] + #todo search each app folder + set bases [::list] + set versions [::list] + set mains [::list] + set appinfo [::list bases {} mains {} versions {}] + + foreach containerfolder $app_folders { + lappend bases $containerfolder + if {[file exists $containerfolder]} { + if {[file exists $containerfolder/$appname/main.tcl]} { + #exact match - only return info for the exact one specified + set namematches $appname + set parts [split $appname -] + } else { + set namematches [glob -nocomplain -dir $containerfolder -type d -tail ${appname}-*] + set namematches [lsort $namematches] ;#todo - -ascii? -dictionary? natsort? + } + foreach nm $namematches { + set mainfile $containerfolder/$nm/main.tcl + set parts [split $nm -] + if {[llength $parts] == 1} { + set ver "" + } else { + set ver [lindex $parts end] + } + if {$ver ni $versions} { + lappend versions $ver + lappend mains $ver $mainfile + } else { + puts stderr "punk::apps::app version '$ver' of app '$appname' already encountered at $mainfile. (will use earliest encountered in running-config apps and ignore others of same version)" + } + } + } else { + puts stderr "punk::apps::app missing apps_folder:'$containerfolder' Ensure apps_folder is set in punk::config" + } + } + dict set appinfo versions $versions + #todo - natsort! + set sorted_versions [lsort $versions] + set latest [lindex $sorted_versions 0] + if {$latest eq "" && [llength $sorted_versions] > 1} { + set latest [lindex $sorted_versions 1] + } + dict set appinfo latest $latest + + dict set appinfo bases $bases + dict set appinfo mains $mains + return $appinfo + } + + proc list {{glob *}} { + upvar ::punk::config::running running_config + set apps_folder [dict get $running_config apps] + if {[file exists $apps_folder]} { + if {[file exists $apps_folder/$glob]} { + #tailcall source $apps_folder/$glob/main.tcl + return $glob + } + set apps [glob -nocomplain -dir $apps_folder -type d -tail $glob] + if {[llength $apps] == 0} { + if {[string first * $glob] <0 && [string first ? $glob] <0} { + #no glob chars supplied - only launch if exact match for name part + set namematches [glob -nocomplain -dir $apps_folder -type d -tail ${glob}-*] + set namematches [lsort $namematches] ;#todo - -ascii? -dictionary? natsort? + if {[llength $namematches] > 0} { + set latest [lindex $namematches end] + lassign $latest nm ver + #tailcall source $apps_folder/$latest/main.tcl + } + } + } + + return $apps + } + } + + #todo - way to launch as separate process + # solo-opts only before appname - args following appname are passed to the app + proc run {args} { + set nameposn [lsearch -not $args -*] + if {$nameposn < 0} { + error "punkapp::run unable to determine application name" + } + set appname [lindex $args $nameposn] + set controlargs [lrange $args 0 $nameposn-1] + set appargs [lrange $args $nameposn+1 end] + + set appinfo [punk::mod::cli::getraw $appname] + if {[llength [dict get $appinfo versions]]} { + set ver [dict get $appinfo latest] + puts stdout "info: $appinfo" + set ::argc [llength $appargs] + set ::argv $appargs + source [dict get $appinfo mains $ver] + if {"-hideconsole" in $controlargs} { + puts stderr "attempting console hide" + #todo - something better - a callback when window mapped? + after 500 {::punkapp::hide_console} + } + return $appinfo + } else { + error "punk::mod::cli unable to run '$appname'. main.tcl not found in [dict get $appinfo bases]" + } + } + + +} + +namespace eval punk::mod::cli { + proc _cli {args} { + #don't use tailcall - base uses info level to determine caller + ::punk::mix::base::_cli {*}$args + } + variable default_command help + package require punk::mix::base + package require punk::overlay + punk::overlay::custom_from_base [namespace current] ::punk::mix::base +} + +package provide punk::mod [namespace eval punk::mod { + variable version + set version 0.1 +}] + + + diff --git a/src/vfs/_vfscommon.vfs/modules/punk/netbox-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/punk/netbox-0.1.0.tm index d98c38c4..74185191 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/netbox-0.1.0.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/netbox-0.1.0.tm @@ -372,7 +372,7 @@ tcl::namespace::eval punk::netbox { if {"tokentail" in $fields} { #computed column if {[dict exists $contextinfo token]} { - set tokentail [string range [dict get $contextinfo token] end-5 end] + set tokentail [string range [dict get $contextinfo token value] end-5 end] } } set rowdata [list $k] @@ -405,7 +405,7 @@ tcl::namespace::eval punk::netbox { if {"tokentail" in $fields} { #computed column if {[dict exists $contextinfo token]} { - set tokentail [string range [dict get $contextinfo token] end-5 end] + set tokentail [string range [dict get $contextinfo token value] end-5 end] } } dict set result $k {} ;#ensure record is output even if empty fieldlist @@ -1144,12 +1144,12 @@ tcl::namespace::eval punk::netbox { proc default_topics {} {return [list Description *]} # ------------------------------------------------------------- - # get_topic_ functions add more to auto-include in about topics + # get_topic_ functions add more to auto-include in about topicg # ------------------------------------------------------------- proc get_topic_Description {} { punk::args::lib::tstr [string trim { package punk::netbox - description to come.. + A library for calling netbox REST functions } \n] } proc get_topic_License {} { @@ -1169,11 +1169,10 @@ tcl::namespace::eval punk::netbox { } return $contributors } - proc get_topic_custom-topic {} { + proc get_topic_features {} { punk::args::lib::tstr -return string { - A custom - topic - etc + netbox /status/ endpoint + beginnings of /ipam/ endpoints } } # ------------------------------------------------------------- diff --git a/src/vfs/_vfscommon.vfs/modules/punk/path-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/punk/path-0.1.0.tm index f0a4a444..1ddd56b7 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/path-0.1.0.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/path-0.1.0.tm @@ -657,6 +657,7 @@ namespace eval punk::path { **/_aside (exlude files where _aside is last segment) **/_aside/* (exclude folders one below an _aside folder) **/_aside/** (exclude all folders with _aside as a segment)" + -antiglob_files -default {} @values -min 0 -max -1 -optional 1 -type string tailglobs -default * -multiple 1 -help\ "Patterns to match against filename portion (last segment) of each file path @@ -681,6 +682,7 @@ namespace eval punk::path { set tailglobs [dict get $values tailglobs] # -- --- --- --- --- --- --- set opt_antiglob_paths [dict get $opts -antiglob_paths] + set opt_antiglob_files [dict get $opts -antiglob_files] set CALLDEPTH [dict get $opts -call-depth-internal] # -- --- --- --- --- --- --- # -- --- --- --- --- --- --- @@ -718,7 +720,24 @@ namespace eval punk::path { puts stderr "treefilenames error while listing files in dir $opt_dir\n $matches" set dirfiles [list] } else { - set dirfiles [lsort $matches] + set retained [list] + if {[llength $opt_antiglob_files]} { + foreach m $matches { + set skip 0 + set ftail [file tail $m] + foreach anti $opt_antiglob_files { + if {[string match $anti $ftail]} { + set skip 1; break + } + } + if {!$skip} { + lappend retained $m + } + } + } else { + set retained $matches + } + set dirfiles [lsort $retained] } lappend files {*}$dirfiles diff --git a/src/vfs/_vfscommon.vfs/modules/punk/repl-0.1.1.tm b/src/vfs/_vfscommon.vfs/modules/punk/repl-0.1.1.tm index cc99157b..d08cb8cb 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/repl-0.1.1.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/repl-0.1.1.tm @@ -3091,13 +3091,12 @@ namespace eval repl { set v [lindex $versions end] set path [lindex [package ifneeded $pkg $v] end] if {[file extension $path] in {.tcl .tm}} { - if {[file exists $path]} { - set data [readFile $path] + if {![catch {readFile $path} data]} { code eval [list info script $path] code eval $data code eval [list info script $prior_infoscript] } else { - error "safe - failed to find $path" + error "safe - failed to read $path" } } else { error "safe - refusing to attempt load of $pkg from $path - (allowed extensions .tcl .tm)" diff --git a/src/vfs/_vfscommon.vfs/modules/punk/repo-0.1.1.tm b/src/vfs/_vfscommon.vfs/modules/punk/repo-0.1.1.tm index f53a06fd..a39fceaf 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/repo-0.1.1.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/repo-0.1.1.tm @@ -39,16 +39,16 @@ if {$::tcl_platform(platform) eq "windows"} { } package require fileutil; #tcllib package require punk::path -package require punk::mix::base ;#uses core functions from punk::mix::base::lib namespace e.g cksum_path +package require punk::mix::base ;#uses core functions from punk::mix::base::lib namespace e.g cksum_path package require punk::mix::util ;#do_in_path # -- --- --- --- --- --- --- --- --- --- --- # For performance/efficiency reasons - use file functions on paths in preference to string operations -# e.g use file join +# e.g use file join # branch to avoid unnecessary calls to 'pwd' or 'file normalize' - which can be surprisingly expensive operations (as at tcl 8.7 2023) # pwd is only expensive if we treat it as a string instead of a list/path -# e.g +# e.g # > time {set x [pwd]} # 5 microsoeconds.. no problem # > time {set x [pwd]} @@ -67,11 +67,11 @@ namespace eval punk::repo { variable cached_command_paths set cached_command_paths [dict create] - #anticipating possible removal of buggy caching from auto_execok + #anticipating possible removal of buggy caching from auto_execok #mentioned in: https://core.tcl-lang.org/tcl/tktview/4dc35e0c0c #this would leave the application to decide what it wants to cache in that regard. proc Cached_auto_execok {name} { - return [auto_execok $name] + return [auto_execok $name] #variable cached_command_paths #if {[dict exists $cached_command_paths $name]} { # return [dict get $cached_command_paths $name] @@ -102,14 +102,14 @@ namespace eval punk::repo { "" {${$othercmds}} } }] - + return $result } #lappend PUNKARGS [list { # @dynamic - # @id -id ::punk::repo::fossil_proxy + # @id -id ::punk::repo::fossil_proxy # @cmd -name fossil -help "fossil executable # " # @argdisplay -header "fossil help" -body {${[runout -n fossil help]}} @@ -117,7 +117,7 @@ namespace eval punk::repo { lappend PUNKARGS [list { @dynamic - @id -id ::punk::repo::fossil_proxy + @id -id ::punk::repo::fossil_proxy @cmd -name fossil -help "fossil executable" ${[punk::repo::get_fossil_usage]} } ] @@ -128,14 +128,13 @@ namespace eval punk::repo { lappend PUNKARGS [list { @dynamic @id -id "::punk::repo::fossil_proxy diff" - @cmd -name "fossil diff" -help "fossil diff - " + @cmd -name "fossil diff" -help "fossil diff" @argdisplay -header "fossil help diff" -body {${[runout -n fossil help diff]}} } ""] lappend PUNKARGS [list { #todo - remove this comment - testing dynamic directive - @dynamic - @id -id "::punk::repo::fossil_proxy add" + @dynamic + @id -id "::punk::repo::fossil_proxy add" @cmd -name "fossil add" -help "fossil add " @argdisplay -header "fossil help add" -body {${[runout -n fossil help add]}} @@ -152,16 +151,16 @@ namespace eval punk::repo { lappend PUNKARGS_aliases {"::fossil diff" "::punk::repo::fossil_proxy diff"} - #Todo - investigate proper way to install a client-side commit hook in the fossil project + #Todo - investigate proper way to install a client-side commit hook in the fossil project #Then we may still use this proxy to check the hook - but the required checks will occur when another shell used proc fossil_proxy {args} { set start_dir [pwd] - set fosroot [find_fossil $start_dir] + set fosroot [find_fossil $start_dir] set fossilcmd [lindex $args 0] set no_warning_commands [list "help" "dbstat" "grep" "diff" "xdiff" "cat" "version"] if {$fossilcmd ni $no_warning_commands } { - set repostate [find_repos $start_dir] + set repostate [find_repos $start_dir] } set no_prompt_commands [list "status" "info" {*}$no_warning_commands] @@ -170,7 +169,7 @@ namespace eval punk::repo { if {$fossilcmd ni $no_prompt_commands} { set fossilrepos [dict get $repostate fossil] if {[llength $fossilrepos] > 1} { - puts stdout [dict get $repostate warnings] + puts stdout [punk::ansi::a+ bold yellow][dict get $repostate warnings][punk::ansi::a] puts stdout "Operating on inner fossil repository: [lindex $fossilrepos 0]" puts stdout "Use FOSSIL instead of fossil to avoid this prompt and warning" set answer [askuser "Are you sure you want to perform the operation on this repo? Y/N"] @@ -217,7 +216,7 @@ namespace eval punk::repo { } } elseif {$fossilcmd in [list "info" "status"]} { #emit warning whether or not multiple fossil repos - puts stdout [dict get $repostate warnings] + puts stdout [punk::ansi::a+ bold yellow][dict get $repostate warnings][punk::ansi::a] } set fossil_prog [Cached_auto_execok fossil] if {$fossil_prog ne ""} { @@ -234,7 +233,7 @@ namespace eval punk::repo { #safe interps can't call auto_execok #At least let them load the package even though much of it may be unusable depending on the safe configuration #catch { - # if {[auto_execok fossil] ne ""} { + # if {[auto_execok fossil] ne ""} { # interp alias "" FOSSIL "" {*}[auto_execok fossil] # } #} @@ -245,7 +244,7 @@ namespace eval punk::repo { #uppercase FOSSIL to bypass fossil as alias to fossil_proxy #only necessary on unix? - #Windows filesystem case insensitive so any non-lowercase fossil version goes out to get an ::auto_execs entry anyway + #Windows filesystem case insensitive so any non-lowercase fossil version goes out to get an ::auto_execs entry anyway proc establish_FOSSIL {args} { #review if {![info exists ::auto_execs(FOSSIL)]} { @@ -298,7 +297,7 @@ namespace eval punk::repo { if {$path eq {}} { set path [pwd] } scanup $path is_fossil_root } - + proc find_git {{path {}}} { if {$path eq {}} { set path [pwd] } scanup $path is_git_root @@ -330,12 +329,31 @@ namespace eval punk::repo { } } } + lappend PUNKARGS [list { + @id -id "::punk::repo::find_project" + @cmd -name "punk::repo::find_project" -help\ + "Find and return the path for the root of + the project to which the supplied path belongs. + If the supplied path is empty, the current + working directory is used as the starting point + for the upwards search. + Returns nothing if there is no project at or + above the specified path." + @values -min 0 -max 1 + path -optional 1 -default "" -help\ + "May be an absolute or relative path. + The full specified path doesn't have + to exist. The code will walk upwards + along the segments of the supplied path + testing the result of 'is_project_root'." + }] proc find_project {{path {}}} { if {$path eq {}} { set path [pwd] } - scanup $path is_project_root + scanup $path is_project_root } - proc is_fossil_root {{path {}}} { + #detect if path is a fossil root - without consulting fossil databases + proc is_fossil_root2 {{path {}}} { if {$path eq {}} { set path [pwd] } #from kettle::path::is.fossil foreach control { @@ -348,20 +366,51 @@ namespace eval punk::repo { } return 0 } - + proc is_fossil_root {{path {}}} { + #much faster on windows than 'file exists' checks + if {$path eq {}} { set path [pwd] } + set control [list _FOSSIL_ .fslckout .fos] + #could be marked 'hidden' on windows + if {"windows" eq $::tcl_platform(platform)} { + set files [list {*}[glob -nocomplain -dir $path -types f -tail {*}$control] {*}[glob -nocomplain -dir $path -types {f hidden} -tail {*}$control]] + } else { + set files [glob -nocomplain -dir $path -types f -tail {*}$control] + } + expr {[llength $files] > 0} + } + #review - is a .git folder sufficient? #consider git rev-parse --git-dir ? proc is_git_root {{path {}}} { if {$path eq {}} { set path [pwd] } - set control [file join $path .git] - expr {[file exists $control] && [file isdirectory $control]} + #set control [file join $path .git] + #expr {[file exists $control] && [file isdirectory $control]} + if {"windows" eq $::tcl_platform(platform)} { + #:/ + #globbing for dotfiles in tcl is problematic across platforms - windows 'hidden' concept is independent + #we need to find .git whether hidden or not - so need 2 glob operations + #.git may or may not be set with windows 'hidden' attribute + set hiddengitdir [glob -nocomplain -dir $path -types {d hidden} -tail .git] + set nonhiddengitdir [glob -nocomplain -dir $path -types {d} -tail .git] ;#won't return hidden :/ + return [expr {[llength [list {*}$hiddengitdir {*}$nonhiddengitdir]] > 0}] + } else { + #:/ + #unix returns 'hidden' files even without the hidden type being specified - but only if the pattern explicitly matches + return [expr {[llength [glob -nocomplain -dir $path -types d -tail .git]] > 0}] ;#will return .git even though it is conventionally 'hidden' on unix :/ + } } proc is_repo_root {{path {}}} { if {$path eq {}} { set path [pwd] } - expr {[is_fossil_root $path] || [is_git_root $path]} + #expr {[is_fossil_root $path] || [is_git_root $path]} + expr {[is_git_root $path] || [is_fossil_root $path]} ;#is_git_root has less to check } - #require a minimum of src and src/modules|src/scriptapps|src/*/*.vfs - and that it's otherwise sensible - #we still run a high chance of picking up unintended candidates - but hopefully it's a reasonable balance. + + #after excluding undesirables; + #require a minimum of + # - (src and src/modules|src/scriptapps|src/vfs) + # - OR (src and punkproject.toml) + # - and that it's otherwise sensible + #we still run a chance of picking up unintended candidates - but hopefully it's a reasonable balance. proc is_candidate_root {{path {}}} { if {$path eq {}} { set path [pwd] } if {[file pathtype $path] eq "relative"} { @@ -380,24 +429,34 @@ namespace eval punk::repo { } #review - adjust to allow symlinks to folders? - foreach required { - src - } { - set req $path/$required - if {(![file exists $req]) || ([file type $req] ne "directory") } {return 0} + #foreach required { + # src + #} { + # set req $path/$required + # if {(![file exists $req]) || ([file type $req] ne "directory") } {return 0} + #} + set required [list src] + set found_required [glob -nocomplain -dir $path -types d -tails {*}$required] + if {[llength $found_required] < [llength $required]} { + return 0 } set src_subs [glob -nocomplain -dir $path/src -types d -tail *] #test for $path/src/lib is too common to be a useful indicator - if {"modules" in $src_subs || "scriptapps" in $src_subs} { + if {"modules" in $src_subs || "vfs" in $src_subs || "scriptapps" in $src_subs} { + #bare minimum 1 return 1 } - foreach sub $src_subs { - if {[string match *.vfs $sub]} { - return 1 - } + + #bare minimum2 + # - has src folder and (possibly empty?) punkproject.toml + if {[file exists $path/punkproject.toml]} { + return 1 } + #review - do we need to check if path is already within a project? + #can we have a nested project? Seems like asking for complexity and problems when considering possible effects for git/fossil + #todo - breadth first search with depth limit (say depth 3?) for *.tm or *.tcl as another positive qualifier for this dir to be a project-root #we probably don't want to deep search a src folder in case the user is accidentally in some other type of project's tree #such a src tree could be very large, so if we don't find tcl indicators near the root it's a good bet this isn't a candidate @@ -415,14 +474,22 @@ namespace eval punk::repo { } proc is_project_root {path} { - #review - find a reliable simple mechanism. Noting we have projects based on different templates. + #review - find a reliable simple mechanism. Noting we have projects based on different templates. #Should there be a specific required 'project' file of some sort? + #(punkproject.toml is a candidate) + #we don't want to solely rely on such a file being present + # - we may also have punkproject.toml in project_layout template folders for example #test for file/folder items indicating fossil or git workdir base - if {(![punk::repo::is_fossil_root $path]) && (![punk::repo::is_git_root $path])} { + #the 'dev' mechanism for creating projects automatically creates a fossil project + #(which can be ignored if the user wants to manage it with git - but should probably remain in place? review) + #however - we currently require that for it to be a 'project' there must be some version control. + #REVIEW. + # + if {![punk::repo::is_repo_root $path]} { return 0 } - #exclude some known places we wouldn't want to put a project + #exclude some known places we wouldn't want to put a project if {![is_candidate_root $path]} { return 0 } @@ -456,7 +523,7 @@ namespace eval punk::repo { if {$abspath in [dict keys $defaults]} { set args [list $abspath {*}$args] set abspath "" - } + } set opts [dict merge $defaults $args] # -- --- --- --- --- --- --- --- --- --- --- --- set opt_repotypes [dict get $opts -repotypes] @@ -793,7 +860,7 @@ namespace eval punk::repo { } } if {$repotype eq "git"} { - dict set fieldnames extra "extra (files/folders)" + dict set fieldnames extra "extra (files/folders)" } set col1_fields [list] set col2_values [list] @@ -846,6 +913,7 @@ namespace eval punk::repo { #determine nature of possibly-nested repositories (of various types) at and above this path #Treat an untracked 'candidate' folder as a sort of repository proc find_repos {path} { + puts "find_repos '$path'" set start_dir $path #root is a 'project' if it it meets the candidate requrements and is under repo control @@ -860,6 +928,10 @@ namespace eval punk::repo { while {[string length [set fosroot [punk::repo::find_fossil $fos_search_from]]]} { lappend fossils_bottom_to_top $fosroot set fos_search_from [file dirname $fosroot] + if {$fos_search_from eq $fosroot} { + #root of filesystem is repo - unusual case - but without this we would never escape the while loop + break + } } dict set root_dict fossil $fossils_bottom_to_top @@ -868,6 +940,9 @@ namespace eval punk::repo { while {[string length [set gitroot [punk::repo::find_git $git_search_from]]]} { lappend gits_bottom_to_top $gitroot set git_search_from [file dirname $gitroot] + if {$git_search_from eq $gitroot} { + break + } } dict set root_dict git $gits_bottom_to_top @@ -876,6 +951,9 @@ namespace eval punk::repo { while {[string length [set candroot [punk::repo::find_candidate $cand_search_from]]]} { lappend candidates_bottom_to_top $candroot set cand_search_from [file dirname $candroot] + if {$cand_search_from eq $candroot} { + break + } } dict set root_dict candidate $candidates_bottom_to_top @@ -936,14 +1014,14 @@ namespace eval punk::repo { dict set root_dict closest [lindex $longest_first 0 1] ;#the *path* of the closest to start_dir dict set root_dict closest_types [lindex $longest_first 0 0] } - - set closest_fossil [lindex [dict get $root_dict fossil] 0] - set closest_fossil_len [llength [file split $closest_fossil]] - set closest_git [lindex [dict get $root_dict git] 0] - set closest_git_len [llength [file split $closest_git]] - set closest_candidate [lindex [dict get $root_dict candidate] 0] - set closest_candidate_len [llength [file split $closest_candidate]] + + set closest_fossil [lindex [dict get $root_dict fossil] 0] + set closest_fossil_len [llength [file split $closest_fossil]] + set closest_git [lindex [dict get $root_dict git] 0] + set closest_git_len [llength [file split $closest_git]] + set closest_candidate [lindex [dict get $root_dict candidate] 0] + set closest_candidate_len [llength [file split $closest_candidate]] if {$closest_candidate_len > $closest_fossil_len && $closest_candidate_len > $closest_git_len} { #only warn if this candidate is *within* a found repo root @@ -1079,7 +1157,7 @@ namespace eval punk::repo { } if {$opt_ansi} { if {$opt_ansi_prompt eq "\uFFFF"} { - set ansiprompt [a+ green bold] + set ansiprompt [a+ green bold] } else { set ansiprompt [$opt_ansi_prompt] } @@ -1112,15 +1190,15 @@ namespace eval punk::repo { #Whilst it might detect a central repo folder in a non-standard location - it might also be annoying. #Todo - a separate environment variable for users to declare one or more locations where they would like to store project .fossil repositories? - set candidate_repo_folder_locations [list] + set candidate_repo_folder_locations [list] #- choose a sensible default based on where fossil put the global config dir - or on the existence of a .fossils folder in a 'standard' location #verify with user before creating a .fossils folder #always check env(FOSSIL_HOME) first - but this is designed to locate the global .fossil (or _fossil) file - .fossils repository folder doesn't have to be at the same location set usable_repo_folder_locations [list] - #If we find one, but it's not writable - add it to another list + #If we find one, but it's not writable - add it to another list set readonly_repo_folder_locations [list] - #Examine a few possible locations for .fossils folder set + #Examine a few possible locations for .fossils folder set #if containing folder is writable add to candidate list set testpaths [list] @@ -1129,8 +1207,8 @@ namespace eval punk::repo { if {![catch {package require Tcl 8.7-}]} { set fossilhome [file normalize [file tildeexpand $fossilhome_raw]] } else { - #8.6 - set fossilhome [file normalize $fossilhome_raw] + #8.6 + set fossilhome [file normalize $fossilhome_raw] } lappend testpaths [file join $fossilhome .fossils] @@ -1175,13 +1253,13 @@ namespace eval punk::repo { } } } - + set startdir_fossils [glob -nocomplain -dir $startdir -type f *.fossil] if {[llength $startdir_fossils]} { #user is already keeping .fossil files directly in curent dir - give them the option to easily keep doing this #(we don't add it if no .fossil files there already - as it is probably a niche requirement - or a sign the user hasn't thought about a better/central location) if {$startdir ni $usable_repo_folder_locations} { - lappend usable_repo_folder_locations $startdir + lappend usable_repo_folder_locations $startdir } } set choice_folders [list] @@ -1207,7 +1285,7 @@ namespace eval punk::repo { #no existing writable .fossil folders (and no existing .fossil files in startdir) #offer the (writable) candidate_repo_folder_locations foreach fld $candidate_repo_folder_locations { - lappend choice_folders [list index $i folder $fld folderexists 0 existingfossils "" conflict ""] + lappend choice_folders [list index $i folder $fld folderexists 0 existingfossils "" conflict ""] incr i } } @@ -1230,7 +1308,7 @@ namespace eval punk::repo { } set folderexists [dict get $option folderexists] if {$folderexists} { - set folderstatus "(existing folder)" + set folderstatus "(existing folder)" } else { set folderstatus "(CREATE folder for .fossil repository files)" } @@ -1238,7 +1316,7 @@ namespace eval punk::repo { } - #append the readonly_repo_folder_locations so that user is aware of them as it may affect their choice + #append the readonly_repo_folder_locations so that user is aware of them as it may affect their choice if {[llength $readonly_repo_folder_locations]} { append menu_message "--------------------------------------------------" \n foreach readonly $readonly_repo_folder_locations { @@ -1256,11 +1334,11 @@ namespace eval punk::repo { } else { if {[llength $choice_folders] || $opt_askpath} { puts stdout $menu_message - set max [llength $choice_folders] + set max [llength $choice_folders] if {$max == 1} { set rangemsg "the number 1" } else { - set rangemsg "a number from 1 to $max" + set rangemsg "a number from 1 to $max" } set menuprompt "${ansiprompt}Enter $rangemsg to select location. (or N to abort)${ansireset}" if {$opt_askpath} { @@ -1279,7 +1357,7 @@ namespace eval punk::repo { set answer [askuser "${ansiprompt}Do you want to create this folder? Type just the word mkdir to create it, or N for no${ansireset}"] if {[string equal mkdir [string tolower $answer]]} { if {[catch {file mkdir $repository_folder} errM]} { - puts stderr "Failed to create folder $repository_folder. Error $errM" + puts stderr "Failed to create folder $repository_folder. Error $errM" } } } else { @@ -1317,7 +1395,7 @@ namespace eval punk::repo { if {$index >= 0 && $index <= $max-1} { set repo_folder_choice [lindex $choice_folders $index] set repository_folder [dict get $repo_folder_choice folder] - puts stdout "Selected fossil location $repository_folder" + puts stdout "Selected fossil location $repository_folder" } else { puts stderr " No menu number matched - aborting." return @@ -1367,7 +1445,7 @@ namespace eval punk::repo { proc fossil_revision {{path {}}} { if {$path eq {}} { set path [pwd] } - # ::kettle::path::revision.fossil + # ::kettle::path::revision.fossil set fossilcmd [Cached_auto_execok fossil] if {[llength $fossilcmd]} { do_in_path $path { @@ -1381,7 +1459,7 @@ namespace eval punk::repo { proc fossil_remote {{path {}}} { if {$path eq {}} { set path [pwd] } - # ::kettle::path::revision.fossil + # ::kettle::path::revision.fossil set fossilcmd [Cached_auto_execok fossil] if {[llength $fossilcmd]} { do_in_path $path { @@ -1395,11 +1473,11 @@ namespace eval punk::repo { proc fossil_get_configdb {{path {}}} { #fossil info will *usually* give us the necessary config-db info whether in a project folder or not but.. #a) It's expensive to shell-out and call it - #b) it won't give us a result if we are in a checkout folder which has had its repository moved + #b) it won't give us a result if we are in a checkout folder which has had its repository moved #this fairly extensive mechanism is designed to find it even if the environment has some weird goings-on regarding the filesystem/environment variables #This is unlikely to be necessary in most scenarios, where the location is related to the user's home directory - - #attempt 1 - environment vars and well-known locations + + #attempt 1 - environment vars and well-known locations #This is first because it's faster - but hopefully it's aligned with how fossil does it if {"windows" eq $::tcl_platform(platform)} { @@ -1416,7 +1494,7 @@ namespace eval punk::repo { if {[file exists $testfile]} { return $testfile } - } + } } else { foreach varname [list FOSSIL_HOME HOME ] { if {[info exists ::env($varname)]} { @@ -1435,13 +1513,13 @@ namespace eval punk::repo { if {[file exists $testfile]} { return $testfile } - } + } if {[info exists ::env(HOME)]} { set testfile [file join $::env(HOME) .config fossil.db] if {[file exists $testfile]} { return $testfile } - } + } } @@ -1484,13 +1562,13 @@ namespace eval punk::repo { cd $original_cwd } - #attempt 3 - getting desperate.. find other repos, determine their checkouts and run fossil in them to get a result + #attempt 3 - getting desperate.. find other repos, determine their checkouts and run fossil in them to get a result if {$fossil_ok} { #It should be extremely rare to need to resort to sqlite on the databases to find other potential repo paths #Conceivably only on some weird VFS or where some other filesystem strangeness is going on with our original path - or if the root volume itself is a broken fossil checkout #Examining the other repos gives us a chance at discovering some other filesystem/paths where things may not be broken if {![catch {package require sqlite3} errPackage]} { - #use fossil all ls and sqlite + #use fossil all ls and sqlite if {[catch {exec {*}$fossilcmd all ls} repolines]} { error "fossil_get_configdb cannot find repositories" } else { @@ -1535,7 +1613,7 @@ namespace eval punk::repo { error "fossil_get_configdb exhausted search options" } #------------------------------------ - + #temporarily cd to workpath to run script - return to correct path even on failure proc do_in_path {path script} { #from ::kettle::path::in @@ -1611,8 +1689,8 @@ namespace eval punk::repo { set platform $::tcl_platform(platform) } - #No - don't do this sort of path translation here - leave as option for specific utils only such as ./ - #Windows volume-relative syntax with specific volume specified is somewhat broken in Tcl - but leading slash volume-relative does work + #No - don't do this sort of path translation here - leave as option for specific utils only such as ./ + #Windows volume-relative syntax with specific volume specified is somewhat broken in Tcl - but leading slash volume-relative does work #We shouldn't break it totally just because accessing WSL/mingw paths is slightly more useful #if {$platform eq "windows"} { #return [file dirname [file normalize [punk::unixywindows::towinpath $path]/__]] @@ -1624,7 +1702,7 @@ namespace eval punk::repo { #This taken from kettle::path::strip #It doesn't compare the prefix contents presumably for speed when used in kettle::path::scan #renamed to better indicate its behaviour - + proc path_strip_prefixdepth {path prefix} { if {$prefix eq ""} { return [norm $path] @@ -1713,9 +1791,9 @@ namespace eval ::punk::args::register { # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready +## Ready package provide punk::repo [namespace eval punk::repo { variable version - set version 0.1.1 + set version 0.1.1 }] return diff --git a/src/vfs/_vfscommon.vfs/modules/punk/zip-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/punk/zip-0.1.0.tm deleted file mode 100644 index aae9ed98..00000000 --- a/src/vfs/_vfscommon.vfs/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 CD - 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/vfs/_vfscommon.vfs/modules/punkapp-0.1.tm b/src/vfs/_vfscommon.vfs/modules/punkapp-0.1.tm index ce46856b..70fa90fc 100644 --- a/src/vfs/_vfscommon.vfs/modules/punkapp-0.1.tm +++ b/src/vfs/_vfscommon.vfs/modules/punkapp-0.1.tm @@ -1,239 +1,239 @@ -#utilities for punk apps to call - -package provide punkapp [namespace eval punkapp { - variable version - set version 0.1 -}] - -namespace eval punkapp { - variable result - variable waiting "no" - proc hide_dot_window {} { - #alternative to wm withdraw . - #see https://wiki.tcl-lang.org/page/wm+withdraw - wm geometry . 1x1+0+0 - wm overrideredirect . 1 - wm transient . - } - proc is_toplevel {w} { - if {![llength [info commands winfo]]} { - return 0 - } - expr {[winfo toplevel $w] eq $w && ![catch {$w cget -menu}]} - } - proc get_toplevels {{w .}} { - if {![llength [info commands winfo]]} { - return [list] - } - set list {} - if {[is_toplevel $w]} { - lappend list $w - } - foreach w [winfo children $w] { - lappend list {*}[get_toplevels $w] - } - return $list - } - - proc make_toplevel_next {prefix} { - set top [get_toplevel_next $prefix] - return [toplevel $top] - } - #possible race condition if multiple calls made without actually creating the toplevel, or gap if highest existing closed in the meantime - #todo - reserve_toplevel_next ? keep list of toplevels considered 'allocated' even if never created or already destroyed? what usecase? - #can call wm withdraw to to reserve newly created toplevel. To stop re-use of existing names after destruction would require a list or at least a record of highest created for each prefix - proc get_toplevel_next {prefix} { - set base [string trim $prefix .] ;# .myapp -> myapp .myapp.somewindow -> myapp.somewindow . -> "" - - - - } - proc exit {{toplevel ""}} { - variable waiting - variable result - variable default_result - set toplevels [get_toplevels] - if {[string length $toplevel]} { - set wposn [lsearch $toplevels $toplevel] - if {$wposn > 0} { - destroy $toplevel - } - } else { - #review - if {[package provide punk::repl::codethread] ne "" && [punk::repl::codethread::is_running]} { - puts stderr "punkapp::exit called without toplevel - showing console" - show_console - return 0 - } else { - puts stderr "punkapp::exit called without toplevel - exiting" - if {$waiting ne "no"} { - if {[info exists result(shell)]} { - set temp [set result(shell)] - unset result(shell) - set waiting $temp - } else { - set waiting "" - } - } else { - ::exit - } - } - } - - set controllable [get_user_controllable_toplevels] - if {![llength $controllable]} { - if {[package provide punk::repl::codethread] ne "" && [punk::repl::codethread::is_running]} { - show_console - } else { - if {$waiting ne "no"} { - if {[info exists result(shell)]} { - set temp [set result(shell)] - unset result(shell) - set waiting $temp - } elseif {[info exists result($toplevel)]} { - set temp [set result($toplevel)] - unset result($toplevel) - set waiting $temp - } elseif {[info exists default_result]} { - set temp $default_result - unset default_result - set waiting $temp - } else { - set waiting "" - } - } else { - ::exit - } - } - } - } - proc close_window {toplevel} { - wm withdraw $toplevel - if {![llength [get_user_controllable_toplevels]]} { - punkapp::exit $toplevel - } - destroy $toplevel - } - proc wait {args} { - variable waiting - variable default_result - if {[dict exists $args -defaultresult]} { - set default_result [dict get $args -defaultresult] - } - foreach t [punkapp::get_toplevels] { - if {[wm protocol $t WM_DELETE_WINDOW] eq ""} { - wm protocol $t WM_DELETE_WINDOW [list punkapp::close_window $t] - } - } - if {[package provide punk::repl::codethread] ne "" && [punk::repl::codethread::is_running]} { - puts stderr "repl eventloop seems to be running - punkapp::wait not required" - } else { - if {$waiting eq "no"} { - set waiting "waiting" - vwait ::punkapp::waiting - return $::punkapp::waiting - } - } - } - - #A window can be 'visible' according to this - but underneath other windows etc - #REVIEW - change name? - proc get_visible_toplevels {{w .}} { - if {![llength [info commands winfo]]} { - return [list] - } - set list [get_toplevels $w] - set mapped [lmap v $list {expr {[winfo ismapped $v] ? $v : {}}}] - set mapped [concat {*}$mapped] ;#ignore {} - set visible [list] - foreach m $mapped { - if {[wm overrideredirect $m] == 0 } { - lappend visible $m - } else { - if {[winfo height $m] >1 && [winfo width $m] > 1} { - #technically even a 1x1 is visible.. but in practice even a 10x10 is hardly likely to be noticeable when overrideredirect == 1 - #as a convention - 1x1 with no controls is used to make a window invisible so we'll treat anything larger as visible - lappend visible $m - } - } - } - return $visible - } - proc get_user_controllable_toplevels {{w .}} { - set visible [get_visible_toplevels $w] - set controllable [list] - foreach v $visible { - if {[wm overrideredirect $v] == 0} { - lappend controllable $v - } - } - #only return visible windows with overrideredirect == 0 because there exists some user control. - #todo - review.. consider checking if position is outside screen areas? Technically controllable.. but not easily - return $controllable - } - proc hide_console {args} { - set opts [dict create -force 0] - if {([llength $args] % 2) != 0} { - error "hide_console expects pairs of arguments. e.g -force 1" - } - #set known_opts [dict keys $defaults] - foreach {k v} $args { - switch -- $k { - -force { - dict set opts $k $v - } - default { - error "Unrecognised options '$k' known options: [dict keys $opts]" - } - } - } - set force [dict get $opts -force] - - if {!$force} { - if {![llength [get_user_controllable_toplevels]]} { - puts stderr "Cannot hide console while no user-controllable windows available" - return 0 - } - } - if {$::tcl_platform(platform) eq "windows"} { - #hide won't work for certain consoles cush as conemu,wezterm - and doesn't really make sense for tabbed windows anyway. - #It would be nice if we could tell the console window to hide just the relevant tab - or the whole window if only one tab present - but this is unlikely to be possible in any standard way. - #an ordinary cmd.exe or pwsh.exe or powershell.exe window can be hidden ok though. - #(but with wezterm - process is cmd.exe - but it has style popup and can't be hidden with a twapi::hide_window call) - package require twapi - set h [twapi::get_console_window] - set pid [twapi::get_window_process $h] - set pinfo [twapi::get_process_info $pid -name] - set pname [dict get $pinfo -name] - set wstyle [twapi::get_window_style $h] - #tclkitsh/tclsh? - if {($pname in [list cmd.exe pwsh.exe powershell.exe] || [string match punk*.exe $pname]) && "popup" ni $wstyle} { - twapi::hide_window $h - return 1 - } else { - puts stderr "punkapp::hide_console unable to hide this type of console window" - return 0 - } - } else { - #todo - puts stderr "punkapp::hide_console unimplemented on this platform (todo)" - return 0 - } - } - - proc show_console {} { - if {$::tcl_platform(platform) eq "windows"} { - package require twapi - if {![catch {set h [twapi::get_console_window]} errM]} { - twapi::show_window $h -activate -normal - } else { - #no console - assume launched from something like wish? - catch {console show} - } - } else { - #todo - puts stderr "punkapp::show_console unimplemented on this platform" - } - } - -} +#utilities for punk apps to call + +package provide punkapp [namespace eval punkapp { + variable version + set version 0.1 +}] + +namespace eval punkapp { + variable result + variable waiting "no" + proc hide_dot_window {} { + #alternative to wm withdraw . + #see https://wiki.tcl-lang.org/page/wm+withdraw + wm geometry . 1x1+0+0 + wm overrideredirect . 1 + wm transient . + } + proc is_toplevel {w} { + if {![llength [info commands winfo]]} { + return 0 + } + expr {[winfo toplevel $w] eq $w && ![catch {$w cget -menu}]} + } + proc get_toplevels {{w .}} { + if {![llength [info commands winfo]]} { + return [list] + } + set list {} + if {[is_toplevel $w]} { + lappend list $w + } + foreach w [winfo children $w] { + lappend list {*}[get_toplevels $w] + } + return $list + } + + proc make_toplevel_next {prefix} { + set top [get_toplevel_next $prefix] + return [toplevel $top] + } + #possible race condition if multiple calls made without actually creating the toplevel, or gap if highest existing closed in the meantime + #todo - reserve_toplevel_next ? keep list of toplevels considered 'allocated' even if never created or already destroyed? what usecase? + #can call wm withdraw to to reserve newly created toplevel. To stop re-use of existing names after destruction would require a list or at least a record of highest created for each prefix + proc get_toplevel_next {prefix} { + set base [string trim $prefix .] ;# .myapp -> myapp .myapp.somewindow -> myapp.somewindow . -> "" + + + + } + proc exit {{toplevel ""}} { + variable waiting + variable result + variable default_result + set toplevels [get_toplevels] + if {[string length $toplevel]} { + set wposn [lsearch $toplevels $toplevel] + if {$wposn > 0} { + destroy $toplevel + } + } else { + #review + if {[package provide punk::repl::codethread] ne "" && [punk::repl::codethread::is_running]} { + puts stderr "punkapp::exit called without toplevel - showing console" + show_console + return 0 + } else { + puts stderr "punkapp::exit called without toplevel - exiting" + if {$waiting ne "no"} { + if {[info exists result(shell)]} { + set temp [set result(shell)] + unset result(shell) + set waiting $temp + } else { + set waiting "" + } + } else { + ::exit + } + } + } + + set controllable [get_user_controllable_toplevels] + if {![llength $controllable]} { + if {[package provide punk::repl::codethread] ne "" && [punk::repl::codethread::is_running]} { + show_console + } else { + if {$waiting ne "no"} { + if {[info exists result(shell)]} { + set temp [set result(shell)] + unset result(shell) + set waiting $temp + } elseif {[info exists result($toplevel)]} { + set temp [set result($toplevel)] + unset result($toplevel) + set waiting $temp + } elseif {[info exists default_result]} { + set temp $default_result + unset default_result + set waiting $temp + } else { + set waiting "" + } + } else { + ::exit + } + } + } + } + proc close_window {toplevel} { + wm withdraw $toplevel + if {![llength [get_user_controllable_toplevels]]} { + punkapp::exit $toplevel + } + destroy $toplevel + } + proc wait {args} { + variable waiting + variable default_result + if {[dict exists $args -defaultresult]} { + set default_result [dict get $args -defaultresult] + } + foreach t [punkapp::get_toplevels] { + if {[wm protocol $t WM_DELETE_WINDOW] eq ""} { + wm protocol $t WM_DELETE_WINDOW [list punkapp::close_window $t] + } + } + if {[package provide punk::repl::codethread] ne "" && [punk::repl::codethread::is_running]} { + puts stderr "repl eventloop seems to be running - punkapp::wait not required" + } else { + if {$waiting eq "no"} { + set waiting "waiting" + vwait ::punkapp::waiting + return $::punkapp::waiting + } + } + } + + #A window can be 'visible' according to this - but underneath other windows etc + #REVIEW - change name? + proc get_visible_toplevels {{w .}} { + if {![llength [info commands winfo]]} { + return [list] + } + set list [get_toplevels $w] + set mapped [lmap v $list {expr {[winfo ismapped $v] ? $v : {}}}] + set mapped [concat {*}$mapped] ;#ignore {} + set visible [list] + foreach m $mapped { + if {[wm overrideredirect $m] == 0 } { + lappend visible $m + } else { + if {[winfo height $m] >1 && [winfo width $m] > 1} { + #technically even a 1x1 is visible.. but in practice even a 10x10 is hardly likely to be noticeable when overrideredirect == 1 + #as a convention - 1x1 with no controls is used to make a window invisible so we'll treat anything larger as visible + lappend visible $m + } + } + } + return $visible + } + proc get_user_controllable_toplevels {{w .}} { + set visible [get_visible_toplevels $w] + set controllable [list] + foreach v $visible { + if {[wm overrideredirect $v] == 0} { + lappend controllable $v + } + } + #only return visible windows with overrideredirect == 0 because there exists some user control. + #todo - review.. consider checking if position is outside screen areas? Technically controllable.. but not easily + return $controllable + } + proc hide_console {args} { + set opts [dict create -force 0] + if {([llength $args] % 2) != 0} { + error "hide_console expects pairs of arguments. e.g -force 1" + } + #set known_opts [dict keys $defaults] + foreach {k v} $args { + switch -- $k { + -force { + dict set opts $k $v + } + default { + error "Unrecognised options '$k' known options: [dict keys $opts]" + } + } + } + set force [dict get $opts -force] + + if {!$force} { + if {![llength [get_user_controllable_toplevels]]} { + puts stderr "Cannot hide console while no user-controllable windows available" + return 0 + } + } + if {$::tcl_platform(platform) eq "windows"} { + #hide won't work for certain consoles cush as conemu,wezterm - and doesn't really make sense for tabbed windows anyway. + #It would be nice if we could tell the console window to hide just the relevant tab - or the whole window if only one tab present - but this is unlikely to be possible in any standard way. + #an ordinary cmd.exe or pwsh.exe or powershell.exe window can be hidden ok though. + #(but with wezterm - process is cmd.exe - but it has style popup and can't be hidden with a twapi::hide_window call) + package require twapi + set h [twapi::get_console_window] + set pid [twapi::get_window_process $h] + set pinfo [twapi::get_process_info $pid -name] + set pname [dict get $pinfo -name] + set wstyle [twapi::get_window_style $h] + #tclkitsh/tclsh? + if {($pname in [list cmd.exe pwsh.exe powershell.exe] || [string match punk*.exe $pname]) && "popup" ni $wstyle} { + twapi::hide_window $h + return 1 + } else { + puts stderr "punkapp::hide_console unable to hide this type of console window" + return 0 + } + } else { + #todo + puts stderr "punkapp::hide_console unimplemented on this platform (todo)" + return 0 + } + } + + proc show_console {} { + if {$::tcl_platform(platform) eq "windows"} { + package require twapi + if {![catch {set h [twapi::get_console_window]} errM]} { + twapi::show_window $h -activate -normal + } else { + #no console - assume launched from something like wish? + catch {console show} + } + } else { + #todo + puts stderr "punkapp::show_console unimplemented on this platform" + } + } + +} diff --git a/src/vfs/_vfscommon.vfs/modules/punkcheck-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/punkcheck-0.1.0.tm index fbf9a4e4..a4113c45 100644 --- a/src/vfs/_vfscommon.vfs/modules/punkcheck-0.1.0.tm +++ b/src/vfs/_vfscommon.vfs/modules/punkcheck-0.1.0.tm @@ -243,12 +243,14 @@ namespace eval punkcheck { } method get_targets_exist {} { set punkcheck_folder [file dirname [$o_installer get_checkfile]] - set existing [list] - foreach t $o_targets { - if {[file exists [file join $punkcheck_folder $t]]} { - lappend existing $t - } - } + set existing [glob -nocomplain -dir $punkcheck_folder -tails {*}$o_targets] + + #set existing [list] + #foreach t $o_targets { + # if {[file exists [file join $punkcheck_folder $t]]} { + # lappend existing $t + # } + #} return $existing } method end {} { @@ -880,19 +882,46 @@ namespace eval punkcheck { #allow nonexistant as a source set fpath [file join $punkcheck_folder $source_relpath] - if {![file exists $fpath]} { + #windows: file exist + file type = 2ms vs 500ms for 2x glob + set floc [file dirname $fpath] + set fname [file tail $fpath] + set file_set [glob -nocomplain -dir $floc -type f -tails $fname] + set dir_set [glob -nocomplain -dir $floc -type d -tails $fname] + set link_set [glob -nocomplain -dir $floc -type l -tails $fname] + if {[llength $file_set] == 0 && [llength $dir_set] == 0 && [llength $link_set] == 0} { + #could also theoretically exist as less common types, b,c,p,s (block,char,pipe,socket) + #- we don't expect them here - REVIEW - ever possible? + #- installing/examining such things an unlikely usecase and would require special handling anyway. set ftype "missing" set fsize "" } else { - set ftype [file type $fpath] - if {$ftype eq "directory"} { + if {[llength $dir_set]} { + set ftype "directory" set fsize "NA" + } elseif {[llength $link_set]} { + set ftype "link" + set fsize 0 } else { + set ftype "file" #todo - optionally use mtime instead of cksum (for files only)? #mtime is not reliable across platforms and filesystems though.. see article linked at top. set fsize [file size $fpath] } } + + #if {![file exists $fpath]} { + # set ftype "missing" + # set fsize "" + #} else { + # set ftype [file type $fpath] + # if {$ftype eq "directory"} { + # set fsize "NA" + # } else { + # #todo - optionally use mtime instead of cksum (for files only)? + # #mtime is not reliable across platforms and filesystems though.. see article linked at top. + # set fsize [file size $fpath] + # } + #} #get_relativecksum_from_base and fill_relativecksums_from_base_and_relativepathdict will set cksum to if fpath doesn't exist if {$use_cache} { set source_cksum_info [punk::mix::base::lib::fill_relativecksums_from_base_and_relativepathdict $punkcheck_folder [dict create $source_relpath $use_cache_record]] @@ -1648,6 +1677,10 @@ namespace eval punkcheck { set is_skip 0 if {$overwrite_what eq "all-targets"} { file mkdir $current_target_dir + #-------------------------------------------- + #sometimes we get the error: 'error copying "file1" to "file2": invalid argument' + #-------------------------------------------- + puts stderr "punkcheck: about to: file copy -force $current_source_dir/$m $current_target_dir" file copy -force $current_source_dir/$m $current_target_dir lappend files_copied $current_source_dir/$m } else { @@ -1859,22 +1892,75 @@ namespace eval punkcheck { return [list files_copied $files_copied files_skipped $files_skipped sources_unchanged $sources_unchanged antiglob_paths_matched $antiglob_paths_matched punkcheck_records $punkcheck_records punkcheck_folder $punkcheck_folder srcdir $srcdir tgtdir $tgtdir] } - proc summarize_install_resultdict {resultdict} { + + + lappend PUNKARGS [list { + @id -id ::punkcheck::summarize_install_resultdict + @cmd -name punkcheck::summarize_install_resultdict -help\ + "Emits a string summarizing a punkcheck resultdict, showing + how many items were copied, and the source, target locations" + @opts + -title -type string -default "" + -forcecolour -type boolean -default 0 -help\ + "When true, passes the forcecolour tag to punk::ansi functions. + This enables ANSI sgr colours even when colour + is off. (ignoring env(NO_COLOR)) + To disable colour - ensure the NO_COLOR env var is set, + or use: + namespace eval ::punk::console {variable colour_disabled 1}" + @values -min 1 -max 1 + resultdict -type dict + }] + proc summarize_install_resultdict {args} { + set argd [punk::args::parse $args withid ::punkcheck::summarize_install_resultdict] + lassign [dict values $argd] leaders opts values received + set title [dict get $opts -title] + set forcecolour [dict get $opts -forcecolour] + set resultdict [dict get $values resultdict] + + set has_ansi [expr {![catch {package require punk::ansi}]}] + if {$has_ansi} { + if {$forcecolour} { + set fc "forcecolour" + } else { + set fc "" + } + set R [punk::ansi::a] ;#reset + set LINE_COLOUR [punk::ansi::a+ {*}$forcecolour bold cyan] + set LOW_COLOUR [punk::ansi::a+ {*}$forcecolour bold green] + set HIGH_COLOUR [punk::ansi::a+ {*}$forcecolour bold yellow] + } else { + set R "" + set LINE_COLOUR "" + set LOW_COLOUR "" + set HIGH_COLOUR "" + } + set msg "" if {[dict size $resultdict]} { set copied [dict get $resultdict files_copied] - append msg "--------------------------" \n - append msg "[dict keys $resultdict]" \n + if {[llength $copied] == 0} { + set HIGHLIGHT $LOW_COLOUR + } else { + set HIGHLIGHT $HIGH_COLOUR + } + set ruler $LINE_COLOUR[string repeat - 78]$R + if {$title ne ""} { + append msg $ruler \n + append msg $title \n + } + append msg $ruler \n + #append msg "[dict keys $resultdict]" \n set tgtdir [dict get $resultdict tgtdir] set checkfolder [dict get $resultdict punkcheck_folder] - append msg "Copied [llength $copied] files from [dict get $resultdict srcdir] to [dict get $resultdict tgtdir]" \n + append msg "${HIGHLIGHT}Copied [llength $copied] files from [dict get $resultdict srcdir] to [dict get $resultdict tgtdir]$R" \n foreach f $copied { append msg "COPIED [punkcheck::lib::path_relative $checkfolder $f]" \n append msg " TO $tgtdir" \n } append msg "[llength [dict get $resultdict sources_unchanged]] unchanged source files" \n append msg "[llength [dict get $resultdict files_skipped]] skipped files" \n - append msg "--------------------------" \n + append msg $ruler \n } return $msg } diff --git a/src/vfs/_vfscommon.vfs/modules/test/backup.tm b/src/vfs/_vfscommon.vfs/modules/test/backup.tm new file mode 100644 index 0000000000000000000000000000000000000000..34f2a73d9eca15bbe0cb8fc4abcdfe7f7a15647d GIT binary patch literal 41364 zcmce;2RxPU{|78(X3y*+viIJ5lTG$M_B@Uqva`38l^H@-iV)cnl9{~|Wfn?2_d!MV z{r-MWzyI@`URTFC_kCa2XMf(G&wbqo6?EoB}+aoXKDpzb_YXTZJZoImQMCC@@!l|00pk54&d+Kn7V>kpbp2({IZ}G z*bxjdg-z<_YU5}n0FVfqT0p?w#!NuK!PE|H4A5YF@-2wj$>9Sb}`?%}t@^)*zo_VLCcN98B$Pyul!S8%IkgkgGYw#u;kp z3tJg>0`Qm5xfx&r0z)8xD6gK9aV!<6o7u_NEFdjMQ!_xKfPgK)fczY69Ko>J+<@<# zO`+B-AUbC!S63U@Ij*LbU_d&+Sm56LNsR9AT>eLC?91Pfs^C zb+j-B%;xkOh?5ia_@a|3pr$tVKd(1DH-Wt=AW17nkiM(4y$$sEtRIsx8=i{&c!E=_ zJa_f6HT)_yfMV9~CJm$d`+R?tq^pw~#QcQ2f4YwK>?DBQpQFGR1h#ht|G~tlezP5z zL|g$M1FXggqsg!93X1*%{*G46y+m$KLDQ^e|%uj+vj>m@C*E3i1&LN&LyC zVW%F;!`>e3Xaz(VYH>r5urP=XI2i(lxuovtUaS*k{zn&lgq6Vh<<0*e;_4~p;e?DyK1Ob}@vBeXh4CDhl znU30%{vQQ*=5&ca*uV)Rr}90HPN&WdoAi(7`27mlyFFkQKw3DFljk3Kgq`+hM*jTm zsU7@LX1`wnW8dD~)D>)e5{Zpn!B!4nM<6)q!y=ud6%ZorojiWH{ZAJLT*=VzH;RAG zcM?ru!PFJT!te7z&FuvQpboIS;R^l3RNn<}Z*J@Wn+8OELg?9ve-HbxrC>xHUvh?< z;|Ov}{r4GvCm(k8IZpu+4iNZ{o$_?~U*$x7ekH?W&-&>jza0Hf4g(8=XQ;M^m^xYk zY40rcC!yQ$j35581_-byLy#bq8xXW$K?e*0fB{U$79iO4zv&FdH0)&t_=VjckN$2q zzkhR1Y}DuY_(wN@Daz8#-u@Jofb?yh02rcg?&Juhf6)0!j`IePpJ6i_f&>I$9Kx;z z9cLjYOCWC_LmLo)Tma53V1VZPSCA9P^+(>0jRh8>je#Xka|-K;z>lf%Vemaqh#@TV z0Ox}(m;qJ5K-Jmg@!J~zm_1-3|5X66nNE59ZKChzA1{8E*#CFrp#C=TvF46Lm${RJ z1CZujLC3xcLumjIJzmcc1OTL~SO3X;sZ1eOZm_rkz*iWaG`EJ?Ensg>ATuBf0%!^F zaoFKwT>Ks13J6?3&W&KG`ENwQxTOM{!c6xR6}SqVK;-XN9n<9u7z`BlJq{tNj zkgiSur20-f2rw>tu&FB)WCcUO4lqaryjy_nO}$(}01)@EakOyqa0NNrn?ixe2Ow_% zy*fHMG9RZCQ-B5fKU1b@4Fm7Mg+P*Ya{y4S7m!VWNlv8C$_gj|M%xL11(E~sJ>Vgx zfIgufP7u3exO*Ng!bA^y{qT%qxd0i#0zkeXJ1{`7{_h6z&%yL6E9;3V!BEzTqg@3# z+Q1wd_;fP)KN%K`4ghAkI@>_OAaPasQ_DJIpg)}aRMa33SO5UZ1PIg(D2rf4k)so! zI%kVxnJ}LsvlE5dIXZa&Wyv|)g_)?68x#bEcpVE4`e*6DC_DC?(@N!!+JT(}dr|!+ zuODC;^g}xT=Ep#=gB5dN2N*xDKt_hG4Lw!8DaZrj1nAhx4eaU)qBDg+Z7hMZ4+I27 zQ&<*-IVMoC0GdBzyMWEOx`9EWe>STVvH`-K-2g0b^I#&f zA|fJZO!qXlf`njd0gBl-+l0j7A$lE9y?J$upVM6Pb;=3p?;Y%l;~ z6AWdYjpRS=?Wa3}ez14Gr2Q_}v+w6vlY~WfSipC4wt|>i9OFfx=>Y-!+6IVzK==pD z?j-12+IRv6cuWb*k^g<6-{Hk~68`zfiB8X2`0r}`W6}6)@%JA!d`<)>7y$HLyT|H) zMf<;8{8aIP=1xR)JRgwy^v`@W{CDA<3pQ?!ClvjGo`3a_)Aq^FK8YoeppMPtd#w#? z4*?hpaFOFC%yGgxfiEEHGobFDY5lV*eg7NBI(I(d-1czNx(j zES)P_W<+INWy(_1jD^N1;-dU;*6#;Kea&F$ZuxkUe3d zI7R^uU<+6q0tCp-6~qkmAAwv496PZS0LcKD8iov9|E!4L-3(>{u*S-dVEL~O1iSuw z+O0pP`2h_8v7K=D-9CZ$?`90-OF-u*-UR~+rtU!G zJ#G%3^k;wR@_mm(-``IQcn5$Cz-O<@TLQr9q_2B2<=J+wDFiUaAJa3RO8vO$2(!u) z(F3-5+%vWSnRx*?(a{ai{b^s<`8d7;syYsGKO7HM=-2~2CzgM9H5j$OP^t;cbKETk zTFM{*8v!5!rg>nsQ}+N0Ef{0~W;gxb6o!H9pS@%l0Y9X8>TAa>WM_a;!2M2p%K#kv zPU^oCcoK4`0a5l{QnTYVaxnEhX3=CKcD|ghZa!ONty6piS;*8oL}So zC)gdD9|jK?C=g74wibz16)#@GgM))ZhHFZ_sW-=l>YI8A4o;i^4o(;j3GRFTfjT(= zEh}qgb{60ttE(GOnz*vUJP7ERxtRl9Sn&BzEU^0U=;$IG+y(d#Iu1_bJXnYJ-y(wU zsa)Uy?Z2a>sN)_DTm)MS<4M|Isg@fzpi@t#>nOT^)F`N4NzX6u079sv#4wXvnB1Jo zT&9*KQv5h3A;!{}#6f6+3zjy`m8;Ukd&($Qk{UQ0m-0;lAHC)o$15dAn`t|Yu#VRz zZICWYRJW14awRhlusWI{W&?xP99(q4Z7q@Ny0jd(5#8`+dB@-t2cW~6X+mHHKd^Q} z&iJ)EuX(dyqjMsuQ8VF^rY_yj!{@L2R^A%fu7+-`5Y%X2DnUt5)KAbCj0?@{nJIMn zU}3qJ>*_3aw2-fpF5yO4RY5kcE962X5PRc+OK@aRGt*(X6G7ixA%33%O03Iv-$M+VF>rkRplC*K336am|epQhiAOcOy6lXuA#}f;pX7$y~S5~ zvz0{N*$_;@$<8lz0h4KWcqWYE#n+B%qR#@s{I?RNPztc&wH7w|-?rH6U&#%9PCRL3 zZ0PretoZd;<1&`}wuxaGP}j}<_ghQwgQQL(6EQM`6o*guNQxsGyMpRMT?<8`MU18n z5FfrNLv?g?@a7|P+%9o)mB`%vnmSw@fl*{v_xUaKvA~DPtk=82$S6lfb9wZvoY!ze zIefiQp{RUIOIIK?*b+)Xovw*giYVyaY%vSe+@Hy;Qt)|LarKwxl1Epf(~Kh1I^PJE zKr44>KeTCa4}GcAQF>eM{h(Hvk9}9rbZ23XKQSUS)uyiS?!<)tsLXa&^Zu@sSK1I< zn=sZqnpm7NZZ4bsi;6IdA^f1E?&$f859CrJlexgzaiL; z9Y~8sce<~Lbbf8eTnyOs-?%{BafM1sP8xGO08xY+T-zlTbE{L@jDWahH+GgTiNNFz zd~cI*2;u#x*4$Q;uRk#=YGTYEDWfAc0HDa;wesYe}%j#gqd8s2xi`|E(AJYN1 zd07JgRyj&sQ6bf~a*1vPW_(gOo*+t)niNJVD(_4BISF>D6*OE4^Jy?@zD>uQ(X4gR znDVS(p9^E*>*I8o+?i>;**(43(+eT0%`Or`<{?TTYo-y$P22>UJC}>@64!BW?a>!q zSDg15@2^t4u_nJ2FlA+Y71fPLRb+59G(%w6sH7dkxB+y4qyORQSb13N14$5iiZ|&1 z!!FHD|CzFH)eVQMw$QPtiI2e;#Hl8lEsvh?QWc8$Uu_-y=GAD3K{8GALHh%e=jsH@ zE4N7_D(Ts0n86=wc}WU8iQw%!GW+xs)3CqYp3S<50q(wAjw$i(7UKituSMF^K^*=} zDL3akd1HY8Zp?O4WD@0yTV-STqbwmyGrpJ(%=N$UGxA-GV9=H4b2GRFM7}4N;o!L8 z5dJ;#L4aUw0o*HaX8rNkX~eq#2bZC(=rqrRC8GG;jNzqoWg!mr1BozUmbWeN($9qP zjJWS#>sFHt*GuT8K|Yuk3w`)?SQ$&u^N~#z#%TeV}W-c%^^7P5GIRD)*xlMB@djFHW}BX|%c*$Yo2E)$$+*3))brlg*1TW>6ezVtNmL>~6Ja(yG=iWY$ zBo#(|b2~#~@_|u`vNmrVb>yP@lhTi!suuZ|@0!NbMdV7N?X4j7B)cVZA>!zpB^VB+ zlGX&1ZX~lc)vVZ}`#qyeaDA0gKCl{3OM!T3CQj^=wQTwfZs$6@#X%Wis)nFy`!Y@z zL7HJa>KN*$>5s`%;=?v*p3GC&V-*uYE>l%V@xJcAJP!8=2wQd{wYo9?9GpAn%JHHMd-3 zQiPxHYFK8i8ngaz^eHek{I;HHK9*$FIsroBM_h&jiM*_q24z|2Y{%i*o}6A2Mm{tn zb))yx)L$t1*>W@Z_(^rZat(4e7Vqh5MXvMRD6}VSfdEKFIH_! zpMpJuux=zlz?1MPYpm|o@X(!4efwWr8xMu)4^&&2*l#4nt{?7A%)K^m-A+mfxh9Gn zVjg&1HSy@fz3~lLQ56eCA@i1N zdDr*!O$|Y`*~99b2eZLtCa*$=k3v{N9&GEdBjWTpf4uYf8l_qHEe!_MohUtfowmkb~Qex_NXD5Cmwz|x#MOD6SLXRv0Md^Ly~p-yAKg-yvVyPELgGq5P6@- zay(h)@W0L>?zo2cI|KYS*1&5ymYg|Cc&u&P|j(13wnU~QgI zlobO`7i;U=SA0ShMmf7#xvzI#wl+`G5*QyL8?A^q&bMqq^yIH)7#OL{`@@}&YjL(g z1TjEdBSnLQ6M;kgyST>e1hKKQaWu6*I)VovUH)l=8^3kbqM0&lp>|D9IRwMUpgIg8 z!rh0i-d0R8sWkNJW9sDVSbNVsLNVq2E?rln3de_#Pxsv9ythc`$TTWk)z9ugTzm1M z-UT*(o2*?Q$8=>FQkV)B zWm!_JXOdnY6i8bB(xr<9-?&cl@_L8D$9lO#LoOUcBZuV4pu$O;qRjwN%3B4YHC{{j zad>8wiM^j@60nR}mm>M!-n0;m*=zh1y=0;okjZ2ykGCVTkBb|(44uU^BHSMHoUG0m zNV!xG$@FjfN?SlugJ1Yj=%xa*+ zcMsDHIc8bqm_(Mnit<|PC5fvMsc>(1#zu&?(7fmC#3dyc=Td7jbXm)_?FlET-xYoN za>Y3ygSM?U??F!^l+G}=xz7w+D|Vr?a*gU{&JLA#^CE^?L2eqnW6U$CuuN5`p3M~n zB>Y`rZ$U0bF#dDgZa%G@@YPZdx!uxYBRKisFJzocGYWyje2lxQf``||JQcEs+_H*ta8^_8eAXk@C$NX6aDFT_I=Rm6@uZcTZ4;eNw^;g9>m4Pt*ZGe=w? zWka{r9eoUxexBI$I3*r>H5WzoF2# z-$}A$l{71;IY_q{e(i88?EuqbM=@MN9o?S$8v&+~zu-q!(xU-i^z_&yr;6qGh{o!B z7^zJHcyXpiUoi$Y0y_tv7_Wd}$d}{VvN3apW7~PB z8wWgE7ILj|CM}8ylS|h!OphGqV_vl!vFnyVn7`LQF7S1w(uRrD-g!VX57JDN(97pa zi}oo)Jh2-=MtE29eNZ@=NF*n5VyHQ_<)h(Z-;E%O48q)Z1b0Hh)3wAI(v_&u*FTyh zE@xZc^B`^MocVaD^X|~#-6OTmXqt#D|DdFF%%*QI*y=;(-?L@T2($!ml4hB*1kc{F z?sqw+x2y=l^cs*d00jePo8V1%%oh+wk*v0;Eo9yPFaMV zhPN$f@Y{#ci`htrm!6s0rxX(=8|Y)97A?PDgGemg_9eaAAdc2UclUu5f9w{Ua&?y@ zFRA*SJAs_xzK6uL-4{TY0~=eO53JZ+pPbzwK6nCNU}K`T5^XVulejEe1__&=d@>iP zFEZ&zxP3O>ts61umbO@Nivsm51Q<%d_}2>d2YUO70rqz{P1`Nc{!iJWHsnG5axrM@PV9hVjBGEo@k! zy9W_BdgHD|ydx}U(=;mz))8aU3RQ$SlnS_mNu4N*xZ`ZW@X_*_Ezlku2Xv`$Ch_cY8^md5N z#<{J&K(yJ4%vDJ$T~_SbP|ifuupg_PRP15%UW*~lVE2g+uZOjo+3uGL-!Wmr#bKX1 z#2pK98a`;$<{K%8>P18+4835}el@{Jx{h4874KAK0mxI;K5pw!3o#xxCKVKHsp^Z~ zyfOCXSO?9EF$R09D}2gZ2DNW`HT;*Z5Z6~xJkC$;z6LLkBJaLzjF!vGLfzt_m-y9J z?i<10evz49NQb^AP52%7{tFxvwbsvnQA9d#tRoE|w{>7#|4%)S|6noS6>%nE9``^1 zo!A}gMC`C7lEag|VBfY5iVQ_bVqrE646E|JE@eS4$3Sz`NXu`dApUOEcfD3HygqB5 z$frk^42EnL`zVruk27~m>+YqDafRlvR2Zk|BqHD) zq@)bIT_d^rCDQ>d@CZ`NNOIJpvITHPLE z@ibIxB!#zVaplqz(KKbp*iGn-0j4=6F#)kq!SHpYpUCABP?05l6^u#)Ja`irGJo&M zu$u_3zfJz!x_QBlkk>6-S}yQI;GPdDe$jY_o1e#g z)MhpjxA==n3ldNL##9dn)I-} z96w{_!~W80Ed?b7?YX()eywsXRR!h?70o?)>8)s3&){3TI$t4FMn?to9N5Pd#Fh^TL_<0kcz;^$%b^fG~An{15Tt9C1I?blOAxN$29+;&(~|Hk#65lp;TZZ+!(& zx*Zi2kbYo)I|`t*7@)KV;S8l+Xh(9hcd#xX08|1Y2~O?rQ;wMz6l{FF>B-o^6k=x# zc5sGz{gkQCb05(&3&TXjmw!=A8CX;U7+QZ(gq-HOUl)dLTQP=pp-&fw)h6g&&FHs4 zXbAn!G!AA+F*NK0+VyanE>?LtQ{U+K@Lm5_;({UWz=Tfw_#zk9wTI8VWv*Y57EHL; zB>mKU@JOw5EI6LzLjp@xZ9jpTj>vg4tQlv1q;|{#9GubrS8SY7{Ruy>VEiEVKSL3` z+00K`FuH|XL9L3}v(y}KAU^%6VYe#OCU96+K>0mVCl)pSP!0<73kcEed{oU~q>^v3 zO5Ivlir%nn7Q5Aj@KDt2pJ53B&yy$2eA4x^CN!G3qn%rIOoz~4&y?~DAre*a$ zE_o=dSo!N#-r$X#i%kCFkDHnDk|M&teUmcka78c35^A}1dBfyV9&PzV4#GzP75H~t zI&Yh9Cq6*&49xTuo439mX*L>AFl>!VkH=OvZ*%(-snP6Z~1boqjmnB3GTYvSqr)K*92@ZD5xYXN zwhjKvH@?q59%SHGvfK~IDSNN9R#oXuIAn7pGk8x47vFk6G9uZMlBSh-Y%+GiO=x6c zDTwBs3*vk9iyp*G^3`GvtK1g_5VRkeG`(KMwhoTDDb`{VEyc4SW@D3tL2toUmR}JI z2z^E(58lb8GQi6uuxoXct!72dy?urD$lN)T=3(3RBy)*9=Bw#I@eidT{G;(zoN}bx zGj|Jyq-X1+Rdc?|`qEdfd~(-?C-Lxd#JTW#mNV$GGjc=mU$WBWm zVlFP+e6JVXuFqx*;it!5rP|V=+Q2Wm2#7rn7?OW)-e6Bt2WNZm&lm@eYqo7+LknFG zs1MpG3wIev<_aP67$3z5A(ObGkW-T#?m+5664mh4VtIfat#a|`$U@O$C!{I^x&AIK zU(9SU;ea#LGUg71%O-)wZ>L1~7GJ%PX!E>6_pv%$d0EcVH0C>E%_VS(~&zW6Tfd?qyBqF4s^1QxdSJ zG<}4VsldK?om?96MW*a)%YJ(cmubYr2V;#sP}+#(#_T6IrXK1!a=zOii%U{(RypXA z_!u-XFhzqy>m$=h>|kB3%25(H?rNEV5qsTdAZRbhZQ)355q-$iUpL$Mr=Y71n03uY zkn9AJ;o$s%dx=ti528;6&2cK}W9Y zMibd!Wbw3GYJ5U2M^W9SUi#>(u%v=}0znwU#{`0KDM%Z>rtu;cAY$tt!*N^v_N>f!+uX z2kOOoG}utlpxF^KT?L+TQJpV(N!o85N9W-v! z1uA?AFnh#ZK;DpO#%U5vPsoiQm1-71-jF=pmBX33OK(x?bvt>RZYbwPl4z2IxqoWw zGnyR&+}Y7UzQGSXFS-P6=y=Umc_&iTb@=a3ldOV_cgeW5)t$t;ZaH4b*>B!z<#|cV zf_$Yapm7FO{{TZFC{wR;@!p#Dk}X1KHwRYkm;$H0p*o|JOx$SrTXA@-qn$nqBJXtK z7^QU`bQ850?Q&#z^7OQ?{GwkUScqaOynV6|>t)v@qem2yZNZE5wj}U^Wxk+;V^;WW zCtH=kixlI#!|SE5J&NP*E948W7MFIC1s1r^O{LMTKatUU_}-224SS!Qbt1WzSl#lr z9(Vp7T@rNX%M8J|8)|$ibpBF;A?Dxu3l9jcDu$z93qVnHz>ZKUHP7i1U}e{3%id}) z$D@ns+NGFI6ytk-v_nq)=9X7SWzAzWo)t1&&AN=F%&6GKG-7=n^4(rG56w=72+0nO zl}`Re^o#SU%l9W_^(axv64&)^Y~E79p7KM~QyyuV&MV3fU(u)@Dt0$oAb;L*o9*DP z$($F)K{pX;ii&WPzW1~?sh?oQu7#aSQi-uOt2KQ|HxGt50STTfky6QU=4EL$4EW&_T?9PaFYs7sP!fWDo6Mccvb8PexU$c@zK`RuS0>R zx}}%*pS?;iskvqw{lVkql_0+qL-~u5hsoja4XrosPUbdhtx&JZW?Cb7x!typFy>Yy zc{5-BQC6mGQ8)zb-=&%2pEl-n^fp#xdj=b&A&ED8+Fz2l&C!oZO?T5}EBvy+08T+} zT+a(Ve+$alY8wnbsZpfK_`WEaHGwbGQM6%Ty6|V{YvrBq6FTr8+|<14X-ti6=T}xd zKU0i?&>@Pbx6X6VC!|0RLViE%v6k{AnM@&$0sd%va@`$=MB09GuFe~_hO~`Dx{SO+yA8A|lwM!rZ zVHl-_`p|`mzP`pHb5J?=yl0!~M*mc>Hr<=ADm%#2r| zxrwt2Yu-@zcx4uuTz`s~ndS+)9`p)2Da$X52wgo#)vK8u^MviU8)C)%kQ+rBD8F2} zENvF4Fo(-NJ)o~;`m)w>075k6b;9SO6*R=6M=Bk_JCxe=q z$1Cb`^a?)Mi^D^M}rVszDQj^87htaC2*VUTq z@xm{s_{pC1)c%_mke}&Z{KM_#Jdy{y8;^4x9I!{C=$h;wkp|F2?@9^nIW}z&)Xk1i zaT!px5FeWL`>s{gA8hJbe^PKqy^hH<-$TLo)-M>Dc7DASZF$oXrA%>N0;z4aTAX-^ zgqDHr-V?DAl8N|88V`5B`fqLigzxH=NXNzzA6c#Jci9Ul_GPjhRc`2KcPm37BEo|F zDpod0t2p3QB+I(d4z*qEAncykLVQaJN2s`-?baS;pcHJ{snKMcq!vr5Nyop!3# z!_5uJzq5WopwZLAg7mhZKg&FC)~Ci|nV(1w(dOzkwod<_xD3WKYK84k0>JMeFs=jR zFWcegc>Ym!F!usc!m#O)pu*Fo0 zPmi6pi|fFpmrxKT-Za5SE_CwhW%F3exfQQw-<T#J(O9ZhL^6L8F+0dHUllfVnIT=TM0F16o>f%=S?t7X%w8?EvVg1rY^g$&JxaqkURO zLV(sv)00vyfetHkdnBRclJ+9rd|m^yx_QONFb{f>eA4*02cJ_ExV{w-?{zoXP#mFk zuNV=L`sd4gt1frcX-{2N@PtU*8GIKio*T*!_obL}k732iZ{&jxMJkS9Xs0J_tx>ZY z8Uz2`b{1 zRnF1$u6*HKXyN5=KTmi>pvL!^lNJnxwTqFBh)BIdfAY&{)q+Kq0SH$K96iB{*A zGVIgcD=|2l;$oDJ838-(;!qVuXaLBb$;g_xFl_9kgPJTKd@{I%lSO3y-PD zZ_PrL+T27TEgeIgh{1|9)(9~EJO%+r)c?|0CeSguf^!QpFl7(F zQf_Y2Xu09QXlR&sWRAa*p02hKFC~5zNuu5OveAY1ZhA|_=vNy46+6$KT%o{`8{~V| zSOEV@^dWIG2iwQVb#eYl#-PMWNE&0=Pr7ojvOe7WoY z(7hz4B$7-rsWH)jZJDW{R#9$1$Dr;3ufl-GnCu~wDoU_?SW0-_ZKXVWf)$FcCs(!x z%?_WpBJN~I^2AFsKU%RRL3D}7Lc#f?53p)u}bxey=D&db1bNjXT6 zWJ)_pz#>QIQR}5}4>K3kA$P4l{c4hEfwnhq+r8FW@1dt5eH*mN)n+Yug8dw8e;ORS*uvCj3!Ljx|XtOuV=(y4rGZgmjO`AwET4A5|tNqaocU*l90Uu4o+Esg} zSEPpGuX&hoXc!e2zKFlbZI$G*HOojrNMdckGD_TbWE0aF9^5$cf1C3fS}t<%Dr%t% zWPewg;!RAz?8A7ARk1nFfz<-^LH*Gz&N)U7G-p~RqOf~UIc_aqDBIsPxFziA&LH;w zk)&f9X4`7Zj?hFtEi1dhyXAvQ9v%nFP*Tp%*Q)EXW5-ujq=E`qZ``PipV<@OfIpk~ zV1C0xOk{K)NO(#>+e_l_yD`9{Gr!;*x0q+Jj4$osAJUY|KDx!(lAmR!kVcu5rx@zz z=YUYjH3XrMMP?qyc$DH`1&@h-pN$KLj^RBEWw@mUj)nlkplsh)^R;24D}9s&@dcS{ zck6?kgm3S%;plZsqlOAcYSYq!n_5XFObH>^E0Q!PE67a`voC#(EWRH#?-)R2N!}}P z%@D!P`?;fn==69=lF^+~H?cb-JKjgg4L9d6p9eqD7y(83fEX+QF)03@h~Z4&IPOh- zm&dNyq4><}EB5<$#dkE6Y&e5)Ji7Y(9+`!>TfbkKa0O@QJ1n%D+K|ATBB{&>UIHP{ z!$rmCh~-?8xI2z^FjznN<)&#a*%vIIbiR8|&=iA3>gM>5MeRv#pu4d};7T*$>$j(@ zszs8oKw{d+Dd1P08&YqNy(a-i`@XgHmd4+%#wxpUiTYdaQRxyEbUM)V86~ z+t;t3enNIINgA>MS-|KATjsWsAm6G19!*(^9p6Zq;2=; zy>>I^F2=63SI^hwdRg!Sqx)|*cx`hLkqRsZ_y@Nfc2LQU$J|ruT&~(@D(uGRv}lFE7zf)GlG?X3sF{rx`j^ zBGD1Wp^7LWI}@a_1eJdJ6?68939=BSm09auPkOtnqlc`|WR`83#WzFUKOhpbvSDOO zY+-bIVQdLSXM%-ND_BQkU5e4%y^#s!+@nO4Mt0$>Ix2I8Ng$tYTB@qp>Y$5~?VG&X zBIL)Y#2ertW#oPMs`9C^_Cv{vw^Lf=@wMMm)VxG56ZY5THjo(_EEmq*9m$aZz1@U zkNnBK4PP>J6N%|4i>`$7jR4(^7gzSX1U4?#EQl81zxVO6OtnNiD7-)_9NQfqh3s^T z|FdM68?=b>HS5-%^hdbLXcq4j2i@C6pL|RuXJriCo_!qs9I-ERs8&tgsg|y4hj$q( z;mfTYqo(+_B3n6gBacTe!74&gRHOc3uCk%K?Tqqk5YO2=?@F?`VoIfn<(LL0Z3QTC zP3q57Gl)Q3!+W4n1_G?vDfZ6vO!T{2^pwTNouK?T= zR-ch^MD>g|zOp_6V_@F>@F}#Cx^$v;Z;JfB~yA{@Tp{M9`05bDpMd z`T0eKN-f}?HLM!xmDi9{Qt9bA=YgnjM{?xCF1x^Wk{G~{|NGL$)dqIM#n=sM$#?diA|tbWRk>DO`KK2t zkq!!Hw^YH_Ca>dof(@*T2@LhWH;>=f{-KEzym+39b340WWJHb{4&MVv=m5t55c^Jk zjOcp;W{zRM{DKWHc=s@ZicCPaI8D+;UA47M9$D@-CW-x4xtI92U7GwiE*=vd(s#YV zn)qP7+%N$ia>TLP4g2h&XxtJMPg;UN+EP6OC2f9}!J^gA`eeQK(R>(sWnu1?4yci> z#l^jRFQ+uHoNp!41d3kBy`1ziKc^!jvBYSHv8DOzWYj(Z;aDQtKBje4o~k6xd^--) zYVntgKhq10`9f8p)eL~~USKHy4>~yhC8i(DpWlCcA`7gLU5TTXUxZN@hR(xp&r*0a z73?n1xa&zlXz@Nt4UBD}mm4H7jDZ+l;?L9nz8$+^(^HlpkgAl}K&cKgci(*c|V8!#$HZE zG@x>yJx&7QZWNhodC$unro;2%5NcVp6#+zH_HZu+jlv45f^&@oqSR&8YiD9E5@2CO?*m#>0BT7Acp?4wf$h6{ah{E9 z;C^9P9}i)s;XyehkmehOcML|8365rtdXCxhAv2G9Xv|GaVe{LHm>%!Ye6^V_+-%;& zPc?W##UdFEAG_3$G;{L>-OWNY#4J85B!$A^7}*trs*YeUv^Sxt)&b1@{Is=>z=P}z zR`}V?-1S@~kM>ue4sT$`U-(wZ;hc_=9=}GDxSeN>|J8RKql9N?3s>FoRbS&zjluYT zrW%h33omp4|FBIpf0=X6^Z!F*;Qs3vFF;s;1j0R1cP`Z&vI>P=HepvaBVo+z**Qd2 z$_-a+B%ETydO+aVPj`<{iQHadcSosU%<;Cy9nL=G2D7bpWj@VmE2I!i(x40MB~LRk z^F2@qXwiCiMI&&f_h>lQbXW>!!lV0()GK;Rya`^#etA^8up~^EOOU-wCBzyJD4h{`$3`P00E@HQ2yUd@q~yUsyOW}{|h~fX9*Hy z+|ubme~B9b5Q7Wwq4~c@Uv6XAmMhpViMg8sKfic_!cTIbLliq~AEoqe`W$1AG&~Qr zWAo@WW=HzqD+$&4>EyEFXct&(4tISRN&A9hN*BGHg(Y?>;iG7|6!VJBjq@+=TnX#a zfw(+cunW2fHM{2c$XcjRSxCj8eO&k!?bdB|{cSzxIloe^7d0qv^pY(~lO(!EaI(wa zt&M?I4&(Me`9?hN9{6%S@euvIU5NL}4}}2|Km#No1-$>Icbx3{K7}5JF@iX-J)=HZ zX0mwix%dwH5?p4Di?L9xp9&|S2WM~jyd~>OlT~tU!+G>6W}HKGa+F4d4@#UQ!u0IX z?YAONJq(@2oTG^<^&qLZ)0Q!JFGRsZN|v?-y(=r>++x!%}r4(W@oV%t^o?j5T( zzjj=jVag6`OuqaAeh=o54>&i9?0wGcxPaMS-Z0u_*xd|ffYJW}3!h{3jOoF!uwhIs z#tShtsjqVTVe#}6y7o_>U&|R~)Ivt!IuL&5E_OM2`PJTAA>UL^0{@qo6LG*Njj2l0mge~rL#wo#} zmL>cA)H;BG?k%aF=j5%FcRC~yg9(~E;xk8$oRaTN1t$^R;B|@o(wBKjm)4X8F#TwS zpfBoVL~rqy20G;C1RYE->0Zq4$5-!4k&Rr~kiM5W`GI&R7XAa-``l0YA0DsVG_Mw9t zJ4$BRkoKYF_@b-tMi3Dfn`W<9cSWL#xc}loi(^*!Q9?5AKZuhiDq<@I(>qAWHcJ zny+{i)U>hdf&ubw!udCgH(efUG+{bqzn6h8Ax|0;%SP8*O==1zbTg;K%$~u`jvh~5 zl;I0!9ND*cw2`Cc>?NJ*c8|uYM1PcZjv2x9f?A86uC|O_6zSH}aEbSVN^t3GnG9%e z?Btq+h%bG0yJvFE*k6y^+m5Z4?w%9zmC7ks+dizw#VKqj+CaP>VoL-LYVDc+xUxmg zl2BE?=&Fg}614czS;U67L7FjlZgA2_P&KxIKM6LR{75dwvfUdh8~-+~?hOU{B8twDt~+j> z5?!t2xRS3pWfAg`^js0+J^jtfQ~h6js}vw0o2H z6zW43k)0c&eHedg-T4Q7sEuXH1+ zmZTxJKAnPV7EA1rYYKUfQ*W1y+|-_9f8O>HnT1tlkku>Ul5EQBL5|Bk*$>LK>zkbK zL2wtE!z={M^`}+)lR1W{w6gIQqaE#e@QoN%$$DCxyhFc&{nO?5viY6Qw4t+DVIfDASCCo)lUbC#sxrwEhO496 zqPOcR1l5{V1DAiF>=X zdg1XtJE;)gxBgeAXbI-Krj_?AKi!^~K?fsl(*)*Nzzd8`HWf3OHdJ0a6J@_H$^^hmo}Re*Y#fLMmue}d-qb4Gj@vTYC3!~Ytrjg zhtDkBEzE>o^4&Dtc+!L0Wnys?`Zi&5d;Dl)$i1;oTwht;xV4G=Q0b9v!_NIEWKIDo zg~#OHwmlcSLK(F!R`BoP^}gfSuyeM47w}F6Pwk?%0%|n#9xbweMWP#ICz z-0Q>nqOL@4^yhoH4zERNSSI_NdLC;Iyxh;=|Az4sWWb_iy4EE9C=eyN(Es1`R{kMM z{s`x%crX9Pw8{bxmLCSrQ45#F<6A5s&z=_HOueGy;*>CLAN_^v_4XJYy<-?i5?`Nt zw2RJJ+(FGNGr?W!;{=|r{hV4Q2s~X&R@KkxptldF?FL^{I)kW(GNOlGSyA_4{o9p9 z^tswguM}DAhWd#u4>(@E0+r}@X6ZV#T{dklkCAL)`U>@igeE?|GEqssX&}mfS)wV{ z(5`kx_f-aAm;Y_;oR{0tm4aCMyn1#wXI13xPfCo4Y$GCv7Uo2c-G zgMQ*-cdXX;;)Uo*>e+opY(4&C)x@Y2xPDaC+|P>NvbDG@)yZKfzSO&L=SHxuhEXM_ zRmO_b8Z)k6pvh)KvF){MOK=h8-AFt;sh9aU;%qTixED-`adVh)y36YxiI(csYNgte zrm;j8>#qA|_F+X4kH)7b+A7dqqs33UUeYmf$9|8q#7vAOE0KDCr*&`GS+ezWQ^=-S zSB-+J_Ikb8Yj(U2YT<#Aw1_W_<5%yddG&HMf608q9vA4@FhSVMa^bVMaZ>$J4;k1q zQ#6p!NfQ3*DpIwXeJ(tNinVk7`ZmViQciD%`OWr;8iNI%Cucm| zr+=>GW}G9!6-7cp{IPFub+h~db4cHW?1r)FpPL#cl#hPDY`91_U(?^rBAhLU6eOsy#@{1AGb#> z1VL#TKZi1ZBvrZTwP3nJ9JgGFHkIO~ndrk&I(E4=apXhnRkp5yfQhk`oJS$W6h+iz zRU+hpna{>9uL=2GH9jz8se`8`c&-&Gy6q;kvS|X5?iBUkOAG^N+CT*!FGd8C zO%6Hcr5yoJ@~#p?;}x7j(J|@|*$JuKg;&UPZ{_$2;1vo&D?VMf{xG6yW)wyq(NFj? z+SaIFgjkx=y=0eGglX+b+o&8t@4Go2>D3j}Vy)$-rx0y1S-MoYd{4!)DRI>&yo5X9 zC>Zzn1t+HbXOSp!AKIF=F}Gi^3W}N$^jmK9MT(SPKlo~}eke$;G|Ch2u$I-jKJ|pE z`l)h1`ji_D-$QtYD5bd2UEcEI;<%fyd}62-p4MgrImU_~QOD&@dwxdXr&#&=wb#=n zoHvUr@CiFj)X4k1*cT)ej~0@~=zNwQJns(7X-0|x;^!f|;O56D^=o!r7}7ZCzI0dc z4pLUxiH~lh3p7PaUKEFaBiQQMGh~YuZJ>u0u}`pmv7o!-6;DA>`y7~AZWpzIBi90- znzxeJL)L^FW8iZMf)x($J3ArN&v0P4FQxm*GMJI?5IZb4lshIn%F-I&(LOEk58j}8 znl;@^!t!+S&DZ^vuIJ}NsI`C#~t}#oft{n4jNNXUk=qg&qx{0=FLYtzF(}EoS9zL@Pv1nWe>5=;xTGFje)n& zaUm^Iw|MaA6|llDm6BR6eEyb65S@!Mu^4)DMYVa3rM)%&`jtc~FVx)j$D6~Q|4(ga z9aYuxHsAw-ba#Vvr<8OE(j4hjkxmim4r%EWkQR`V4y8k-LAoTRyFvI4_uk*-fOx~} z=UPV={IQ>TXZD#rd*+>I^yZRV1^3YHFleGZ)GDJ!Z!Xh`;?zGxKd@PF82ysx%*}^# zQdF=klN&YOSfnoVTG3z{Y5jp%ohkO`Te4vZmc6VdkB_-E=~Pjg;%=t$WIyN~8-_0# zEyQ0}f`YD1`P}cTPxMF|I)b`apKiQlcR`M(Uqmw>B?G>+8Dlp+;8r_+^Xo^1bo*XW z?R&eM2V6a>HRhNfFG=p)+fg9`|nc?qDzuMsYR`1eM`7^n^>Wk1{T3wR(Lo+ zyTV8Tr|j9%y{AEZ;lUJ2=5sG-^IxS2-Q142J-Z$JAtjEpxfD49`2nE`Cft+c4SJCh z`$%&b`ra(nKxWnLwwLk>3=?j#UCBlf5_vZK#{#wQl004*Z9DAEj2=6fA3z4YY#wY| z4zY^mi>7ZQR*+4_@aXgvGTnPJROGCJ8Kf2cF2B^_SuEn-*PZhD9?`DJ%&xoh*(xcd zaZ{vAi)!2v^N4IIehjxD+Swv{_!^)}(860nrLyYNts1HrP_&b#5IRx@X?KA4{rI(k z8I3OHizV4g)^7_|EXG@Iv#6Ff42_+lwF)u$dG|W&#$^V_OKS|kYIC1)rs*bhnV+f< zJ%n-2sFZUa^S*oEU1m7mrCE>Fud>L7vb!VHz+Qo>{0J7EJW3(_&^l|&g5=;B(K8@E zTx%dBYouXWZE=_0j*VTH_J9Pq(R8zbc+#{R`-D-h`2BtqlVV!qsa@3>*bDLbfaDD6 z)!YrxQme&pmXE)AZTr!;>Cb`4s_LXEXr0y7mh`MKY&Sbp_$ao=7r8+t+P3g{aF}

)WiNG1kO{3RRdgDrXBLK%46+{RMP<@$ ztAzQXZOr@f~Np3kbRQpFopmwgSF(mTTEtrpl7YPyocB z4=SHus?4Et(InEb+^FXDVma1%O6jez^j=q| z6N9+7Ret6vo0iCVgJHXm$lG}MGLBl8k1EIw)#l>Ae9E0ifhgkRTt*Zo_yRwr`y_$^Lt1hFykTneAX3L+y7;vC_n09h`0ZHCI0 zU&Y+dMWp`EX+as8j4`6Lx}Gbnn!?|H}?Vz@!Cd`6uk;0set!f!I` ze@wT*CB7ZuktP<{5%S#PE6&Bk3I+7_3ZJ7-KA*jL0{Sri-L&fOUoVqCvlf1zFTD>0 zg1iy))47}_%5;*9be&!IdlgxVl(*IXsI9Ta)^{oHQ;sDKk z{ZYcXe_KR`c)md3Ht_8NYxiv^6LzS@skwl;OEc5wg?txQ<8}(_p>BZIqgnr1A^%K1 zxp>wms>oW7aia2r+-juKLljwNLlQ*Rh$EsNsU0ak#kVWa?eb!8VTD_p;U0t3Y7~^K zBQR+iqT#-cT$Tdafd#z|8~Y87G`Y*W5by9XSDYw`cJT9a<7~c~3r;}CbrUT~BdH7k z%QMsX8+^=Fs_r>VfXr&k{p^dL7+&6T_M6hK9;SKm_Je*)y#j3Rz>V#i{odfzC^NCP zS2=@5n~j|ZP6|%ZW!NCI+Q|Ao%Z_}}jb0HtsE^Txfno=GN#xUB+>#XgdP{jwlXN9B z+gfSBLTVBp&rGr>sPATni$+k=-X;w+c4i(%8iq9NJ$h}m-bbU!Ty07d5LI!z@c{>f zzT6Qmp327}zB}{wo#stqUwuNY`VtK>4(iJa98FSSoq@*`Owk z7rnhi|HL>~ha6~9NOkT}!CtEB#$vclnM0Bx4kFWv-6pn(no!=(2uEHIzP2x$g%m2i zYwSxofqL_i24__Y&qMD*pJhhqd8FhoH1}OsnPz%4S6@kdp6IgBpYfhsa5khubk!bw zHHF}V6-S$m@*!C(*KBI5>rD_6&n5a$&Fnb1rOr+t&co&pEWSn^()h@nQ7eCFB z8GAIF*oxPk2JB=R(q^V?EAejN!<5KO((lzk6k|2cx3&yrd>%n-sZ(!RL2@HZmZNkE zn|s~{XCS~((xscdxsFV;N^gUoXPmB2Kmq$Eg)-GQly^sHOBD)AXP^5ORL2LG1~ZS| zXP?rQrOXwrc;3);cHLL@*7ndZst}px`=T{t)}a)5W)3o*eT9-h3`7+nl*U*@q zcE~y?O&0?Z_+)ZMscE=)+Gb277$Wg5&CG)wyG*CM&QQ%&1Wl410hx3y**YOE zzWt;mel8@!WL`7=Huu+11AKe26($*KsL{^&JA85~CKF;AH0qd%gauP&#*h5+2r1FC zrjF*tzRs6+))pgUtV6DcGf+=YDa6V9*}P*w=Uef%)(RX(OSiVkswYsT`Aiv~oh7bz znkj7!MM9G{_;OmCWpNuI9ae{pyLD^&T^m~N*Y_nKF>2^pU)XR zFP)FY@$-i5gfIrV?f!?OyK5`&f_2fTYd8E<7DqehT6cZrsH1kQzhy_9f%!qsdz7eI zB4ISpB#a)YN8tr^eSbMs{d>1}xkvePypsXyRc7uY^0&F4-AMVcv6d92_QG&R+#hb!V*15*+@#b(=ep6TE8gQ zkRN4~qHLwNlZ)@yLn6AXZ1KK9^5Yr&~hCzu>(|Y_l|TU2%x#!!e}1{Ar)dj zd>ApYyAY1%ro|MEP;^MMCwbtCm?vyiN+JIu29x&Ys{;xOB`jvB`eo}d**5b*(-}1~ zv-}+Sl2Zy9`m%6a!F{zmW)@^!U$->u5>+Nt40@U|p)(lLM#D}QT1|uYQ*bbIiMX-u zZ*{d5Y5}z0`ECF^xYZNxgJ$WG~h6JjXM@3|3`%Fx!e;e#QwK#{|rLPNzxP$97Dzw2#_ zbjSPw12P9L@3es#QYSwDHY$X1S{6#7o=!(1lxIS{r(jTiPg0q_c-Y~%ejGLMEe3P7 zAyPwHW36z+jZVJtbW%O1+tLD6%q25irG3TtW0-KdxgO6rNHu`)ijVPjCrqa@;K>F< z4q2f>^^FkqDM%s>Yx}(8ww62!ChgUZZIRRldPaF|T6*rYw0W~mLj&zfh>gU;Wo7#+ zqtgm9@<}Qwh{))BpQE_$l1Dxv)BScozskDbS^Jwto@;@M+uX~~!RoeifuU}$`%$gt z5XRQL<#T}|+g*be-sjU3C#~YI(StL}8>68L+>*k>s3NvP!i4+={Mw`^fFc}?_FZQ=Cs)@JZFcXHG9n5vHkvg9emG?9(_8c ze0~!qth-(-onnrocXsJr+F52GF=&3mpxKhjqrCp^LgJc3Y);R#*prhdQkz!t#eUDp zQe^LkZSs3V+{NaKSc-m;9GBFmNH1j&kA19JQIHdB>BW!khiHzd7y1$ z`@DEct-CAkp1m+5=gQ_mVKF4mU4d{e_)Ine0;Bbo z$W>#CI8Pa-1^i%pE}QYhCd$-m3DXfoIK+&m6r=iJ3xt7%=$05Q!|WyP$@$n^MgM;9K+` zz+E18bL%LJ5P>SaAN2X#9FM=L_&+=Q-yCV@_20yT=(8W?2vcl|lTOg&iG(hq1z`GO zJnnC}^|~ppbBx&VL8y@AVHn1tQ`dSUI&R9X!lE?DXf}u?VrPbFrY`cxz)A5|c5dWW z$i@UXAM7ljMq*+TTZS*5DeS?dn>fKY{NTm-*&;t3=^t6ph&>SR?c<0Vwyt~6PP_dv zSw@%&#|DpnA{eAlvO|x7b+JRqvn-~0z)A@(j$i_>^&r^77(aZOLHXPAC?Uoh`Cac0 zCw|fPjc9+J3Eg_V`ivWEJYlFNDwc}I4)RXlBQLpx3$ ztPzUX)iWZv*S&6n%nm~51NXlXi2mV;Xa3{o9|QOET!Ph?zgghj1vP7@lQD-7q9KV` z%veHE8u88Q<86Ku!NUfLjf&~_qGeMgf!2d(0tuyTSB9P?=4J>Eu{zjchIB2yD6vk@ zQbLF7GGxJo&SHh86aaRfQU<^w1H;f<;DQY<<<+d=Ra)|BX>4I%(E5^(wj!^^b{A1n>?uwU92-I(?P41{JJnr&C z@ANihHF%LpnO{}56GvN9{7Njk{Uhqb@T>D4#QCcPp``M z#ifTh)F=#Q)Tubi^2~FK`9EchgQGj-g3lHqSU_m^j@?-uG!~9x#B4&vV2t5l#Hvoo zQd$}_WrRdd)qc(<8r>IjhaAt{IaA1@>22bcnTm8_sD`R_Wu%dPg#N=^Q;L0HfXBT+ zKnkoAZ!Wg}Kqld$*eK<&;}S8TbF7m4qa8rLPvwmhrUe4A98$5V`}%N0`2q*#1kS;$ zmNefPsDdCe;}_Bn@(;%Q#1tEBgW{YtUri=9vDeAx0L?yp?zOnM3^Lm!ZV`JdsvoOCT&rUtDdTQZ(i)hu5DAKL)>W8f@fb;Ox0Q=bLJ-sLhO;k z?whJ^Ra>D$0jy7*aA;s7s$6GtmCXI5AuKaZFFb^wtbKi(FZWwY{jKkGyM^1Z~io@C)_y=N3kKoTQLgDn(=wORIP zO2TJBt>|_Q1Km61w)6op%*}Og5%BYY)vak32anKQM7ye7_U<=EnVJpF^I} zAuI6{Dc8Q|7ZiNIKqhEF%ZUbcu!R=RP^#=Slm8e!d=V;9qfm!yu^krQ-o!TOJ&Yp6 zdg+6CWVvbXfySnz**A>Eab&tPWUnhm)3$hP#OauBW@p)k*5&PNR89%)WBt>_fQx9ip{)kRKC1ewo#T@u+Ub@dhA3 z*bV_S6L?ptdv~gS?Lr7dgU@-jWh1NS!H7j$xyQ z>d<2A&z0DDG#4@(^Gf8MkNvUPW*KLQGIrhJSAQ1fk}=DCY5#mYQ`b;DAFOPoJq!m_ z5oYg+dQr=;wLL;FQ%}^yFxVtN%_Mu@;EoFRtxP*%6;@%-NE&xZ+#*P2Be@Pmh)-#( znxSj>E*-bG<)DvGQixqtYBQ_ZR77cf6$BJ$xQHEh8XTG}rCyPjvvsn*GS~}CRb|Rq zHZ$h!=-SR9!RlL)o#jDPFO8&HTC8$kKtEzLG!J_{{9UL$e1v0pwjOVwVP9{cNo zJu(-BlWBMSIGu^8INyWai1pOS&=>cFfih;VgxuUn{48a6RXtP!4(bLh#=#?w2>Tn`{7e8cC*oH{!`QjQj<@wTLy)Z&Lg`A>d85b;>2 zWJFbJ$CR2&PIyei_`;pUTNsr)dANH9ZHW7Ex6Fn}WkRL^tXzB~3Q(cwVYD7Si%M*Q zC&ro(YZqJ6x}>(GQW?2ATWObVPi~Ou+Qu@dZwL}EhGkF5k;GDBaU!;u6B;}~G=XK4 zzK7R=Hc?naRESR5O$dv5(%0Ac`BMxeRZYR-b86-4YHi;G>k;EFXf(*}^yfPR$7Ww> z&v;Dj2r^%?MLso5-@+pPb_=%G(=hDV%Rj?$Et-XS+9ly2r&fv6mQ({hzzL$Z4}%9g zBfRve{P;yKLN{iKG>o(5gFZW3x3hQc7+irloaXVAQ zg!&~5JSL0Am(53zJC3fkTDf2AfPqNxIj$ZKr*})&o#>lGyaewp5c_R@u+a^H!lN^* zB>_vT96cZIOheTJKm!(QXaL~c>iE~Q3cnwV^S|Ma?$amFEN%YCeN!4W0j)~9Ocvmx zi^h8*IAG1Dpo+?lL*a|k++(3Pe$1?HtiMWA%DA(h*xwwT+X6QXV;slxbl!I8sfaYT zOlmo59HNnr&^$CoX+*jVWb`b0t%ryo8%8nnz)AM$r~EH%y5jT^7~I5B48l~Ju$1?t z)rl37$c)HE_q5>2fOzj%h#psTVpY?0Gs*dhwHOTtx)%VwzAEc0KNkVKx*^n@{qckF z(u1yJ4Kf}5%=Ch|hY^p2aCPd3)h97xx#y!z?%FY+4?cP-%Q%p@1cZNETg{=|icsB& zG}REJ0cj|FBM@6UUt_R{px=k+RL!`Dq6^!aylP@_C0f@dYYj_C-Yu8(yC- z;NnJv@eqNuV538Pv7h$*SsamaSN<&;LR>3tr?#}6tj7mfhv?R2-0dMqq^#F zS&Xip3`&aL!>pqpX^H!GTX|v)VU!?)ZUnPE)W*(}AsCS$W~%Q?_81YUJ-+>N;>>+| z-a_Ej*h#{PN2=ANta_1Ez_5+L;Ww9?;V_PO9AafHsgud~kZznjY-;4kRHz}S$|K)j z2%#P)3V$cAD1hQ5IB^J}_@*#!Zj4_&bw$8{%!Fb^z)<7_>=m*dbgoj3o5=?_P)D-^ znyaGv;a&B|sQLF(mOy6>=BbQYjNV0c`Kl_@0cji={=zHSD2kNp4)n*& zph2a5M7xPPHhswpvvk*)v{-IuDov+ffT6 z5qRhc*nxBU9cGIJ(lOS1>@v|d2*MAfGgYKnZs`Usob=7z zx8FQzZbOZ*TmN#CzZrl7?AdnG^Lzbe3{cHa?4%vlJ6O97G4^+MjvZzk?rKzWYSQD_5qEOC8#>QtFuxUwX7v3U6yJa4!dpn+tpKSohwg+pn*WTi9X{5a@a-2zXL|9@>806X<&u)bW(eZk@PAX*2h7!61Qf{%5as))57N(5Q@DC1EwWBih+=y zq}1@@qp;f)CvFyunqwdn9j#Ty5qCczYGx+fePg)4n6z1kp7A!!{L>Y2P&-aR7*ptynON9PFwjd~eA17()UL>E(JfuFTm(k){w^ zOXtruiZWyIp<7ia(=2K2T4$-2Iz1iu>YW$idPkpt`35U&mPdyhCcdg4Ez ze`poI8u?|LI5=Jv`{yISg1_t*zgmRLCUEc~5aawm72(>}IG4R#R(OM#W%K9Daz!)^ z9{)M>vd$WusgC#4@n2zH8}Rp1XK;8o{!hcfHEQ6|elIr$2l9Y+e*WZ_`;zJyocLRt zUQ!i;6UQljns`a#ca?Zm6nMexq5L((YuocWP2UB&6ZEe1lhymDwC`%5m)(08EC9d| zWb*hAv`Z$wtJKRTGjM7M-LIowTgB)1(`6wPIKGwfr}1EVsH@>#HZOtmI+=b2@7h4W zw;O?jXPAE){704?c#zjQjxK2TSbmyy*?0twJhy9H7T{a}0f1L*{{eZOeda3qs_Nzf z&cgnS(bu-__fDIO5&!^gKVOC`hMTK#Ul!VcGetOlI_~ckGgq;fT{hs@nqP^%wyLj_ z*j$uA{Pxd>eaY%_HRQ|cm=NBP=817|R$ORby$N^;z{>N~C zw{~0&_p%xU9LWq)68{q9wc&nm0Rd;%{de}YPLQk7U$t;tl%av|r=!25s<=wLti!nA z0RV469)q8(?@PpMtNVK!1vvUONd5HR(BF3*=fta4i3_G8=jV)OXb7Qy zivGbyXz(WeewXzH2mqi4DK-9Cls`cIFucp#62X}!Qh&qzJpt{~{OWhpo!9Nvx`0%G z_L%%-SU*Bs8_s#^;^mDi7bE}x2jouq2ds;2Ea0tke(B4*PQWi+`Y$ehu?OYq^)GK2 z0l&Tm=%l@WQ1m~ipTBE`>$1l$0J$nZarqy%z~$u83km>$rTLFIKTIXPT49&7CBaEA zwEi3E`ry9H4FpGG==>e>^3wTtZS;ML2KeQdAOE|{f0wWUUU}Co`(MBy4gVzyEC~Rd na@{iU1w{?y-@E>vzPc!^APo)5#ysEhzzaYG&39#(pa1rM+;^tv literal 0 HcmV?d00001 diff --git a/src/vfs/_vfscommon.vfs/modules/test/tomlish-1.1.1.tm b/src/vfs/_vfscommon.vfs/modules/test/tomlish-1.1.1.tm index 8405fae74a50ec468daaff5adfc86c3c68353219..bd9499bb1977a3695906bf55498c269ffba1b933 100644 GIT binary patch delta 8989 zcma)Bby!qe*B^%NPKiN6YG|Z8B&9>T1{hjq0LhV%6hsaw-618ZaHUI7X(U7%1O!A7 z5COjteedi2?mzFD=Q(G^-fOMB&z`l{{+)p>aC8bdNeBfofZg?l`@j$o7#!&W^MTm= z!rhT@Pe>r#+X=x3@$!NAIU%H^&@2S$1@Z9m^+ZDaUEuDppDny$j{F3WKQ1;!cO=Zm z(+&yugSiJld_8~mLwG@uE_O%=>>kp`&H)K?gs^#dIeL3JLcK-o9Ng@jVNgGq4+8Gx z332jrcSHvPM?laaAnZI~|B=`sApA%Vh!fiJV?kzBDRd-1El5eZ!|kP{JnYqT8}e7`=ijb=ok|_G{ zeX(I{1e>S~t72chcK#tsM=FtFcJwXLFg4w?QlYUb36VQ+LT6-05zm zITaghLsw5krp|nzyQ$!mHnkCpcBRt$xXQ+sR!#0~f<=Mx&8KfTp> zAAjp%hVIg)KdISr2{&~#_7ev^^_QJ{4V;Gd98|Gj-h3$cp#8id%1Gq1uSZDW7m51d z-fJ4(RxlP3AxRYsQofVvrD&G!?*onW$5N4!_W>3BQgX2I+UL=^9(N16qNomr1#26t z&@-mWvF|oD{Q0gxbPf`6@NN6c26&RuOYVK58ZFD^^V4gUaqX`nTB8ua)Wxl5~u%=x7?drT>4IfnO$0**edA3kTDoEYrIE0x6igR1s43_T~0mbp@BY}3JS zJ7pix=J!P?y?*Wio%U;>#0bspBf`p~kvMH9;}`$xon)RjAVe{2CVzu`gvugu0CYg8 zM18*wKdGXe?eKQhojB6RDX~=2_!0UlBpC$a!`v%MLMo^&B1$EPMHoQ|d|+ZGZ(lyK zE-x|&V>Whwo{Lm0H|uS|>$l{KYY+6g?kdSRJkW-?@V)aqpiJgWC#=Y1XchZ%%3YzO zwHh=(+Ms3nN#je{2WOk>1im-*U6-|t0|Fl5*o_0+bAvz5!CuJ=w}1hiX`TwCPaHQB|zxAUI= zjqidro9c2KY2@Au@oVLS^kDaa+z|^Pi~J&HIS-QrHk4UMs`T+bZyDbA3X{bMVH96l z@amv=BKl^!JjjwuU!>?Gz*FVzUJNfnVdybvVPa8%Kp;F2UPq{Tx|SjPI0guW zO#lK3{7h3QN0^_$U0*MBl6Hdy@FQUeWCp;ij2@7Xa!$!xc1MtZB`q7 zUj0H%utLx*^T0(WxvDen6W-|{R_`-$Q9?f%FhdRsS3t8Q;RL?2dTO}(Wl+?aSMi}$ zY(>{6#zGfcO=EqoS*45eQ9V^-=l6PnfmG~mJicN+Rzn= zca>(SGkR@2?;lbsSjd@Ub`>VJ+K;aT&5FRHRYaXKxI2d!o^~tB3*HR^Or}k*A8xGI z?}oG}y^Dx-9VN!);yGur>_24uim|^Br3aHri&*+!IOt*vYv6h<)in2@W=kjeb?Ks0N9Wv@|BnSp+;m$n6u@%WM{7H|+4pI4Dp&~fv9v!5OY)P~ z2uHR(m(;;{kRe8%G&ZAU$h{ROOiRtl&s9_Yfsf z)kOHu*Wf+G?L~67Ew~cgYsE>V#xX$`iNkvNU6)#K=YN3o{$35xgb;H-y%T~ycl54R zPXq#qp_hXQApZm#^?L!7m}+^g-XxPV?Xa&L^sX#1VOAW!&e=(u7iiuMD;ft+v(X9o67AqyaJ^c6>&qkH} zy4*9&TRt{z=7_on3i3DO*m(j_=b89}!cxb$UgS&82IW~Ma4nt>62o#53C^W%&9pI} z$G>!cL4BcFxyQ|IG{Hqrw&n1gIF(^98 zb?y)Y7fxTshR|0@H}e)Zb>rZ$tIA4l5- zl9u(@^_8SPCK{gd1#d<~=?uZ1$zg6><YUP;@d{JFVP1PL1k^E!s8>O@{w=Z zVj=oQA0xn-=dS+tsi}I*LdCs- zr$hI!>G+`&_#etM1P_L2MEHp0F}I^Vwj=GNGHDlwBkczSWQqpbPOSucLa1)Vc5Dx|xjlO|yzH0G*rPVqmQ2M7cmL2-RJTMp6>H!L#d|=x^kiuL z@e?02VOH69>T&cO4UvH;dhHJ8?N0y6K~^Z1Ge!F7eDT8SCH}LsYD5P}Y7fw0m=5)3 zOxm&`r~G;t6z~eWB{)>%(Iw8${M4|?<93srP9($}y={TOKX2&E{;H_%?8r`zv*h6w^BJQx8XC=2k@%;#DH+}|1? z*25V?_-_ZFYq7~~9DLlJ_>o>7?*C~c;Au{2Tp0R~piDqGfPMoDuzwF5==3Ck{tU|p zePVJ%`oO*aOa1?F&||_tM}sjE1El%l|qCxntr#$7~HKvO=zct*gh?w?SO( z(^tlRI{FzL9O3ex=b!4ohmQG2##d?zHFtgI(jJHl0vX-{frNkq4_3gtffAkY(IvsI z<-8|4-G`)g*yr<&5mXwAcG4}Yl6@&NNvDFF$lF6qN z?1M$}v`LodgG!?`Diyxl1*1Tbx{&K}>Kx;GCE-fhNqBDUZcXM66dwwu$&UD8W+mNb zEpAN`^!l+)R3Duwl-oR_U<9Sm&UdfxC-lea&Gp{&Z0QiE$&0lurY(w&79yrj_z<>l z>elTj+HFzK{8h`~fx}~XmCt+?Os>%Z@u=$}iTmB5Xa_vjLBYR-ryIq#bR_4LJw(*1 ziaRi)EEOeQv$<+bp`&@R>5w1c?+u+`_LJKE!jBtlc!s%HpCx%1%=m8ak)Oqgj_t+< z@mXba%&U9acZ2uT7N4tCOSZ^n=OpW#93u4Rz={;&U=$Lx zGTUi=-Vb_8;dwNi=F2}KpB-{eSxQ@$CzoxNt@M7xl{QbVo2p*5`XS5$3q55f)O^1PCYWw^dKkPv&BN(5gkrSK^;i zq^IQRT>~wO)VxF`C_Tw1eJD7@ZIpcM!&hFvEwWYQvYH%KVV}o+Q?n_tff+-3%O^B)5V*GrhW}+`owwGoO$&D1Td{T4NMM|!FOJzrinYmr7B`DlbbMcW=9FLCshc3 z5YtU#6gIbR{^Y$JU~P3RjQkd8Lv(rjT@gKTdKlePA9=TBRJToHQ6LF?ZUdul27f%_(WH2{_CvhjLoS|X-ewn{SHV9t!pj zgPhY0Z?7=jFB?k}7bx(ySX!kg`M%P%z$-5ROtuJWmn9+7L75 z(wrf2aPrvsf{La@floDzW3Ywj&xn_DNxgSyUkImc?6Oo^>^qW#9O`(lJk5dNY$ur5 zHkW!CdXC)H&%dG3uR`)Qb3}b)km;fk&o9~3P5&>!p>%I9bLBCHY)-%AR5R*pFEFo1 zhEuS)N@iPISy>n4P*7TiS!qspi)(&eRJg0DTphED{}7dt(yy4Ep}Xogz{u`X!PCcR zgv?p|da>?ng@Uz7>IX7WP?My89N3M#S+5v_kbHip(u3&+PVD%^_IM9Qvu1BpYTl(}sO(4FVKDon1%FQi3cWgTthqF6N$MsDn+qjRsbZJP7Z2yQ;(AGt@ zM7md_=Q_f&$||61Zzo-?!>XO{RNShfvh3K|syGcbeURR9-=jG@c!6qxN30G?$eZjh zi#?nv{3cVfd6`+ij1Ca&W#Z^h79$WYpPdy$I zaXuIB=b0Hde3T(0See+`PP0He?C!2Fo6ar1Df(y`g! z5I+$0q7QgMj@v(a|Hi;ulB^TV?9=wzwu3zW0qf=f%k~A(aLY3;+@bfK;9-?Ij8%5e z`F%$3-uS9Gd?mkTsLI8=td^7G+~=rrSkv1d-$o^eP0hc5JMl7Q5{b8P{Q9o0?8%44 zICakNapE>w-}d_jT=1sJKGk9Iei{C5_axL`8MXTn7h`9V7kEoSIHJm@eZ8`zg>BJ{ zowe!4?X`l{Jdug&)LW z=08?i@&d0#&FY%ELNjoQzcOqyWe4{8wK$X1Kv;3u)bAy|Kg>^Qt^V?Mrfuz|avB|L zxDo35ef5tbVLC3_I+dW^u}tdXwt6o(bMtWe)JLy%6C>S(cTq#csiZ3FLlXxaQUa&P zr`*RT{gQiSk3$L%avXfyEuLr|auiaiPzLD*fqgcuCf<=cQ_x@-wqr?Zk4uCzdk$%y z)kVK)w0mbdSo1PxMtgeh^7CtOySg4*>836Uwh;|KyJe}t!^%jZsPuk@IqY&z4$>}G zX@mdQ(B05^tTVx|%L4o(JMgY}n4ETgme`p>*kuX+QT(|1h)n}*L#ZCaIfRCy23-BY zXDpppYGLWQBi8ibR%aa9`#T3#i=tfegFeD`uq=2$X#;OlC2zHL2WPwcgQnz;EoF-t>Lw)+dF7hpJ`dPD;j)dCF~% zW!}$))f^a>vkq3V!$fc08yGU_)J#!8K=eKf2#|`n*$`x$wK}=w8tra3Q?Kl3l*!Pl z;JpSI#=CE;tDffQ`t$VkVmxoB_U3S~Uk zP&!d~c&qe#Ap4-6-S>;rs~YzgB6GVg)ZE)=>fSf>`&GmSfh4Z#J@orU{aMWAq|Cd{ zE09I)pKwR@CN(c9d11fcQqiNl5!O$pN%2~fVOGn;{EoCHl<;Mcvu_>rsfMO6YiuT} zUGh`iW@H*)hEY0M7Nbjo!Uncs6Hu&8khVt95v~-20O|zB&RyGwYL+LwRNV~8BoZ}E zArlnWHO5f}){#bQcyog>vUv~4GKp;Ha3wtn`uGW&;wi7E;+r2|UwS&Z6rgh_p@5=u zL@_`4_1YS{N8M%!oT^sXRCrW-#)*zXZE@+7`$v48WN$6#m@G}K+p`Cy))t7=y`4cF zK&y?LXjwSPkyZtpqIFO26rER~ny9ouE%VD;;|l`6@>|SYT@&RWr`w;mWsdBj z6nuSK%uY?;T?&-*oP3xT6Hpb)gP!LtZbAZLS}uEn{dOV}XT?eI`pHR8^b{}bTxQkw zrheoi{nfwF6oxXNga*FFRc#Ac;G^Bcq4;{Rz)n@5*1bBf5hMTKWI%w1@4TN7r{JIy z!Dlpl$B8cA>4B{jvR~zUwaL8ayc$`^rm1!{7@m@x7?JOi3K5saK3@`bIpQSik7Lvz zeB3s_P{L1sw4ZY)nTA^u{vfSc`>rHnnahFK1I_J{joMx3#3iIkLH#8%72U&nKB}Y=p~0O}AoxLd z*2Bf}F9Ba`>U)bP-vf37G|e+_TJUZXlF~AE63QKp(`FP6+xpW^E?;cUhY%=?!(xYe z_!E}_E^@}GC$*G35{H5PQ|ckhOoCCVoa(&?xzA#C6BtEoH@EE;kyH zWb~wXqo@^|)W(?+J`3{|ziN-Yd=d;6-_y@UT0yCI#^Z}1!T z$sMa*=Xk8$p0M_}F;|ET+krkiGZ7>fejkxznpt<@!YCJxWs1^yC&la}soiqpa_o(G z9~V4vur{MiAL()|s)uII>}8=< zQ17n(PNQnDTPBU3+8voS-85ENEPbs6wVse8vhBA*KQ5HmYC9J>YEAU@nD6YV_b(*9 zd3bU|+lenzYk0%<`job^?AiFyxbdX`&9cq>|52v5_|=>yO^Gwmxr#@Z5=x&vNDJ+LIpFtil!5AdaD!Fk9JY4+mdJEdRiD@D$uW8=3k#Duke(=Z&!PcP9`7ZU*8A*Zt{~j z!vdC#S>*oxx!_M%zd_~yV#@z80l`I^5Jp4H|$X63^--s9~aFWLZ4x#zY(g8`u zM8N%gX7CX$Kwh8#EaeM;t?1FDHyGpkRU`gFV&GK)5BTeUSOxGGwku6Vp$Ish{fb;r zCI`5Rc)$%euGoYk74Qzv6)CGpi0)1X+$d%Mf8qUGq^pIGcFhCEgSk@3h{)Hj_84O5E z3DAGW@e@wG!tMTNI1$LJioHulT7#@RuRfqR?!&Z&HrMEfBr}QjUoQopF!oS zI~q*n{hz?ZUzPzmf4YCnblOidnvj11ihsHS;i+BuLSu`zf7YA-E4KLOp#Fs|{=-p} z8gNiA5Bb+|<{yoWZlfFVqfa*Ee1BU0SB?CSPELAPo%9>&Apfe5{?V|>02oW*qS4dB T#`!51NB$>K=D>M;o@E9zPl@pHSe>}*|P3=sb3|&l3NL-yQ?aWDR?M)o)O?Y{24XsV} ze_1-{|N8|v;58yntv;v(G^k5$5exw$a2tmx0SgVu&CHpX_v;*qr89}ET`db%2{@`s zExTqWgoaug1PF)(76=G`0u2d}z>x$~wsa}g!z ziyLa)ZRekqLQ+OukAxHn(T7VTU6RxsvqiCpH;`|IX+nbw5!G{pH)UD67@_!2J9Yu^BwT=e{>j8hXp zmiR{Z$E5#PiZ0crA`ssUDfI_gKTc4Luv8>&^Luq+QKAdQWO@&BIBt(4?`*sik ztunWj4qsZ@(_c4-uFo?{Ci%QJ`2MAsbB4@0TwY}L5<{WLz;1>&+6{*6VB!5!Eg(%A z^LAx34$@(oRIxYo4-=1`0O>;7gj+cPZw#L1=0w!UKJMRQ*6BZUW-~np_0#8wzpt}0 zMThwkc^fsFQFJk7^NcfwT~-#1TSdyS=nh{L%N6&VO7s{GoyYL{ON`FwU%LnN3gPQa z7;4rPy%sL4!o9o;<91=+-Y)#5+c<(F{O^Q?nC=5sCewdz!(m1S4CPhO4tcKve(G>I z1lwl)y5Vl{#^6d&Y)tZzb#w{?Bh)ynKqdB-ToWvo`#Wnm1)3=a7fgkaD2y1kKxDew zlghC+fAsKjax;6W7_;%|>;%Rb?ELAfhZM)p`=9@13T_ChLxg3U!T0P%4UC0#G0A7NhE@Pc=pE7 zas5y@e|v%S4;l9vUlUcwzg4&Wh0(v=b=Kji4}7U(vURwzm9KHw~tsESpWkBW8m8sXGR+3+|waehSew!p1 zFj%UU4VIF z*eR2DS%sbg6k+{1!8kEpOg6T)DDH5E(~TJU=q&0m3Xqu;UQ(L#&Mo*vu!j}c( zEm)sjt0-qA7pphs6{J)y0nfnOCp%>KPHl3%OaCJByZ&j{h$ig$CHy4bvT|LUhm5Tl zDvZZ+FIlL1G5+*11ki2u^m<>MKdQlPS;swhW!Wta(6_gjQ1t!iiz|CU_h~(I?}%Qh z7>T}GXx7a>ZE2^9$zLSCTK}zYmuq5<^Ow+z$zIM*;!QNf3ynLG&fJ0+rT#~?4L@q74EUzgLkJ!FOG?%Z0%XF=$}Ao0i#2n-Mq5Eu}!2s+K; zmftVn;2@gteD=ogm&FOcq)vw- z^{6GgRfj~!hvaG;iv4WRk&;ir{k-IplHYAIEj0GQq2Ch~SbulX??k_FbHduJ!3-E^ z6|sQ8mx&y3<6D;>Q0AzM^~0w!`!U*ab`<1wC-d!Z#$EypsqC&vbwfg2n>K^j*gyS|B zpb4SZ67W<<1!7=*dj@nCi=R6{xd)S_Jd_$ZBpI2lH?xqqM-aT!hXxkytZtd_0Wuq# z@I-h{|KfWYrvTbLB^NdA*(n~S2*gJ>v^%hK5}J6$s_Bw?{urt;OB9IxcG=F(Rk(7l zqSeeM4^}cS(WfUCVJwS4B=~KWsD&1H(}Rb+=HV3bp+uqB!argXr{>y~$5B4iG*6~~ z7Eza?c#_7^VUft22o+nuM<%6sDVr13VC##+Y2Vi-A_MUIYYVv!mg$+Ky{3HTjdZ!O zrn0|S9!CHJf`b!ZQOZ>@LTRVSt7-t{<_cx_(0(8dlQ-wpnf-mr@X@mZzGL%@bMU#A z;b?5f1N{Sf@ahLNe<81irxqB3Q8)v6NMd%rSSle6jBlNd=JP! zapv%-ew|W?{_a`@`B7}q!S0Y~@%MRQ>iiAtKeYq?RXbALt~!2SExr*R1mqh~NtPYJ zQajwjaMtOM8SUR(?MLXZ0>_^(_ebcr^kYe8XfaiDcUXr)u}@#S0k5nW;m zAx_$Gd0A@vyH21Y}TTi<(;-C3~CXQGeA=)S3O>Rps zC26;r;mh*lsoj40RxibGRmo8Ld*m!TD!K|W3k|xXk)(rjOKSl`*Ek+o(+X`^d0vsW`pfFfc9C9567!F4Sc0+Xs-}gZkFuFJN=5Lf9B7BNhu2SamEL3Mjn~b^zd8sFY#hGxQv)nSiFrRWi z`TXMC@xf2~rr68Cs-6&g`SG;2Gi}^=o0t$xDF_p693ZC%{5*#Te9{O?7KCTHEp7LV z+7D(0Ik)c)ie1NVGrFm-Z#4(b`uHC!3WdND{*vrHnrxbFz=}5dU6)_79aL#B90G~%a1r+62oWdjo$b72}5AeX))TQlIO!S&j$2u7DW`PMzZ ztWbqF@T(h(T3Q?raEKLemK;sUKJzF{pz?iAPq0uRY-)I#+mBU=n_(boUZT<6H@{%j zC}C|ouM@?Y7bZAKb86%Rs=o zfGl^&0DdJIc8Q)&>ARsytG1WIk`tX{u0W)*tf3v-ka&#~Vb%2k|Cu4SN`}LLB^FL= zm}|Iq_}{JHDScTxdbumHuxqQubam)xdCzvS1(}gRG*NEeUoo*2=q0VUC0|oU`?@!& zvGhM-^o|AWXm@*WoV27Uvvl+nb^##&n^tjFfmktLv?BQG^aB5()qnT;qW{9ys^4et z&*W_rB}z&8U?eY{x=_dnH!qqtDm(t zeQZ01CH~qeR$IJg@ZVaXuH;Sr5y~BL{(_`_#UTxz2bggfMx?-r`>g~NeddEmo)vEszL=+u`{)A$8UJhsT`7z^foF8| zxI>q1WIgQLWsmi`teIqpHm7Vr7vPn;7{39t^nLAm=H>(`!Q_`-d4uZAayqV^XhhqT zO$Y!fl4q;rl+}JfO~+bNHXOE5wZM5v5ydYy2!b>E59ZTpz9dtrUD~!@eA~0b6|-6i z>+5&qMaVcn0?92hVJ}2R_KYCbTix9T?r~hbQ0TaPDWi$9VP=*=>N~=?DBvY|ch$uu zRdWI6$w8D2a^9%HWg+b&LziuvS&~8E(6g+tuT2!M4vHK-Y$!HDu$StDdkCF?NSH&Z zOV{zNz-lZUzwJ?QboAK4Ka0A*xv*rc!-YmSwtLbDRW){RsOF5^JO7USSNA@WQgJ~B zm|aY(3%^8dh?XUeG&JTTKj0T12fZm~C;AAt>RtG01)Jn!MY$e`RL~0{`@xoUzyde@ zqaxpjoREifPFIM2JzX;o5e1LLMO`gJxUCS$_X5JsdgTv&W+~XTW++WKv6-{I!e48? zB1!tCr~}pZvoI_e(;AtUbBr4ZNRf+kSyD*hzhse!K5ckzQK{Qq-T_vaMgwhpTc_;M z)?5bP6I~q|9@^UwvIqqCoK)B%hrL{dc^@y2qi_%i6=9&uM-F?0Lx2iGpM!oIo}TFM zm^}dW9#YqMEk#oCs6vzPe`d*hof5m%GCF-I{fb3;6P9o6Dpahs+$?Pz|DASwg|8u5rN!IpIYU8J+852 zAh2$HClrWe#{-5KQ1x-5@%r-9ATvd zhi9q^(`Cw1AYNV=01xvl(%lJqhqf+0G>$%Wj;fS~qNyTs0D*~_$X)L}EN#KNCoI`p zyuCr!1UZIGL4fTPD=r4uVU4CGrZIg$60LZkzK2BYrEdI@&03WrrtcP9l3@J_Ka#!U$tD zX(eJju{SL8b;EXC1j;EX0qo&EA9&Owpd|1C9lf11$CQ?G>)Tg&Z;hsVEDRLpg1yEd zBJhHhPNBQ&jXMF_0_(omw*ZjZT1tCPRHQGtm8rT;yYvMx4#a<16$oYn3IHCx@zeY46Fk*&q#0EF(dSymq<|2=17qz!g>+ zpr1{$e^KlqwU+OTVuZC*?6z9ZAZo5)4Ha8ZTCj^+h&6v(&M)6_fQUQI5aTjT*7H+% zW^ZhO@o|zr+Cw>-w*Byi-PJLoy$r7|znnsV^*C!aMAtfkJn$l2vAWjH$C~3=*u#J@ zwfxcB=o&s0Z7wZq?`;Li+;x#ffm^5ADMhsBjO@kp25~L`(k*PFo5_6gAD6zKDyT9W5uke1UOd0U z*vMnvyhQ_+n13=w5AJmrKS>v~Oe*Zkzs)Xf3Z zjW@5}?@E=K|fkckg~ndenEcFw<)}GH?8V^n6CNk?NKz!3wQr)l@5j45r9(%}bx`Nt7tO zrT9#sl{7UaHD;pRpTV^hnUEkA!gJ|DFSMasbaD%k7+GU&2G%Lm+ z1^>)qM#M|UDp^{F=LB2#OZF^lT!2UW8ukPe=!39+V%z5!p{YlYr(be)k+ z0o2@06}Mco9&GnMIIDcnf&gyP;%h3&in@vh3tz1^cOw2KF&|?IvAwP{pG6u#jy#9H z&T`yelHVlpb=u5nb;m=dd1p%7Qva8j{pJrA_$+aI>@^;7;-IrSPYh(Cwm`+Hf1x(aOebE&#{@#h7v*cMwfmqW^ftf?8 ztISP1*a^B3CoN%b0g2K5$v;*AcS;cV%}T?h>am`4Is^3sQG0eog14^UkFO1!#D@d{Pry*qY)cp3`u&Ii!u5H(!i-PA7cx)rT;iqe zLlBYLK3K8I-T04*3jFeYc`-`)T>jq6S)4B_8tH`+MNDCjMqBAk3E+v7y8U^i7GOAQ z>|c_^nmF3g5I;ROELT13YI0H&`azQ_S>z#8xgo6B$c23u4vUn|!?(5p*oG!9_-$p> z&o}^T9vHR7=X==U104yFx_o=px%}WGl3n7Aw>``0yWD6buWOQ@Lfmkr;{FXr7bP1P z^2k+PULNN??iE8J-PD{FXcsH|NfB4D>G1%`Lwx-DI^p3M&XvOv(8x*^wRln(+k;PB zwU@X|<8@HdITDcH4IMLmYWu;;cYP71OldugB#wsYLxY3ymV63e#rq6HZW2q&=plv&gKL@Q`7$J>+|t&=YK@q zKTJfn;B|C*00RM8|Hp%ZKmxBNh=3>tP(V!`G{EO4C;krLBR(!cXXO$ ze~sp(Rj5-sQS5F*v?rG%&(*C8Z|?5^%BFavL#ApJBXJCVqMl)b7XSy znf5cRRwl39+H~s3eQ8knJY@zmYs+wTtJQdyKOrDH^XBG5O$m*3A%WC0rgZCd_eb(H z^CH@n$VG7V{pk0F5oG_0p$X_71C!b%-H%`xTw+BDa~bKwwZAJ5IU#;!HUO3IN2*0M zNn!|%q_fiZOsQ`~inTN_@V0Wo%avtK7K+#nt|wB?QQs4yDSq1S$Iw>h6bM1x0>ACu zMi1qsarW0E0g(&{tT135bFb({>O2x{q3LHz)gzhJZ$~o}6d5)Esgt=Dz#kPZ{I3F? zZQ1@Y7Pp=cyQ{CBwohOY8G!!9(bHIm)bGjkqeO~w`RM)=p+eRVj!QM(Y8X*E$!(SO zp023~4~KV+2h*aHo5hn72W4t`Bx&0uC&wDxzyk!fyf6kb&@ndP^!FZ!I@E-LIO)>v zLWiCf24vmrZTRuLMcO-Ml`wu?<)U66+vB>jpH6?P&g|9)zOks+_W+jGK2QgRn8Jc) zy!F$Hqtj)y7GQL_KRFBZGbe37)Cdisy^EUVz1M;yRQzO@(|!7lS;LxZTqvi;D}4b^=Y4om9P4ss)#nNr?B1_ zHDvs^Zx%1 zI)nbdf=&tvfpwo2{Y_YRKAuSXWjNtoT~dyK=pu3B)+{?}V_LkGA6NPxC<%}2bkO+0e$qVw^HF2;1HlYCQf zFT|PaKK5KJ@+HK_~Hqwhm%$=EKt1#90j&@-gqFEfio+AiTh0*=zK1haF8l z6h^H`IrW?DX}?3NMH15*ekRJ>nzeNDp`_v5GEZ3&a$fS!eyAALZ_z;I>$7F_xEn+pKcDw6M>PByQqn+-<92UV>_amtA3CG z(0@I1ynNgn5yS|F-k9C&-@Jg^K!yHNodxwLe%&c%WTMH2%yhJA}z$_rFk4>l|sdzgWSF)dboFQIm)zK{N zZ%deM-nBha#bW%u5&0<3_oA1<)0ZZ4fVswg`qs#w17y&Ki97xo^+pAVxtTLcSxNWH zvX$oGo4ScPkq1lR-Fl?vUM^}U3jrI@jn#7$4!J5T14f-ClPX7aJmf51JR1X z@!DIdVNuE#7g+j`w?cP^tZDOeuEE(gQw&Oh?bC*=vF2Cws-M*50-?~Y#Qau!XyLDP zS6t$^K>q@<$nn?^yF+YXo(=&h)c?~>u&w^dHJM!OZNDZ0U(E(oMOnF8HS7SGqss!M z(`5nY{7>h>`On$^E~|evB4CQH7CQ1*9k#`H06xCz5F8E!g!Mlk1k&gs{kvslsma-| zaiZ{l1*jx4OBAIxOFsym5LQI}^T+doYri$2xmTo;VJ0});Jkk2rxcXuE6@d6q6wkB zT=oKGkySIESC2itG=EO-LECUK&b%lI@9--Bq`4g03T{BAO%a~RAgV1WHx?K0_XOLj zwMcnxe8s1y^X$g~=zzc=d5>!uUw`Y0bdSZblNkXvKjo|2j>nnk{3IK((VX%{i|gKr zCoe^>yUI27E?@4q`ajJW}k*IGcPYkXw@C(fFhSVw0|J_g1Gsxtf|d zIG~u+5v6T!xn>2q;BWRq??mx)qIqo3gHegY74{{#IHhf6lBPu6A_@n2Zb5~@8Vxcjc9rDOo?gCUrv~=#R>!LPIAic+r`Hgk1 zae3}=di8yys)u~_tK$Th2G4ABYy_q=_iHQ>4WWv=6^@E&Jl#+>J82Yp-_#6wfo|KC z9&dGufajpwSDGk3b4mH_q5PQBD-eslxYSR*>1r*r z2i8;c8#;^P45Vyb`P#}tOjK|97}JYURx+?+yho}-MS#zMm(JsMP4SO%*)^lRtU=tV z0_6#oC0%C9(Ym0X?-)OdvrT8T5X4w5E1m4)7(;-x_Ilm+O~l~wavb&BSlkCL*b5Qn zl0H-H{avKmEyh>;JnM9`0*Y8r6slD3$ZapECrye!Kj-EZ)z=qK7K>ln%RcBD^7d=a z0>JgXeF2ZELAw5?HBBNr-?wyjZN`5_e%iu+(hR32^32<<-EmnHi3ZJ*pxHGjcQ5vm@P_Db!S9nCk0_=aDAP+B;luzb=}-5^>$utc z?OL8H3?V5D_)P@v!LZ?n36B!^H7eJ>Ki~A&HU@Cc{$cT;hr{tFxgxxTR2X}!OW%(L zS{-Pof8#!kGsE)`J7bcihFG0Q=ld?NX0;(!M5Bq3MNqZfU}+RqK|qOCy8Ut>c6d-f z(OHXxehGG&z(BpTt(c||=F-N1_Wdl#Nhfj{wb03>v>RWYW{xtwtW;d%qgciXf|#aY zF$1up%W`}RA`{<*g>yr;(>99w=ditQ7`=m@HO6DBM6~|<<^)epmY!V2f^7LLKJrKy z69=-FbhErI$DqH-F?W>euW+hh_7>RtB$y(iFz@`ZUzMuL7H2IfQ|mwccNyEeEMJofLH{~ElI5Zv`FshxKp%lA|!S>&lY7~kdM znXi114h30B5@X^pD9yKQ^Y?_)K1Fy_B9*8X|Ojm#o}Dnr~-Trr-ro{oJ5+U!xGKu?!7?8}~;Er~nD1~2K9G(s`Y9SH6Y?^-|*7>3$4CA0T3Q7W1;y)(O4+Z@tf9zAarXm!5*eIL(b)H zw2$?E&1}eRo4yM%)K^Y}C*?DYPF@A0%N|jb^XJh}ap5-!oQK~Bxgqk|8ZaPn;PCF4 z*&t5f@!z6=S{9TdR~ze%XF&vHb_WPXRZeF&n2N_gubZY(EB{4jZZ${jDd_DK1^~e) zzONUO7<+w_5olqq+vTdCt;JizfYtxw@5(`-I#JU5i>|RG?A(kK~H`|AfBSmf} z7wv*FK9Swu2E|LzqKg`PlOd`A*$MGfz?;~3p>RP$RF}n>x58_VK-V=PDNn**G&^T> zjV+#}uO^9MOX1lWsX7&HS@YUEHe|Too>3Pb7=P9t=cUHKhgcYmd{Bl!0iffjx^)UE z_Bm$uPTC4SizA7?e6m@;J(YiBx5QD_g=cE{^p2S0o1^r#gFQabc=kb>O%o!R_4GzpMocFok8=*w*yMQ;1%| zg>ZL>vP+;7Dc|w?uoU(-adV;2vh)jN*who56f7VWV#yuR5woZZ+%KjgB^RM{C_kpR z!Tnanq~*%TYbDRe3to$_7t1T9)>nBX1|2EIX}QLinT$LN-hIoV%9@k2on{tVM%`T+ljBtV}~93UtS@xL_xP$(|+f2}suw(F6B{!5l{ z>#2$mei`QZuc!F`kR@M-|HGJnDH+>1Ir%;ogy6@dU(mJI*oF9g0f=ZKIv`A2mh0i> zHzj>(6Kh1~25~}?&++KbUXz!-XgGOf)iniR$!wq}MBWTLOq1k^k(=U!?A%C$V7-~J z!C0liy+lOBZVX!idF;_7*VxhEVQ^ynY>6W;rZ08?8ZiU$nOTmcWv8xocG}zFTv=f% zY!_VmjcA`mcXzZD7$0}!3j10b16E2nad;~@9fN2)OT2_r2G#e|RRZ+i3imcO8|+IB?AoMb0s9}E0P6`*u)V#WpLysWml zQ@>Fps~8iQp?X464kmZwKMuT0@piFpQH?2`M~ep6IVyI+o3nT|&6IkEx|1QZ7ns*3@gQJgP{N1NU889L) z%}5+bLL=rRbCKKEDy2^2@*@uWUsJ2R~C1Yl6;~F?-(9P)Q9$jr`w!~nicRZI|6SlgqD@C&;f~yCx)1v(eHTSF(?mrtZh@v`z~CyYZ}36#*ldX*WJRtLBw@)M zk(w|Ra_^tuE;3A3a}O^xT&rP%HHu>%oW*SE2&ZDGODnY8S?8`QuiPdomlk_8o&If> zAo`;lO>!>~%kPFf32fY0Dc^P^^n1bGZ$zr3q(@1B1g81k0J$P{n|vWqDmdq%_^NB` z)$pnn;sK}w95fmcS+!!$fgm(0rpt0KzS^u9?xGa&6aDs}7RGp55v@7h_y}Kf4j}-Z z^Xg!k_uv;dY(35=)`1tqVJ=+EU;&YYV&ZSBs9{t@ip2)>nodwb3bM2cSzLv!*tZj`C@utE5>YZ| z8*L^cwgQBf8x}j=3W?nk;WrhXyZfO*qk0fP4-{LQSPLsSo{w1zTYQ^ci!q%myn47U za6!IGZXDRc0-VMhBkGs3+kMEScLM^TjH+@*I2KHH)fgV2?X8p77q7+R1PCJnjfpwD z*Bg2YFyHJ^HPMg3zXcl1@(gfVw0Nn;+@K2-`ho>>uoNYhNG9x=N(Cz3W`R#ke?QaX z*gR8o+YSFw=i12w^P*9)-8U^^`)M2}AV#{s0WN6|HN&jW%p}iT6;6a5M)-71sB@d6 zEWG~SN+%wS)e6vn1pJHY|K4N!M;}_=J=uwTVaAUD1cdv4W9GjF;(40wKfLi1-(4a&pi|d{&fh3Zde$5Q#;@{hK`SkZ@m_uS@9|{rNh6R%try<}@J_NlVq2U}kQn ze-Lk`_Odm_3or4T7C{cyE^2G+3plY3GZxkIQCH}aL57x8bDT8tp z$lBh(i5g9LI2B$sn1S{U<~d(xX}gX`OX`F91*A*T&AD@V zpFGF`3QHw9hA%A1Om4i|vdaMF$GwVa3Kt|i;>02Yq?*+((ZNF-t1J>CC-nW z?Ey9LlYI?*H8SMnNo?bK78#d(e_sOPBlC@_b8PbFaO!rVL8|+|JY{ z=YwtiZ_wa^?ZLDoO6h=-d@`{m$K43T_acIxs8x{502d;2yoIHoya4wihM9gVW=b(X z#f2(?3S7F#RjmUj?mj2O7RQF)2aYTEeSveKgj?JyG#uhK2j6J?rpFN(0|J98dXDcG zBX4VeZyLIJzMQ|E-C)c)bU0m~!f)_LMhWzG~}IGoL{Vsk0(VZtNspW~eF# zHVvDaOftKfBxbx;fdf=CU7*+bv+N6R*Sp?!?=Cxi`Jq9nSz22@ZqIJu5e~Fj>I-3Q zso-Rb@sU_!7yotbRkHi7}UWT3k06Q ze;qm|a%b{g+>=OYH}Z5V1Dt|zo^$(iU1VG(ng9&aE_s}+q9eyEMru5s zu_iwq(~*h%dABjiv+{mE9m{!N9Iu)3HX1pLE+B-n79~FDWMS8qA5N+jT?V4QH=YV! zd14yqKc6G{xLP){4i7xcuUrl~2#6N})-3b%gsI7!S?qIPVq9kCXl*ZH*Ih-dr=^@* zuiY&0hvY3}695)bXDgINk;$BuSR2uzpK-ExyHf6OE@CNP($mo$c|XQpYNcsjI(B?a zK)1JMp+J&rU1>=DTMo5{D8J%y_1|HYm3kM3A9!5K zRo!HaQ2<&;x&)JA21^pF7cdm=f!Fm*rgqPbrvR$wZmOo*C5yT+>-YhJT(?giW8wrR z%3FTp*1jeCf0GB6fjFaLI)Y#KHng=j(DU`TUJM)|XXhy)k@x@frZw!EML_P$KqwFp zfY84JEfDg5-!j1H0(_Og0LB=6ty9|CuX28YN4s+;7h?%N8H|v{h9wTU7tf|U-Nk|* zL(~Q)N^DikbOyDIB75tzV>gmO+U;z~HS152;1a8+J4Wo}aZH_4Vd+mah)Hu649HSe zNJ;_ai4V#MSS00mR3F%=o@x~Ivy8nbGl4XM-o{4RXz?ajLxYzDm6OY-xRQRQXZGqgBn>;OxFvqWfMBMqSp$u z##f)YW>QFUb)J(AIm>d32e_RjYx#bY0Cr(fLMconrcoW-c=@@sAE+JH+Gg^@=c%+@ z8mbD)JJlA0r)1y36gDGt=}EeVBJjy&v;lULOZ%@5G9_nZ6#*ZjNxz4jV5w z+x$OS^ygPJm*LJ2{D~^h@z*)0y1wPr`uP;HBLeXGR?n2w3W6F49F}-Apb2@xt9FD| zmTvLEEL>et^%ZVBScUaUGGzZs>*<>iZuP^)~?&NYS@5KAkJ_3ThwEb3DG zCC78XEf(&~m*rl8WY_mM>&8Y+raDeb-Kjaz!UJe(_{W;!Q8~h2DiS0Q#*6n4mgzz< z!LisX;6wbp)@%RP-p92gtePdNhxp}P=OQKXhJ zGM)+s>$74?Jpi|;G%xL(&8$B5E`@Sso1tNDq%Qu=Xd(0>)8|&RnJmWX#yo}7ro5IBNPN!E7em_>VTG;xTOeI zXD@6T7+{OlRZ*M zy4?E{Xj%IDXkw|$+26;~q4ZO!tkLOQ;Z|c;il55F7L;Z;$ch(x?8%e_u2F+%?mY`r zcjRvL5h=|5U4P;6DwSIY3+$eZP%SyGh2*HUT#NrA;Q@Y^t9ync52WN8pbcpJ-d{?H z$nT0AG6%%!Ikcx67CZ+H)?~;FzF0SAWR;F<1TwbYCH@9iah;2Gr9=A3PpI12&Mzp~ zencv0M$3r`@pOZlz)-L1wOeU|mT(M_rB$uRbvy=x=V9d*)efx$dRcF9fF!@ez0lkD zviF;@HjPw&mo(Kot%#I!XP+LY+UOL1Q^^dBo&q4=ErIYjtvg#><&iXJ2dHkuK|UPHSTZ*(=f2$b;oVFd4ruSV-_aRmRO!o8yX;(62lm-&6x zg73%uX=}EoxYue0B6FzxI{Ok1|F~#p1=w)r@YbF-w0~l`54*CLEg&2sua?k6LGOE1Q}qO{k)PA`KVOue%=4etYR0@3g2-to!XauVL^ z9~D31+$Pfh`tn9pBcw)94*jLMMW|$PCbjpTZub(binWU$hyth)}XELUk>i zOIS4{{d~>-kwCcYI9qsr-{TM)iGDmyF7x93{$07ozKIhrajcl-Cr>IWbb(zH#wQzj zB82VIHvn=#FN?bIAAIvCqbiYDz}Bmmp+q^0kZ({M6jezaTW{TPWFH1ksO(=1Yu}~S zA^>{wTJDdbXIs+h1q$46MRdahI>!9azJqK>_h;?P0m~Z~6Zu+E)O1`XTX>JZ1dZMa zMHmik*0iD{oOkT1L>3Gbvql3ecwTuTpWYj$Do`@K=l!HuS|V4 z(~=1Fp19hH7=>+8wg_Jwl5sO+xi|cX$NB7SPU+OuxljFx3)-;tcfOx1z=`>P4<#-u zduIq?DUjZ3taP~u-J?>$1h9Q;PVL*TW0H0#(=0yc*xkF5y>-7S()hW>_2N@AXKro`cX0q+`awM&u(}7drxODHQR01+oL>V z1{+_K7%jN*9hp^q=WLtpBJ#h(1;&>l3Q{C;WV((p2C%rEcPw9bLhMVEEgQOEy5e-; z^s19z#TEcQK0Lq>kPO{6KE1sk@O8!){mlIl7hyB5G=^}9NAD8t@^=x0BpH>FCXSX# zP=&$K$N2&pQgfHP#<+qc5sf)HzQ;a$7!_kmEg1AgjT5ry4vpL9RVQvbg?FP4CnPYa z^w+;lkeD2SQ-h1r01l8Yb}0@A_VKO49JQ>nF(lR;ZGI{qxe88ENy`)86US)6QqM-7G z5Z+$n*|m3ovjfA5;Z9>G7@<0C*re^jlLeY#3}~bFU-Fc^2OF#@o+t{D z^RJC<_xI+GD)v*iLt_|PqB%KQeIXRj`aN<)iZC)u`9a60b2>%H^lR4XTRCH1Tb!MK z!ayAzukkN2FPsd7Vqbbu%Q6KKTE0GHPHa=O@&(0usGOn~iiGAiwtIY{p|q()Q|YZI znh8?IBNha1CV;BQvIS@G->Gz2pzQK**Xl}XMIyVhcWD((4u?a9`x@c9Qr+M)@g7+= zIDc&gb!WWwvW|{F#uupVYE(?fQ$~DkiR$I)tirt^H2{c^R9^oM)1~&DGgo||afvW>lL0uQSUN|mDU>{8xDw>JK>Qb) zR$J^AaUD;eN4CNV&*YmuOIg*8qb0Xy+IUP~17UhSe=NHxJ)D-z&KA@PadCVsK=Iqu zk@%{(!@pR6s4>f~LYbA#Dx+U~;MH7Je@jy0wE(~g&Na-G0J834N6l+mKc26hH<=0n zLMazoi9gkJEAxt89CsyZY7PatuLe-}oadpk)&RWCKKRY5hgwy|d@WC{XS0{W$w@d? zQ^yEg0c1+FB?ueVjtRemS{ZRhW=5wolq5{Qg?awmI`h0K(BPu+HR^m@8?FLw;t$!2 z$7S%K9O^4M_|LpG_R1JmGqo!^HwepY1umkIxk#TSK8+`8K=xLV4y)$(Er%sV&9_Gd z762w%kSf|MDo{oTB@>i*SP(_yjnT6my+HgQj>d|rCe@9N*8{+Z{k`iVI;1pI1<3~& za#cJ^uDH}Z&bhMvN3=UWe#NgH-f#XWDV15{hw6;mSbazS5BjUVoQoum4Rym;-W~as zobZD{{>Qm|P5OZ!5~x5sD-@uO1sdS%Ox90bnO+tQAL27X9T$ZjqBY}gu27^#SS?f~ zT1~It-F4w|<@BVV>xJVDzE7YVp$P|TUK8WPl&iG`yaNSRop`Yj;hRJ7BL0_@j3__H zFr@c$Gfik1WBiDNgi*M2m#217m$*%)WUoY;Gm8aaAooOS{U}ca!JgeEM7!*`$CIP2v#s`GE%tX zs2kNagw<%2Qv@&=Z?m(#b0aBWR2@~vA=Ij^t-7I4PAis^kf>m{g&}tfuQpq>pFGy? z_{AA)iO%MQH<(24WH2)U=79Lu!0@797s)KlJ3g6D<()q{-AJ_1BD_F5XVH1EiW2Hy z8ee1nz)xY+$v}JC8_c@90Y2Nt(A|@!?a+|;9-Lr-{HKT{z$fCCpki7q@Q%&*GxUdO zLao&ac97Xr(&6*m+aSFncXLL zxJ-7v8T~I{cfWi)b^aW7DMup0mHYa8en`|`deQgC1`0|Y5rth3x#-72;L_Q266^ox zD_{M`tnNT`gM969IDK_|ZjgVkc-UFte{Ej;v)GaKbJgl=ThM2-3I|OzJpkSlb1x4? zRBjytPn1TAh2GMHS<}+=oTi@f?lNn>Kl#r9>@u`v8jtgV+mf@043=zuBT5>AMX=BT zBzirtP!=qC53SQ*B#aHcmU-c=>|>;IYgAvH9*E9Ol*AxRr42(VC8J5Cm`!Q{AQyem zfg@GMZDS!cX_~-nrI})q4-*@(SdR3oQVu*+HB}7}0m%Uu>Mt7}5Sxpe-6X%P}rwohZZo?QG>x9fWV4K-}(0QG-;h6Rp-k zpLHI!1Jgn^Q(k0XIUxAjD5QD>EOBi&s0eFAGF7!uHj&R_0IP2>GEU(=m3mZeID6bt zxWkwAdc8RKN?G~4a#tFz2M=~U9t|H2cKz#s*{yuGz2&fx?ZCN(P#CBHxzpn#gS^1(C{)ER;&7&u%(Ou-vEZ6N!J@#U*$j2DDrE6jeh@Kr&*u8C2z0)F%h>qz+c~fk$XR>KeDlwD z*p$<(afn!U5qN(0fl7e>#pjtSXHT6={(uPnX4u!ukD=Is-%>&Tcoa*$PMFXpt|Wl$ zCAjens`R@$ZGVklGyhD0(u~xK;!MC?HbykW32yeX`{)lY}$$cf*Byt`4L)$E`vUwb740;Ga=#_TU%(xlQ zPKY}WDTprD4Msthl1nk1QUKJpd-*Ms7@$1xh-ak&6U)-r60m62>;W9J(!`>#i?J#6 z-7QGv_NLN?NVeWL@lTE`((>~|*0035KllYUVJ{P;d{8RsBwqp_8Fc==OjW{z2Uv8c ztsw)z)=&roJ6N&J8l=M?eOM7i8V7*exH_n%})v2~fPv?yGoQzx9uz0NpRQp!oYi zu$8B8y^O<3w$?!YPZ{SP4b>I~aQ2FdVa8+7+>EL2NJEh!kA#s&d5;jfx?H7HuDpiv zm>GHZ^4JtbrBb>QZiwY3Z!XhlTGB)1mb7GrbXh80-E$6$nKd(ioc(>@Z-2AT?7jBd z=j`v>jXTKk{`rqzwb(gY7423tDg9*I2%2={U$NC2j^DqNPcP_gXn*U{H{jr9E4+1E zzBsWaPdbwPFx_@r-M&>$Gobk}lp2y$M6qVu>g8cRw>3#P$@;TPowPU_FV{e6|X-vvqchyVR_@_@> zb*;fp&FvXgYT~w#g#7t?$2=Y$x;Z<&lH7IDuT3f3!ews1!f|TPHQ(A(^-gau z@jDMYjT;jGetN8i+Y#1~>zy}WmF6eSd|Whew8o5i3iLSothtb{*2{b?TR9l2qNw?8 zqM?xdC_uAAf9*{9q1g|Yrka&Yt8+qoK6nfo1PAOdzcSjYxTf<8_sOW2cT(i71KE8f z%PyG#OSe^JKRC)f_VAy=l0q$HlPr1fl%I#{_QOFlC+o(U@5r^T@$E6^LS#nrx^~JQ zBr4ky&h*Dxyl|Lpnb7=qNZ)AM@w@-$2qN`h?#S5#FNx3j?Bv!cL2hczF~u7m4~>o5 z^m_&VE)Pcp$vxR79oz&)-Q1H;&831N?VnUnuPrKb&Q!0Wt5ZI7H1{2TCDA`O+-;+^zahA^zT&=7)LBDTt)NPYM z7&A7@xqut+P*!7BzEeEI@nr0N#+p-cP*S)!c}~OmN1#o67AtH=LVpv}`Q?Rd+o5@r ztA(ZLZj3Zgm0H-3kvRSYIc;G1b6*2iyK5oGq3BU04j@>jkW#(oB1nPNiA0J-#>d2uVCkAb41=$*tFFCrSSIff=Z1xu35 zA(y@q>c#2#i@R@?HYNwfw`x5c6wJngs|_OWoVGm#8FE~vFQW+2EN3OP=&fJ=b291=jztr2oK zAeaf6+;9-&fm|G*JdX|{_8^`Z(ArHFrt@e(#dA@_V@~l&WYB@C93U%+20FZuqB~}p zM=ZVGFy{nnA;9PpB;dXm5#zv{y_gHvWGgW21Eo_I{=gfa%3^)N_eD%>(Cvp@tl=eZ zSKt zoDXObzTjCb*j<#BdLFU_qr=}ejSNgfF;!-oHes6>JAfHvu#jHZ!Xi;5<99`Q?(di% zBq|SnN7^9~wnOmWMCeHsk+mtSY7dm9MQ^mV;8|S*wldjkXW3FC@Wo-wWsx}W9VjAdjPR-p(2HC$t P^1_jCB@(Cu3Q_5QO+&p+ diff --git a/src/vfs/_vfscommon.vfs/modules/test/tomlish-1.1.1.tm.x b/src/vfs/_vfscommon.vfs/modules/test/tomlish-1.1.1.tm.x new file mode 100644 index 0000000000000000000000000000000000000000..8405fae74a50ec468daaff5adfc86c3c68353219 GIT binary patch literal 46279 zcmce;1wd3=+cu0yO9|37(%m54-7TFnbU6$yAT8Y>sic5_lqd*DmncXJA}tb1Dj~wR z2P}@B^StkQ-v6I-wlFh$-RsWlzSi1%g8};GMdM@V3bM9ygn&HlV74F~D@Tx{iv<`0 z1-U{Yt`KK11k8@{%lRN08;COmY5{|QLGEsL&Nd(?7qF`fSV+jp!U19iNHaV8;M^cP zYml#zl?BYo7UX+6nX?Pj$->dj2Ldv(bGCK?xmiK&Twx}DaB1)pfZu%2Nr0;WfkIuN zAnG&uAh_agFn7zdkJ&-G&K8z{888@Cc~&hh7XlXC(bEdWp2ID?GbTpjITr)T{T#%A)(?WY0&@os=?&y7CKhQE3Z z(3pefEVOKJFMgNzM^C!BxI?YZtoyrh9KQ--hdG_ozz+m*bc6gM#b|!Z9k@r_TrGgv z++0AO5RjFHGhm;)GYn+m>I!vnh1vnN;OKo$JUm%}@2t*p%nf1%1NlmVr2drC@KaCy z;phl)wgD=TR?-9{DhlERPKH8Y?oeltuiyD#!-v3M=Z8uC>tSLbqhBWfJ0;;W!t(~G z7eL3~%!Pjqf5A_Y1kp2P9Ena|TAYb^&jI>@% zf9tqkPM7*a4xAbC&A+GU^sTtzLjRbK-$%fIIs$0{z~-5sy#8n-{IowC^5;*#<-s3) z_WKC9`Hof=ZV)q=6THaG+#ohi5N80KjNnKIAU4d!(Z%ye+5aqIpp;BZe$)7;JfJE8 zG=+ny8{CB7<-x2Rg@j;ELPCxJ82&-jcgH(gnK{A5fN0MY{Z;Vqun(UKuEgn(U#vMr zkZ;<5m-xH-@X_Zg1!y<`@Shgtx9R`tC))EfnVeSE&l>s5xBsbN;4t`$){amMXB(jH z{i;1+Kiv1f)Zt&|009|g0urWi2S5uBIuIz#(HnpwH=ql{<^L8mxYh8NB~Ta+fBg3M z#QFV`bAF>eXUN~y0X$OH?v9QCWI9;D4YhZ%0~&>ui!;#wLFa{>HVz=A;F3*1LPBs8 z;bTFkZOFwMXxwK)EZhLH0oV#i`u-6Va>LyY3i+dLr`ZC>Xft5SZ%u{c%;Trp_%i#Q zSHuL~dVupGU^XBY0G&D4f_|IhZ`%jl<$rYmybpb|@i#%=&p(~~S7rZq>R|jP_%w2- z*k$G74d7~UV@*H+L!zesyZoiGfZDjjfdk|Mh4VoxTX^CE`Q`$$ z1lk}#mw+ONe|<_EJ>X&i=|V!Pr_B)pv-(XbxV1D83n-Af-)MoG5S+%rhn|f()yow~ z7#RF>cozIw2tYi6hRn^$&BMkiCQsmuz#!dR08aH?cMyGw*Y7 z00DsOcE(_V?f`raREPx-Pnf3*)Zvuxo~Mg&*TY{wD&x!~kP#T5z90t(ps>;J3G(-7 zO3lG>7C1P~Ix944kh2}Upnv%5?-C2H2f(x3T zF0<7T{CD z2&<}urAnndT-`dU#NWfD~;D!9p6a7vvzN_%}-<-wt*9`wXjDK7;{&n^D zA0vFu1!o-Kbaw$B-7_BpX#X!K{}y;4a%ZkOl?SvwqhH>d{Im1UfsMQKnMQxm=N~KN z+y2SVjS_31L7k?__r*4_PKI+VphQl0VNM&?8GQlK{zB^hUe`Z|((lhGKm%aWnXAvy zEs&eLB|wLPRkI6F`WB9!@OBDsg>bR~Xa}=}0QhcY3vaf-njF}FfUn8VIEe?u*$y}j z08}`%0)Po`jquf&yYtylAd2u-{6{~1+g13NQT|QjKe9v`YYRt5OMu?O3knYYK*4?I zP`^on7YdD<6g%iTKrc>Nixt4@f$j-+#VHGLf`H-s5Fo&BZXh-g9AMzzo#hF@WB^VL zX9jM64#e+e2G0OM)=xP3#{z3Qe0pPYX z>%QkF@bh~b|9yVKJ^5{c?gY#Nlq9vH^-tjd=K=_Z2Y}P3dx>n{oOrs42v4#zPXeiS zxOU)Zh9I;9OdaPR(O*27PLzfRXkV35)GjQ`I6ziV--&iVZN+X>vH5D*a15VUJ}46=~)_0o|L5ab9E5JVAB5x%z*n2Qsz1!c>|#SZ+( z;pPskG~77g6$I>nxmy9ds*v;V*x}2)laq@G2p14P=sUSg@#7vlevJ&yP`|(pI(UDT zs)27JXbEB~dPUlixE5AduTj9P8LKUM;^&zM)`lidN?^dG$vfhEo-QS+z%v5)o%0u$%ioJ$hM~9l0_DpA6Qa1^FlM9$lul}9}hqD}cq^2(k= z{$Sl3RS$PM3t}F48c$;|yz^&>%`p}r(%K^CQ6=N65%wUgn>(_(bu4P})_OGf22Lk0 z5?bMK4m^$2)?#CDV z$2}%by?wuqkG`)aX_zMY;Lf>F9AxI=BB$Yh+!0@Li0}7w-LpAnvb-;5bFAJZXRV=$ zJ~nThYIFL5ne#oc4RIBPFT0DXv)qw%m@l3{GP8{>749SXRPDB}IuABl)5Qr@n-dnv z6oG%%;umq$V_NUkXdH;6c8ADD9pkjMKKluMh>^?&MGX%QF9Lw&f(gLie+zwVE>Jrg zJ7){W?-+P}+F^8~)eXZRmIpoBBk1VLR-rEHPNl%u*lgs0WIw0LXdZjsSj@IuKX zH9Ul0`5P6~4~;P)ExdXk^7)#|rMhJBSDNk#YAUIR80p@&#nfOtUs-NxtgLcr4%=Tlpqh}RSYGHc?^9e4(5tQd9t>CAC9nPYo zWzQP>)+po1I|*vOj(m=oS+4Gg8R(XH&k-K!WfT!vg9sLQYh~p8y3-+DtJHO&UC#s` znc9p+yU8J*RqO{G{*;^< zH@;rFIE(!L*>gzLB%9@MlSGF}hmzKv*r~vxrCid2iV0ZZ;EP0uH)y)V^~kXiJ&a2q zpr+79s+(8kmqGOy5%-74$3?cyJg&*M zRR?2(AC3@zR@+6O+7t!cjc)-&{HPzrhND4`ZT2@3={k4(T-+>c?u}&@OjHA^f3hE zT&$Z(pr2$7Q9qgrybrBXeT;hF2-!WqAhamhAwRqVTC}opl<}T9IgNriy|-e7U38qw{s*-E{ZXHJ6me{zGq~u zN$Pud+2Sd}t|}tKBl~t9J9l$ypFh&oqI!J2I`yr z@|c@}6q%|*q3HI4ZD(ERfl;G%i_5){{fyt_H<~onf_2<1bXA!_O)iPbBr9HeV$hm7vaG;QsyHEimowKYX*?HH0 z6t*0WT8&=8|E8K{rfMPl$VqvQ(~g6j@{7MZestg*PCp;kev8c8P~E}bxnE96IHdrZu=J$LEO4smN* z=$6?^m}B#}K0R9>JnR>^q9GB6PT`}_{(j)ea2;Wc<%8P1`*R@`<}bp=PD0s3@9*ey zq2TqqeoT8rch$1*mNv7-ZnU8zT6pY7$n7B2jCqynt{eK-zO-r}GT#|EY8`#8{*biG zr^nxO^QPvGTpC%*&Q7RJ|0 z51xw9`Exb53sevi)l|xu7&9{otuGLXb6_JF;BJ5YLO`U>qTn#6@FneeN9zm&q1g$V z>57>1Li;w-PXguI%JrJc%A6Ze1G>PW+r~lfNYV;R6~aj#7S*qWxXb4aTs&=8vK1(P z^;S_>o%cI}_$!uIlU{zBO~f_hco!u&c@r!gyWjjN=AF56U=FK^;+0*o1AP4WW!M~! zDbdbruj$(Cp;V+sXih-O7ltCTI)dV_Z?=ZESFsbpKBlF0xBpHS+;bcXtYXXFB?TRg(xkO0H2AlB;v&V{=~o4M@X0A9c{N*1Zmj3q z_eYR5?ukEtzTz5~&Cpq2aKFD9#%L1PI$(KOH*T?~dY$HG-Y$(#>k_tRQGO<(bL>-? zs9a5$p&hXjD#4zpk1#I_gy0!|pMdUe#9BGG!d`i)DS~3iAqCI7S*4&c0hT=t;bT<^ zFQvOJVP=n*>jf!k1?4{0*04r6Nq|K1DV{yjIyU1_L{G0rF~E=+T3;;idE+mYVpe>) ztI}l{jq}PY{Vcl?wzrtrQR5@oir5i8D%g}Kj)FUv8Jb{U?FlTq8ii-qcu*a#nTsU5 zyViYfYQ)SY7hi;Gb4T_1x=RY}ZLCBSV^V0Kp_cY7w@HR2sY{%6-+JrqjsKOPEdamG z9qM>8J5O39<3Pr&&!lsp!0N!1b$hFC+Ekj5J#qBz>(Uo`qiLf92di$)hoVgLJ?+MV zZ)vG!zM?aAr6pT)NLv=w9c6*XUOC;$Ji_tZRgRF-!gA#MN{C|`ApDVo{A9=vD=RM9 zrD}N<#Y}4-`%a6{m3Rx&FW5tyK|RKMPMD;fZ|w}^-7cB5_K_HVC7QnyI8_D3R;%>Br9r6fNjls+@Vhjc_CwPO6bcxW~dew)Em*+lv83DZI&vUDYx zvs7rYHa?msE$7;1c#^mG%zix9e}8QJ{-I`141MI?fZ*gToR+U`oQOYxa?>7rbVUi6t^OB3(>;1Cc!H3JFHYO*0MUi*6!n{(`z9QWA zD9xM#uOiYx+s7U>^7X^S#az^5q^A~+sij0I#zwdpCCjVpP^rb+e&p0ml9>IB>Gx#> zxDQYHoivv|^_^J-11E^cb?p$x3S@-fo2;bxFJe z8on_7cs|HTY}%h_=U1fLFl9CCE7pxo#X5P^g8snTxfV9SpuZ z?8Xk?Wn$?W=x1TltJJ-%SFBfzFcc<)ks{HjAfJn&K*BPzx(Q_hA;=^M$|NAmB+z-t z%Hhh=P2niU?tJ$ZpF3(o&?g!Le70d=34Tsib@aI2&iov*AKtc4tPgQ+E_#NsPIl79ik$-qQ|lsX8tvH+ICOF zq%VF7UkUdQN-X_DyNz_{BhnBDFL1x9w|(}PKxAEubEXIUwgDWf|7mgkgXI6D`+o|= zk5>6@jSa-a;WQ=^$L&$vUR*^7_6;yJ7LY1-31cgeq~lAR!wz=#jn&eOas}>x$KV7WJ4ck)5{w&QeX3i<*`?prRt~Xk1O7d zu;A0`A&y{^+MT47x=LKw!!w_7x!6W9()h|2)Y?F9|4`gmllh*a_5*0-y6;hWvyVg! ziHFPGsqyJ3oyt!+>=)P!;?c3O@=y3R$(-ujo(2=TFKH1(qr*VHRrf3*!3aSc@+sEi7?@a4b-2U1qoP&C4Ui)&IBrW z3pnKdeI>)MySV}PFx$dw#0w@HTZP@mi7B&pGj#OjCTjG}3l2or+#_Taf<6T8`;rrs zOl7LHZmH@d4r( zyYm`eR6NoY^46XJv)1FCm5&E)Av@Ce_93^u6|**4FbF!m-r^}8N~I*Cmyx66G3EJ< zdwP*{-9WhII!eOA=8B;18U;~yzU<1M$PCVrKt|%TE5I>wOk0zYf1G4i3@_o`V z^7YyZUb1JskLg@^$yyK8U)p}~aq8?jSvxk1PeIse{_@6C{Jbxg4w~or0UyBA;J?61 zOW;Bn{Pw4xSovVEyjE99MM-adzI0HxQddKX?Lt*+e?e9UChk+jj^3UZ$kj2?f&E90 z@x=*T3QxEn5%*m91wY_rlo+U{m8#)+KYLjFqejV0U6K|*hxgt{P!)#(i;XbJH1cP z%*g`kUSVvV;e?e#%Vzm2bDH?Sq0Sg{x$UF5~3d+^jp zPL)_zI5DF|_KDTViDu91kOZ<1iR?A?gM^m)V&~JaZi?-p=BWt?2&VsEnej{L&+K^t zw+ChLDZ22@RzdQjiEaEUS`D23cdZG=k~5#0_G-fHg2oJl)K*b@aA^rf^U&Gapd_~o zF?2#u%f7~`^yw0p46|>Qx;KRKQ#Bg>ViGbC8IsS&<0pVgoWNXi|2`#vAVA=E4E@SO zViKyHg8?4mnKMrt#(sfhCtCtL#Rd2Kt>$TF~7?_BC>{Wi?et=HEP+0>A{-g)l~K3S)BeDyWI ziLev1)`$qyWkPA(mR>k8_d#x|{qRh&F znL2Pk7f4KAMFI$h2;gV+f1f&k@$+AD<%h><-_8|anjmr)pkKw4zF+E_=J9lbUY}bm zBrfprLoTHhJv)Nu!+y^`9%U0$v)>EMt5{W8uc`JS8nwHg6SA*@Phfix6`5jvmA-@Y z^>o~#yU6(ByI}hFH&9lwE_#x(D%MIkt?^wHLe_g|-tubgvTaE0O^J5%7#aRW2|K%F zY$h;gMPXGO;PhFk0z{V^)q&pTLA`4eoOLUj9$hO8CswXG^bb0BrrF9IabC;>Nq#5~ z6`V+@;ZY#xn@ukom7Qyh(a8HE@5fZV^2x&hk<8QE^|H-8d-yn+JI?cqlu2>LRpp%hZYN_lm;5l-ZuWYJAuz{^8inAJ-sCtzjI z-O!qBw8nG>f!Mhaq9Iq9b!-}x*DjIXf45BZmO!J3cG7F7DcW%1Z zdgbq2gR)k;a8fwPnvB*@zJs`HjQVSTOz9hqwPNMH*NsgyZ&*;3X=~o`l%+6&?}qmZYpb)!-C4Lg;4@}ZMCdRQotG3$Ixt_al} z@|SK?=yNwv61NR*eGEPMn$1Y2Xp|f6BuZd(&r)F&EY8dNn3wul3bxclx39u;QC}ki zgSU#80$h%ocNl||4g)P8@)c1wC0X*AhcFTG5k%jy45VyI8SBmCxwFRvF898jvcou< z*On}vEM*mNr{gL8E+PKhM3BJ92mZERVLQfamTTAEq-yC4-kTv?1DWkn@abu}Nc7%v zCeAx(-R|Ij&cKdFToc$li(zzxtrVPNSiO|7uJ_I!xu=gCH~+N~kE4kei;Gd zBJRoV02PT(7HO=?hCY_LW~^Q%8X{#@<`+TnFZaRXI7*X`7vsDgTI38#LUX~_P$$cR zE?5@|J2~Htxb0%E9(0jvYHw_#{FP^E{5_>Y(Y4a@9*UqMkNLNmj2n;T3?HnzvkY?$ zDA*=Z>Pj>$?-=qGrWuf7xn5!p!Qa#rP-hH~5e~KbI#_%}NUa=!MHh&!>~uL&z1%9V zSBQhlfHQZytMUqCZ0{b`Op=7avy)v)+TmN?-PLuEF!@&~@O2uplXIfumNH3=^eOjV za(e3YFh@#vYp?VOE@53bjP?Vxom-&sd)T-meD|>L9Q*hQirl|RgCNpz6B~m&Vg{}F z@EPVzra$uLltJITrxX9-AZS{Hu0{Zy-2YX2s*EJYbfEfBKKqhdO8V0VmHB)R7gt|r zN^FGIT61nsxi1Cvo=~)T?1Mns_vr1K9_#|oqF*^g+uGCCYe{!?`gsgT{B`;*iLofd{|9&FL9R>9z z9?VzxY&QmneMt3Ym)-n6bP(x^jrtJ#h3G4D#tpe-NeYM>F`=WojW<0kRHl}AOi(Pu zS$eWf{be-B!l3-p!P6I6Wp#A+F&{ji69@aJnkZh3I!=i|Z0fk4KAqpJyF$ArpJR*c z?S9)a(u_};Y1t!aee6dvwc%hpZnF7U(0(*N5X_rg>?CiSnfFWjKuH_yPj<2k4l)43|)Q> z$T@CSi}9+jpe2tGXN+*VqF&jK9Jp31+^^{bbAL1@;h>L#ahYW8_pCmO@Omu}FMGwa zFU(`s;N@}kNSo(6hizw^FT7o>VoDzpHEUB)h3X zPc(K->-jwdY}3pzU&e6pS9I)hN7eJs1{OP6k`eAR&zyJ+w8ojSn`vbf@i^+<8|_h=t}dX*v+@D$|58hN;}x2WRX<_8LM6#f+GiZPJ^A@7OJb` zNRk-~L3glih3+MJ-^mfnjzxCR-+n04MZFrDNp!q6h01s%e`RCE@nbF|pXCLe-j&e# z+E&Hs;8wP&s)jtp&q_z5?RCnFTYB4@ltUDfL2ngF3;0KP7%%O68}s=vMSNDTyUVwN%#G9V8q>6s9$OCjtyeW3Z5i5rQu4r1#o=G*rxKX-4?$yC*eJ(b-f~8-P+pKi z?OdysBz;H5z|5KPSYn*)O+pmCr-y&z*UkW<_l+v#ucuHR+N>P(ItnQdxPML&ArRPm-}Cd2)s)?!NB+Gvh}P0rCw%uJCS0S+-@y1 z?cAInUEhwA)ay~x4T*X{wTBY!BshO`d-`^H+HQL5 zRwo@k0{Y{=)e3@{`_JV#WMcvXq=+Vc17@Q0Pkvd2p00J+9CxCCwN5*5{1+U>8n_=A z_H)Pel%r5YD`U5VfL*1mHm%glg#33yke}yVEF{omk=1y_>T_i2vGKyIvE@LJ^6Tj8 zjgp;JBy>F~n*Lz6L>dn3aJ%5JWW#$$Z_86B3tjU!ArQhX>0+c-(8XrE)Yhg?_d}-8 zE}~$|8r`RTjh`P{n6`05sNLVsjygFgc-N|6&bJP{EJ&h&VnmcZFBRS%|BKhZ2h7b01HN*6`d7E<3_ope5@$qwJxY)NN$Lxs3^L- zubbt3_;#TreCZC=r$;V3r45jBBy<$1;TFWG#hz=1x%{>Y?xkzFH)p=+)lCX9WOH0} zOCr)l|A4(5>5}nq)bHUyYFr{JCV6Dt$939Fy!_DS)PYZYMR(FouzB;`#JUycnT)DW zkOA9Q8khnlkAGQoIbpFH%;PWn3j;>$0f)rDH{R9)3O?OC)Sd-)U$kx^7H&s(;Q7)a z8zC3=9BG9nABlXz3r&pfZ*&ZuKYF7RIy65*9SW_qRT9%cEFjJ$Lr3^aCWdLQ2Q&dI z!9ZX)M&aKtOW=x`{kAr7*HLxJ;>2y*VJUi7NmQ*nY06AzxD+p4s3QpTE!Mh1vdKOc z6yu2B_iTeK^J}CbdyALY+eYt&thzqb$rZI%FNG$>0s{J=KK#=vxuZE{npd*)a)Rha z3&~}9n}eD--;;-c|f6}kH&I$gWlUqN?uT@w2}8=lKEkR2#2Lt_nB90{Kr4& zQ{BN64(st^s5foZ#DwDGD_Y%nXF793K^#og%EL#1ry^8~N#ngpjlv^-a@(&3e4kMI zgiWsnTdg(%Em2*vy2dqz$xR@F7c-)A^79+dNQ{I5^KyNkx7?I*649Oy+qA^7*6nQ_ zG*{xIwqextu1_yVi4<4ayls@dubHl0%g>K(Nu$;p?>_i2n}3xxFq)lGGjhJK#oo)= zuFLeMRr5pa=a>!t$?m?!q1hjVgt>fC`8KjCP){zK?b1Khl$0m+oih^lzQa`w!=WAFORtLw<#8@5NV=wZI4n9FdF({3Bi#3dlxxgugxRm^6+l1VQ%SwsePI5s z_+q4#g)^s$!POBQybRi$Oilcq8rDn^KB*_X6-KRt_cVtkHcnO|nW@T?A)F}s|$c14d zYk`Y}uaw|w;IUm!RR}D|Tiy5)o18D;RHJ`&<871gUM$In6dc%Kc3!Z1ZNR=qfOo>H z;1z3(^3ULyyxH3AE375{>tGF9D|4mHENn>Zn1$@MclJOOccEF(926U6 z1H@)zyzxml5+vk|4^LKvph_Mbduc>*2rTRzh_}VOHMp>*N2}zdZDY2$yzz) zg?2#I?$gJ_RCo#_0#BQZ5MPKtAZ_L5{5ZWKDLBm%yf(nAh=cxBU$@U!@=|{EAoFO0 z^}Axr*x6?#=&eeJ=>ZQs%3{l+D5R5{lZ-i+S&QnG6^8VU8}46I8uENCf6S_Z9-4@%D)2@v{z;-P|bt1nJ0LMGwN<%RJKY3Oor44;%-|@0a27VU0y< zPx)FeCPZ*uV`fEC3l=7OtCuVU&eMO`ffV6sc>`nALwCTamMli7b9l1Ld%YtAD--qW zh+V!ON7>`c&u|Y8(8(5Z3rRA!Q$od`vEA{M^Q^X4|8k?!#D-yPtN2~l>l>RJTe1Vy zWCX^ARjkdAtgi389I--9Bhz|m@VJo5S~G4O&(`m#)6p`!o47M}H2nQ=r&tPR@qpfo zgNbYpd?RfkUmcYCHAj~h=6QzJim*nEChqdgvv6a&GN_P*XFTD) zwS1xCV9)rLsFw$`#Ogz7=S-Z=wf0?+H-!uwT*mL0kE;3kovg#ic|OzCHsr=lt*Ofd z7jay_UY#(zFT{=bYvY604L>P~={=y~sQ}wvQvZH826)=+FFeOR_9?vM%X$Wcw&Zh7 zZ1c1i-nCT9yqa8~9Om!ugj~%#3Z;@qW1GT$nCfJMh=X;HlNXPXd6oTYgf$pXTZnl? ze&CDM`j{#4z}2FJqMY^g#$XrG+k2dNhJCUaVWLrb3=EK#4st0ABB*Lrvd(lBrNwbB z(wC^xd(jKdfh5+HFNNq#kR5!UIV*|JOqC^@rj@%(q>b~)Sz#m)+5$p!LY_n(l2rN>=Fv#w^x;j5e2PO{-zUTSB&Y8> zy?tburdJ=lQ*PhX?BnM@NcPhym6uKwl2FFE0o@S*p8&Ul{fEbB{{C{eqxG+QbPI^T zFdSARW`hgZ+V6INDGY(BWPzFfCGT{ybF(soKd*B-nUj`k6oAuBsM}O12SZZxlcseC zx0?7uhuBuG4ochiO=NUgvh}j`X1;i~q41LZN>I$;%_i?1UJ`PlrNDrY_Tz3Eg{jyK zm7e9A1J>d}e34rUxzjAGxeQ!)A)63#pHWMYSKjkf(bq4G^|@y!3i4Qt3EVsyt}-b~ zb&+&QIk-DAPx$ME&6Y`ZM{{eSNXgFzYrliZKKX((_t+dwJ;cA~87-kvml!6LB|6F+F_Hh!i}c#Z<=k5Nx`u^F_&^ zpKe-fsN3sfiBlYyzt|=c#IC+F#81w0?ZJ!cCuVvNq^l<1>Q3e96FP{I>^^{sNlfMM zfeftgwj6|E`B>g8I&5>Sm##0_-rf=7*h$PqT??|=yF4bV$vSUPRD)PyU(Pim=YDK^ zbE(!>En}bu^eh1^{6v8AamJ<}1(vzgOfw}yX2Fvh4h@9iTl%!6Q3gw z9KX?rxYG#sv6!c9E9m1o+L&{<-yU}ft0@J5KbNHonvK)9QH*j^Wl;yTo8F718U zUEbJoSyBbop=o=etN7-PzpQ3Z09?CrU%LVXWD_-TsQ!CC-~@k^-OLeqo)Y*|JHSJn z-!BNmxq$Xd#RVncny}XVyp|d}A~ex4B~dafi#N1mx1(Q#{g*U{D@3|q&%^*ILkAr2 zRmQ(g^FJx{18mOg)Tg+xq*Sd7T(gF+MqVmvE2yaV_n)gk41^N}O3@p8z}=n*7{Ku# zpBef4I(K$4bB1`ref4X-vnaB$SLrITDeC=N_;8PGwY;aq1*XIX4#j`Jv~jb8UvM#V zhgl2!dQFjqO|hm@x1sV=TWXY((yzBv!RMxI;C_4=m=^~)wElg1{66=ONSyJ-^IDv{ zvkR_9)P%`c2B1PWaQqk8clHOozBgdDSguQLoL55jjw5L(gbYeErEh3ybaX1BDcr^( zbKI`Pw>V_ z$=YWlikFTt0@#KX;U3mb7*QRir7s1ZztzTdy_G~CBz__PQu6b{yzcCzGSgj__SP@c z(FcS?uahtjaBQOsG^FVly6{-nN)IpoY%g%*i#0^nvH`*Y=q(@Y5w6_z(`q10PNIQEJj z({@garSy!g_Ibsjj=Jnovy#bGNkcNEevd0&3OPNR!mYCZc^>QWd3T7kFWJLyxHkE} z$%V5EV|;z}ShqM4kXnha->h|0I-m%qX9sb zP(d5eZ`ETWVYae-a4$J1p8JumlCIXR$`_6)L&^8%3G0+rFqB;Dq)=ooY0&+Gxu`&f zk*o%GqypNK1N1`n-xHYc<;C+Wu0aMx;rn>VvrYFap+WRtseEFwTg>rv^0e|Smyg-_ zwZdX=;)q(^R>tvskLjn!df{g47Qr3k$29EHF^F;Rnv!R4wlUr;#zeU*V1ueuJQgdz zVqDW5;*B{RcE>i5ZBUS*-WmAY56m_MxvhMSyk!p$)}D-QUQW31wVK;C3q31gojz%& zz?R^P-xPKk|L!)vmh+2&=ARLR+y7J}0R;{(jDY>{n`-`L&pB`ZkBC7ARk7PZxPS*D zJn!rx)g5z)gkLh}(y%0BDd^ul#!$(RP;MrA%ZYoR(0PzCgGhzaQEG2jrRcTuZS6Fk z0ktN}?JhL|of#X{P#p5$3tVMSa&QVg(FqwaU+#%V;>+&SbFb^O7tcn-43=nBy)5$~ zd=Yo}uzqn@40Lhw3Fjs!9f1iqHO8f}Lw|l?-L7$~x6%uCI*6+u9jvomqgAdrD^WUQ{pBem?EBGJZ^RNK^ zWa$|TKkI=`(OmHRC}sDu=2`k>5&3DITPNt)oS8z16Ke~zDCH$FFL2Zy@A) zFL}F)O6^u7Mlu4pozmvCij(tg zyoy^V-osC^Q{3Xy6ZB#NFw$f()~63|Pl`S9G;x)1r8(qp)l{uvRII+DTrA6=_0h|8 zOG=-`f2!Y;&hC$&}Iu1%+Z7e4*i)oxoHfx;p|Pqxqxc-KoDeSf**0-k#X zW0;rVS2NfEL;njde9q8cQV-r|O=9b@+axe$z9<}oCosJ+aD4KNE^mTG7Y&*BNc5?P z#HEzw7yFYUes_2X1D@l&Njn(z%s2cv>B%Xmb3pf+k1=#FR9rjgB1UZGqaYeyw$wC` zW@1snRs{1Mv1^A?wheE_2GL&fWzVA=POB>}U|d_w6eMmqaM8Z`er&MMm zsQm6z*Dq^Wxa}puGegpV?eLrN{)_uTzuEr%ZWF+fQEDUF>XA&E$X7#3? z_#K=B>Hx=oasB0-raz+eS8czky9DTa{ePk_DC3;I*nnpnn=sd(0}qO|080l^Ks_&;rKI%z}gz*#BW_I4|2*c2$pMq#Me~OJG7=q%oebE?i4lj@dTQF>S&n%(A5$X^X;HA*s+UT{fX;EA+EOR%(50vQW4t zL-+c2>WohQtNDYjeTrf>WtJ$8ZS)V(p-Mid%6T#}WZVeq9+X1deFu%Xl zeI~grMoL=xMTZ%E9YZE4NR>~B&@$N;yDzarax;T|*nZff%f}E$`1v-sYEFn#huqv- z8{Q>|-$es{{Od(dG4!$#Nn(1zR}~ZKzg(fBWr*7l4pej(ExcK}b>oqC3yxFnsvKe& zW%6r@Tr9)2P?{!#bz;*K9Ai@QCXuQ0 zbbHh(z~+oxqg&6M-X+!5zoym9TcdS9ywb9^BxdvINwW>V=F4L~Nb-1a?PZ|=vdajH z`!MXHMCc0cCkwLP~X3ZRcR}Wu-h3TelZ@6NFY3e zayPnsC_w6nqoa~3XYJ-D8~2!ZmZ?m8@+jwkei0q`9aq%4Qo*A;x68(F>dkXK>->nu z&Y?cS;hl&ipZaQq`%-`I{Yt&Y7S{|Y{$gu5Sjfs~Mq@CAdz3~ump}|js>jW=spSG5 zVRh$BXC52jr|J1+=$29aK95m&Fj*YA+Re{f(|1|dF-)-uZ8Dx<3nbJV=0A9SQWyG6 z#C)e@q+;gY?58;C`MLF>Bff3OJ>@9yV$v0ciT?XvNikGxXCx`RjjFglU0Rhd?0KpO zo5KwcJ*g%}Z4XLeSM#pPp-3F7jqZ%uX{Zv`Y}E*S+(VKqPmgMn5Oe1>tZ%6-;-n47 zKgPN*9s6x0;+O>UCdFM6oVnfj$?dfZj}ExVMFhSMzOcYdwA!<%zE}O}_M2HO2+9t9 zP#zdj==F3yImC02*bRVsu;A#kV}s5 zmJznu#Zc+d_pZhDa;o@R7Gf($@~btc&+L5dY((CQee`@+WJh)?B;wx~*@Y|Y3u3-T zdl~oG?S;+tTU%%kR36$l?cR$<;}MckdPM1C-+!?;j71N;LXdIg<$LZ;2Upwof$!C? zXkOG)!iZtpCpGlL(U8%wZ5m({sUYc{e|5Z2(woGG^=u#C>6JJ=`}BZI|0A8D=Lgw> zU$K9Z3^+<==}t3E04T|e^}pF$`5Tn{0q5WNUg7l_^+kSMe{8&yc3$wKTkIgO{&vwE z!;+NJ)Nnmtqeaz5N9^vGudz|3zC82n5}yaBVH8xDjoP`_gEBAci;;I>}g^PQM#VO*nYh7LF9)D`Yc zOO1=|prC~s_Y}B^Hqdqv-Dh~e>pV^^8|ltzn}Dk+0oI$McAUK zfp?IZGyb7Y_8RsMda?(2G_?%Y(e@Cf#8E2gdh}v~sB3@UUhb%E9idEM5$(`U0u+X> zD~sX??%f%k*k?@+dH3Yk8r&>ni-hxs^{lQJ2y z|ESySC|A%jV1`Gfili8!WHG!`T=c@xAZe)wZpW%*F;=ox?tm$0f57WnQVc45f0|mp zr=^pe?Kj>vC}1l;H@uK`J;XrUw3^2zd&Om)4c|Y=e52Y95G1RXb-zh- z+~+B?lwiM`M0>E?u|MW2-SN34bjz~0PRUJgqfz1&*OhKs(V_9o$iwC->hw(Sm)xy~ zIm2A>L0(O7h+eW^_$+Cb+<4MY0rAQa457Dq*(!R4yiN!nWzEGQ_P8K%j`4kmmx5uDX?XNu#=JW--a=8BkPZPU>68ZP?oR1$5dIG{?{5g5cjk5G?^=&67Hi$l+2`D6-*flb`@7#!Z(~b4 zJ1*(0VTOJyf}V+Xd=cTqkT(w195K2TLO|C(;661Tom$|XgO^Q&Q_PL)kyt$rwaMv1 zpmnK1Q)S&hMeUN0TBi`eb70H4wx?|^^p(f;G{Q$O(a46qblKknXL{H?J^mU{$-9AR z6DDTy4hFX7iXM&7j%y7!%`Mf19XX4`=JS!H;nt|kOHChK|30+NAY;uwZcHJ3yWA5} zZmP}lmN603p4A0qp^Y`29EET771oNp&&gs$G91M7XZU2wS+nczcpMDypI7u8d)t9>#3t>qLWnSL$jMNp z`9KCanjN}^jp2jTRpI^5Pv(9MW(CQE=fhwY!4Pq#q!|A*;;$u zeHUuTZe@K8c*&UlO=RUS%3p6zfF5YN{YS+OuxH;=6gQdV{Y_~_<}GB!9JYqFVM9rZ z6l9PQc^SRQ)>qA<0g8zzd8O4ld*KifSplo3K5`y~;~L%02bcQG9|>wuIJ}^DtfTNN zWH?HCPLL4NGRmJgz+-00bLYcB&Th=)us(}jJSknVd9&j5IE?)BaQX#fOJB+dUiiac z0i-q(ou|F2gp16h`G|YY1&43X4X7-sy33gT+Fzy&)6OGPDq4)|?ZY5hHwn5iBa@54 z`+?n|ODPect$gP2-==e#D^tZ@>O>^xsB%-(H@B`+FiLa zYVy$rg#cQE4&tfJs^jEbo-->a++|V0hD2`EbW@Rv#79~E1(+Re!Fm(aAp*&;4;BOT z#;-0|)hLwUnqwcOvSn)zOpQa9OcrA9yZ{5QOBovW(ZhME0Ukj*phq!XaBVe_$jgcX&l6NWjOB^E29#alvDFx6f9dyP^%TUd@#`Go|Mm*26;kw|it4VYZ zHau`VUYxveG&=?Hk8c_6+z7FZ;f$v2#FdduMRM=);Wat78Y^;EL=IGsuE{TTw2gs2 z{&rZt(l5|Eo7pS8lC7BXG!`kFFp#0oS+iZ2xba2G>FKW8IY2|{>ls907*x@BV( z6`V%mJXCkeDEXnByf2rATt?Gdv$c}!7uKH(HqED7pV29mHjYhQA++(*_<9XEYsF>; z#fhtqJkemiW=_-k&}(+3h@Dfa4RK$0sJ?>?N%{E` zM8YVU@H6YIeRI6i3uq7jxN!B6jI4>q4dt~XN_z%IE%H-5x!vYR1-P>&eW;hzQpL3= zQ8cn?O;`3+*LPlsZ#E>?FiFcd0%7KVN8jVmzD<8@M7ES>Zxq2?ep3WHdZ-BI^=FD; zM8e$DZ>zLsA?!KW0xZTM`4%|0F(;na!$i&d@kpb`)Gn^oy29!3xjBs3Algb%Gw7*RTm(Qy`K} zGtK?hpR?n!r{`I^{EX1!KR z8h5o&+Tp(`f*tDKR|M-)@m^j!7(U%!A&iU&I9Wu9tmc%n*9iF%L|gFuDbkxWrt_<# zm)OBPKKuIn%lqe`rjLByC=3HZLUSOl=E5+YNR?HOL3Ix3C`GwK0J&6RaE5=V{KhFk zetj{WrMgS-ot zZ=-5~AMhT2qmLaPvh_|Z>Z6kNtnJsK4>8!KRJbP1;r4l4jmKrYiy5{2SWs!wL@Y^$K66OumWUSOGrNe-&2!{p)4?N7lmc@lts?Ie>1&%0e!4i2{WP zHAPRa{D3T7k-|Pjce@1G=ODAF%l!yzId=&pH39M0gc_iP8iWC=I1*fmLfMYl$|dNl zm>{+oAf=Wq)^`h#Z$@XC7r!Y37?~a5!~9pF@Q0)O<4gaWcEo>1x%|HllPZogK<+^9 z^D2GcGcaRDu(kPR|K)qp>6?Mpgne)IM&b;0`95ZDc;4;DiH1SVhB*etxeG{0K#fS#9I@O(^Lh*eVSM-xU&Na z1{`-!8k@*+H;#a7FpxK$h;a@v^K)ZuzM1jNfXDXXtc$}aj>wf~rg1fTn<-X_I?e!e z)i#D1*F2Csy`&uW#9iD?^5Psueb)!L8QkP{55AlX1f@oq3U(&tj2iAW^_)7%I7OGC z0(8|Tc24LHrHeoZ_$k2JqYVNCPjwRs7d%--h)#6Z^T1{)N)`{))8q2-ZTnM}GagE?HsX7b3RydbgU1KUwGGEYi}=fgA8EZtIoz>w1N z%Yx%nrQNk~n=;2l12kxwP5V7mer4Xg!wIImeoPG?26HiZN|%^;DeeZdiAHB7B9Ak# zLhlV~@D-TkIWl>dEtbRdW&AmtIh@_&@LLIN%K(ND6!<(a9@+vb4};> zOHNs!24OaXyxEBR+GWm_Uc<@M?5e=O9g0e=_2EM4p8y+e!XQ0uic_o_TrugRoKYVY zqQYmWPgRrSr6IY*Lhc_8G!};tWM5VInsM!MUbj}OB6O7_G4*mOp$(%iO|FM-OoNuV zv&5^B6Zv^&qTYZiv>?4vzO_Xt^}7gi3(W?L3Ovv-Nv6_yRMr(6v=M&;k+*$}E%o?n zRl2)eY||8j+%l+-h!jY^!_}N4tXIgqxE>moQJNlIAI&_k&Ay^2OIa@3^Z?azb~#b- z(s0)+s^DMXoKs&k?S2t(Z3fUgYmbR!8#bRvnOp81Y;4L-JEI>Jr+5z>U^Tn=qItY{ z!Dfm-2slBQY*9PMKGR9q8LXuWt68MmKa-+0Tl0MfGcwS}mN<9JFZ;8fY;$7xz(n|5 zKjDHpP|diZK*4(gWO>z&wq_mXb(sfq=^Q8_(cPc!;_QG+cU_jmEr&!Huc*a6WBnGY zkLe(|Nh3iDHrW%$!6~I^JR_Jvrh=S+T`*r}^wKvEn;0=`{(MF7+e&FqT`?@u4#-Y8 z73spfOsur8O$`+y=cbpndcZhBy0uMK1C|om5OG{~mXPvQrnog29$DIG{DKDE+5wPw zSUoEGKEXmwCqnMG+LCspFO>Ab4s#y`N;zkH*pd=7CG$okat5*BI(%uE;GD!NrOcSx z++VG+1}ePqBk^Xef;ftLl7Z{%oa*}~UqQ}rv+8}{^m8|M3UBj^cZ~-h!lsx?O{&eBIqn6${0-9a~K0LMEHwD*0N~pqy%ECd@byD|-{I z*0km(8sEd`1%EEbioGA^ytKMb2@q_2ihbBPrnuFxCe@f9WtgI1se71=X)tkx|JBP_ z1P=wBN_Mzvo~!Yl*`uwe3A4VvsdoF`whjKUDF{-RMe6GPFR35b<&nN+lAiI1+&$=H zFR9JycalAoFY{M-88fyAsyrB&=!4=$aI<@?aS;eph^nI#F>|yUj^L_J6Ae{#Ms_T6 z>H?j|XIV-l9sC}d{87>=5zz}2TCj!<>oCbqvr&^pWqi~89O;rPA_>Z}a66t8We!tw z{N8W-s`d$rGm85CEy&;*RB4l8SF3F%fhQ?w$hkPIDDwNgorUT^8Z|x#xZyg&ff|;HTL5(PU)YQuE0`R5@*zy;Zx2vUcgA zrb4Nre-V(-)HBRj_jKcDr_d)xA&SdR`)j!hht zr4-YTL%mR|D9DMi@Z>`DMKs@$irSu`_|8G@cq+-ORd|5l!uqcDfCxtF_B=-OTb%aRfJwZ-S{=QBxR^zz*a))-M8#!brGs zhg@&z(wiz+S>Va(TDap)OL1SNjlia(O0H7i(J65sjmE%6XCN`joy65Zeo{aoXGz7Z zCQQZjo(d}!OvxhEl0U%%?#M!~+QSm>4OsPFyi7_Mk~Has-B^=f8nAE<;ytYn`@$dm zF-ZnS%!c*aSC!`KPFmBAqq$Z&utWz08+rjB&c8b8|J~8Nb~JlwVQQp%lW1u2S_{y` zx~t4;G<^V+&e8S20;_% zJ^=EoGi2s{@pL^*HfOlt^9B@SpvarJOa?40!=2X1EhC~>4+)x8%peCAo9TpR;?(Nr zCKJ#Q&>77sh7CdHP$R3+t?$(hvez|cS7LJCyxnT!_PRIo-%JPXeG>KNaj^+nI##m>3?jce5Y3#?w4cHL$L83cDO>~XP+pOrVkL_s9D}kxVU(BRC69Fj6qNL z(1JjHAqBY@B0J9Y&dtdLwS@)-nWDz6>uVXw589I@_(;%fFeqn&05VGUi0_}gwTH{I zC??aUCx#S)GKN&w4l*~w4Bwzq_`WfTjr2+S$gA6lOQ35v+D~&vt3g*j6KkXu2J8U1 zxUp%VORG}J`+82z95VgljbqnBr1UH_d>Z-YmKA6MO-6IPIgxckfqv7sIYr z0E@5)ScI2AS_zicVC^Zn^cNr;l1FVqX`{OuvC{V!fh^Kkf*J6bl?Pp4 z{I+f1iq$e%6o#))%9EyF1=&Kewk&wZ8HxBNMHDu!FHKN5HzTa}RjpjfC!+j*`<*Uh zy-xqd*Ha}BEwtg!I2bPsTn4)Gd6bz(c=Ly`i)z3)gbL57jnCc}GK^~H#>|n1K2eG7 z%`(eeUDzIwm~VS*^wCkz{ksSkaLTt(NXkI!PtA(N9vwnr)Oemx$po#%x09Qz#pEI+ zktf03Q5l(r{M}CY8!T7fErSJU7aB(u6VOtZvqU$|OE=7EM#=@EjB}&LC`<4NpxZTz za>w^eeC@AK&ghZM$d$(c^JIUr+VN%T!-7wC$(Ldw4pD*W@Fb~-K5~E>zFZnUo~1#qRo6pW^;#|hvlR8tUcun{| z1a>K`1hZ1IeyO~eQAyKbqsy5iy)lY)i_I%D-tSpigoKz12Zur9_aeHq8>rpvg9^>{ z$Eb`o*M_2td?%MRM9IeZF*MCp$zMFOFA>*^)>(sL>Hci7Nix|}hG69d9E{}6FYkux z9uRGBDKJ&_9nunP!{s-o^SO=0ZgZG z*F1XwjD0!lH~Um+UBd19ZxD;6N7!g$>8QK<#G^18BFbu0*-B_>Up+mkG(zSzCY1LQHlp>93IF=;$UWSizn!4y2#UA8 zSosxdC%S=m0Iq!H~iM@i9T#bNaY{+VV+_ORKpsNN%ktI)5w|&AWkZxVs zRI?5r&a}f%FeFh?CnCZq21~7kGNd(9=@FvdNynMH^>Y_GyVYRF5$X|bFFW`rjcJp> za9(CoB-m%}&gQk(6Z5+XJUdqOrQXO3Qt2;0fhyVp;|5K-urx|Jb_;Dc>E;mpg6YL% zAXf4ieiqGFykE3@=-R;4uJ1#?C6VkmjAxXXlhL+RFg1u4+wo{?Z4s8RHqYZjdHswW z+;%j~AVxl`QgGQ7?_EN;h;#XyjN*V-6jXW-xgZwU6z7TP!g|OyN;pC-tk(?f2v#f{ z9ucFt9L{w}r05vIh@0$!XBEH+$unfS)PZD#zJn5h5lNay9Pkgx10rXIK#MbmWi*2R zL_%S2|4qAG$x9O$O$|>K)jN!XRuxTXo>7%Lj>WIAy~J}wsz9 zYh^a9a#9H1N8(O*0r6&{%ZU6a627D->M3)O0NT^fxydxUDPy)yZgCse=>F?DPLf)v=uFBx94<5iq zho|QJ02ky2$hEssTl*V3{ktyc57)mHYj)#{+;})bujx)fYEi8%wP4O<#46sAuo?1) zAYy!uZaoe^%1_lGwhFqw=-$lNYqzuR5f30IX%5#n(AQcC(^ov7>tlx!{zMKf31J>M z*9CA!A(jJ%g;IgLNFrW3MkGVbvWJTy1Hto)o;JGjY}!0>A-t>PON|g49Tcw>{E`E| zW-oth0==RXv=hfox$#DyI+5e8BT$h_hJpd!h_B#V+X{GblV?wniWH>7r@u*wrM) z(#96|>X!!l3U<(+C(XAig03$sV<{5AMfalVmePsa zq`JFcEByrQoi^VVyGktP@iCP^ zaLj7aALe@oc4Ocq(2j=QKCc?L;Q^jvv8x^!{x5r6+kH)y6&wpL`}IQ&3FZ zs5`Eb?~|*w7y4OpOR|l)t#AdEm`w^Zy+Fs>#7jjs$B|0x-a{Bhxx4L=E;&-nEL4_Be*YD4z zao|(k@3o(Ss9n%k^9l`$NFWg(19!2y85bN7{^EI@RZn z#cnDumk1Kd=AG1W2J`BDO6V`55SdK@1zGtN3|jG0Kayz*e= z6TlHgfu-qG#|V=eihYjo#Y9bCs(mYloJCndT5h4xux*2Y6I9CLb!)aDmSy0(PVyQ{ z0URwqQ~gIwgaiGQ6_Lv*!Lmn=NuXcIzq?x;@KGy-*sWcy+Lg8;E$*QiHa=N-#h$@h z5#J0&`l;HOLuvI@uPRvPnl-{B24?JmM)LePJ+*O(^27qO0dWY+4=a(D>V6aqoeR+F3(Y8p zvQ1aRPEJ=Vo8R$dG(NaEytcD~JhPlR-=F7tL8mo5p)wA+wc?JOzlAl;+*kiBrP%Fl zIwOoL7RThKtYVs18MfsZoAP5EHot-e-U*uYEzhD+3#Zz_QP;#PP=$$0{-k} zOlV4~5I?E>Gqq%0uvWp?^bp4{GNT#wif<&@R#*l7UQ@?HP@J(qX7gjMLUnn?9Bz#o z@kLQ1H^U=Qzh|OGsZPmyu|8!&4Fa30@s2?tdhk65A%>fCCa-z(=Y)MzMe)K=RVC}n zNJEDRJ)K+=q7ylPchLZ#lqXK?xu|+0nb>QBlf>h1)^UM)rYc$6?SZ5R6+by4n?vDB z!4#Xg?Tj~;uQDOepq(bQrui&_6$IiN1&cdMYfldf$~M{s#yY7b%_cN6)=THenSO0& zg{|kB4dO-0&^xQvA4s6?FVFRWn#BggFr>`WDN865H!nw5NmUYE5ez=EYmRh`os3%b z7>s&fwcSLU*+GPjI#Jm7NXfNoKXlBW{p zRc$jr!(zIA%29IkgKK@Ctc}>J{AqbC+&{HG;HyE1re$rMPTHAQTT#3e&$&r?d_q>Y zvL|)zVdN)JdE227TMF10TsR7KwOl+rwX66%`sBC;Z&sxPK)`k5X0BN5>yK{ zS=PFqU^*Dv1=c>61>PyuUV)WbU>#{{K41DoT^x(AwTK_%9Gij9ys%7(UifkYYF1Vs zgpx?8K^Xd^Ut=({z#(err8^yaHEMt6n3zY((HpAnFFha|W^qa9e=dG>j=+h?;DZw!tSMqI9rHmVa3tG^jkm*v>0TLghyrT;**8Br+L9@Yd~v^g z3=@}73~!Wdm}4YIcz#;1nFaxiu-xzG{gMK0)0TjQg4Pe2VmZ9+6~j zBIrdR3WieMvcMf_^lG8om~XqE9Y}#+T&Cc@RjkXbW>6F$^O50}A!EUPbJ*zEVj-49 zSkBNxpQL{rma0UPvteq)-rakU^OU{tdEWC-yPmkuF6{n=&@ukRUq6!_KI&{bW{@U{JI%nj~c_Otm4H1?V^DFXsivD3Wjl*G- z1Vz?kuX@Nz_Cnbw+vQKtLVTH-YuPO3(SpW9^R(_wUcQxE+&4X7o0#^1kc& z2Cgx<)drYHgnejjWNIptSfi$GhW@f<83?xNL*bM9_}3SS&%<%Xtp?M#jv6gP0+81F z3B}KyzjMkJSyV7%Ms{V=y4lRFVc4(@t*oO?h6LBu@dZ; zrd2km^$F>J=!d;Z8kFqA+BbTRJ{#h-m(bIJZ?cJ73$7rM`Sk293DM}%W7xj8^zQaw z+B_+vq%`WvbX~p!)7V&f*LFR!ehRDwt+A`;q7oa0qj}0wi%ZRC`hE`Q+%g&?UV?ST z4X>NS!gPZ|Nr`pC9WSj0O>2R3OBzzpozn*|JNrA;JGwNnx$=CQZJ#9)c@&0cl`+lB zB{X7|*(#Y^Op8mq5(lWMZ4hT|cf+|jZa!MKhMiY@vV^d=?3-H$_OIL|}B8nK(nv z9A0Lkh>mDC2X^DoX?*QAODT+;wf1X3Xb%skl5Z)!?0NcX6_gZIfNTYJdy(i{>oS(H zua&BCBC_z5mFWwaRXbc@juZ@m_>`}w7ib6*dzI79`9cQbzBaOStshJkj#mV-h-J_! zw>+P|&B%o{g$G~VuQY4S6&q6}%qg(Yw~>}VMRz%FCs8?uhW4v1a;#rkL0@=6k8Dq7 z&f~ApuT!Dsz?J|UuUkXvKISNL1kzTN*^}{3(!DsO*4>#kFw;%R9Fgkl7}@&ji&vK|!YC_Gm!dpuy*md6sI-$oyXSz@d7-dWIlXEn~ zF{9}r=8VXcK1#|sCkn5uVK~CV{TkaBsV6pfO4frIO0O}ev%h@F)!jy@RV1N->wC!o z6SAD>mwhEY9Vcwkhr;ZLT-;|^`Tk=Al$!Da0SocG^SEqDY>v7* z)KuPyDaN$jCzVoFvbjXha-C6F7N)C_M_i^QPhI5gq0UXN6loFmDWs{Dd0oaQ zKIb`#NMIwj8F|_rsSMs!fZwi=+C1(X6*ycQ=$Y121)Eo!mj~b3CK4{oMh7Dhri+wl z79Iz7aHPC zbjWY#IJAUH-}s zncPpL;v(VXWQug6bt&l-V?KBwZS&IiG9>PZXo$QhBUE81?X~OA4K&%_-2m(v1BHs8 zFs9^)puC`S!Zly!9X*9Me!?IwiqVZQQ&@ykh)CRr{RH`PaIk5p<2?w;mx8r-qzcv5 z8a}7i6Gpw@2p|XP?+!;UOy|h2*-Y%QGUFK{UmK+Fqu_ogcrxH&5O(3|m+@vhnvQni z?T6Exx);oLPgN29oq+2Gk=Rf(!b{J~FM@NS`jAV+A3IxU58B(gUe|OX*+=!8Bf@eV zTSG)}ZNNN@IK`{-$|Oex{WAM~6X`ezM|HA?5oj<5zkMrt?fabL_VbMrkB{?wm``go zsnN>cC-)XKS-QA9a|Ozqwl{(P(6DZfL1W$&-*OIe_{OD9J@;F^TmTGYj*GkFm2l~f z6J<+?Cy(eVuJ7Jg8?6v93<}daygS8+lQ(a{3t$aEfNWlCz?OmaFB7EhZx^&)TiIIJ z{9ZBkd#+T%i%DZZM(^9%0(3-yI1eaCl%*7S0m*4FOaU@cI!dEgv?@k=TV$owhdT+w zEz!BH5aW-HV%c7=*p0pB7e|#yEr*YVHuUCQ0Y@s0NS6SKUP7#M=l5kmDyAK|%)aW# zpX<~TqKrUd#f_rkBT;)oEGn*oE0c(CNGNcu4v8;^QA3CGs-g#_nyimT%2%+}a6G`R zK+f};kz!a^qK$>^sSrnB zzLumONm!SI{9ISfq|gRc-2*e<_+AlQrbM7n9cl1&r#Xl!g1+1+72OIpAnTXpWQ=9L zOrB2-oTi|PxPovHIiheMIer7mQMOTjpSjTSuWe<)Q3^Xi z44ZJpaa(AWgpYAe7RiR)yH{>)H^OKPOPr_4F|OEGW92#)N1->LfD9YmQp2e;Eoie; zXP;;(FEc=q_%W2Yvhk#r3PcvQiwD&US+8;W$#!zw!J{^|7=yaOs|EIV-7BWa&R{!+rMs?W6F=Z#W!dBrQmj z36EhwFLj!mxR7POU{&Q2o~(wDPUD2v2+4B8Iq}S#0n2_Wj9s4MQc2z9*2gy{+T=Fi zzq}LqRR;9^{^Dx<6$0RG4gonHB!3$D{ZB~c_b%WxHfDK>ljf7c@Nd5icp>Mn^}TW_At5_G9{R+&#qdn?JVx~^9U{7nRZuBQf=$z17Sm!_ok`TdqD_`xxkra)sJgkq zY2~9It-Jy0u@Lu?Tgei!mih=4;I+k>tsv~c7LjqNrY!D?rY!9XvNBtjZVXd5U#ZShP+aXJDme{c_> zw1mS6^YN8pgTspgZlcSYG6M_esHXmb4rPP)Dy=ca(Fxp18{q6VfL zgv5A0h@!G&>q%wtS)rfJ61}ioIr{J^?7Wdf8=6uwR3w~B7b)oxn@;`A zv-&UV1+gbFT;fTQ^w;<_K?q>eJ6JO>K4TiV+UC+72dIm@TCE> zzw4^pRIc0LeMQ;-XMHWoI50OqwCV;+$_+#^UyAsN&yBOZB z&*+&Y!9oti{*Wc%hgQgl_H?sxtJ?azqBoOYS0(eu$URuM^Ms*>T{N?-irIC22pOKC zn9Q}wx6wxk{CkJx;4l-xU3@*M1$iEfwVWo>nAR8&?9n)sImo1ut6>__(aF- zE|8uhz{KxFqf1=t@HdCpSvU`Uk(HQ=3l*HbVo8n7xH(1w20;b_v?Ty~0wfP`Cm+C+ z6=MPJL>Tq=3TMC{{`0RE{V$G{Zd%O%b}zQNHn!G!wD*4dZ98)p^<&%a|HIt;tN=(? z{MQq#dl&x+>W|m!yUd?8FTSOc;Qs~lkIcB+Qtltjxk^fKC=ppfbBf7gp6hIW_zuqoCS-QKn{vYwD z)BLkuYq#(`nqNjg=)88<+#BY@24}a-TtJS=FPi&+`KJco?f3b(= z-ft6jm#9Gh?+|}#?2moF?xL^%0s2q7fIYPQe)q4tcn5}GxBLPAelM_xLnyn~x$Eu_ zco_db4dJJ&aU;%pzvb55u^=-2@>l@Ri@OcD?%IFDyx)H6F7pkb!~HLQ*B&r`YVeOu znC`;&n1305SN8m_wLdl^x(ieVq>lWewf9;R-6j6EruSM4+$CP|{xb2N=>9|ELt+10 z=04xQL;UG_{!CW?7QMs&%jiEu_8%I0Un~EX1q9>^kO2C{#r#1L{2}$e^7vh9q42*) z{pl3n+)wufobTdSMSmH8N6z`7x%ZWl@A7uU{tezw4gFD#_%0Ys;+Mhy(I&oY476hIwDG_7(^bSOQ4*{o>90bNSkb=!ep@w{ThMe;NJL)%{U}_I3n7 zK%2ilh6jqY5AD7$Kzo;|3n-HO#VP+$680hXzV_^0?CigZ{pnQyOmy~k1p2bSZuUJD z)`uqFmwLSg0?M%fy>NeZrtcyD)ZB-j#J^#Wuh;!mghNA<|N=&!2(6#b*?xFJ4NfxKl}tNlB~pBno!LC0G(f%@M?|A}zf-6j1| z73~%T=y9d<4^e+=-hCONyUYOnzhM4eEOsx@`a`($XWA;aka2)$_J8&Je}?#}IX7un z_k|{INq|#Tv%kfF2{mxnJFQmsITV&q#l2+{0SFTPW+BzlFS; zy#COhhgCYa7q52tpD+G%6Mo3KzhwXl6g~fnazFRrr?=Vt+{e3@r||!U%m37jA5&@W zas)#EH_i`20=$p7xc?$6lWY>m5=pPkg-a!MorjPmf@UPc@oP)%{u Rnur^y08nlU5_|L8{{woe1EBx_ literal 0 HcmV?d00001 diff --git a/src/vfs/_vfscommon.vfs/modules/test/tomlish-1.1.3.tm b/src/vfs/_vfscommon.vfs/modules/test/tomlish-1.1.3.tm new file mode 100644 index 0000000000000000000000000000000000000000..ed5044a73e5fccdc0c437116e82de7c592c4f98a GIT binary patch literal 41874 zcmce;2RxPi`v-1sGLp@)_uhMFW>fY&I5`fEV~5Oa*_Dw^vdIjgjLJwvWJIzmg)$QV z`=HWO&-4BMpYQMgKd;wqoO9pT=i1l%y6(??@Ia?t%>EE}kRt>N2Khh`&LAUuCi~v>+~Ht%Fw6n$zy~q_dw4VK)k_FKadv;d7Y;l2;ppt0D*lGa9eu> z*a5`s>gM3?=D_Q2Ywu#~1m^Vy!#yExFp#4g6v-aM69jPJY3mC9{*J9Dh!5d#2*YYhrk@&K%Vw+h&#eE z5V~_(tsS6IK*0`RK!2_f7#K;-3wY1n z7U9eX;&6BK^n@VK@w9aW1KI)3at8rsL%<>S2tak7@|;Y+EE@RBe@G!%PWS_XJwQxM zpet8EjOIrIfqfyK2v5-W&;RfFX9E4g%&)8g=0M8o0D*&!*#Z87Ax-~-pIn(pF0JQ})=>!9rd%8m*h@-Q95aYExQTq{r6R-T` z>LYLXtJVOH`Mwnu;h6hTUV@@eF$ zNBV$5!7wKv!>}k?f@Ebu0>H^|Fv1HC0|f;BYHZ{s$k(rzDgEoqI$9nSpqm0PY{w&C!-#zhz zKkDrFE0E$t?QK25*2kIH+7s;L3Wfp6$sC#KU`{}agu40s2>YKQ41|)UDSq<5T6 zk;&8(DZ=mc5cW_hDTFJsZg?X8KWeJjI_5zX?GU*a3tj|C`N_LL*;xKwP-|@zdY^=J$7g zQ5(xIa{O%=APwc{1%;lV5|H_2Hvop1+q=Pl@(=oz$Wh$@>NAqEB}hsNDIxM&&`}j~ za|G)45wrmT$OVwx0SRcnzXd;rTz{19$XSpn+8S8$q^9s6EBuI?0ItAa8L>oG9^ibi z1213-B&a%FJbqi_Z>tAV<$qNGlG2HczY+R={?X#6nf-sq4&HBsk1ThTy6oLtU4b(1 z2|9{RBuWE-=+SzXAOIjSG5wwUGTXwPypVYVfUihAY442mTfpDkKz2YC1ke%?fe-*HM5fB09C-o&($fuq zRNr|A0nP;l+j=5EPDljoiiAYKZwD~c*3T0J0C67(%)!ma6XXuHMF5!(K;8g)g}K3a zkIIQHAOh!~IWuxbf_LCTph$YT0;tvxs3riBW9{?v0|r3yb_`&F;sCr4M2Ib5PlS&f z+~o-F{)!fnsz<(lM8=U`fQsM%AYYIR7+~1^cL(|VWXiy(532=WtEgM5$)0B9572rr;5LN-M(H^6l64o5oS zJway226chC`2cOnFTRU(Q8zCH2m$vyQXJyX+Cg%56gelI${($RJPG+?{!L#$z%uBE zcK#`jfnBt=_f6-5Rn z(6IoPKjpiC&v<%)LGpigt7EnS#@)RDEWq>+?EkdsKWgB=q44*L29hWoe&KKH$PaD- zn}L9i7C_sOf8+*fIL7Zi=I^ZiFv$<$ewZupKQe)2=16Ov2p|>yY(YJN_ESzy?v(4E zuAXCn8Dx>Dtp5oe=W$vbP6=fnkFMkeiSw>vSgn z>2E*75%fd6Ut8MmdOiL77txfFnH`z%z1*GPwhl*l5g2;Ffw+bM*$+tnfZH7>eMg8d z;DAS*AOrcI7y2Dud}rbBKRLGPX%GM1jDKtz|JwZhM+^U=f@2H-`flALb0D+*zg+yp z@POrxRdqxUD1GLq{ zYyjK=6Sf~?C!i$<#t+Dr{1}sXgJBThG$5h=oRb0Q2kE`XmjYHqmf}C^>13$zFRlC= z$$vzN%#OBDs2u=rkpYEF{y@Ne$56jfLIw)6juIc}A^Vf)>w)TtRK*bra0NRc z#}FVuZ=N7tVEzcyI^eToKLL;ofT@wl!1K?B_&v;!9)KLI{79Dn7(mGDzh~aR;PW3s z{g>(f2%va6ftY@JDRSKUgUk3Yh9B$^8gCWTOKGW=?#6A8JT$|H7#eK<8*$42+aP05$?Z z1k&=rYA4|VG+Ic=08qF6J`_fR?4Pq_Bm+ORcoJ(zBV>0#P$2wHX3GE^`_Ae=GkBbG zSO8W2(W#L#{9~9PPe8tonkom7`S%d{-Y|UU;)tDJ9rkY*MAG{&JpTWtt{@lt$+YoF z=4Np`&bz;G{ErMH>HPnYzmd!QIfwuKCx1TwFB4k8P{(b;f2G#nRPpN?zy623L-WJo z0S5(=>Ce$3wVoC_##s~;6daUT%uqAn4-_=y58%ZH9N+5?!p#*JSvm6x@(J<@^Lu&$ zt%)bU9WY}*ha@S~7hB`8$aW&Hb;8?nr*Eh1ki3qFigjIAGtU^0$@C*$p{ zORJ^2>Nk+JQshp|gQ8V(zAiE+22g2zc&UAr{5Bp0vq?oVsntri&ge}Ow*t?N(4gDt z-;`dW@0a5`+@e~GdMLd8wO8~}sA)eN9;=KalSk-nCE9D!(He#YG|^lA5z6KpO3kdU zV|NdeY}_BJ#Pm*1q;l@wl+@V&%-4Li0WV(cCTEn4?ajFdBG|0i)yqBIv<%dDMXzuX znB7Z{nRL1{Tp9ZMaV}YXY2RFF&6b1R4%uYuq%}3KV~O6(Bj|D@j5N`NQ7Vz5WQOEb zT)xIW*%`4RH2x{lY>l+1OYY+`TVD-bMg-eBNy=z2X=A`Q6?8M_=tQ+M?bvU8O4oLx zjvmnD5aqV8;-0G23=IWKMkG56k_0tgW))Mf<`nTUaa;hGjdR~nDc+EnyQ@%YaV126 zuf)){btEU={NgJ|6hBH?KC(t;f4Y}GqAP8_U2~sE_V?eSa>HPFk8C61RBsH1syVaz zQ!nAD7CwMqI!E4j#d5)jVUD|OyVf8%_#w?+%hm%~u-%qwR%wSsR$6d`89m2LpL)t2 zujcwmas5yTbk5`n)>o~H8?xhORWuD&G_S0zErWLG9(PVzSMudrIHJdXeLKG}wm5)U z%GrKp9|g=ycYAi42#aFa(=cXW{#cQ2kpJdM3cu?13?;C4nsKr%1_xh4m zslV*mNYXuB%Mw<`W%1d+>)xXkdJ(5JpQo#yIPz~*iygYI7vq27&7n(Arrq(j(mePK}F%Cy!5qx`nMOf0?)Km9wf_t%TF#eKWaxmvKMczwFr_H?Q7= zf8QK#74BMSUhsLf2n%v$DrP{RIegAH>4}C*zQxeDuhFw?fXOqF|Se!*PXXItj zg}Kj-oNe|;<103>UtXasuS=@BwRg1=+^);{(x;p+-Fdo9U;1`HYH{)@8U&yzw!TQ|DJ(@kupSq4SfzDnxO)x9z%In6JkWazxw4L^G`fBQ` z1zNG_>sM}y-mIP=HeqoreikS{3evw7mWeMB=3m^e7>gYtYv|_kY1u?NsBdCScq;Oy z#C=im-BR<_PcjK4mm>WsRAuy`ajHT(pT%iAf6|20=~C?X@kq5JApc>R{QOx(BKFW*qsG=?R%+s@w=8xW_go5y_uMyu#5d%`=T z1S!wb7%=LvVvcRpuh66}nQK?e*a;S>mK8UDC)srGS@+jEL3JZ(wQGa8v$F0C-yi|s z#>eJrCE?vk7a9clX&f19MM~BVcc&cKsP5RuiG;_>Ira`RJl7fr9jr?i zh(()f8P@E~6OnG^EbY#u^e%-_2!dX?)vDlp8j6X;d1Xh-JOjIDPVXUz7Zq{UCp@IA zI1*Y&##Qd*(2!IlLRHEa)g5C31f|4t+>lQSAeE%6H z^vJ*I)mtk9QjF!7G=^7#MFUeRWyn@%7GTZ0dL8O8uCg0+Wo2Z0A7o_15^!?fW7k-S z@vAK5X1vA~>j6Pa$=gz;p@P1>yc071i zx>ew7;OFU^lk2xFV37`bLYJaD*Fx^x+|vu|4Jc=H=3~kO*+|Dcl_}*DAkSAvV+~2e zxi84Rw=8@;(x#_$hwYuj(~aB~fwknyhuU@~xWdZf_xc|=6FA||%9GZLC>fRW_4zg_ zY1}LVi-^P=CAC*#kk$=K&Epf8{g<&IHW zo00N<^tOh(F)_L2vUtO5pYG9ES%;dN`(ih4*eTx>!R}S<_Aojd5taB*fBq6(?|#3= z0mdS^?Nhc5YiO}sQ@wfr!5Y7q(3_^OXxgox&-@IWva(P!E4BGSYIGEoIBFCWq5nQ` zATTHZ_>be}roP*x0CDeZ(hd=O%tNtg>@QKH*v0vT@gulG#$?KUENV5Y6A-Age(Jha zrUZtPb4k2^G1pxnPPI1|wc+^vGK|!jg6hDSNeqv}%~E#^Ajd>JI)GS3-*+v`cEOx^dlIjM`C-XdeB zM%N;@)CmTs-@6O!Vm%wkUf6PL-wswhd-E_uBGP3!zE{>V+2BdKhYa_}G~M@#X)h(c zhMGA!l6MZ?+N_@ea|TJ>6|sgKsBG#p?M(;ouTRSB2iJ-W?oL`S6F6cxOk%rmYwcuj zds!#1at|Di-%7+{#+LH9@=3aVY`;tH0eOs^XnN5e7R0Ef3SnLPHCmWHt{sh2cTcWv z@59-c*$)|C?me|y@hkE%Y>n51sEdf4jmL|{i?!o{1rue5fV+h@3dFq$*eTE!9}5<` zBlI;%VFP#3-@skPh8SNbbCt2eR5H41ozP@Lk{d-F{i!W5jXJNX@#Xk!?4e!{hvL)2 zYzmw-T6cH&Zr#RzHcGWkkc4e{H_gvFNx6YXJukmLe~VXhot-!YwH9R@Ki>?4D8S{y z6CB$`(vi#eq7IC&8ePq@?ukS%k^ex*Sj$df(KoZW@UAPloTs(+%gfJ24*t1aC0$EH z;~AuqLhRnoZ)@~kxP1CVL3f6VOJ={=u&NF1XQa8Kgqqnrvcn_?B5j-&1w{-6>px(7 zphQ6s$jO4Ws~522>qoR59s*Sk^}Xqo&XfXiU}9=8WrU3JN8)9}LYewUmkX3iskKV; zIVLB_F4eT#xH&UFIh>)JegBYXco^$-8fegB@M+~Xt@XUnLc%o2*SF&heW*ydinX`& zbix47mZc+T4xLPZHknxrW16TmNzMI$AS9}ACaF8y_092Kv1i*x(N30nz2Qs zy=g*r=!pAWOUd-P16TUF0wbMZP6sRsgP~81UMLo%J5LP+E!=6GoSWgIS3#)gQz6n8 zyANF9%4dm8eR1SB;c8_wBN0I(E6-jDUVIdEhNs8%&cU243%*^Zv({KsSqSWv{z$c% zHms*vgz!F9q27pxnxa_dGWv)lxl_*I9G4^|5k-#uz%tDi`HYvOs=&DFl=j+o-I#@1 z&fN(92b%1t7kJ2R+OJ++MV(Q;ZO}cRpE{UUSASu}!zVrG-mCmUL9(E#EJ`#yhTG^) z8;{W1MDM?4y@OU+r9Eaf!w{+9c$bcJ6q6;Qa+K?FJ~Lg7a)*RGjc$j6z%#y~9x}p* zO1vwJXG3xH>26ysw|MUve??VPI2=pYe@lX4|E;@MxI#>r$4|3zjqttEkPaiuOZ5IY zuaR&y!F35I`e#uSuP5y8-QJSEdI{5&!JKjr z?@n3y`L^PfY#i4G^|+55T#tXgDRbTnhK&_RRG*|5veyt+=#&pvHrT%v}GI8%Lf zq-yQdv8PFN8My_5j9%|xw5MT;Cmi47rFyBoY81_StMHAJUQ$M{lK6Qm@f~`>#FnkM z^ZbFWr1-Dn!sA@iyR9u|LboU%%_`9DNU>~GmnT)IG?2d3bWmg}nQZ)M`q537t$?{G zDq=i0sh^y(gMjrB;#t^|>_S_(%=u=0hMr{%qE400rDefrJIqENnB?=%IJ=M*O?#pO zdyXsOqhIpvnjaaZ(`y!t$9$5D{iO4z$#~%~ugB}-ra*we&?@ax!!(5m7iL`}n$fO9 z1^n%dExw~AzTvm8z8h4j#BGCWVU`wiT^m&?tD#p(V>@)crGrnk(wp}}%+B2t4qXEp zU}-!Q6af_M{~T_f9$s$14Nu^fmmEs7%|S_1x$Q#oS2Ff zLu3}k=cT?UJsXe}mFB9N>_ZlQ5TI5=7tHc4_xgx3qNakXjk;|Co5ghNsR<6AIOath zHd3s6R78NJXgeR+VmqWo?RPRJEfGXEK$1J2%wSifYbzwOA9P zHBd(``}l0`S?pPw&o0UQEOB?cDl`1->(aXWrvwpZ+?7&_(D%9DVuqv?e-uW zh;%7ONBs*OtjH*^yo^XTpB1M>-*@VKUN6dhcpX*_xYQ=`^Ud6=)32Y8JQ_ke&U?LXyT`vnZyx)3MIcu%IpJ@TGhpHS#1IHGMHO05|ZDY@h2FdNRNzv0WgLPMxmiMCl|YLg?=x=p?N8 ztb!TA>Yp*ZcCX>p@OF1D!NtVVY_AVZXv?W~+6Ih12-B4f7ELhP7ru0XwE7Kje<(@> zx>$f(agMOB*Q*=b#RFN%ZszL_X_05YZJ~-A@_9{U@|np&qOzJ6#VZbX-e@}TsMkfX(N|MO%mnfi2_HdN;_NMeq+cvPc_QT$HnokMlQ zsfEoiWg}HgvRbo|t=Z*%#$WVuAMSyhr*;W{dMzVr*e_#9=l?iB1VF~geDXWW0QRrh zLXRAmnU9bAB9$vsL<;5({9OnM#0yBKn_FFdP`; zIsm%}-T8m~bvh3hUDR@05F?hm*kQ-@#J#qZl%+)Jnk?UBH=1gz?AZkBVN&qjJat|T zFd4?ddN$*o3~(c7Sr~7M@a&aMmbSgFc+3Esb7sXCc(-kgnRCl9#r3qB#>!HP#=O2R zkKf?Y&(Ru|S*+D#T@hFq6A{m@)=BE9?uxmXjM+_1#9H_6nsY=z#B!EN?7W4%Gz#O~ zR9?fY`trHKs5i4JywB#xbY7xIJ+3%MZM`ErS;g(VN@0bj!AKs8NXL#<*^!DN{uKRQ zGWqM|*sU;LjL8~(7X7}dg&}Q)^k=o!zOg8`^>blnMZD3zi#%WFSaNPwzSIGAX+6Pz z@WQz#Fv>DyTZS6C`>4#}6^vq-k+0J44ccf0p|q3IO}wZzm}}gW zvAX=>#%rrY0>6@vWX}yVmD3~M)86OmCqA%$BG6Y{a5hd-e&8Ti$vqF$5Rm76T{9w~ zA=DPl;Ni75$%|7C^%-U+_&e^(LVjyyy+IDgG|>xa*?RG*)u1 zhgsKiHQh{%Cy+%DL#T%?=e*k`^~S77+mLVbRqwzrv59KVNU`wvit80rJi=gk|AK!d zBe-Xtw%~v=&t3CAE6freHD-7vtEp~}NE)l)tk1~3GUH{`p2_AKQ_9Jvm3dCr&}Re7 z3#$_MlgC^;c_KFlB-beKm$3TZb`Ft|L^IgW(lvcf=6fjj(Ho0zqg`p9qQW|nkJbs- zQzE{C6C9!Uh-^$h=OkT1rzjG=xpq1RSC^}1`SYV$=GvqDQ%9?71ZbMr#M+8J?c_M zPso6`(zuGJbt!j;?tSrI{Gf2k`Q?=`Q^=UiUIA+J8>f5TzK?E{ULrr+_1KTKdrEr3 z(X_ApEw7rjVN+`dM{q~#;b!@Lnt-!X2jrx7K7+Hbg@kA~zTI=M=#(ZSW3yVe3y*kB zp%7RXpEm5nzBzS9h;jB4{`m4|xgZMd;Dv`KOw}ZjwENgu!J8ygb@O{!DY4|8W;`3U z9UZJC)%shNpa>o67#|1+!H$wweku*Vk}Y;qKHQ@)|J^lhoFT$wyYu}#d6T!LJuSq% z=A_l%Tt62o9Id?UnkqNHkK4X?XHx)Osv^ZhJnox~1nBu~LNdA%@%3bU*zVQ`x^Jga z=(-h`X+^h_s5~$Ufdhy3f0~H=$W=eHmNoK*tLMpp(arG$40!S(lPP!K&{J+slWOBA zlTwpXl#xg&yflT!>S}p->QvmLs~_Ql>!^|Tf|V(=)BTPDfsb_1Aqdq3vl;C0rRWr}J6 zBfC4{mlSx6BemeJ6;j?{8r5&xS#%sY{Tsb)>#|FA{a-P2s(bT$YJ2cp6=(Q8)&1y= z2))4euTs6$hM;5bOu<80Q4Kvo#`c!>&toiN+Hn-8*(c5xwR{ zY|$BL!>B^9nw>lTVu&p9L>L=jgmvJ!@Gt7zX^;7C2wpch#0dhkg&rOr^&x;wT#js_ zaL^qq{W;utlx$^j+aWo?z=5AKB+)95b5}D6eW1W5}?b5i$?Pyz3gFeb=UZt%` zdL>56qCVmIB$84m$ry{XpWu$B=XdtxE%do^H4N{G({SZ zr;FcNT)}9R&(wh>enMOv;hEP~kWz@0j$X(935GC$07?BS9hV72@F(Cn|L-FixtYcj zcrM8q86&<3)r1UA0h^GG`oLs$vMr)lX$4G`#L}I__FtPlA}{>{u@J z$%NqHTpp2RXc*02)9!V{VSbw6z2V%yw7*d4Y{^O8(eDEu+7=Fde%oTWCBSv8Z_3M! z!h!Wct()96hF`_6Pi&RD4T${(ICTHd#Q))#KlGsa4g2oR*Jmhq(O&Su)<|QoV@zRw z+LqulXxv=+u-g^BsZ4e`JjzcaYyANp`6J&MQq4W3v}D|JT3k}j{J?P^U#cDtl&kJz zRNTDoD7x;kU@aJlyI3-pLyiI_hA5=)j5#!8O+~FS4_%wc$Gdttq5rt@iG)?;!rTuto#c<7d@jx}e&;mg%E@xQNie_a^4ecKwjbK+!iWUo%x-${5C zM1VQmYPdf~OJoQQ=`kaHfL`b4&T?_sCvg2+xd)M=D-R+2J#-Ob*1N6#=PyvIN+;iX zpxR_VdZ^#`GCYaqeKKEN^YA&lOLD)uVZ#(}mHv?kC@5C{Ux{(b^vCiHAmzatZpD?p z(kV$>Jh4Gm!=iWQ>D$gE3&q*bZQFH`kkA*VQaY>HeZ(x}WBIteU2v+XB0QsT?DB7k z+K-JX?>y)GROZzZA;xgu{FF$TfMuw@Sd1S6A_)L%o&WbP0T=;{+y;Cahr}nuF=x%5=VN6pmiZN9PGvyw}N7m>LuP?VE~KuP0&gZJF+?_#bUB3fZe)&a(oQ3y`SKv{tXX%F)-|8$$euBVQUqDW?b~ zzVtjxITV!8&F|Wr##BLEee2fD61Z-I>-g>+8m|t9?_0mk;ih*?&}ZKY+Ri;9s5hqo z^;ptdblof(dj0cVVYFgJb1Q7;vAlEMWNd!UPbJU0tAvu#OWYVSyYn< zD1A<;5Y5e_HpI^+w0~_vpkYPdyJv;{(B3_V?e3$^Y2I?^nSt3*#rG8vk`qaF!s@i5 zb2p2}RA1kZ*USH^7RXt<^4Z%IjmF2%oy2LL@7g$x*O@2i^eKr2VLJC`GbLX2S-BV+ z#>`)jw%-{fbQywdVE$A)6Z6I;=8xoe&;hky2M*{yC_<8kUvYb+E5eB zcup|=!3UJ{H6-X4=vA@0a@3wV4nrM0X0cLAUbY7y*kjV#^BOPC+%i5CJ!!gj*E-W=*L5{}sho90>nRCK)s zuc_TQwu>|l3Q91rr%vVHgXj}Q3!P~C2s_`qG5~r21wJN?$vfic>H8F5g=)Vf1%-`+Y zcqsOSoezhyE~I@9&wQUqGc3ofcJbCbled>K`yLAs7rfLIhFThMyPdy25k0AhMtrz6 z#6abrMV+9%eu>aVKf$CL2aP@}^Q)x%*AfT$Gn$i)Zxa1n9-KF$ipX;i$DS+?MRhEa zc7@%Jj&i%K8;Z^_wf$nf;+ap`^<2#&*|oBYKDy9i@A;Wbj`ha#W_MS;xStCSsXM38 z8!NOdZJLP|Wth?sy5n<&lYP{e(B%kLk&dwcHe9-Yj!7$;kTnEX%atTXx57TZUy5JQ zR3LAor}`{MLjN|yY>I+J$Ke(|%k!&#y|oSZ2*g(C$c$RDQ*+`H7c;5NFVSxg3iufH zam6V28m{z7E)t?I+*rzerDn#6N0+j0cJb3yO_G@)EHj<)?%BdSMbRsU^6Br76~ntYn^!^OxkSXHqPavj4*UZpWlF9vqsTnGLWCz2J&RMi*Fi9w z8HD+9%JlKPkE__;FlbtjwNAnz_31a|sdB1#tD)LGwQPKyw41Fh+Vch8ZtejvdLoq0 zdK)31^Ir>_ec(9rM7tp@%edY8-h2`raWBhnU%ojuE={-D7p^wHaOs`ea{+2wiOXv8 z;w-klM$>)s!D7+iKv2lAg|W#V{Yu>=(`V1ipD}gzYt*F7gxSjUv%$*Zk6=MO`lg>eHlp#R zMo5bbu0QQE3wB_9T@N9WP?^A>CTsuT98llq_t$Yrmzpwi}YQ*Y{}kE zWg4rdRK9ZuBjGcMbh^|=*_l$pzdduHB?=f-=p^pg#$0>7^Nu4`#4E%SKB~61;v0>3 z5wA{;lGvY3EIS|_`$=F!g?RoTD-|bR4F<_8xx8_vS%v2wkiKlK51Irq>^*@lm^q&I zZ?0c>2ETI;ZPxruPwX@2(Ovgi^^&?r4niL+sQB4p5rURkJAJG7qJ3XVTvt8o^ElFb z&UEmgcC^dq9l!IVL<`dL+E*!+dK#sV$OFqgwnTSsx*e=FyL8`Ma?hEqr>axM$!^CP z@T3ySHwjE6>pIVYctChBqxUA(Ox7EYk5|tuyg_li6<4y5Le&47gDU<^ZT91WH_`hr zp%sK5~aj-Up&EZk7vc3ZSkOwZ{9$+;&8!=zs zsWBba$vaiklCSYabAPP6LF>&YlZ}t`BXo+PGaA%|Vxz(w_&a_UqW+xGUvwL8bL|j4 z)H3UTSm4tYlwa1kqdK$uyc-l`yOVTxbE%M~Wc%a20#{d(@i>kL&??#xw)kxonH|`J zkLOxmk28x{Fn3cQ*bN81tGU1b$;|n)rZ?V&Ghz!*86+ly!g1Ia)+-2>KEZG+wHB1H zAFb6ZQop5P=MuQps4!0RDk+xD$2;i$w@1Mg%lEZuUru3FIj!vWL#4Eaa`+BwKbq$~ z)-*;npFZWoo*b6EZD060puu5Dl1d#5!o(`j7yJ{KA!Wv^xjdE( z$U6!g7l7j*A8h#h&iface{>zZPi64{6pT41J131JgoUqlpdsV?PEy;9)(l5OLw0M& zI19EnvvB9y;tht+_uMwiTEG<;xL8WhAE3p)=@U206LVJgDqG9DGW*q}VN!}cn;+dX zg+d?qJ<(E(+pVgxz^bA2#AIv&+L(q9?^rTP3nJRnhdzrI-?(W>B$Dqb*Q-9yXN4uyX&yt6Ib;b?YfI0sB$46dRTZNxn!4PeDI z$1LjGH;72xm-$Q@ksSB*J~U!}|CLe1$owc%1iac=Q%(=9kTQ=37v+>EQcDJ#arPI4 zwga7DC@_st|MzVPk}>PwdJ`|B3vO8g#BH10#c!)AYK}~xr6%QqgCE2F#iq6M#&XK_&t{qA zgtCq$W)s9XY-#DIJZI!k9wXRXPGfFWF3k@UBMd$>Qj_*AbyGybydQ7H+(GFM@5K<^ z+?NS=E163id}Ic#uHSizCeZHxKp>!n{S&ujE%s-HI_3HBFOhJ?5_WdQGd&Yj9+(g} zlMuv&0~G`OtrxeYVbAO(B`J0%BVR`SWDeq-&GF=N43ovP3x#dG2KF@{uK94v711V5 z?te+w6!}(6z4Q11gyE3j@ro4{ZE%r>zur=Bi^&YWrY~G6V{|!Eu^>_sWv`5JhikQ3|`WZO~obu86o;ag*cz8E(3YO zcbA=A^jEIOZXlT0+*?UvWlC$DX6~z&=-)J~7ZW40W7g@s?loMMEw;)N630icA2a{> z!DU|&l&qvWYDwHdwRcBKt&Btg`2>+6+oqoG_ z*XC_0dW@1SOhDU|ar6x7EtZ^2eX`9uo=h20r6!R|^UmR1{pSknhbz(NpDV5si=Zc~ zU8vTS3RLG#TU^q3vn2U&Du4W|n4Vjn_m{+sM*<27dbYG+rN^J>J*BV7dw9QiRiuwH z96;mqRLsLxYx{wH%P46Rrf=uPrI}*Zr**I50x^?6tZeRm!GD&!^5O0I53F;RQt+0z zgHyXMk?AYT;yy+<5GZ*-py>bmw(_??`H{j-^0${!4Gh>PHjVy

lLi)g!4vD+KF& zBmt&@L#g!HJH&dVyd>%BA%*#?>t7R63nX0YE-|jpv;}M@P`yt(gBZ@v5A&)I-ti9h zOL`Wz;)qxA#UVa_u72Yz&z+!m4tgy1Hkz4PM2b{gPPBFzhG)TZ zu$;6^(b_Rd$0t3hFfebuZ(5OpYkKoYa=BCsrslyYkM);fc#zRP9cF0)9Z?o)7)WeLn0byaKBwLejK2PUl2FU zHP+(zw$v_RuHz1Fr{>A})8$RcKYA@@4^{BRVVt?_e^li^ekB{r0 zREKJ5$SsO$c-rsTU)&rVwa3h$F&H#$EMjofPaG$84%~kPwaf0Me3USDZTa~lxio^( zA(MgKiEM8&b3>^BBdq2%sM`RorQ$O&9#S@Ltv7p$T?G%7MK0TAr(>q_w-H;VY{CQ- zF1;B2co;mH{|r$rw?7c~rXK{osl)I*A>{SlB!@MHdEt?@V!~1LiQB^S+(HEI?Alb< zZZ!#AT|%wg-L|+Y>+8*>uv(=I%RKXFt$R!6RS`SCpvCgieyy08t79as@E6wlmb}EN zHC>gkV*ZO4Ym?@7q=e8;mp)|Rh*48nVj>5?YZJU)3i# z;z5Dn#D;Kp(QP};Ovcngt;nDtSIk{NNGRYrxELdN)({~=D>l?D7?!B0F< z$ekiU2@U|~TK_(KoKnJXdE-PM+X@GYbI&NDyEhfL47DM`;iNwO!$Vbe5#G+LE3Z7k zc}1>odTb#yXtvn8bJ7?foCTD)qZ45gb>1pA}+r}wVd7SQbx2V_ayazmtBEV6Va zeYn$;`UrG0@ea7wPWD37j8nZ_8YMj85j_LiN{1!O<`nq~DP61Ziq2+2q&|Yt=;IZO z9>wX~t~2+{GEADoHY+Z-wfhGK4b%KoN;UqWdJ5LK5b_2Ppc53if3Fm%|SjX zjTqrwVH{Sz{CMJ4j~#D6cYo$U$GZ9;-`UXk;VW%^n<7-SQi~zM;oS$l%<5AKx3v3~ z>UMcbhsk8Fs^?8}uja7}-UfdJ)B2Cufqe6yq|3e>u(%{NH&K|+Z9(qo-NMMJq0~dw zqvYZR<(ddGikvG~>Wvf9!%|Y43p0F+P;L5p=5?bDjtrxd-NT!{oGwfg2mGz)mmr;r zpCY~AV^Q-95alRs5cT;HZOFvufMssf@J}Rqlo5FQ<4~x3$H{4rZ=*Q%))vUpz&~Gc z)YH9uiBO(y*JfaYLXxQV?1&gGxA@(G+9qq0yUI0_GsaW-m(ID!QElCY%PCA1Y=cZ4 zZ$H?LB=ontQoPp%ZB}l+v$3%$#lM-HhrJf+v`z9tRi9_xw73qf@^XdX=y|UL=PQf# z0Xnya`am5?4$@5$^o_SZ2GSAQD9y$>^e0z;3^D!KMY-EA^%1?{jeIfrYCwSF4M&3g zQdC;m#K%c-IBr)ZzbIexLfm0|#=o(n`T?ajp3gts)imnP=Kx#f*XJ$0T0cyDiP=4W zpkL3@r=O+gau%OBdGBhz)q|u*cP^{jTlrLZgzL)0F;4_v^Hhu6?%~#W2lsuQv0Q#z zB%wl;TAgQP`mz)wna%xE-3%6x)y|d}R)PR;Vgil}|NbtDEAsnktdS380AHU6e9^-9 z8^Qq4Ks6lHSkMIS2^-AM8|d(%!IPnB$%7dHhqgwBMGqX8Q?JZ_wMog+CMCD z{QSP@L3&}?8gyoA{01Lgq@jv9g<1gj>UVeEK1o68B&W3Lv#4yuInU-ZLdl=|F ze58S+9(9HWx>4XV}U-t3fe zt1a&C&acyPyXPogrV#9&agHn0Q)XM}A>~;s+dH-K9w~gOp3GV{Aow6~==={hIQmA? zAHx6KPKAuoV_gtOY%3jh|3w+4*9gTVp?sx>GvVG+?c2T#6b`GY`d|_Vvw|?G7erXm z<-uaZt34!bpM2HMg)&!ATWGhy=X33+J~U3=ZWgzD>C#Mp%e0|iC|OQFEnHSw&FTTY z$tuc$Z`=z*SVjW9PeQH#Gk#s{CGWbGOu=eqsuA5>!RtzxH{<9$tDio}=Q;RUZISAb z>0Z1n2dKjG|Hc=NZ;XjPZYI1cfP&FUdC_B%^eJ;PcjRr#Woxm9tay{V+W}9NmWA?7 z>tX_KR=n-Ba|;x~=E{1iQBl{dQt;u>MEzF=@2b!gC;-esfaCwbUdIgnC0-0U_&9-t zWdtNF;As*dp(+5|J}-5ea8hyE+uhAg4ZSXO&sfvg;A-^%G;Jg`cm7<1<_eysdxH{| z3ceoesho=qsFZ3o_=a-WMsa+FfgU@sT76^;@lw zdlqh1(mS@4%|d7LuYprUvgZ6M{|}3S zhc6IyfrtSOMEl&>!e}_)m$`;-BdBLb!(I4v>i|!?AX=-PVn%?t!f4hBJK_v&7^+}-Q_h(pAKY{71cTf1F=VPcY(noY@s-X+ z#}D5zs2MExKR1xLSJnJxOAdrS*(C5$fRxg>+l7i@ugt7|x<4nksF1hA0L%GvC$Q!J z`!}{AwO~z7U`Gc?PXipP|3jTQ$ulA+UI6G+3#k4^QTkj!iHp`Z;26Bf(SH$mIO)Pu zlljxd4#@<|Fes89U;ua~6fniVuCd=uam>UIQ=H5u{(+yx(+o*-Z(Mpx_=GG5V1^8k z!{~p{zM|I1Emz2I)b+LnzJ~l5g&)^I*Em7sK1$W?tasO8w)cdDYABUV?QGuJ3*hjOlnh zvUefn;MD$aq)8M9HO8(18Xy2PpaT5w{!p^V zYwI#%Jm)6aWWw;gjetqI{!BG(&qt(HpA)8pNqrN&uW#bvKxHxwfdxVi92Yj9RI$x%RKg;sn#PV`^Q^OkAiy0*j_O9I-ij! zDwg!&jd)Lb@eVZL)Q$_JpoK38@R4^jcmYBG2Q2)Hpr>39S!XR1nu)p;2vokR?_Nvd zd}Ru4>R`>E;5Np=6xo+;^;W=7TN>DzlnJ~cd@lIOnO7ORV?G6DA0~YSB#m}iUy5=> zY)8l&hN9yoRNo6_7U50L0O=cue5plJ3y*50(P#sc2i6^4|y z$7F1kasgH3w4qdjmFG3fog}s1e(pKd!y;wB6E-`d49Je$jQ2n62R)Jf`)(6Jk+C|X zhPpAF`s0S037q;di)GcuWk&Nc=g%4I#Te@iKH=9e=IB>97U0v==g_$@bYXy7zmLa6 zyP!&345F*$y!=)1 zicr^r!m#t*_e9$&+gw||g2-CV-ygLBGkSq9PcmCfI2Ns?EyZt`8d5HwEB5u${1Vl%tTMP`S_ByGBys1LEZOfm zPUVvHTtTsaX{I zJ;yqnMj|BkrkdY1=@^;=Tr#Tbk!$=u()R_kJ)eKEFH^3=u+CVNgf1YB8x_t#(^`tF z^C!4(d<`RG5+@^kEFL7u6T&dEXHvADsbuFSk#rwObFV=AJ5!hJrp}* z?IgMj$4;d-*&9^|;wT7I4Ba!bwvqP4`)#7_O{6$tT^zUIvJtc#;iFw28Wkr!)F_Fsso=XZEofjgUP;N0 zZIHetUCsJMAtg{UmJ0_IzilxnnU4YBrUL2Kr86V9SnW-n9nb-1ras7o&scjxu{WN5h*C8J?J@z|+OEXiqCwD&4o@0&>HrmloHSr~h2QN+M*s8( zdRUl#o#e?CjH#`t4;xERWqWK_1$d5ny9`ldjCT!RrN7z^{y2$d3cpF?n`r{gH#%PT zoYA=E#WEG2VqMn?)a(xKW>2tT>(Zpl?F59@MnTgzPN>`o(!RUbGp^z|0t44ut`|FZ z%+}dqB?v7&hOTFc>szwkVdiRNB5;%Lpy9%m7~Curj{2x=9whaZ7j+b|JF>#D>z=yz z7sPzIB8#_M>0yW*eBv@?r0y1-Fzta1Y9jPRNf=>)5Rwt$AdFE zU8A3^`@U^oI$mP%_f4Yv?eIEy_4lU<;Mw2)m_Z>Fx_|7uKx%X`z|(aMh#~#k$BI4p z!Sv4pvG}o_`h9(=eCG~W(Kh?J;6|w`y%ZCDcaL(v66-6~4f?KjIoOxs*71iMu?}~9 z}*F#P!6`7ZpnraIq)Cz_jfgy5A&5BMPfzD$4nf%_-h(aqY(*2>)Y+YY9s zqdwU3*Tfq9f$QpI9VLGotTGGOG?khC}k7 zAq#)8_bFx9kTA;*t6i7AlXct4Fj;ly^c90`A?^{FL6AAEB#FsE^nnnK;`$ z5Pd@9nMX8H?K*=**CA=KfB`JmGt_5 znne8Q^6yXo5ZFV!{Ns%a+28iqK3Y+%qED}a2Z9qC0KoZEI(WwwY(L6ka@O2rC2<1m zM*;Tig4rWOXHoDIa2kuvutn0=NPN|-D5>sil!}9;>1|Vy?}G&w39>|$-9>9 zN62C9f+Q2;ayiCPB1!^}qn7VhP8qHBNv>SkPYaqZuk4OSlgBfXcN=CG1d;zirM;=@GK0~466TW-<>{#6o4B^t_@B~h61+<^ zsTeKY@iUEXyw=Qn&na*{I!A^<3Rb_4Gdlequ9JfT+(D380-_@DV;@Ext(+-)YYlHJ zi-)NNypRx^pe#FD3kHsha1*pqW=KDKs1ps{x_{IA&Cs<2x{%dA5~=+tw&i{-?rBf` zC|=d~vOYJl(fxdM6Rb7%y`RKGrR0VTwmc;iAUw2SA`LMyY3OTol%bTLj>LrRN~2Bg z`4WvBIh&Q&QkECC)PG}lrJ1L^hwx@sk~0U(yCAhncqjEG3JQ3UCp zxs3gTRguVX^4e)<-@a#igCU#qT0p(XepGwoyV@gGI$R${aT8hy=f(O`ibmm+O(=$A zvJJ1qsiIH>+Tn4w%m`Oydhk6Ob&@e18)zZ1tX{H7wJiELgo$Y{18ZbZRX!qbA4*(c zS;_V!b7gkpaC3C~N%0#(uRTv^HrSh8+T8kuhDdv_)oiU9N>f_9LdH^R7D*~bl~||J zm{Bdq4rzfSy&3-Q#%it6L(D^JWhl07=B!A^*G=|v{Pzr{HqqKQ7B*(@eqAVf6tTj|4t21jy0iE7OKKU#pizGKdoD7x5B4 zu9omZ3*$oeR7YpL#rF^oEyi3b2iOtSt^78x(g5wQxHfgjXQjm;#(K4VVK`*!nLx}I z_S<>bLgr7A_UlL_c>`o#RmxKj1?Yc*EQzPy|;flWjXd(_Q*v9&JaUD3q_Kk!cm?v3#!YIsu?3 z{l!&1v8kH6##>_c4uA;^l$z%QnRcpVHRzFCJl*!DsL``_&(shZJ%EZT#bhm3HpC%w z0|rp8*?bM~x9`?N+1Vmgu1FW6XBQqhZVpw?rx)?V!c07dW$Ps^g(_iskP?y^5h{j5 z)f@s$2KLDGypQ*igynCyET#RV0g{DP$;u!?yN$!&E`y9mTn&vyAsvEO1|6ubo~Uk? z3xeh-=8s{TB)&Jxt%z!Fg3G2~_n6L^eMX)S~W&vKeHk?p-C5j zO7wsBxfyAg>+yRR+K}nA^aK;O&e2LceqF-rzU8JR6D3mdozK#ehwPjq8B*D}%s!~e zG2!3sIozhm&Til=OJR;=x&4UPPk?S5Ef-P9vA_0hKk7Ot#^sv#K+{%LN9sD37ja4{ z;d^ShrH0WCU7E};*FfhW7Zi(k$&`0$pAe89tZKIuWsV-Rn+SEfl%=~M5;I4Y(tbJ`Qg1sR~Ir zH05iIJa>MTBQH0vn{O)FDBcYVX=Bb1nD@v#7$2KV&287}H^nLAx|9hSeAS0I#M%My z(`pTj=jH_O$h>3z2j?}uPu+j*3-tf_95^02#)Db+geB_4P>KK=;h=ayI~^k%?W4nJ zxszkuE8;M022G`A2h;3uw&Mx@nD{3Bc0RHi8_?KbxKu|q zCNaK12ML&=Z-%*=y?`aUUNV2N+9C$9Tjw~mXF0aj6w0$wx&E4o6Mn2c5h_ZY2tKu& zsq~9_BDt~oz(>uZu9n&RNO=vUaI%Fr`uC+j8I4!1C|IM%Y1rk?^#&A)-jbemyc#L& zh?%@knnbUWF4K~HYl;}{C4#3ki~%WT)aP7Pj6^f9g~ouD5s-ML;cJ&A(*8Zw9FP5L zH41_wDiZnJx|>aQYby!JBX=~TGkFCi@dfHqA1v(NyTf?(2!&a3h-b`Sn{qgkpnS+! zjfN1D4o5}|lfeflpnrdaF zJ>!~hUGblP$0UwPT$;%kz5^N<>!IYxr;VFkVeRf``waU?%5>*VJ}0)7&Z@7Wgz$`S5~KjdB#16Vx*)OZZ4y+zOa53$ylA(r3eGGdOw=KvI&Mf z4K~?QuGySmMni5yrNIFqkq>b#M_iuFS>m0~pwYav8%}3ycHiUB$J^2$zl5OX`7s3) z5ViBFay0PJi+-dw)KU+zpcUVyv*W# zWCB{gkmXyJf~_SngAT*j3?TzR>+~G!$z|8nZQ;Q#YngYDT zQ3vepFObFu90XR@7q5JJNyUw%mkqndJ?nA+ZJkXeO_8JJ>rzJ9Ovy7oU%lBp;@G|^ za~0p}F;}h~c=u*70u`l9d zxy*8+atM|U`&EZWM!GZtq&F~Y1%j8dM)2NAOSr$7KasKZv-Ml!c<4LwTa6CPj353G46tXJC~WjDmQV8A|TYc+kG`*w_1 zN}X%VrJ|^u#;N>xnbWc{c_c9AUDEXed@T0t0QL&e{3Jw%6k&>K-|ohqz2P9r2cS3O zk4kp?bUWy5+@29HtPHc9ev48i_0`h4O*V=JURi2^?{5FJ*1@II(w}#|zOORD-+ot8 zbQPv~a0817LQd>dDv6jF>dm;aWONER%?OxS^E2}MkQHZWZd-<1-m^l;%RJmIBdO?8 zN7=G8Skw_FCL`mw?H+La{2B?lHUkRYr#4sIK=GQY#`B}MM}mQp8Z@*`-fLI^HY1$4 z*Iyk8_O^EVhG8?uy`cRfF@8X}DyynAuAC z!z*2MJKQ^AN$90kM6TVt;c8m-)|;Y_0zb{Y3*B6*B|q4z8sR_K+8uouWjecNoYqLE zbL`Q_U%UE%w{{=rRenhk!JPU%VdL@PdDcRgwlyuu7fX8VRVg}iVGTE9s8AWr?zkAi z1d&H_nU-Tcy_sKCaaBv~9X-#cDQhQby@3h5Mdp^))XOj@Wa$p~(R?!wkS{8tSgB=C zvUvqieofss%SJ@=o(t{c)^U~>lY$|iV%tP^wu#u=m}E5JYCfL`J@i}{^>{Ad;rb$2 zb)A)}BYT1Xdq;Q>vlKr10muCkM%T&q&6y*+jgL!c6dHj=07j`RNN)ZxjA96e6t2P9 z<~IcR&{MAva=<((z7>vbmX2dZi0ZHbi zA<^jc&2Z#MY*?>Ra$NnBnXJl6GJ(3Jot~>ioxY&tn-Yxy@3;eu6<%LIYK_*@nt9f1 z9n$N@6rev^2Q?oMH;YqqQMKUAcJF&j3QWE zSml=Q)r~mG-Vr3-cJu;jG>=th?`pg>IJ%g|Ixqgu4WDSOdluVlZmx+G#6I5J@yo?- zxQ0zTIBH7`Z!>~3&w{Zsj$91Z+PSq?FzprTZCJ~G`T{nCbU4whx!*42+CJg%U`GZx zE6BlgOlnvsB`4aXVjxp54aZA|As>_#gM}+um{*_@&kz^M?Lz9!^l;XsD$x@sh6VR% z(6R=^DzyISpz}j#wDlM_gSpbRjOG4GdpAc}-tqX|SLw7AkL&_zaZ#eYaW%-?_Czg{ zUw+&O>oT=C*0e`URrhzL#}(^X;K6{>GJ&Sz{B|o7h-4X5094AxG@W`19jlqE?r<# zRQaT+EnF3?xFXJVpB79R>`ob?QCT%DO@0|Bl(!!D?iVxVOUvB97Lxq1hIhGm&Od=M zNhJ|8<*He@@GP8iS?p6e4${TM0{LOr8iCb@Bmh3hDkk zdj2Xih#%U51)l_9CZp;TBJhIisxTv$h2l`eBWdkWOy&QbA0tZX$M>J)pF zT7csA18ru%kdN7xS_}<3iwOYb7W^x6ubl?!#6e2^H`xkz@OC0Q+2yiYl&x7*M9t9ZWi|^#b47_rGT}42 zcjZn`iSO=!=|Re92D~$#7^ulRWmx-(oY%wU94X41Z>>gI>gpTD=*mb)<vdQ3W4=yXgegX?Y(3+16BgTGsBfe(q&{N?u0 z_rdgM5hQRa!0+E7UZ{=Pj7efXm{XVQf;Nwji5SQr{_tLxeK8 z46rBO>z0-MU3X(`gn6RS{pr)45f$X9xfMgGZ$equj~>R5-D%k+vQS2hWUYAZn|Qa% zHNMkA6Q7|p!s@BlbXF3NC%HCkf+fhrCm||Z%iG(9%$9I_)fu|mR@VQ{Y@U?E?Oc>l z{}q8}s*4O`q-IoxeqY6wT58IR`h*Oudf4G=qPQ zf}k+5%mLn!H&Nrw;^@9So{|&ulIWb?Qhz-RvdpLC#jHNWng#MqS1lw{+OS;?XJRda zH3r>5>Q5L)Uc;_w(Q1WV!yV0jK`7{xa8KM8WEp!w#nmW_>pP7rH(|&Zo{NGE6RFnq zR1nd{y10?>9=i$7Sv;*-M<;BQ!J&#V>3QFjD{`B#*afZF*8Ncf3^w1?E01exI>BKG zux4M1w6w0?O<-cOuO2S9>-G1Jbocz)hseM#)!jK}K2uG8C^B9ZQ+d;1X~%yQ1M!ub z;1X^TR~P2=xc6W(2ovUT)ZaI2{-s#1W?Zu0IF68S5vLFTZNSmGAl=Wc1Ru&940WBODtem=HX#dcbUJHOu;FmO)v0| z&(Jh~c@<>6{(AhzRBy&w+E~>nCQ%^E)$P!GyT{S%b(p3vqphDWXpOO&8tCPx&o?0R zf^OvHL(ko5Cr{&Yig=g*APw{O$r07$MvZAoqwvEqw^5Qe!6Pw7??s67)k`fSE4gMO zx(0~8q%I_>Dc*JyFi}*yCIZ_Z9NwDs0HvvKHFa|$l5<<;P4LH9NA!#iF0c*7amWfb;Lk$WNPsXZ?S)aE9|O=aHrrdB~4 z64*@OEhj#DDt)(mh&TJG3t;feQ}n=xW@4ZtEpAJ1zRVU*dHuDLf=JB8+*%g1!Ey}* zw$Pe#Wah1nOx~wFxAf^ITg}-uWTiF4-)8c2?kk~D8;-5?T$SLos?joGJqkj?dRXo; zowXBg^m$mEYJZ~^tBdgnd^iUR8W(^IzMFA*H8t=H5dZ%64%d&`YLIPStgQyo+|RuM z&)j6aauD?r?7|Lw$j0+5WiJ|KQk--zck$CwTU1BmsM>!1yq79bp9a#qJ|4( z`xk3foVE@YPJoZ~{IvZ`D_1}=E*kVhGNQr9?|;hpb3yXMt{<}Xi}vl1t@mO5tJWdS z+#w+s-L@eiLEy3c(-giBfQz=;|IT|GGOCNV+mKP=;{7D5A2*&)&tm=Y^%@d!nMdv^ zq~prJM?m_Y>YsDWg(P1zy*=du0FFfejr{+!n&*jU-CZGxhv1{bf7{8ITu#Vb|4;mJ z91jwGnStpkJPv$v`4`dW>`c!y&%1`6GGoC9m46TOFB3j%(|L*pSHvXy4{!+6&hzP> z_1=Ue3XuOE;-$%6G}DAc&;AGWUs`LP&-|>VCL~_}+OKDR4u95Q^Lz+r?JyxjpaI`* z{?)Pew;^2G8-IAaobj=QjAifFV*xK5AYCmX^Z&*?>*)x|G^G0F{Le8jP57d-Atd}g z^)JIAy+k0hz3A`<2^0Y*^K;rwr{>{IbG=w?8`E<|P4?yyUd4C7*(nK#x{2{?he7_9-ejpPv$;*WPr!*z7 z_0lh1)U&dGNaQz77;;%XH6+l~3uKqW_uwr^@Plx@YCbr$7K;|92rTP4}CM?5vO&l3f56 zm;LIX{@%NP%8DV={f0cR-93dCi2o+!U#5FjF?&h|0A5M_XZD}c)${3|)yG02xxu9z z{^J!srHmtpICXrxyyvBrr%X+m-$T4K*~?Utr)VVEe~SJK%_L-(UX&W0f&c&( zu(IZF-$K7dcmx^GMa2TqN`KHgRg&><&SNcb({?YWQb_lZli!vX`_K*Kr z`#&}We<(nHJo8tgAIKQKUB2^jpVKJZ!S!SQL3jS8_y>}7nat&sv~HpI(6L@$uBTqb%sjm1LcXR%x^fq^7k6gr%?4*mXU|hQGpsIA;fmx_G7p5|wrLU!ov}0VL((DFaB#uGwEv&fHxC ZpE*#Jg@gb0mqOqlW3b(Zob|Wg{s$+-buildversion.txt -# -# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. -# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# (C) 2023 -# -# @@ Meta Begin -# Application textblock 0.1.1 -# Meta platform tcl -# Meta license -# @@ Meta End - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# doctools header -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -#*** !doctools -#[manpage_begin punkshell_module_textblock 0 0.1.1] -#[copyright "2024"] -#[titledesc {punk textblock functions}] [comment {-- Name section and table of contents description --}] -#[moddesc {punk textblock}] [comment {-- Description at end of page heading --}] -#[require textblock] -#[keywords module utility lib] -#[description] -#[para] Ansi-aware terminal textblock manipulation - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - -#*** !doctools -#[section Overview] -#[para] overview of textblock -#[subsection Concepts] -#[para] - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Requirements -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - -#*** !doctools -#[subsection dependencies] -#[para] packages used by textblock -#[list_begin itemized] - -#*** !doctools -#[item] [package {Tcl 8.6-}] -#[item] [package {punk::args}] -#[item] [package {punk::char}] -#[item] [package {punk::ansi}] -#[item] [package {punk::lib}] -#[item] [package {overtype}] -#[item] [package {term::ansi::code::macros}] -#[item] [package {textutil}] - -## Requirements -package require Tcl 8.6- -package require punk::args -package require punk::char -package require punk::ansi -package require punk::lib -catch {package require patternpunk} -package require overtype - -#safebase interps as at 2024-08 can't access deeper paths - even though they are below the supposed safe list. -package require term::ansi::code::macros ;#required for frame if old ansi g0 used - review - make package optional? -package require textutil - - -#*** !doctools -#[list_end] - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - -#*** !doctools -#[section API] - - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - -tcl::namespace::eval textblock { - #review - what about ansi off in punk::console? - tcl::namespace::import ::punk::ansi::a ::punk::ansi::a+ - tcl::namespace::export block frame frame_cache framedef frametypes gcross height width widthtopline join join_basic list_as_table pad testblock - variable use_md5 ;#framecache - set use_md5 1 - if {[catch {package require md5}]} { - set use_md5 0 - } - proc use_md5 {{yes_no ""}} { - variable use_md5 - if {$yes_no eq ""} { - return $use_md5 - } - if {![string is boolean -strict $yes_no]} { - error "textblock::use_md5 requires a boolean (or empty string to query)" - } - if {$yes_no} { - package require md5 - set use_md5 1 - } else { - set use_md5 0 - } - return $use_md5 - } - tcl::namespace::eval class { - variable opts_table_defaults - set opts_table_defaults [tcl::dict::create\ - -title ""\ - -titlealign "left"\ - -titletransparent 0\ - -frametype "light"\ - -frametype_header ""\ - -ansibase_header ""\ - -ansibase_body ""\ - -ansibase_footer ""\ - -ansiborder_header ""\ - -ansiborder_body ""\ - -ansiborder_footer ""\ - -ansireset "\uFFeF"\ - -framelimits_header "vll vlr hlb hlt tlc trc blc brc"\ - -frametype_body ""\ - -framelimits_body "vll vlr hlb hlt tlc trc blc brc"\ - -framemap_body [list\ - topleft {} topinner {} topright {} topsolo {}\ - middleleft {} middleinner {} middleright {} middlesolo {}\ - bottomleft {} bottominner {} bottomright {} bottomsolo {}\ - onlyleft {} onlyinner {} onlyright {} onlysolo {}\ - ]\ - -framemap_header [list\ - topleft {} topinner {} topright {} topsolo {}\ - middleleft {} middleinner {} middleright {} middlesolo {}\ - bottomleft {} bottominner {} bottomright {} bottomsolo {}\ - onlyleft {} onlyinner {} onlyright {} onlysolo {}\ - ]\ - -show_edge 1\ - -show_seps 1\ - -show_hseps ""\ - -show_vseps ""\ - -show_header ""\ - -show_footer ""\ - -minwidth ""\ - -maxwidth ""\ - ] - variable opts_column_defaults - set opts_column_defaults [tcl::dict::create\ - -headers [list]\ - -header_colspans [list]\ - -footers [list]\ - -defaultvalue ""\ - -ansibase ""\ - -ansireset "\uFFEF"\ - -minwidth ""\ - -maxwidth ""\ - -blockalign centre\ - -textalign left\ - ] - #initialise -ansireset with replacement char so we can keep in appropriate dict position for initial configure and then treat as read-only - - - - #for 'L' shaped table building pattern (tables bigger than 4x4 will be mostly 'L' patterns) - #ie only vll,blc,hlb used for cells except top row and right column - #top right cell uses all 'O' shape, other top cells use 'C' shape (hlt,tlc,vll,blc,hlb) - #right cells use 'U' shape (vll,blc,hlb,brc,vlr) - #e.g for 4x4 - # C C C O - # L L L U - # L L L U - #anti-clockwise elements - set C [list hlt tlc vll blc hlb] - set O [list trc hlt tlc vll blc hlb brc vlr] - set L [list vll blc hlb] - set U [list vll blc hlb brc vlr] - set tops [list trc hlt tlc] - set lefts [list tlc vll blc] - set bottoms [list blc hlb brc] - set rights [list trc brc vlr] - - variable table_edge_parts - set table_edge_parts [tcl::dict::create\ - topleft [struct::set intersect $C [concat $tops $lefts]]\ - topinner [struct::set intersect $C [concat $tops]]\ - topright [struct::set intersect $O [concat $tops $rights]]\ - topsolo [struct::set intersect $O [concat $tops $lefts $rights]]\ - middleleft [struct::set intersect $L $lefts]\ - middleinner [list]\ - middleright [struct::set intersect $U $rights]\ - middlesolo [struct::set intersect $U [concat $lefts $rights]]\ - bottomleft [struct::set intersect $L [concat $lefts $bottoms]]\ - bottominner [struct::set intersect $L $bottoms]\ - bottomright [struct::set intersect $U [concat $bottoms $rights]]\ - bottomsolo [struct::set intersect $U [concat $lefts $bottoms $rights]]\ - onlyleft [struct::set intersect $C [concat $tops $lefts $bottoms]]\ - onlyinner [struct::set intersect $C [concat $tops $bottoms]]\ - onlyright [struct::set intersect $O [concat $tops $bottoms $rights]]\ - onlysolo [struct::set intersect $O [concat $tops $lefts $bottoms $rights]]\ - ] - - #for header rows - we don't consider the bottom border as part of the edge - even if table body has no rows - #The usual-case of a single header line is the 'onlyleft,onlyinner,onlyright,onlysolo' set. - variable header_edge_parts - set header_edge_parts [tcl::dict::create\ - topleft [struct::set intersect $C [concat $tops $lefts]]\ - topinner [struct::set intersect $C [concat $tops]]\ - topright [struct::set intersect $O [concat $tops $rights]]\ - topsolo [struct::set intersect $O [concat $tops $lefts $rights]]\ - middleleft [struct::set intersect $L $lefts]\ - middleinner [list]\ - middleright [struct::set intersect $U $rights]\ - middlesolo [struct::set intersect $U [concat $lefts $rights]]\ - bottomleft [struct::set intersect $L [concat $lefts]]\ - bottominner [list]\ - bottomright [struct::set intersect $U $rights]\ - bottomsolo [struct::set intersect $U [concat $lefts $rights]]\ - onlyleft [struct::set intersect $C [concat $tops $lefts]]\ - onlyinner [struct::set intersect $C $tops]\ - onlyright [struct::set intersect $O [concat $tops $rights]]\ - onlysolo [struct::set intersect $O [concat $tops $lefts $rights]]\ - ] - variable table_hseps - set table_hseps [tcl::dict::create\ - topleft [list blc hlb]\ - topinner [list blc hlb]\ - topright [list blc hlb brc]\ - topsolo [list blc hlb brc]\ - middleleft [list blc hlb]\ - middleinner [list blc hlb]\ - middleright [list blc hlb brc]\ - middlesolo [list blc hlb brc]\ - bottomleft [list]\ - bottominner [list]\ - bottomright [list]\ - bottomsolo [list]\ - onlyleft [list]\ - onlyinner [list]\ - onlyright [list]\ - onlysolo [list]\ - ] - variable table_vseps - set table_vseps [tcl::dict::create\ - topleft [list]\ - topinner [list vll tlc blc]\ - topright [list vll tlc blc]\ - topsolo [list]\ - middleleft [list]\ - middleinner [list vll tlc blc]\ - middleright [list vll tlc blc]\ - middlesolo [list]\ - bottomleft [list]\ - bottominner [list vll tlc blc]\ - bottomright [list vll tlc blc]\ - bottomsolo [list]\ - onlyleft [list]\ - onlyinner [list vll tlc blc]\ - onlyright [list vll tlc blc]\ - onlysolo [list]\ - ] - - #ensembles seem to be not compiled in safe interp - #https://core.tcl-lang.org/tcl/tktview/1095bf7f75 - #as we want textblock to be usable in safe interps - use tcl::dict::for as a partial workaround - #This at least means the script argument, especially switch statements can get compiled. - #It does however affect all ensemble commands - so even 'dict get/set' etc won't be as efficient in a safe interp. - - #e.g $t configure -framemap_body [table_edge_map " "] - proc table_edge_map {char} { - variable table_edge_parts - set map [list] - tcl::dict::for {celltype parts} $table_edge_parts { - set tmap [list] - foreach p $parts { - tcl::dict::set tmap $p $char - } - tcl::dict::set map $celltype $tmap - } - return $map - } - proc table_sep_map {char} { - variable table_hseps - set map [list] - tcl::dict::for {celltype parts} $table_hseps { - set tmap [list] - foreach p $parts { - tcl::dict::set tmap $p $char - } - tcl::dict::set map $celltype $tmap - } - return $map - } - proc header_edge_map {char} { - variable header_edge_parts - set map [list] - tcl::dict::for {celltype parts} $header_edge_parts { - set tmap [list] - foreach p $parts { - tcl::dict::set tmap $p $char - } - tcl::dict::set map $celltype $tmap - } - return $map - } - - if {[tcl::info::commands [tcl::namespace::current]::table] eq ""} { - #*** !doctools - #[subsection {Namespace textblock::class}] - #[para] class definitions - #[list_begin itemized] [comment {- textblock::class groupings -}] - # [item] - # [para] [emph {handler_classes}] - # [list_begin enumerated] - - #this makes new table objects a little faster when multiple opts specified as well as to configure - #as tables are a heavyweight thing, but handy to nest sometimes - we'll take what we can get - set topt_keys [tcl::dict::keys $::textblock::class::opts_table_defaults] - set switch_keys_valid_topts [punk::lib::lmapflat v $topt_keys {list $v -}] - set switch_keys_valid_topts [lrange $switch_keys_valid_topts 0 end-1] ;#remove last dash - - set copt_keys [tcl::dict::keys $::textblock::class::opts_column_defaults] - set switch_keys_valid_copts [punk::lib::lmapflat v $copt_keys {list $v -}] - set switch_keys_valid_copts [lrange $switch_keys_valid_copts 0 end-1] - - oo::class create [tcl::namespace::current]::table [tcl::string::map [list %topt_keys% $topt_keys %topt_switchkeys% $switch_keys_valid_topts %copt_keys% $copt_keys %copt_switchkeys% $switch_keys_valid_copts] { - #*** !doctools - #[enum] CLASS [class textblock::class::table] - #[list_begin definitions] - # [para] [emph METHODS] - variable o_opts_table ;#options as configured by user (with exception of -ansireset) - variable o_opts_table_effective; #options in effect - e.g with defaults merged in. - - variable o_columndefs - variable o_columndata - variable o_columnstates - variable o_headerstates - - variable o_rowdefs - variable o_rowstates - - variable o_opts_table_defaults - variable o_opts_header_defaults ;# header data mostly stored in o_columndefs - variable o_opts_column_defaults - variable o_opts_row_defaults - variable TSUB ;#make configurable so user isn't stopped from using our default PUA-unicode char in content (nerdfonts overlap) - variable o_calculated_column_widths - variable o_column_width_algorithm - - - constructor {args} { - #*** !doctools - #[call class::table [method constructor] [arg args]] - set o_opts_table_defaults $::textblock::class::opts_table_defaults - set o_opts_column_defaults $::textblock::class::opts_column_defaults - - - if {[llength $args] == 1} { - set args [list -title [lindex $args 0]] - } - if {[llength $args] %2 !=0} { - error "[tcl::namespace::current]::table constructor - unexpected argument count. Require single value being title, or name value pairs" - } - - set o_opts_table $o_opts_table_defaults - set o_opts_table_effective $o_opts_table_defaults - - ##todo - test with punk::lib::show_jump_tables - how? - foreach {k v} $args { - switch -- $k { - %topt_switchkeys% { - tcl::dict::set o_opts_table $k $v - } - default { - error "[tcl::namespace::current]::table unrecognised option '$k'. Known values [tcl::dict::keys $o_opts_table_defaults]" - } - } - } - my configure {*}$o_opts_table - - #foreach {k v} $args { - # #todo - convert to literal switch using tcl::string::map so we don't have to define o_opts_table_defaults here. - # if {$k ni [tcl::dict::keys $o_opts_table_defaults]} { - # error "[tcl::namespace::current]::table unrecognised option '$k'. Known values [tcl::dict::keys $o_opts_table_defaults]" - # } - #} - #set o_opts_table [tcl::dict::merge $o_opts_table_defaults $args] - #my configure {*}[tcl::dict::merge $o_opts_table_defaults $args] - - set o_columndefs [tcl::dict::create] - set o_columndata [tcl::dict::create] ;#we store data by column even though it is often added row by row - set o_columnstates [tcl::dict::create] ;#store the maxwidthbodyseen etc as we add rows and maxwidthheaderseen etc as we add headers - it is needed often and expensive to calculate repeatedly - set o_headerstates [tcl::dict::create] - set o_rowdefs [tcl::dict::create] ;#user requested row data e.g -minheight -maxheight - set o_rowstates [tcl::dict::create] ;#actual row data such as -minheight and -maxheight detected from supplied row data - - set TSUB \uF111 ;#should be BMP PUA code to show as either replacement char or nerdfont glyph. See FSUB for comments regarding choices. - set o_calculated_column_widths [list] - set o_column_width_algorithm "span" - set header_defaults [tcl::dict::create\ - -colspans {}\ - -values {}\ - -ansibase {}\ - ] - set o_opts_header_defaults $header_defaults - } - - method width_algorithm {{alg ""}} { - if {$alg eq ""} { - return $o_column_width_algorithm - } - if {$alg ne $o_column_width_algorithm} { - #invalidate cached widths - set o_calculated_column_widths [list] - } - set o_column_width_algorithm $alg - } - method Get_seps {} { - set requested_seps [tcl::dict::get $o_opts_table -show_seps] - set requested_seps_h [tcl::dict::get $o_opts_table -show_hseps] - set requested_seps_v [tcl::dict::get $o_opts_table -show_vseps] - set seps $requested_seps - set seps_h $requested_seps_h - set seps_v $requested_seps_v - if {$requested_seps eq ""} { - if {$requested_seps_h eq ""} { - set seps_h 1 - } - if {$requested_seps_v eq ""} { - set seps_v 1 - } - } else { - if {$requested_seps_h eq ""} { - set seps_h $seps - } - if {$requested_seps_v eq ""} { - set seps_v $seps - } - } - return [tcl::dict::create horizontal $seps_h vertical $seps_v] - } - method Get_frametypes {} { - set requested_ft [tcl::dict::get $o_opts_table -frametype] - set requested_ft_header [tcl::dict::get $o_opts_table -frametype_header] - set requested_ft_body [tcl::dict::get $o_opts_table -frametype_body] - set ft $requested_ft - set ft_header $requested_ft_header - set ft_body $requested_ft_body - switch -- $requested_ft { - light { - if {$requested_ft_header eq ""} { - set ft_header heavy - } - if {$requested_ft_body eq ""} { - set ft_body light - } - } - default { - if {$requested_ft_header eq ""} { - set ft_header $requested_ft - } - if {$requested_ft_body eq ""} { - set ft_body $requested_ft - } - } - } - return [tcl::dict::create header $ft_header body $ft_body] - } - method Set_effective_framelimits {} { - upvar ::textblock::class::opts_table_defaults tdefaults - set default_blims [tcl::dict::get $tdefaults -framelimits_body] - set default_hlims [tcl::dict::get $tdefaults -framelimits_header] - set eff_blims [tcl::dict::get $o_opts_table_effective -framelimits_body] - set eff_hlims [tcl::dict::get $o_opts_table_effective -framelimits_header] - - set requested_blims [tcl::dict::get $o_opts_table -framelimits_body] - set requested_hlims [tcl::dict::get $o_opts_table -framelimits_header] - set blims $eff_blims - set hlims $eff_hlims - switch -- $requested_blims { - "default" { - set blims $default_blims - } - default { - #set blims $requested_blims - set blims [list] - foreach lim $requested_blims { - switch -- $lim { - hl { - lappend blims hlt hlb - } - vl { - lappend blims vll vlr - } - default { - lappend blims $lim - } - } - } - set blims [lsort -unique $blims] - } - } - tcl::dict::set o_opts_table_effective -framelimits_body $blims - switch -- $requested_hlims { - "default" { - set hlims $default_hlims - } - default { - #set hlims $requested_hlims - set hlims [list] - foreach lim $requested_hlims { - switch -- $lim { - hl { - lappend hlims hlt hlb - } - vl { - lappend hlims vll vlr - } - default { - lappend hlims $lim - } - } - } - set hlims [lsort -unique $hlims] - } - } - tcl::dict::set o_opts_table_effective -framelimits_header $hlims - return [tcl::dict::create body $blims header $hlims] - } - method configure args { - if {![llength $args]} { - return $o_opts_table - } - if {[llength $args] == 1} { - if {[lindex $args 0] in [list %topt_keys%]} { - #query single option - set k [lindex $args 0] - set val [tcl::dict::get $o_opts_table $k] - set returndict [tcl::dict::create option $k value $val ansireset "\x1b\[m"] - set infodict [tcl::dict::create] - switch -- $k { - -ansibase_header - -ansibase_body - -ansiborder_header - -ansiborder_body - -ansiborder_footer { - tcl::dict::set infodict debug [ansistring VIEW $val] - } - -framemap_body - -framemap_header - -framelimits_body - -framelimits_header { - tcl::dict::set returndict effective [tcl::dict::get $o_opts_table_effective $k] - } - } - tcl::dict::set returndict info $infodict - return $returndict - #return [tcl::dict::create option $k value $val ansireset "\x1b\[m" info $infodict] - } else { - error "textblock::table configure - unrecognised option '[lindex $args 0]'. Known values [tcl::dict::keys $o_opts_table_defaults]" - } - } - if {[llength $args] %2 != 0} { - error "[tcl::namespace::current]::table configure - unexpected argument count. Require name value pairs" - } - foreach {k v} $args { - switch -- $k { - %topt_switchkeys% {} - default { - error "[tcl::namespace::current]::table configure - unrecognised option '$k'. Known values [tcl::dict::keys $o_opts_table_defaults]" - } - } - #if {$k ni [tcl::dict::keys $o_opts_table_defaults]} { - # error "[tcl::namespace::current]::table configure - unrecognised option '$k'. Known values [tcl::dict::keys $o_opts_table_defaults]" - #} - } - set checked_opts [list] - foreach {k v} $args { - switch -- $k { - -ansibase_header - -ansibase_body - -ansiborder_header - -ansiborder-body - -ansiborder_footer { - set parts [punk::ansi::ta::split_codes_single $v] ;#caller may have supplied separated codes eg "[a+ Yellow][a+ red]" - set ansi_codes [list] ; - foreach {pt code} $parts { - if {$pt ne ""} { - #we don't expect plaintext in an ansibase - error "Unable to interpret $k value as ansi SGR codes. Plaintext detected. Consider using for example: '\[punk::ansi::a+ green]' (or alias '\[a+ green]') to build ansi. debug view: [punk::ansi::ansistring VIEW $v]" - } - if {$code ne ""} { - lappend ansi_codes $code - } - } - set ansival [punk::ansi::codetype::sgr_merge_singles $ansi_codes] - lappend checked_opts $k $ansival - } - -frametype - -frametype_header - -frametype_body { - #frametype will raise an error if v is not a valid custom dict or one of the known predefined types such as light,heavy,double etc - lassign [textblock::frametype $v] _cat category _type ftype - lappend checked_opts $k $v - } - -framemap_body - -framemap_header { - #upvar ::textblock::class::opts_table_defaults tdefaults - #set default_bmap [tcl::dict::get $tdefaults -framemap_body] - #todo - check keys and map - if {[llength $v] == 1} { - if {$v eq "default"} { - upvar ::textblock::class::opts_table_defaults tdefaults - set default_map [tcl::dict::get $tdefaults $k] - lappend checked_opts $k $default_map - } else { - error "textblock::table::configure invalid $k value $v. Expected the value 'default' or a dict e.g topleft {hl *}" - } - } else { - #safe jumptable test - #dict for {subk subv} $v {} - foreach {subk subv} $v { - switch -- $subk { - topleft - topinner - topright - topsolo - middleleft - middleinner - middleright - middlesolo - bottomleft - bottominner - bottomright - bottomsolo - onlyleft - onlyinner - onlyright - onlysolo {} - default { - error "textblock::table::configure invalid $subk. Known values {topleft topinner topright topsolo middleleft middleinner middleright middlesolo bottomleft bottominner bottomright bottomsolo onlyleft onlyinner onlyright onlysolo}" - } - } - #safe jumptable test - #dict for {seg subst} $subv {} - foreach {seg subst} $subv { - switch -- $seg { - hl - hlt - hlb - vl - vll - vlr - trc - tlc - blc - brc {} - default { - error "textblock::table::configure invalid $subk value $seg. Known values {hl hlt hlb vl vll vlr trc tlc blc brc}" - } - } - } - - } - lappend checked_opts $k $v - } - - } - -framelimits_body - -framelimits_header { - set specific_framelimits [list] - foreach fl $v { - switch -- $fl { - "default" { - lappend specific_framelimits trc hlt tlc vll blc hlb brc vlr - } - hl { - lappend specific_framelimits hlt hlb - } - vl { - lappend specific_framelimits vll vlr - } - hlt - hlb - vll - vlr - trc - tlc - blc - brc { - lappend specific_framelimits $fl - } - default { - error "textblock::table::configure invalid $k '$fl'. Known values {hl hlb hlt vl vll vlr trc tlc blc brc} (or default for all)" - } - } - } - lappend checked_opts $k $specific_framelimits - } - -ansireset { - if {$v eq "\uFFEF"} { - set RST "\x1b\[m" ;#[a] - lappend checked_opts $k $RST - } else { - error "textblock::table::configure -ansireset is read-only. It is present only to prevent unwanted colourised output in configure commands" - } - } - -show_hseps { - if {![tcl::string::is boolean $v]} { - error "textblock::table::configure invalid $k '$v'. Must be a boolean or empty string" - } - lappend checked_opts $k $v - #these don't affect column width calculations - } - -show_edge { - if {![tcl::string::is boolean $v]} { - error "textblock::table::configure invalid $k '$v'. Must be a boolean or empty string" - } - lappend checked_opts $k $v - #these don't affect column width calculations - except if table -minwidth/-maxwidth come into play - set o_calculated_column_widths [list] ;#invalidate cached column widths - a recalc will be forced when needed - } - -show_vseps { - #we allow empty string - so don't use -strict boolean check - if {![tcl::string::is boolean $v]} { - error "textblock::table::configure invalid $k '$v'. Must be a boolean or empty string" - } - #affects width calculations - set o_calculated_column_widths [list] - lappend checked_opts $k $v - } - -minwidth - -maxwidth { - set o_calculated_column_widths [list] - lappend checked_opts $k $v - } - default { - lappend checked_opts $k $v - } - } - } - #all options checked - ok to update o_opts_table and o_opts_table_effective - - #set o_opts_table [tcl::dict::merge $o_opts_table $checked_opts] - foreach {k v} $args { - switch -- $k { - -framemap_header - -framemap_body { - #framemaps don't require setting every key to update. - #e.g configure -framemaps {topleft } - #needs to merge with existing unspecified keys such as topright middleleft etc. - if {$v eq "default"} { - tcl::dict::set o_opts_table $k default - } else { - if {[tcl::dict::get $o_opts_table $k] eq "default"} { - tcl::dict::set o_opts_table $k $v - } else { - tcl::dict::set o_opts_table $k [tcl::dict::merge [tcl::dict::get $o_opts_table $k] $v] - } - } - } - default { - tcl::dict::set o_opts_table $k $v - } - } - } - #use values from checked_opts for the effective opts - #safe jumptable test - #dict for {k v} $checked_opts {} - #foreach {k v} $checked_opts {} - tcl::dict::for {k v} $checked_opts { - switch -- $k { - -framemap_body - -framemap_header { - set existing [tcl::dict::get $o_opts_table_effective $k] - #set updated $existing - #dict for {subk subv} $v { - # tcl::dict::set updated $subk $subv - #} - #tcl::dict::set o_opts_table_effective $k $updated - tcl::dict::set o_opts_table_effective $k [tcl::dict::merge $existing $v] - } - -framelimits_body - -framelimits_header { - #my Set_effective_framelimits - tcl::dict::set o_opts_table_effective $k $v - } - default { - tcl::dict::set o_opts_table_effective $k $v - } - } - } - #ansireset exception - tcl::dict::set o_opts_table -ansireset [tcl::dict::get $o_opts_table_effective -ansireset] - return $o_opts_table - } - - #integrate with struct::matrix - allows ::m format 2string $table - method printmatrix {matrix} { - set matrix_rowcount [$matrix rows] - set matrix_colcount [$matrix columns] - set table_colcount [my column_count] - if {$table_colcount == 0} { - for {set c 0} {$c < $matrix_colcount} {incr c} { - my add_column -headers "" - } - } - set table_colcount [my column_count] - if {$table_colcount != $matrix_colcount} { - error "textblock::table::printmatrix column count of table doesn't match column count of matrix" - } - if {[my row_count] > 0} { - my row_clear - } - for {set r 0} {$r < $matrix_rowcount} {incr r} { - my add_row [$matrix get row $r] - } - my print - } - method as_matrix {{cmd ""}} { - if {$cmd eq ""} { - set m [struct::matrix] - } else { - set m [struct::matrix $cmd] - } - $m add columns [tcl::dict::size $o_columndata] - $m add rows [tcl::dict::size $o_rowdefs] - tcl::dict::for {k v} $o_columndata { - $m set column $k $v - } - return $m - } - method add_column {args} { - #*** !doctools - #[call class::table [method add_column] [arg args]] - - - if {[llength $args] %2 != 0} { - error "[tcl::namespace::current]::table::add_column unexpected argument count. Require name value pairs. Known options: %copt_keys%" - } - set opts $o_opts_column_defaults - foreach {k v} $args { - switch -- $k { - %copt_switchkeys% { - tcl::dict::set opts $k $v - } - default { - error "[tcl::namespace::current]::table::add_column unknown option '$k'. Known options: %copt_keys%" - } - } - } - set colcount [tcl::dict::size $o_columndefs] - - - tcl::dict::set o_columndata $colcount [list] - #tcl::dict::set o_columndefs $colcount $defaults ;#ensure record exists - tcl::dict::set o_columndefs $colcount $o_opts_column_defaults ;#ensure record exists - - - tcl::dict::set o_columnstates $colcount [tcl::dict::create minwidthbodyseen 0 maxwidthbodyseen 0 maxwidthheaderseen 0] - set prev_calculated_column_widths $o_calculated_column_widths - if {[catch { - my configure_column $colcount {*}$opts - } errMsg]} { - #configure failed - ensure o_columndata and o_columndefs entries are removed - tcl::dict::unset o_columndata $colcount - tcl::dict::unset o_columndefs $colcount - tcl::dict::unset o_columnstates $colcount - #undo cache invalidation - set o_calculated_column_widths $prev_calculated_column_widths - error "add_column failed to configure with supplied options $opts. Err:\n$errMsg" - } - #any add_column that succeeds should invalidate the calculated column widths - set o_calculated_column_widths [list] - set numrows [my row_count] - if {$numrows > 0} { - #fill column with default values - #puts ">>> adding default values for column $colcount" - set dval [tcl::dict::get $opts -defaultvalue] - set width [textblock::width $dval] - tcl::dict::set o_columndata $colcount [lrepeat $numrows $dval] - tcl::dict::set o_columnstates $colcount maxwidthbodyseen $width - tcl::dict::set o_columnstates $colcount minwidthbodyseen $width - } - return $colcount - } - method column_count {} { - return [tcl::dict::size $o_columndefs] - } - method configure_column {index_expression args} { - set cidx [lindex [tcl::dict::keys $o_columndefs] $index_expression] - if {$cidx eq ""} { - error "textblock::table::configure_column - no column defined at index '$cidx'.Use add_column to define columns" - } - if {![llength $args]} { - return [tcl::dict::get $o_columndefs $cidx] - } else { - if {[llength $args] == 1} { - if {[lindex $args 0] in [list %copt_keys%]} { - #query single option - set k [lindex $args 0] - set val [tcl::dict::get $o_columndefs $cidx $k] - set returndict [tcl::dict::create option $k value $val ansireset "\x1b\[m"] - set infodict [tcl::dict::create] - switch -- $k { - -ansibase { - tcl::dict::set infodict debug [ansistring VIEW $val] - } - } - tcl::dict::set returndict info $infodict - return $returndict - } else { - error "textblock::table configure_column - unrecognised option '[lindex $args 0]'. Known values %copt_keys%" - } - } - if {[llength $args] %2 != 0} { - error "textblock::table configure_column unexpected argument count. Require name value pairs. Known options: %copt_keys%" - } - foreach {k v} $args { - switch -- $k { - %copt_switchkeys% {} - default { - error "[tcl::namespace::current]::table configure_column unknown option '$k'. Known options: %copt_keys%" - } - } - } - set checked_opts [tcl::dict::get $o_columndefs $cidx] ;#copy of current state - - set hstates $o_headerstates ;#operate on a copy - set colstate [tcl::dict::get $o_columnstates $cidx] - set args_got_headers 0 - set args_got_header_colspans 0 - foreach {k v} $args { - switch -- $k { - -headers { - set args_got_headers 1 - set i 0 - set maxseen 0 ;#don't compare with cached colstate maxwidthheaderseen - we have all the headers for the column right here and need to refresh the colstate maxwidthheaderseen values completely. - foreach hdr $v { - set currentmax [my header_height_calc $i $cidx] ;#exclude current column - ie look at heights for this header in all other columns - #set this_header_height [textblock::height $hdr] - lassign [textblock::size $hdr] _w this_header_width _h this_header_height - - if {$this_header_height >= $currentmax} { - tcl::dict::set hstates $i maxheightseen $this_header_height - } else { - tcl::dict::set hstates $i maxheightseen $currentmax - } - if {$this_header_width >= $maxseen} { - set maxseen $this_header_width - } - #if {$this_header_width > [tcl::dict::get $colstate maxwidthheaderseen]} { - # tcl::dict::set colstate maxwidthheaderseen $this_header_width - #} - incr i - } - tcl::dict::set colstate maxwidthheaderseen $maxseen - #review - we could avoid some recalcs if we check current width range compared to previous - set o_calculated_column_widths [list] ;#invalidate cached column widths - a recalc will be forced when needed - tcl::dict::set checked_opts $k $v - } - -header_colspans { - set args_got_header_colspans 1 - #check columns to left to make sure each new colspan for this column makes sense in the overall context - #user may have to adjust colspans in order left to right to avoid these check errors - #note that 'any' represents span all up to the next non-zero defined colspan. - set cspans [my header_colspans] - set h 0 - if {[llength $v] > [tcl::dict::size $cspans]} { - error "configure_column $cidx -header_colspans. Only [tcl::dict::size $cspans] headers exist. Too many values supplied" - } - foreach s $v { - if {$cidx == 0} { - if {[tcl::string::is integer -strict $s]} { - if {$s < 1} { - error "configure_column $cidx -header_colspans bad first value '$s' for header '$h' . First column cannot have span less than 1. use 'any' or a positive integer" - } - } else { - if {$s ne "any" && $s ne ""} { - error "configure_column $cidx -header_colspans unrecognised value '$s' for header '$h' - must be a positive integer or the keyword 'any'" - } - } - } else { - #if {![tcl::string::is integer -strict $s]} { - # if {$s ne "any" && $s ne ""} { - # error "configure_column $cidx -header_colspans unrecognised value '$s' for header '$h' - must be a positive integer or the keyword 'any'" - # } - #} else { - set header_spans [tcl::dict::get $cspans $h] - set remaining [lindex $header_spans 0] - if {$remaining ne "any"} { - incr remaining -1 - } - #look at spans defined for previous cols - #we are presuming previous column entries are valid - and only validating if our new entry is ok under that assumption - for {set c 0} {$c < $cidx} {incr c} { - set span [lindex $header_spans $c] - if {$span eq "any"} { - set remaining "any" - } else { - if {$remaining eq "any"} { - if {$span ne "0"} { - #a previous column has ended the 'any' span - set remaining [expr {$span -1}] - } - } else { - if {$span eq "0"} { - incr remaining -1 - } else { - set remaining [expr {$span -1}] - } - #allow to go negative - } - } - } - if {$remaining eq "any"} { - #any int >0 ok - what about 'any' immediately following any? - } else { - if {$remaining > 0} { - if {$s ne "0" && $s ne ""} { - error "configure_column $cidx -header_colspans bad span $s for header '$h'. Remaining span is '$remaining' - so a zero colspan is required" - } - } else { - if {$s == 0} { - error "configure_column $cidx -header_colspans bad span $s for header '$h'. No span in place - need >=1 or 'any'" - } - } - } - #} - } - incr h - } - #todo - avoid recalc if no change - set o_calculated_column_widths [list] ;#invalidate cached column widths - a recalc will be forced when needed - tcl::dict::set checked_opts $k $v - } - -minwidth { - set o_calculated_column_widths [list] ;#invalidate cached column widths - a recalc will be forced when needed - tcl::dict::set checked_opts $k $v - } - -maxwidth { - set o_calculated_column_widths [list] ;#invalidate cached column widths - a recalc will be forced when needed - tcl::dict::set checked_opts $k $v - } - -ansibase { - set parts [punk::ansi::ta::split_codes_single $v] ;#caller may have supplied separated codes eg "[a+ Yellow][a+ red]" - set col_ansibase_items [list] ; - foreach {pt code} $parts { - if {$pt ne ""} { - #we don't expect plaintext in an ansibase - error "Unable to interpret -ansibase value as ansi SGR codes. Plaintext detected. Consider using for example: '\[punk::ansi::a+ green]' (or alias '\[a+ green]') to build ansi. debug view: [punk::ansi::ansistring VIEW $v]" - } - if {$code ne ""} { - lappend col_ansibase_items $code - } - } - set col_ansibase [punk::ansi::codetype::sgr_merge_singles $col_ansibase_items] - tcl::dict::set checked_opts $k $col_ansibase - } - -ansireset { - if {$v eq "\uFFEF"} { - tcl::dict::set checked_opts $k "\x1b\[m" ;# [a] - } else { - error "textblock::table::configure_column -ansireset is read-only. It is present only to prevent unwanted colourised output in configure commands" - } - } - -blockalign - -textalign { - switch -- $v { - left - right { - tcl::dict::set checked_opts $k $v - } - centre - centre { - tcl::dict::set checked_opts $k centre - } - } - } - default { - tcl::dict::set checked_opts $k $v - } - } - } - #args checked - ok to update headerstates and columndefs and columnstates - tcl::dict::set o_columndefs $cidx $checked_opts - - set o_headerstates $hstates - tcl::dict::set o_columnstates $cidx $colstate - - if {$args_got_headers} { - #if the headerlist length for this column has shrunk,and it was the longest - we may now have excess entries in o_headerstates - set zero_heights [list] - tcl::dict::for {hidx _v} $o_headerstates { - #pass empty string for exclude_column so we don't exclude our own column - if {[my header_height_calc $hidx ""] == 0} { - lappend zero_heights $hidx - } - } - foreach zidx $zero_heights { - tcl::dict::unset o_headerstates $zidx - } - } - if {$args_got_headers || $args_got_header_colspans} { - #check and adjust header_colspans for all columns - - } - - return [tcl::dict::get $o_columndefs $cidx] - } - } - - method header_count {} { - return [tcl::dict::size $o_headerstates] - } - method header_count_calc {} { - set max_headers 0 - tcl::dict::for {k cdef} $o_columndefs { - set num_headers [llength [tcl::dict::get $cdef -headers]] - set max_headers [expr {max($max_headers,$num_headers)}] - } - return $max_headers - } - method header_height {header_index} { - set idx [lindex [tcl::dict::keys $o_headerstates $header_index]] - return [tcl::dict::get $o_headerstates $idx maxheightseen] - } - - #review - use maxwidth (considering colspans) of each column to determine height after wrapping - # -need to consider whether vertical expansion allowed / maxheight? - method header_height_calc {header_index {exclude_column ""}} { - set dataheight 0 - if {$exclude_column eq ""} { - set exclude_colidx "" - } else { - set exclude_colidx [lindex [tcl::dict::keys $o_columndefs] $exclude_column] - } - tcl::dict::for {cidx cdef} $o_columndefs { - if {$exclude_colidx == $cidx} { - continue - } - set headerlist [tcl::dict::get $cdef -headers] - if {$header_index < [llength $headerlist]} { - set this_height [textblock::height [lindex $headerlist $header_index]] - set dataheight [expr {max($dataheight,$this_height)}] - } - } - return $dataheight - } - - #return a dict keyed on header index with values representing colspans - #e.g - # 0 {any 0 0 0} 1 {1 1 1 1} 2 {2 0 1 1} 3 {3 0 0 1} - # - method header_colspans {} { - #set num_headers [my header_count_calc] - set num_headers [my header_count] - set colspans_by_header [tcl::dict::create] - tcl::dict::for {cidx cdef} $o_columndefs { - set headerlist [tcl::dict::get $cdef -headers] - set colspans_for_column [tcl::dict::get $cdef -header_colspans] - for {set h 0} {$h < $num_headers} {incr h} { - set headerspans [punk::lib::dict_getdef $colspans_by_header $h [list]] - set defined_span [lindex $colspans_for_column $h] - set i 0 - set spanremaining [lindex $headerspans 0] - if {$spanremaining ne "any"} { - if {$spanremaining eq ""} { - set spanremaining 1 - } - incr spanremaining -1 - } - foreach s $headerspans { - if {$s eq "any"} { - set spanremaining "any" - } elseif {$s == 0} { - if {$spanremaining ne "any"} { - incr spanremaining -1 - } - } else { - set spanremaining [expr {$s - 1}] - } - incr i - } - if {$defined_span eq ""} { - if {$spanremaining eq "0"} { - lappend headerspans 1 - } else { - #"any" or an integer - lappend headerspans 0 - } - } else { - lappend headerspans $defined_span - } - tcl::dict::set colspans_by_header $h $headerspans - } - } - return $colspans_by_header - } - - #e.g - # 0 {any 0 0 0} 1 {1 1 1 1} 2 {2 0 any 1} 3 {any 0 0 1} - #convert to - # 0 {4 0 0 0} 1 {1 1 1 1} 2 {2 0 1 1} 3 {3 0 0 1} - method header_colspans_numeric {} { - set hcolspans [my header_colspans] - if {![tcl::dict::size $hcolspans]} { - return - } - set numcols [llength [tcl::dict::get $hcolspans 0]] ;#assert: all are the same - tcl::dict::for {h spans} $hcolspans { - set c 0 ;#column index - foreach s $spans { - if {$s eq "any"} { - set spanlen 1 - for {set i [expr {$c+1}]} {$i < $numcols} {incr i} { - #next 'any' or non-zero ends an 'any' span - if {[lindex $spans $i] ne "0"} { - break - } - incr spanlen - } - #overwrite the 'any' with it's actual span - set modified_spans [dict get $hcolspans $h] - lset modified_spans $c $spanlen - dict set hcolspans $h $modified_spans - } - incr c - } - } - return $hcolspans - } - - #should be configure_headerrow ? - method configure_header {index_expression args} { - #the header data being configured or returned here is mostly derived from the column defs and if necessary written to the column defs. - #It can also be set column by column - but it is much easier (especially for colspans) to configure them on a header-row basis - #e.g o_headerstates: 0 {maxheightseen 1} 1 {maxheightseen 2} - set num_headers [my header_count_calc] - set hidx [lindex [tcl::dict::keys $o_headerstates] $index_expression] - if {$hidx eq ""} { - error "textblock::table::configure_header - no row defined at index '$hidx'." - } - if {$hidx > $num_headers -1} { - #assert - shouldn't happen - error "textblock::table::configure_header error headerstates data is out of sync" - } - - if {![llength $args]} { - set colspans_by_header [my header_colspans] - set result [tcl::dict::create] - tcl::dict::set result -colspans [tcl::dict::get $colspans_by_header $hidx] - set header_row_items [list] - tcl::dict::for {cidx cdef} $o_columndefs { - set colheaders [tcl::dict::get $cdef -headers] - set relevant_header [lindex $colheaders $hidx] - #The -headers element of the column def is allowed to have less elements than the total, even be empty. Number of headers is defined by the longest -header list in the set of columns - lappend header_row_items $relevant_header ;#may be empty string because column had nothing at that index, or may be empty string stored in that column. We don't differentiate. - } - tcl::dict::set result -values $header_row_items - return $result - } - if {[llength $args] == 1} { - if {[lindex $args 0] in [tcl::dict::keys $o_opts_header_defaults]} { - #query single option - set k [lindex $args 0] - #set val [tcl::dict::get $o_rowdefs $ridx $k] - - set infodict [tcl::dict::create] - #todo - # -blockalignments and -textalignments lists - # must match number of values if not empty? - e.g -blockalignments {left right "" centre left ""} - #if there is a value it overrides alignments specified on the column - switch -- $k { - -values { - set header_row_items [list] - tcl::dict::for {cidx cdef} $o_columndefs { - set colheaders [tcl::dict::get $cdef -headers] - set relevant_header [lindex $colheaders $hidx] - #The -headers element of the column def is allowed to have less elements than the total, even be empty. Number of headers is defined by the longest -header list in the set of columns - lappend header_row_items $relevant_header ;#may be empty string because column had nothing at that index, or may be empty string stored in that column. We don't differentiate. - - } - set val $header_row_items - set returndict [tcl::dict::create option $k value $val ansireset "\x1b\[m"] - } - -colspans { - set colspans_by_header [my header_colspans] - set result [tcl::dict::create] - set val [tcl::dict::get $colspans_by_header $hidx] - set returndict [tcl::dict::create option $k value $val ansireset "\x1b\[m"] - } - -ansibase { - set val ??? - set returndict [tcl::dict::create option $k value $val ansireset "\x1b\[m"] - tcl::dict::set infodict debug [ansistring VIEW $val] - } - } - tcl::dict::set returndict info $infodict - return $returndict - #return [tcl::dict::create option $k value $val ansireset "\x1b\[m" info $infodict] - } else { - error "textblock::table configure_header - unrecognised option '[lindex $args 0]'. Known values [tcl::dict::keys $o_opts_header_defaults]" - } - } - if {[llength $args] %2 != 0} { - error "textblock::table configure_header incorrect number of options following index_expression. Require name value pairs. Known options: [tcl::dict::keys $o_opts_header_defaults]" - } - foreach {k v} $args { - if {$k ni [tcl::dict::keys $o_opts_header_defaults]} { - error "[tcl::namespace::current]::table configure_row unknown option '$k'. Known options: [tcl::dict::keys $o_opts_header_defaults]" - } - } - - set checked_opts [list] - #safe jumptable test - #dict for {k v} $args {} - foreach {k v} $args { - switch -- $k { - -ansibase { - set parts [punk::ansi::ta::split_codes_single $v] ;#caller may have supplied separated codes eg "[a+ Yellow][a+ red]" - set header_ansibase_items [list] ; - foreach {pt code} $parts { - if {$pt ne ""} { - #we don't expect plaintext in an ansibase - error "Unable to interpret -ansibase value as ansi SGR codes. Plaintext detected. Consider using for example: '\[punk::ansi::a+ green]' (or alias '\[a+ green]') to build ansi. debug view: [punk::ansi::ansistring VIEW $v]" - } - if {$code ne ""} { - lappend header_ansibase_items $code - } - } - set header_ansibase [punk::ansi::codetype::sgr_merge_singles $row_ansibase_items] - error "sorry - -ansibase not yet implemented for header rows" - lappend checked_opts $k $header_ansibase - } - -ansireset { - if {$v eq "\uFFEF"} { - lappend checked_opts $k "\x1b\[m" ;# [a] - } else { - error "textblock::table::configure_header -ansireset is read-only. It is present only to prevent unwanted colourised output in configure commands" - } - } - -values { - if {[llength $v] > [tcl::dict::size $o_columndefs]} { - error "textblock::table::configure_header -values length ([llength $v]) is longer than number of columns ([tcl::dict::size $o_columndefs])" - } - lappend checked_opts $k $v - } - -colspans { - set numcols [tcl::dict::size $o_columndefs] - if {[llength $v] > $numcols} { - error "textblock::table::configure_header -colspans length ([llength $v]) is longer than number of columns ([tcl::dict::size $o_columndefs])" - } - if {[llength $v] < $numcols} { - puts stderr "textblock::table::configure_header warning - only [llength $v] spans specified for [tcl::dict::size $o_columndefs] columns." - puts stderr "It is recommended to set all spans explicitly. (auto-calc not implemented)" - } - if {[llength $v]} { - set firstspan [lindex $v 0] - set first_is_ok 0 - if {$firstspan eq "any"} { - set first_is_ok 1 - } elseif {[tcl::string::is integer -strict $firstspan] && $firstspan > 0 && $firstspan <= $numcols} { - set first_is_ok 1 - } - if {!$first_is_ok} { - error "textblock::table::configure_header -colspans first value '$firstspan' must be integer > 0 & <= $numcols or the string \"any\"" - } - #we don't mind if there are less colspans specified than columns.. the tail can be deduced from the leading ones specified (review) - set remaining $firstspan - if {$remaining ne "any"} { - incr remaining -1 - } - set spanview $v - set sidx 1 - #because we allow 'any' - be careful when doing < or > comparisons - as we are mixing integer and string comparisons if we don't test for 'any' first - foreach span [lrange $v 1 end] { - if {$remaining eq "any"} { - if {$span eq "any"} { - set remaining "any" - } elseif {$span > 0} { - #ok to reset to higher val immediately or after an any and any number of following zeros - if {$span > ($numcols - $sidx)} { - lset spanview $sidx [a+ web-red]$span[a] - error "textblock::table::configure_header -colspans sequence incorrect at span '$span'. Require span <= [expr {$numcols-$sidx}] or \"any\".[a] $spanview" - } - set remaining $span - incr remaining -1 - } else { - #zero following an any - leave remaining as any - } - } else { - if {$span eq "0"} { - if {$remaining eq "0"} { - lset spanview $sidx [a+ web-red]$span[a] - error "textblock::table::configure_header -colspans sequence incorrect at span '$span' remaining is $remaining. Require positive or \"any\" value.[a] $spanview" - } else { - incr remaining -1 - } - } else { - if {$remaining eq "0"} { - #ok for new span value of any or > 0 - if {$span ne "any" && $span > ($numcols - $sidx)} { - lset spanview $sidx [a+ web-red]$span[a] - error "textblock::table::configure_header -colspans sequence incorrect at span '$span'. Require span <= [expr {$numcols-$sidx}] or \"any\".[a] $spanview" - } - set remaining $span - if {$remaining ne "any"} { - incr remaining -1 - } - } else { - lset spanview $sidx [a+ web-red]$span[a] - error "textblock::table::configure_header -colspans sequence incorrect at span '$span' remaining is $remaining. Require zero value span.[a] $spanview" - } - } - } - incr sidx - } - } - #empty -colspans list should be ok - - #error "sorry - -colspans not yet implemented for header rows - set manually in vertical order via configure_column for now" - lappend checked_opts $k $v - } - default { - lappend checked_opts $k $v - } - } - } - - #configured opts all good - #safe jumptable test - #dict for {k v} $checked_opts {} - #foreach {k v} $checked_opts {} - tcl::dict::for {k v} $checked_opts { - switch -- $k { - -values { - set c 0 - foreach hval $v { - #retrieve -headers from relevant col, insert at header index, and write back. - set thiscol_headers_vertical [tcl::dict::get $o_columndefs $c -headers] - set missing [expr {($hidx +1) - [llength $thiscol_headers_vertical]}] - if {$missing > 0} { - lappend thiscol_headers_vertical {*}[lrepeat $missing ""] - } - lset thiscol_headers_vertical $hidx $hval - tcl::dict::set o_columndefs $c -headers $thiscol_headers_vertical - #invalidate column width cache - set o_calculated_column_widths [list] - # -- -- -- -- -- -- - #also update maxwidthseen & maxheightseen - set i 0 - set maxwidthseen 0 - #set maxheightseen 0 - foreach hdr $thiscol_headers_vertical { - lassign [textblock::size $hdr] _w this_header_width _h this_header_height - set maxheightseen [punk::lib::dict_getdef $o_headerstates $i maxheightseen 0] - if {$this_header_height >= $maxheightseen} { - tcl::dict::set o_headerstates $i maxheightseen $this_header_height - } else { - tcl::dict::set o_headerstates $i maxheightseen $maxheightseen - } - if {$this_header_width >= $maxwidthseen} { - set maxwidthseen $this_header_width - } - incr i - } - tcl::dict::set o_columnstates $c maxwidthheaderseen $maxwidthseen - # -- -- -- -- -- -- - incr c - } - } - -colspans { - #sequence has been verified above - we need to split it and store across columns - set c 0 ;#column index - foreach span $v { - set colspans [tcl::dict::get $o_columndefs $c -header_colspans] - if {$hidx > [llength $colspans]-1} { - set colspans_by_header [my header_colspans] - #puts ">>>>>?$colspans_by_header" - #we are allowed to lset only one beyond the current length to append - #but there may be even less or no entries present in a column - # - the ability to underspecify and calculate the missing values makes setting the values complicated. - #use the header_colspans calculation to update only those entries necessary - set spanlist [list] - for {set h 0} {$h < $hidx} {incr h} { - set cspans [tcl::dict::get $colspans_by_header $h] - set requiredval [lindex $cspans $c] - lappend spanlist $requiredval - } - tcl::dict::set o_columndefs $c -header_colspans $spanlist - - set colspans [tcl::dict::get $o_columndefs $c -header_colspans] - } - - lset colspans $hidx $span - tcl::dict::set o_columndefs $c -header_colspans $colspans - incr c - } - } - } - } - } - - method add_row {valuelist args} { - #*** !doctools - #[call class::table [method add_row] [arg args]] - if {[tcl::dict::size $o_columndefs] > 0 && ([llength $valuelist] && [llength $valuelist] != [tcl::dict::size $o_columndefs])} { - set msg "" - append msg "add_row - invalid number ([llength $valuelist]) of values in row - Must match existing column count: [tcl::dict::size $o_columndefs]" \n - append msg "rowdata: $valuelist" - error $msg - } - if {[tcl::dict::size $o_columndefs] == 0 && ![llength $valuelist]} { - error "add_row - no values supplied, and no columns defined, so cannot use default column values" - } - - set defaults [tcl::dict::create\ - -minheight 1\ - -maxheight ""\ - -ansibase ""\ - -ansireset "\uFFEF"\ - ] - set o_opts_row_defaults $defaults - - if {[llength $args] %2 !=0} { - error "[tcl::namespace::current]::table::add_row unexpected argument count. Require name value pairs. Known options: [tcl::dict::keys $defaults]" - } - #safe jumptable test - #dict for {k v} $args {} - foreach {k v} $args { - switch -- $k { - -minheight - -maxheight - -ansibase - -ansireset {} - default { - error "Invalid option '$k' Known options: [tcl::dict::keys $defaults] (-ansireset is read-only)" - } - } - } - set opts [tcl::dict::merge $defaults $args] - - set auto_columns 0 - if {[tcl::dict::size $o_columndefs] == 0} { - set auto_columns 1 - #no columns defined - auto define with defaults for each column in first supplied row - #auto define columns only valid if no existing columns - #the autocolumns must be added before configure_row - but if configure_row fails - we need to remove them! - foreach el $valuelist { - my add_column - } - } else { - if {![llength $valuelist]} { - tcl::dict::for {k coldef} $o_columndefs { - lappend valuelist [tcl::dict::get $coldef -defaultvalue] - } - } - } - set rowcount [tcl::dict::size $o_rowdefs] - tcl::dict::set o_rowdefs $rowcount $defaults ;# ensure record exists before configure - - if {[catch { - my configure_row $rowcount {*}$opts - } errMsg]} { - #undo anything we saved before configure_row - tcl::dict::unset o_rowdefs $rowcount - #remove auto_columns - if {$auto_columns} { - set o_columndata [tcl::dict::create] - set o_columndefs [tcl::dict::create] - set o_columnstate [tcl::dict::create] - } - error "add_row failed to configure with supplied options $opts. Err:\n$errMsg" - } - - - set c 0 - set max_height_seen 1 - foreach v $valuelist { - set prev_maxwidth [tcl::dict::get $o_columnstates $c maxwidthbodyseen] - set prev_minwidth [tcl::dict::get $o_columnstates $c minwidthbodyseen] - - tcl::dict::lappend o_columndata $c $v - set valheight [textblock::height $v] - if {$valheight > $max_height_seen} { - set max_height_seen $valheight - } - set width [textblock::width $v] - if {$width > [tcl::dict::get $o_columnstates $c maxwidthbodyseen]} { - tcl::dict::set o_columnstates $c maxwidthbodyseen $width - } - if {$width < [tcl::dict::get $o_columnstates $c minwidthbodyseen]} { - tcl::dict::set o_columnstates $c minwidthbodyseen $width - } - - if {[tcl::dict::get $o_columnstates $c maxwidthbodyseen] > $prev_maxwidth || [tcl::dict::get $o_columnstates $c minwidthbodyseen] < $prev_minwidth} { - #invalidate calculated column width cache if any new value was outside the previous range of widths - set o_calculated_column_widths [list] - } - incr c - } - - set opt_maxh [tcl::dict::get $o_rowdefs $rowcount -maxheight] - if {$opt_maxh ne ""} { - tcl::dict::set o_rowstates $rowcount -maxheight [expr {min($opt_maxh,$max_height_seen)}] - } else { - tcl::dict::set o_rowstates $rowcount -maxheight $max_height_seen - } - - return $rowcount - } - method configure_row {index_expression args} { - set ridx [lindex [tcl::dict::keys $o_rowdefs] $index_expression] - if {$ridx eq ""} { - error "textblock::table::configure_row - no row defined at index '$ridx'.Use add_row to define rows" - } - if {![llength $args]} { - return [tcl::dict::get $o_rowdefs $ridx] - } - if {[llength $args] == 1} { - if {[lindex $args 0] in [tcl::dict::keys $o_opts_row_defaults]} { - #query single option - set k [lindex $args 0] - set val [tcl::dict::get $o_rowdefs $ridx $k] - set returndict [tcl::dict::create option $k value $val ansireset "\x1b\[m"] - set infodict [tcl::dict::create] - switch -- $k { - -ansibase { - tcl::dict::set infodict debug [ansistring VIEW $val] - } - } - tcl::dict::set returndict info $infodict - return $returndict - #return [tcl::dict::create option $k value $val ansireset "\x1b\[m" info $infodict] - } else { - error "textblock::table configure_row - unrecognised option '[lindex $args 0]'. Known values [tcl::dict::keys $o_opts_row_defaults]" - } - } - if {[llength $args] %2 != 0} { - error "textblock::table configure_row incorrect number of options following index_expression. Require name value pairs. Known options: [tcl::dict::keys $o_opts_row_defaults]" - } - foreach {k v} $args { - if {$k ni [tcl::dict::keys $o_opts_row_defaults]} { - error "[tcl::namespace::current]::table configure_row unknown option '$k'. Known options: [tcl::dict::keys $o_opts_row_defaults]" - } - } - set checked_opts [list] - foreach {k v} $args { - switch -- $k { - -ansibase { - set parts [punk::ansi::ta::split_codes_single $v] ;#caller may have supplied separated codes eg "[a+ Yellow][a+ red]" - set row_ansibase_items [list] ; - foreach {pt code} $parts { - if {$pt ne ""} { - #we don't expect plaintext in an ansibase - error "Unable to interpret -ansibase value as ansi SGR codes. Plaintext detected. Consider using for example: '\[punk::ansi::a+ green]' (or alias '\[a+ green]') to build ansi. debug view: [punk::ansi::ansistring VIEW $v]" - } - if {$code ne ""} { - lappend row_ansibase_items $code - } - } - set row_ansibase [punk::ansi::codetype::sgr_merge_singles $row_ansibase_items] - lappend checked_opts $k $row_ansibase - } - -ansireset { - if {$v eq "\uFFEF"} { - lappend checked_opts $k "\x1b\[m" ;# [a] - } else { - error "textblock::table::configure_row -ansireset is read-only. It is present only to prevent unwanted colourised output in configure commands" - } - } - default { - lappend checked_opts $k $v - } - } - } - - set current_opts [tcl::dict::get $o_rowdefs $ridx] - set opts [tcl::dict::merge $current_opts $checked_opts] - - #check minheight and maxheight together - set opt_minh [tcl::dict::get $opts -minheight] - set opt_maxh [tcl::dict::get $opts -maxheight] - - #todo - allow zero values to hide/collapse rows as is possible with columns - if {![tcl::string::is integer $opt_minh] || ($opt_maxh ne "" && ![tcl::string::is integer -strict $opt_maxh])} { - error "[tcl::namespace::current]::table::configure_row error -minheight '$opt_minh' and -maxheight '$opt_maxh' must be integers greater than or equal to 1 (for now)" - } - if {$opt_minh < 1 || ($opt_maxh ne "" && $opt_maxh < 1)} { - error "[tcl::namespace::current]::table::configure_row error -minheight '$opt_minh' and -maxheight '$opt_maxh' must both be 1 or greater (for now)" - } - if {$opt_maxh ne "" && $opt_maxh < $opt_minh} { - error "[tcl::namespace::current]::table::configure_row error -maxheight '$opt_maxh' must greater than -minheight '$opt_minh'" - } - tcl::dict::set o_rowstates $ridx -minheight $opt_minh - - - tcl::dict::set o_rowdefs $ridx $opts - } - method row_count {} { - return [tcl::dict::size $o_rowdefs] - } - method row_clear {} { - set o_rowdefs [tcl::dict::create] - set o_rowstates [tcl::dict::create] - #The data values are stored by column regardless of whether added row by row - tcl::dict::for {cidx records} $o_columndata { - tcl::dict::set o_columndata $cidx [list] - #reset only the body fields in o_columnstates - tcl::dict::set o_columnstates $cidx minwidthbodyseen 0 - tcl::dict::set o_columnstates $cidx maxwidthbodyseen 0 - } - set o_calculated_column_widths [list] - } - method clear {} { - my row_clear - set o_columndefs [tcl::dict::create] - set o_columndata [tcl::dict::create] - set o_columnstates [tcl::dict::create] - } - - - - #method Get_columns_by_name {namematch_list} { - #} - - #specify range with x..y - method Get_columns_by_indices {index_list} { - foreach spec $index_list { - if {[tcl::string::is integer -strict $c]} { - set colidx $c - } else { - tcl::dict::for {colidx coldef} $o_columndefs { - #if {[tcl::string::match x x]} {} - } - } - } - } - method Get_boxlimits_and_joins {position fname_body} { - #fname_body will be "custom" or one of the predefined types light,heavy etc - switch -- $position { - left { - return [tcl::dict::create \ - boxlimits [list hlb blc vll]\ - boxlimits_top [list hlb blc vll hlt tlc]\ - joins [list down]\ - bodyjoins [list down-$fname_body]\ - ] - } - inner { - return [tcl::dict::create \ - boxlimits [list hlb blc vll]\ - boxlimits_top [list hlb blc vll hlt tlc]\ - joins [list down left]\ - bodyjoins [list left down-$fname_body] - ] - } - right { - return [tcl::dict::create \ - boxlimits [list hlb blc vll vlr brc]\ - boxlimits_top [list hlb blc vll vlr brc hlt tlc trc]\ - joins [list down left]\ - bodyjoins [list left down-$fname_body]\ - ] - } - solo { - return [tcl::dict::create \ - boxlimits [list hlb blc vll vlr brc]\ - boxlimits_top [list hlb blc vll vlr brc hlt tlc trc]\ - joins [list down]\ - bodyjoins [list down-$fname_body]\ - ] - } - default { - error "Get_boxlimits_and_joins unrecognised position '$position' expected: left inner right solo" - } - } - } - method Get_boxlimits_and_joins1 {position fname_body} { - #fname_body will be "custom" or one of the predefined types light,heavy etc - switch -- $position { - left { - #set header_boxlimits {hlb hlt tlc blc vll} - set header_body_joins [list down-$fname_body] - set boxlimits_position [list hlb blc vll] - #set boxlimits_toprow [concat $boxlimits_position {hlt tlc}] - set boxlimits_toprow [list hlb blc vll hlt tlc] - set joins [list down] - } - inner { - #set header_boxlimits {hlb hlt tlc blc vll} - set header_body_joins [list left down-$fname_body] - set boxlimits_position [list hlb blc vll] - #set boxlimits_toprow [concat $boxlimits_position {hlt tlc}] - set boxlimits_toprow [list hlb blc vll hlt tlc] - set joins [list down left] - } - right { - #set header_boxlimits {hlb hlt tlc blc vll vlr trc brc} - set header_body_joins [list left down-$fname_body] - set boxlimits_position [list hlb blc vll vlr brc] - #set boxlimits_toprow [concat $boxlimits_position {hlt tlc trc}] - set boxlimits_toprow [list hlb blc vll vlr brc hlt tlc trc] - set joins [list down left] - } - solo { - #set header_boxlimits {hlb hlt tlc blc vll vlr trc brc} - set header_body_joins [list down-$fname_body] - set boxlimits_position [list hlb blc vll vlr brc] - #set boxlimits_toprow [concat $boxlimits_position {hlt tlc trc}] - set boxlimits_toprow [list hlb blc vll vlr brc hlt tlc trc] - set joins [list down] - } - } - return [tcl::dict::create boxlimits $boxlimits_position boxlimits_top $boxlimits_toprow joins $joins bodyjoins $header_body_joins ] - } - method get_column_by_index {index_expression args} { - #puts "+++> get_column_by_index $index_expression $args [tcl::namespace::current]" - #index_expression may be something like end-1 or 2+2 - we can't directly use it as a lookup for dicts. - set opts [tcl::dict::create\ - -position "inner"\ - -return "string"\ - ] - foreach {k v} $args { - switch -- $k { - -position - -return { - tcl::dict::set opts $k $v - } - default { - error "[tcl::namespace::current]::table::get_column_by_index error invalid option '$k'. Known options [tcl::dict::keys $opts]" - } - } - } - set opt_posn [tcl::dict::get $opts -position] - set opt_return [tcl::dict::get $opts -return] - - switch -- $opt_posn { - left - inner - right - solo {} - default { - error "[tcl::namespace::current]::table::get_column_by_index error invalid value '$opt_posn' for -position. Valid values: [list left inner right solo]" - } - } - switch -- $opt_return { - string - dict {} - default { - error "[tcl::namespace::current]::table::get_column_by_index error invalid value '$opt_return' for -return. Valid values: string dict" - } - } - - set columninfo [my get_column_cells_by_index $index_expression] - set header_list [tcl::dict::get $columninfo headers] - #puts "===== header_list: $header_list" - set cells [tcl::dict::get $columninfo cells] - - set topt_show_header [tcl::dict::get $o_opts_table -show_header] - if {$topt_show_header eq ""} { - set allheaders 0 - set all_cols [tcl::dict::keys $o_columndefs] - foreach c $all_cols { - incr allheaders [llength [tcl::dict::get $o_columndefs $c -headers]] - } - if {$allheaders == 0} { - set do_show_header 0 - } else { - set do_show_header 1 - } - } else { - set do_show_header $topt_show_header - } - set topt_show_footer [tcl::dict::get $o_opts_table -show_footer] - - - set output "" - set part_header "" - set part_body "" - set part_footer "" - - set boxlimits "" - set joins "" - set header_boxlimits [list] - set header_body_joins [list] - - - set ftypes [my Get_frametypes] - set ftype_body [tcl::dict::get $ftypes body] - if {[llength $ftype_body] >= 2} { - set fname_body "custom" - } else { - set fname_body $ftype_body - } - set ftype_header [tcl::dict::get $ftypes header] - if {[llength $ftype_header] >= 2} { - set fname_header "custom" - } else { - set fname_header $ftype_header - } - - set limj [my Get_boxlimits_and_joins $opt_posn $fname_body] - set header_body_joins [tcl::dict::get $limj bodyjoins] - set joins [tcl::dict::get $limj joins] - set boxlimits_position [tcl::dict::get $limj boxlimits] - set boxlimits_toprow [tcl::dict::get $limj boxlimits_top] - #use struct::set instead of simple for loop - will be faster at least when critcl available - set boxlimits [struct::set intersect [tcl::dict::get $o_opts_table_effective -framelimits_body] $boxlimits_position] - set boxlimits_headerless [struct::set intersect [tcl::dict::get $o_opts_table_effective -framelimits_body] $boxlimits_toprow] - set header_boxlimits [struct::set intersect [tcl::dict::get $o_opts_table_effective -framelimits_header] $boxlimits_position] - set header_boxlimits_toprow [struct::set intersect [tcl::dict::get $o_opts_table_effective -framelimits_header] $boxlimits_toprow] - - set fmap [tcl::dict::get $o_opts_table_effective -framemap_body] - set hmap [tcl::dict::get $o_opts_table_effective -framemap_header] - - #if {![tcl::dict::get $o_opts_table -show_edge]} { - # set body_edgemap [textblock::class::table_edge_map ""] - # dict for {k v} $fmap { - # #tcl::dict::set fmap $k [tcl::dict::merge $v [tcl::dict::get $body_edgemap $k]] - # } - # set header_edgemap [textblock::class::header_edge_map ""] - # dict for {k v} $hmap { - # #tcl::dict::set hmap $k [tcl::dict::merge $v [tcl::dict::get $header_edgemap $k]] - # } - #} - set sep_elements_horizontal $::textblock::class::table_hseps - set sep_elements_vertical $::textblock::class::table_vseps - - set topmap [tcl::dict::get $fmap top$opt_posn] - set botmap [tcl::dict::get $fmap bottom$opt_posn] - set midmap [tcl::dict::get $fmap middle$opt_posn] - set onlymap [tcl::dict::get $fmap only$opt_posn] - - set hdrmap [tcl::dict::get $hmap only${opt_posn}] - - set topseps_h [tcl::dict::get $sep_elements_horizontal top$opt_posn] - set midseps_h [tcl::dict::get $sep_elements_horizontal middle$opt_posn] - set topseps_v [tcl::dict::get $sep_elements_vertical top$opt_posn] - set midseps_v [tcl::dict::get $sep_elements_vertical middle$opt_posn] - set botseps_v [tcl::dict::get $sep_elements_vertical bottom$opt_posn] - set onlyseps_v [tcl::dict::get $sep_elements_vertical only$opt_posn] - - #top should work for all header rows regarding vseps - as we only use it to reduce the box elements, and lower headers have same except for tlc which isn't present anyway - set headerseps_v [tcl::dict::get $sep_elements_vertical top$opt_posn] - - lassign [my Get_seps] _h show_seps_h _v show_seps_v - set return_headerheight 0 - set return_headerwidth 0 - set cidx [lindex [tcl::dict::keys $o_columndefs] $index_expression] - - set colwidth [my column_width $cidx] - - set col_blockalign [tcl::dict::get $o_columndefs $cidx -blockalign] - - if {$do_show_header} { - #puts "boxlimitsinfo header $opt_posn: -- boxlimits $header_boxlimits -- boxmap $hdrmap" - set ansibase_header [tcl::dict::get $o_opts_table -ansibase_header] ;#merged to single during configure - set ansiborder_header [tcl::dict::get $o_opts_table -ansiborder_header] - if {[tcl::dict::get $o_opts_table -frametype_header] eq "block"} { - set extrabg [punk::ansi::codetype::sgr_merge_singles [list $ansibase_header] -filter_fg 1] - set ansiborder_final $ansibase_header$ansiborder_header$extrabg - } else { - set ansiborder_final $ansibase_header$ansiborder_header - } - set RST [punk::ansi::a] - - - set hcolwidth $colwidth - #set hcolwidth [my column_width_configured $cidx] - set hcell_line_blank [tcl::string::repeat " " $hcolwidth] - - set all_colspans [my header_colspans_numeric] - - #put our framedef calls together - set fdef_header [textblock::framedef $ftype_header] - set framedef_leftbox [textblock::framedef -joins left $ftype_header] - set framedef_headerdown_same [textblock::framedef -joins {down} $ftype_header] - set framedef_headerdown_body [textblock::framedef -joins [list down-$fname_body] $ftype_header] - #default span_extend_map - used as base to customise with specific joins - set span_extend_map [tcl::dict::create \ - vll " "\ - tlc [tcl::dict::get $fdef_header hlt]\ - blc [tcl::dict::get $fdef_header hlb]\ - ] - - - #used for colspan-zero header frames - set framesub_map [list hl $TSUB vll $TSUB vlr $TSUB tlc $TSUB blc $TSUB trc $TSUB brc $TSUB] ;# a debug test - - set hrow 0 - set hmax [expr {[llength $header_list] -1}] - foreach header $header_list { - set headerspans [tcl::dict::get $all_colspans $hrow] - set this_span [lindex $headerspans $cidx] - set hval $ansibase_header$header ;#no reset - set rowh [my header_height $hrow] - - if {$hrow == 0} { - set hlims $header_boxlimits_toprow - set rowpos "top" - if {$hrow == $hmax} { - set rowpos "only" - } - } else { - set hlims $header_boxlimits - set rowpos "middle" - if {$hrow == $hmax} { - set rowpos "bottom" - } - } - if {!$show_seps_v} { - set hlims [struct::set difference $hlims $headerseps_v] - } - if {$hrow == $hmax} { - set header_joins $header_body_joins - } else { - set header_joins $joins - } - if {![tcl::dict::get $o_opts_table -show_edge]} { - set hlims [struct::set difference $hlims [tcl::dict::get $::textblock::class::header_edge_parts $rowpos$opt_posn] ] - } - #puts ">>> headerspans: $headerspans cidx: $cidx" - - #if {$this_span eq "any" || $this_span > 0} {} - #changed to processing only numeric colspans - - if {$this_span > 0} { - set startmap [tcl::dict::get $hmap $rowpos${opt_posn}] - #look at spans in header below to determine joins required at blc - if {$show_seps_v} { - if {[tcl::dict::exists $all_colspans [expr {$hrow+1}]]} { - set next_spanlist [tcl::dict::get $all_colspans [expr {$hrow+1}]] - set spanbelow [lindex $next_spanlist $cidx] - if {$spanbelow == 0} { - #we don't want a down-join for blc - use a framedef with only left joins - tcl::dict::set startmap blc [tcl::dict::get $framedef_leftbox blc] - } - } else { - set next_spanlist [list] - } - } - - #supporting wrapping in headers might be a step too difficult for little payoff. - #we would need a flag to enable/disable - plus language-based wrapping alg (see tcllib) - #The interaction with colspans and width calculations makes it likely to have a heavy performance impact and make the code even more complex. - #May be better to require user to pre-wrap as needed - ##set hval [textblock::renderspace -width $colwidth -wrap 1 "" $hval] - - #review - contentwidth of hval can be greater than $colwidth+2 - if so frame function will detect and frame_cache will not be used - #This ellipsis 0 makes a difference (unwanted ellipsis at rhs of header column that starts span) - - # -width is always +2 - as the boxlimits take into account show_vseps and show_edge - #set header_cell_startspan [textblock::frame -ellipsis 0 -usecache 1 -width [expr {$hcolwidth+2}] -type [tcl::dict::get $ftypes header]\ - # -ansibase $ansibase_header -ansiborder $ansiborder_final\ - # -boxlimits $hlims -boxmap $startmap -joins $header_joins $hval\ - # ] - - if {$this_span == 1} { - #write the actual value now - set cellcontents $hval - } else { - #just write an empty vertical placeholder. The spanned value will be overtyped below - set cellcontents [::join [lrepeat [llength [split $hval \n]] ""] \n] - } - set header_cell_startspan [textblock::frame -blockalign $col_blockalign -ellipsis 0 -usecache 1 -width [expr {$hcolwidth+2}] -type [tcl::dict::get $ftypes header]\ - -ansibase $ansibase_header -ansiborder $ansiborder_final\ - -boxlimits $hlims -boxmap $startmap -joins $header_joins $cellcontents\ - ] - - if {$this_span != 1} { - #puts "===>\n$header_cell_startspan\n<===" - set spanned_parts [list $header_cell_startspan] - #assert this_span == "any" or >1 ie a header that spans other columns - #therefore more parts to append - #set remaining_cols [lrange [tcl::dict::keys $o_columndefs] $cidx end] - set remaining_spans [lrange $headerspans $cidx+1 end] - set spanval [join $remaining_spans ""] ;#so we can test for all zeros - set spans_to_rhs 0 - if {[expr {$spanval}] == 0} { - #puts stderr "SPANS TO RHS" - set spans_to_rhs 1 - } - - #puts ">> remaining_spans: $remaining_spans" - set spancol [expr {$cidx + 1}] - set h_lines [lrepeat $rowh ""] - set hcell_blank [::join $h_lines \n] ;#todo - just use -height option of frame? review - currently doesn't cache with -height and no contents - slow - - - - set last [expr {[llength $remaining_spans] -1}] - set i 0 - foreach s $remaining_spans { - if {$s == 0} { - if {$i == $last} { - set next_posn right - #set next_posn inner - } else { - set next_posn inner - } - - set next_headerseps_v [tcl::dict::get $sep_elements_vertical top$next_posn] ;#static top ok - - set limj [my Get_boxlimits_and_joins $next_posn $fname_body] - set span_joins_body [tcl::dict::get $limj bodyjoins] - set span_joins [tcl::dict::get $limj joins] - set span_boxlimits [tcl::dict::get $limj boxlimits] - set span_boxlimits_top [tcl::dict::get $limj boxlimits_top] - #use struct::set instead of simple for loop - will be faster at least when critcl available - #set span_boxlimits [struct::set intersect [tcl::dict::get $o_opts_table_effective -framelimits_body] $span_boxlimits] - #set span_boxlimits_top [struct::set intersect [tcl::dict::get $o_opts_table_effective -framelimits_body] $span_boxlimits_top] - set header_span_boxlimits [struct::set intersect [tcl::dict::get $o_opts_table_effective -framelimits_header] $span_boxlimits] - set header_span_boxlimits_top [struct::set intersect [tcl::dict::get $o_opts_table_effective -framelimits_header] $span_boxlimits_top] - if {$hrow == 0} { - set hlims $header_span_boxlimits_top - } else { - set hlims $header_span_boxlimits - } - - set this_span_map $span_extend_map - if {!$show_seps_v} { - set hlims [struct::set difference $hlims $next_headerseps_v] - } else { - if {[llength $next_spanlist]} { - set spanbelow [lindex $next_spanlist $spancol] - if {$spanbelow != 0} { - tcl::dict::set this_span_map blc [tcl::dict::get $framedef_headerdown_same hlbj] ;#horizontal line bottom with down join - to same frametype - } - } else { - #join to body - tcl::dict::set this_span_map blc [tcl::dict::get $framedef_headerdown_body hlbj] ;#horizontal line bottom with down join - from header frametype to body frametype - } - } - - if {$hrow == $hmax} { - set header_joins $span_joins_body - } else { - set header_joins $span_joins - } - if {![tcl::dict::get $o_opts_table -show_edge]} { - set hlims [struct::set difference $hlims [tcl::dict::get $::textblock::class::header_edge_parts $rowpos$next_posn] ] - } - - set contentwidth [my column_width $spancol] - set header_cell [textblock::frame -ellipsis 0 -width [expr {$contentwidth + 2}] -type [tcl::dict::get $ftypes header]\ - -ansibase $ansibase_header -ansiborder $ansiborder_final\ - -boxlimits $hlims -boxmap $this_span_map -joins $header_joins $hcell_blank\ - ] - lappend spanned_parts $header_cell - } else { - break - } - incr spancol - incr i - } - - #JMN - #spanned_parts are all built with textblock::frame - therefore uniform-width lines - can use join_basic - set spanned_frame [textblock::join_basic -- {*}$spanned_parts] - - if {$spans_to_rhs} { - if {$cidx == 0} { - set fake_posn solo - } else { - set fake_posn right - } - set x_limj [my Get_boxlimits_and_joins $fake_posn $fname_body] - if {$hrow == 0} { - set x_boxlimits_toprow [tcl::dict::get $x_limj boxlimits_top] - set hlims [struct::set intersect [tcl::dict::get $o_opts_table_effective -framelimits_header] $x_boxlimits_toprow] - } else { - set x_boxlimits_position [tcl::dict::get $x_limj boxlimits] - set hlims [struct::set intersect [tcl::dict::get $o_opts_table_effective -framelimits_header] $x_boxlimits_position] - } - } else { - if {$hrow == 0} { - set hlims $header_boxlimits_toprow - } else { - set hlims $header_boxlimits - } - } - if {!$show_seps_v} { - set hlims [struct::set difference $hlims $headerseps_v] - } - if {![tcl::dict::get $o_opts_table -show_edge]} { - if {$spans_to_rhs} { - #assert fake_posn has been set above based on cidx and spans_to_rhs - set hlims [struct::set difference $hlims [tcl::dict::get $::textblock::class::header_edge_parts ${rowpos}$fake_posn] ] - } else { - #use the edge_parts corresponding to the column being written to ie use opt_posn - set hlims [struct::set difference $hlims [tcl::dict::get $::textblock::class::header_edge_parts $rowpos$opt_posn] ] - } - } - - set spacemap [list hl " " vl " " tlc " " blc " " trc " " brc " "] ;#transparent overlay elements - #set spacemap [list hl * vl * tlc * blc * trc * brc *] - #-usecache 1 ok - #hval is not raw headerval - it has been padded to required width and has ansi applied - set hblock [textblock::frame -ellipsis 0 -type $spacemap -boxlimits $hlims -ansibase $ansibase_header $hval] ;#review -ansibase - #puts "==>boxlimits:'$hlims' hval_width:[tcl::string::length $hval] blockwidth:[textblock::width $hblock]" - #puts $hblock - #puts "==>hval:'$hval'[a]" - #puts "==>hval:'[ansistring VIEW $hval]'" - #set spanned_frame [overtype::renderspace -transparent 1 $spanned_frame $hblock] - - #spanned values default left - todo make configurable - - #TODO - #consider that currently blockaligning for spanned columns must always use the blockalign value from the starting column of the span - #we could conceivably have an override that could be set somehow with configure_header for customization of alignments of individual spans or span sizes? - #this seems like a likely requirement. The first spanned column may well have different alignment requirements than the span. - #(e.g if first spanned col happens to be numeric it probably warrants right textalign (if not blockalign) but we don't necessarily want the spanning header or even a non-spanning header to be right aligned) - - set spanned_frame [overtype::block -blockalign $col_blockalign -overflow 1 -transparent 1 $spanned_frame $hblock] - #POTENTIAL BUG (fixed with spans_to_rhs above) - #when -blockalign right and colspan extends to rhs - last char of longest of that spanlength will overlap right edge (if show_edge 1) - #we need to shift 1 to the left when doing our overtype with blockalign right - #we normally do this by using the hlims based on position - effectively we need a rhs position set of hlims for anything that colspans to the right edge - #(even though the column position may be left or inner) - - - - } else { - #this_span == 1 - set spanned_frame [textblock::join_basic -- $header_cell_startspan] - } - - - append part_header $spanned_frame - append part_header \n - } else { - #zero span header directly in this column ie one that is being colspanned by some column to our left - #previous col will already have built lines for this in it's own header rhs overhang - #we need a block of TSUB chars of the right height and width in this column so that we can join this column to the left ones with the TSUBs being transparent. - - #set padwidth [my column_datawidth $cidx -headers 0 -data 1 -cached 1] - - #if there are no header elements above then we will need a minimum of the column width - #may be extended to the widest portion of the header in the loop below - set padwidth [my column_width $cidx] - - - #under assumption we are building table using L frame method and that horizontal borders are only ever 1 high - # - we can avoid using a frame - but we potentially need to manually adjust for show_hpos show_edge etc - #avoiding frame here is faster.. but not by much (<10%? on textblock::spantest2 ) - if 0 { - #breaks -show_edge 0 - if {$rowpos eq "top" && [tcl::dict::get $o_opts_table -show_edge]} { - set padheight [expr {$rowh + 2}] - } else { - set padheight [expr {$rowh + 1}] - } - set bline [tcl::string::repeat $TSUB [expr {$padwidth +1}]] - set h_lines [lrepeat $padheight $bline] - set hcell_blank [::join $h_lines \n] - set header_frame $hcell_blank - } else { - set bline [tcl::string::repeat $TSUB $padwidth] - set h_lines [lrepeat $rowh $bline] - set hcell_blank [::join $h_lines \n] - # -usecache 1 ok - #frame borders will never display - so use the simplest frametype and don't apply any ansi - #puts "===>zerospan hlims: $hlims" - set header_frame [textblock::frame -ellipsis 0 -width [expr {$padwidth+2}] -type ascii\ - -boxlimits $hlims -boxmap $framesub_map $hcell_blank\ - ] - } - - append part_header $header_frame\n - - } - incr hrow - } - if {![llength $header_list]} { - #no headers - but we've been asked to show_header - #display a zero content-height header (ie outline if edge is being shown - or bottom bar) - set hlims $header_boxlimits_toprow - if {!$show_seps_v} { - set hlims [struct::set difference $hlims $headerseps_v] - } - if {![tcl::dict::get $o_opts_table -show_edge]} { - set hlims [struct::set difference $hlims [tcl::dict::get $::textblock::class::header_edge_parts only$opt_posn] ] - } - set header_joins $header_body_joins - set header_frame [textblock::frame -width [expr {$hcolwidth+2}] -type [tcl::dict::get $ftypes header]\ - -ansibase $ansibase_header -ansiborder $ansiborder_final\ - -boxlimits $hlims -boxmap $hdrmap -joins $header_joins\ - ] - append part_header $header_frame\n - } - set part_header [tcl::string::trimright $part_header \n] - lassign [textblock::size $part_header] _w return_headerwidth _h return_headerheight - - set padline [tcl::string::repeat $TSUB $return_headerwidth] - set adjusted_lines [list] - foreach ln [split $part_header \n] { - if {[tcl::string::first $TSUB $ln] >=0} { - lappend adjusted_lines $padline - } else { - lappend adjusted_lines $ln - } - } - set part_header [::join $adjusted_lines \n] - #append output $part_header \n - } - - set r 0 - set rmax [expr {[llength $cells]-1}] - - - set blims_mid $boxlimits - set blims_top $boxlimits - set blims_bot $boxlimits - set blims_top_headerless $boxlimits_headerless - set blims_only $boxlimits - set blims_only_headerless $boxlimits_headerless - if {!$show_seps_h} { - set blims_mid [struct::set difference $blims_mid $midseps_h] - set blims_top [struct::set difference $blims_top $topseps_h] - set blims_top_headerless [struct::set difference $blims_top_headerless $topseps_h] - } - if {!$show_seps_v} { - set blims_mid [struct::set difference $blims_mid $midseps_v] - set blims_top [struct::set difference $blims_top $topseps_v] - set blims_top_headerless [struct::set difference $blims_top_headerless $topseps_v] - set blims_bot [struct::set difference $blims_bot $botseps_v] - set blims_only [struct::set difference $blims_only $onlyseps_v] - set blims_only_headerless [struct::set difference $blims_only_headerless $onlyseps_v] - } - - set colidx [lindex [tcl::dict::keys $o_columndefs] $index_expression] ;#convert possible end-1,2+2 etc expression to >= 0 integer in dict range - - set opt_col_ansibase [tcl::dict::get $o_columndefs $colidx -ansibase] ;#ordinary merge of codes already done in configure_column - #set colwidth [my column_width $colidx] - - set body_ansibase [tcl::dict::get $o_opts_table -ansibase_body] - #set ansibase [punk::ansi::codetype::sgr_merge_singles [list $body_ansibase $opt_col_ansibase]] ;#allow col to override body - set body_ansiborder [tcl::dict::get $o_opts_table -ansiborder_body] - if {[tcl::dict::get $o_opts_table -frametype] eq "block"} { - #block is the only style where bg colour can fill the frame content area exactly if the L-shaped border elements are styled - #we need to only accept background ansi codes from the columndef ansibase for this - set col_bg [punk::ansi::codetype::sgr_merge_singles [list $opt_col_ansibase] -filter_fg 1] ;#special merge for block borders - don't override fg colours - set border_ansi $body_ansibase$body_ansiborder$col_bg - } else { - set border_ansi $body_ansibase$body_ansiborder - } - - - set r 0 - set ftblock [expr {[tcl::dict::get $o_opts_table -frametype] eq "block"}] - foreach c $cells { - #cells in column - each new c is in a different row - set row_ansibase [tcl::dict::get $o_rowdefs $r -ansibase] - set row_bg "" - if {$row_ansibase ne ""} { - set row_bg [punk::ansi::codetype::sgr_merge_singles [list $row_ansibase] -filter_fg 1] - } - - set ansibase $body_ansibase$opt_col_ansibase - #todo - joinleft,joinright,joindown based on opts in args - set cell_ansibase "" - - set ansiborder_body_col_row $border_ansi$row_bg - set ansiborder_final $ansiborder_body_col_row - #$c will always have ansi resets due to overtype behaviour ? - #todo - review overtype - if {[punk::ansi::ta::detect $c]} { - #use only the last ansi sequence in the cell value - #Filter out foreground and use background for ansiborder override - set parts [punk::ansi::ta::split_codes_single $c] - #we have detected ansi - so there will always be at least 3 parts beginning and ending with pt pt,ansi,pt,ansi...,pt - set codes [list] - foreach {pt cd} $parts { - if {$cd ne ""} { - lappend codes $cd - } - } - #set takebg [lindex $parts end-1] - #set cell_bg [punk::ansi::codetype::sgr_merge_singles [list $takebg] -filter_fg 1] - set cell_bg [punk::ansi::codetype::sgr_merge_singles $codes -filter_fg 1 -filter_reset 1] - #puts --->[ansistring VIEW $codes] - - if {[punk::ansi::codetype::is_sgr_reset [lindex $codes end]]} { - if {[punk::ansi::codetype::is_sgr_reset [lindex $codes end-1]]} { - #special case double reset at end of content - set cell_ansi_tail [punk::ansi::codetype::sgr_merge_singles $codes] ;#no filters - set ansibase "" - set row_ansibase "" - if {$ftblock} { - set ansiborder_final [punk::ansi::codetype::sgr_merge [list $ansiborder_body_col_row] -filter_bg 1] - } - set cell_ansibase $cell_ansi_tail - } else { - #single trailing reset in content - set cell_ansibase "" ;#cell doesn't contribute to frame's ansibase - } - } else { - if {$ftblock} { - #no resets - use cell's bg to extend to the border - only for block frames - set ansiborder_final $ansiborder_body_col_row$cell_bg - } - set cell_ansibase $cell_bg - } - } - - set ansibase_final $ansibase$row_ansibase$cell_ansibase - - if {$r == 0} { - if {$r == $rmax} { - set joins [lremove $joins [lsearch $joins down*]] - set bmap $onlymap - if {$do_show_header} { - set blims $blims_only - } else { - set blims $blims_only_headerless - } - if {![tcl::dict::get $o_opts_table -show_edge]} { - set blims [struct::set difference $blims [tcl::dict::get $::textblock::class::table_edge_parts only$opt_posn] ] - } - } else { - set bmap $topmap - if {$do_show_header} { - set blims $blims_top - } else { - set blims $blims_top_headerless - } - if {![tcl::dict::get $o_opts_table -show_edge]} { - set blims [struct::set difference $blims [tcl::dict::get $::textblock::class::table_edge_parts top$opt_posn] ] - } - } - set rowframe [textblock::frame -type [tcl::dict::get $ftypes body] -width [expr {$colwidth+2}] -blockalign $col_blockalign -ansibase $ansibase_final -ansiborder $ansiborder_final -boxlimits $blims -boxmap $bmap -joins $joins $c] - set return_bodywidth [textblock::widthtopline $rowframe] ;#frame lines always same width - just look at top line - append part_body $rowframe \n - } else { - if {$r == $rmax} { - set joins [lremove $joins [lsearch $joins down*]] - set bmap $botmap - set blims $blims_bot - if {![tcl::dict::get $o_opts_table -show_edge]} { - set blims [struct::set difference $blims [tcl::dict::get $::textblock::class::table_edge_parts bottom$opt_posn] ] - } - } else { - set bmap $midmap - set blims $blims_mid ;#will only be reduced from boxlimits if -show_seps was processed above - if {![tcl::dict::get $o_opts_table -show_edge]} { - set blims [struct::set difference $blims [tcl::dict::get $::textblock::class::table_edge_parts middle$opt_posn] ] - } - } - append part_body [textblock::frame -type [tcl::dict::get $ftypes body] -width [expr {$colwidth+2}] -blockalign $col_blockalign -ansibase $ansibase_final -ansiborder $ansiborder_final -boxlimits $blims -boxmap $bmap -joins $joins $c]\n - } - incr r - } - #return empty (zero content height) row if no rows - if {![llength $cells]} { - set joins [lremove $joins [lsearch $joins down*]] - #we need to know the width of the column to setup the empty cell properly - #even if no header displayed - we should take account of any defined column widths - set colwidth [my column_width $index_expression] - - if {$do_show_header} { - set blims $blims_only - } else { - append part_body \n - set blims $blims_only_headerless - } - #note that if show_edge is 0 - then for this empty line - we will not expect to see any bars - #This is because the frame with no data had vertical components made entirely of corner elements - #we could just append a newline when -show_edge is zero, but we want the correct width even when empty - for proper column joins when there are colspanned headers. - # - if {![tcl::dict::get $o_opts_table -show_edge]} { - #set blims [struct::set difference $blims [tcl::dict::get $::textblock::class::table_edge_parts only$opt_posn] ] - #append output [textblock::frame -width [expr {$colwidth + 2}] -type [tcl::dict::get $ftypes body] -boxlimits $blims -boxmap $onlymap -joins $joins]\n - append part_body [tcl::string::repeat " " $colwidth] \n - set return_bodywidth $colwidth - } else { - set emptyframe [textblock::frame -width [expr {$colwidth + 2}] -type [tcl::dict::get $ftypes body] -boxlimits $blims -boxmap $onlymap -joins $joins] - append part_body $emptyframe \n - set return_bodywidth [textblock::width $emptyframe] - } - } - #assert bodywidth is integer >=0 whether there are rows or not - - #trim only 1 newline - if {[tcl::string::index $part_body end] eq "\n"} { - set part_body [tcl::string::range $part_body 0 end-1] - } - set return_bodyheight [textblock::height $part_body] - #append output $part_body - - if {$opt_return eq "string"} { - if {$part_header ne ""} { - set output $part_header - if {$part_body ne ""} { - append output \n $part_body - } - } else { - set output $part_body - } - return $output - } else { - return [tcl::dict::create header $part_header body $part_body headerwidth $return_headerwidth headerheight $return_headerheight bodywidth $return_bodywidth bodyheight $return_bodyheight] - } - } - - method get_column_cells_by_index {index_expression} { - set cidx [lindex [tcl::dict::keys $o_columndefs] $index_expression] - if {$cidx eq ""} { - set range "" - if {[tcl::dict::size $o_columndefs] > 0} { - set range "0..[expr {[tcl::dict::size $o_columndefs] -1}]" - } else { - set range empty - } - error "table::get_column_cells_by_index no such index $index_expression. Valid range is $range" - } - #assert cidx is integer >=0 - set num_header_rows [my header_count] - set cdef [tcl::dict::get $o_columndefs $cidx] - set headerlist [tcl::dict::get $cdef -headers] - set ansibase_col [tcl::dict::get $cdef -ansibase] - set textalign [tcl::dict::get $cdef -textalign] - switch -- $textalign { - left {set pad right} - right {set pad left} - default { - set pad "centre" ;#todo? - } - } - - set ansibase_body [tcl::dict::get $o_opts_table -ansibase_body] - set ansibase_header [tcl::dict::get $o_opts_table -ansibase_header] - - #set header_underlay $ansibase_header$cell_line_blank - - #set hdrwidth [my column_width_configured $cidx] - #set all_colspans [my header_colspans] - #we need to replace the 'any' entries with their actual span lengths before passing any -colspan values to column_datawidth - hence use header_colspans_numeric - set all_colspans [my header_colspans_numeric] - #JMN - #store configured widths so we don't look up for each header line - #set configured_widths [list] - #foreach c [tcl::dict::keys $o_columndefs] { - # #lappend configured_widths [my column_width $c] - # #we don't just want the width of the column in the body - or the headers will get truncated - # lappend configured_widths [my column_width_configured $c] - #} - - set output [tcl::dict::create] - tcl::dict::set output headers [list] - - set showing_vseps [my Showing_vseps] - for {set hrow 0} {$hrow < $num_header_rows} {incr hrow} { - set hdr [lindex $headerlist $hrow] - set header_maxdataheight [my header_height $hrow] ;#from cached headerstates - set headerrow_colspans [tcl::dict::get $all_colspans $hrow] - set this_span [lindex $headerrow_colspans $cidx] - - #set this_hdrwidth [lindex $configured_widths $cidx] - set this_hdrwidth [my column_datawidth $cidx -headers 1 -colspan $this_span -cached 1] ;#widest of headers in this col with same span - allows textalign to work with blockalign - - set hcell_line_blank [tcl::string::repeat " " $this_hdrwidth] - set hcell_lines [lrepeat $header_maxdataheight $hcell_line_blank] - set hval_lines [split $hdr \n] - set hval_lines [concat $hval_lines $hcell_lines] - set hval_lines [lrange $hval_lines 0 $header_maxdataheight-1] ;#vertical align top - set hval_block [::join $hval_lines \n] - set hcell [textblock::pad $hval_block -width $this_hdrwidth -padchar " " -within_ansi 1 -which $pad] - tcl::dict::lappend output headers $hcell - } - - - #set colwidth [my column_width $cidx] - #set cell_line_blank [tcl::string::repeat " " $colwidth] - set datawidth [my column_datawidth $cidx -headers 0 -footers 0 -data 1 -cached 1] - set cell_line_blank [tcl::string::repeat " " $datawidth] - - - - set items [tcl::dict::get $o_columndata $cidx] - #puts "---> columndata $o_columndata" - - #set opt_row_ansibase [tcl::dict::get $o_rowdefs $r -ansibase] - #set cell_ansibase $ansibase_body$ansibase_col$opt_row_ansibase - - tcl::dict::set output cells [list];#ensure we return something for cells key if no items in list - set r 0 - foreach cval $items { - #todo move to row_height method ? - set maxdataheight [tcl::dict::get $o_rowstates $r -maxheight] - set rowdefminh [tcl::dict::get $o_rowdefs $r -minheight] - set rowdefmaxh [tcl::dict::get $o_rowdefs $r -maxheight] - if {"$rowdefminh$rowdefmaxh" ne "" && $rowdefminh eq $rowdefmaxh} { - #an exact height is defined for the row - set rowh $rowdefminh - } else { - if {$rowdefminh eq ""} { - if {$rowdefmaxh eq ""} { - #both defs empty - set rowh $maxdataheight - } else { - set rowh [expr {min(1,$rowdefmaxh,$maxdataheight)}] - } - } else { - if {$rowdefmaxh eq ""} { - set rowh [expr {max($rowdefminh,$maxdataheight)}] - } else { - if {$maxdataheight < $rowdefminh} { - set rowh $rowdefminh - } else { - set rowh [expr {max($rowdefminh,$maxdataheight)}] - } - } - } - } - - set cell_lines [lrepeat $rowh $cell_line_blank] - #set cell_blank [join $cell_lines \n] - - - set cval_lines [split $cval \n] - set cval_lines [concat $cval_lines $cell_lines] - set cval_lines [lrange $cval_lines 0 $rowh-1] - set cval_block [::join $cval_lines \n] - - - set cell [textblock::pad $cval_block -width $datawidth -padchar " " -within_ansi 1 -which $pad] - #set cell [textblock::pad $cval_block -width $colwidth -padchar " " -within_ansi 0 -which left] - tcl::dict::lappend output cells $cell - - incr r - } - return $output - } - method get_column_values_by_index {index_expression} { - set cidx [lindex [tcl::dict::keys $o_columndefs] $index_expression] - if {$cidx eq ""} { - return - } - return [tcl::dict::get $o_columndata $cidx] - } - method debug {args} { - #nice to lay this out with tables - but this is the one function where we really should provide the ability to avoid tables in case things get really broken (e.g major refactor) - set defaults [tcl::dict::create\ - -usetables 1\ - ] - foreach {k v} $args { - switch -- $k { - -usetables {} - default { - error "table debug unrecognised option '$k'. Known options: [tcl::dict::keys $defaults]" - } - } - } - set opts [tcl::dict::merge $defaults $args] - set opt_usetables [tcl::dict::get $opts -usetables] - - puts stdout "rowdefs: $o_rowdefs" - puts stdout "rowstates: $o_rowstates" - #puts stdout "columndefs: $o_columndefs" - puts stdout "columndefs:" - if {!$opt_usetables} { - tcl::dict::for {k v} $o_columndefs { - puts " $k $v" - } - } else { - set t [textblock::class::table new] - $t add_column -headers "Col" - tcl::dict::for {col coldef} $o_columndefs { - foreach property [tcl::dict::keys $coldef] { - if {$property eq "-ansireset"} { - continue - } - $t add_column -headers $property - } - break - } - - #build our inner tables first so we can sync widths - set col_header_tables [tcl::dict::create] - set max_widths [tcl::dict::create 0 0 1 0 2 0 3 0] ;#max inner table column widths - tcl::dict::for {col coldef} $o_columndefs { - set row [list $col] - set colheaders [tcl::dict::get $coldef -headers] - #inner table probably overkill here ..but just as easy - set htable [textblock::class::table new] - $htable configure -show_header 1 -show_edge 0 -show_hseps 0 - $htable add_column -headers row - $htable add_column -headers text - $htable add_column -headers WxH - $htable add_column -headers span - set hnum 0 - set spans [tcl::dict::get $o_columndefs $col -header_colspans] - foreach h $colheaders s $spans { - lassign [textblock::size $h] _w width _h height - $htable add_row [list "$hnum " $h "${width}x${height}" $s] - incr hnum - } - $htable configure_column 0 -ansibase [a+ web-dimgray] - tcl::dict::set col_header_tables $col $htable - set colwidths [$htable column_widths] - set icol 0 - foreach w $colwidths { - if {$w > [tcl::dict::get $max_widths $icol]} { - tcl::dict::set max_widths $icol $w - } - incr icol - } - } - - #safe jumptable test - #dict for {col coldef} $o_columndefs {} - tcl::dict::for {col coldef} $o_columndefs { - set row [list $col] - #safe jumptable test - #dict for {property val} $coldef {} - tcl::dict::for {property val} $coldef { - switch -- $property { - -ansireset {continue} - -headers { - set htable [tcl::dict::get $col_header_tables $col] - tcl::dict::for {innercol maxw} $max_widths { - $htable configure_column $innercol -minwidth $maxw -blockalign left - } - lappend row [$htable print] - $htable destroy - } - default { - lappend row $val - } - } - } - $t add_row $row - } - - - - - $t configure -show_header 1 - puts stdout [$t print] - $t destroy - } - puts stdout "columnstates: $o_columnstates" - puts stdout "headerstates: $o_headerstates" - tcl::dict::for {k coldef} $o_columndefs { - if {[tcl::dict::exists $o_columndata $k]} { - set headerlist [tcl::dict::get $coldef -headers] - set coldata [tcl::dict::get $o_columndata $k] - set colinfo "rowcount: [llength $coldata]" - set allfields [concat $headerlist $coldata] - if {[llength $allfields]} { - set widest [tcl::mathfunc::max {*}[lmap v $allfields {textblock::width $v}]] - } else { - set widest 0 - } - append colinfo " widest of headers and data: $widest" - } else { - set colinfo "WARNING - no columndata record for column key '$k'" - } - puts stdout "column $k columndata info: $colinfo" - } - set result "" - set cols [list] - set max [expr {[tcl::dict::size $o_columndefs]-1}] - foreach c [tcl::dict::keys $o_columndefs] { - if {$c == 0} { - lappend cols [my get_column_by_index $c -position left] " " - } elseif {$c == $max} { - lappend cols [my get_column_by_index $c -position right] - } else { - lappend cols [my get_column_by_index $c -position inner] " " - } - } - append result [textblock::join -- {*}$cols] - return $result - } - #column width including headers - but without colspan consideration - method column_width_configured {index_expression} { - set cidx [lindex [tcl::dict::keys $o_columndefs] $index_expression] - if {$cidx eq ""} { - return - } - #assert cidx is now >=0 integer within the range of defined columns - set cdef [tcl::dict::get $o_columndefs $cidx] - set defminw [tcl::dict::get $cdef -minwidth] - set defmaxw [tcl::dict::get $cdef -maxwidth] - if {"$defminw$defmaxw" ne "" && $defminw eq $defmaxw} { - #an exact width is defined for the column - no need to look at data width - set colwidth $defminw - } else { - #set widest [my column_datawidth $cidx -headers 1 -data 1 -footers 1] - set hwidest [tcl::dict::get $o_columnstates $cidx maxwidthheaderseen] - #set hwidest [my column_datawidth $cidx -headers 1 -colspan 1 -data 0 -footers 1] - #set hwidest_singlespan ?? - set bwidest [tcl::dict::get $o_columnstates $cidx maxwidthbodyseen] - set widest [expr {max($hwidest,$bwidest)}] - #todo - predetermine if any items in column contain newlines and are truncated vertically due to o_rowdefs configuration. - #if so - a truncated line shouldn't be included in our width calculation - if {$defminw eq ""} { - if {$defmaxw eq ""} { - set colwidth $widest - } else { - set colwidth [expr {min($defmaxw,$widest)}] - } - } else { - if {$defmaxw eq ""} { - set colwidth [expr {max($defminw,$widest)}] - } else { - if {$widest < $defminw} { - set colwidth $defminw - } else { - if {$widest > $defmaxw} { - set colwidth $defmaxw - } else { - set colwidth [expr {max($defminw,$widest)}] - } - } - } - } - } - return $colwidth - } - - method column_width {index_expression} { - if {[llength $o_calculated_column_widths] != [tcl::dict::size $o_columndefs]} { - my calculate_column_widths -algorithm $o_column_width_algorithm - } - return [lindex $o_calculated_column_widths $index_expression] - } - method column_widths {} { - if {[llength $o_calculated_column_widths] != [tcl::dict::size $o_columndefs]} { - my calculate_column_widths -algorithm $o_column_width_algorithm - } - return $o_calculated_column_widths - } - - #width of a table includes borders and seps - #whereas width of a column refers to the borderless width (inner width) - method width {} { - #calculate width based on assumption frame verticals are 1-wide - review - what about custom unicode double-wide frame? - set colwidths [my column_widths] - set contentwidth [tcl::mathop::+ {*}$colwidths] - set twidth $contentwidth - if {[my Showing_vseps]} { - incr twidth [llength $colwidths] - incr twidth -1 - } - if {[tcl::dict::get $o_opts_table -show_edge]} { - incr twidth 2 - } - return $twidth - } - - #column *body* content width - method basic_column_width {index_expression} { - set cidx [lindex [tcl::dict::keys $o_columndefs] $index_expression] - if {$cidx eq ""} { - return - } - #puts "===column_width $index_expression" - #assert cidx is now >=0 integer within the range of defined columns - set cdef [tcl::dict::get $o_columndefs $cidx] - set defminw [tcl::dict::get $cdef -minwidth] - set defmaxw [tcl::dict::get $cdef -maxwidth] - if {"$defminw$defmaxw" ne "" && $defminw eq $defmaxw} { - #an exact width is defined for the column - no need to look at data width - #review - this can result in truncation of spanning headers - even though there is enough width in the span-cell to place the full header - set colwidth $defminw - } else { - #set widest [my column_datawidth $cidx -headers 0 -data 1 -footers 0] - set widest [tcl::dict::get $o_columnstates $cidx maxwidthbodyseen] - #todo - predetermine if any items in column contain newlines and are truncated vertically due to o_rowdefs configuration. - #if so - a truncated line shouldn't be included in our width calculation - if {$defminw eq ""} { - if {$defmaxw eq ""} { - set colwidth $widest - } else { - set colwidth [expr {min($defmaxw,$widest)}] - } - } else { - if {$defmaxw eq ""} { - set colwidth [expr {max($defminw,$widest)}] - } else { - if {$widest < $defminw} { - set colwidth $defminw - } else { - if {$widest > $defmaxw} { - set colwidth $defmaxw - } else { - set colwidth [expr {max($defminw,$widest)}] - } - } - } - } - } - set configured_widths [list] - foreach c [tcl::dict::keys $o_columndefs] { - lappend configured_widths [my column_width_configured $c] - } - set header_colspans [my header_colspans] - set width_max $colwidth - set test_width $colwidth - set showing_vseps [my Showing_vseps] - set thiscol_widest_header [tcl::dict::get $o_columnstates $cidx maxwidthheaderseen] - tcl::dict::for {h colspans} $header_colspans { - set spanc [lindex $colspans $cidx] - #set headers [tcl::dict::get $cdef -headers] - #set thiscol_widest_header 0 - #if {[llength $headers] > 0} { - # set thiscol_widest_header [tcl::mathfunc::max {*}[lmap v $headers {textblock::width $v}]] - #} - if {$spanc eq "1"} { - if {$thiscol_widest_header > $colwidth} { - set test_width [expr {max($thiscol_widest_header,$colwidth)}] - if {$defmaxw ne ""} { - set test_width [expr {min($colwidth,$defmaxw)}] - } - } - set width_max [expr {max($test_width,$width_max)}] - continue - } - if {$spanc eq "any" || $spanc > 1} { - set spanned [list] ;#spanned is other columns spanned - not including this one - set cnext [expr {$cidx +1}] - set spanlength [lindex $colspans $cnext] - while {$spanlength eq "0" && $cnext < [llength $colspans]} { - lappend spanned $cnext - incr cnext - set spanlength [lindex $colspans $cnext] - } - set others_width 0 - foreach col $spanned { - incr others_width [lindex $configured_widths $col] - if {$showing_vseps} { - incr others_width 1 - } - } - set total_spanned_width [expr {$width_max + $others_width}] - if {$thiscol_widest_header > $total_spanned_width} { - #this just allocates the extra space in the current column - which is not great. - #A proper algorithm for distributing width created by headers to all the spanned columns is needed. - #This is a tricky problem with multiple header lines and arbitrary spans. - #The calculation should probably be done on the table as a whole first and this function should just look up that result. - #Trying to calculate on a specific column only is unlikely to be easy or efficient. - set needed [expr {$thiscol_widest_header - $total_spanned_width}] - #puts "-->>col $cidx needed ($thiscol_widest_header - $total_spanned_width): $needed (spanned $spanned)" - if {$defmaxw ne ""} { - set test_width [expr {min($colwidth+$needed,$defmaxw)}] - } else { - set test_width [expr {$colwidth + $needed}] - } - } - } - set width_max [expr {max($test_width,$width_max)}] - } - - #alternative to all the above shennanigans.. let the body cell data determine the size and just wrap the headers - #could also split the needed width amongst the spanned columns? configurable for whether cells expand? - set expand_first_column 1 - if {$expand_first_column} { - set colwidth $width_max - } - - #puts "---column_width $cidx = $colwidth" - return $colwidth - } - method Showing_vseps {} { - #review - show_seps and override mechanism for show_vseps show_hseps - document. - set seps [tcl::dict::get $o_opts_table -show_seps] - set vseps [tcl::dict::get $o_opts_table -show_vseps] - if {$seps eq ""} { - if {$vseps eq "" || $vseps} { - return true - } - } elseif {$seps} { - if {$vseps eq "" || $vseps} { - return true - } - } else { - if {$vseps ne "" && $vseps} { - return true - } - } - return false - } - - method column_datawidth {index_expression args} { - set opts [tcl::dict::create\ - -headers 0\ - -footers 0\ - -colspan unspecified\ - -data 1\ - -cached 1\ - ] - #NOTE: -colspan any is not the same as * - # - #-colspan is relevant to header/footer data only - foreach {k v} $args { - switch -- $k { - -headers - -footers - -colspan - -data - -cached { - tcl::dict::set opts $k $v - } - default { - error "column_datawidth unrecognised flag '$k'. Known flags: [tcl::dict::keys $opts]" - } - } - } - set opt_colspan [tcl::dict::get $opts -colspan] - switch -- $opt_colspan { - * - unspecified {} - any { - error "method column_datawidth invalid -colspan '$opt_colspan' must be * or an integer >= 0 (use header_colspans_numeric to get actual spans)" - } - default { - if {![string is integer -strict $opt_colspan]} { - error "method column_datawidth invalid -colspan '$opt_colspan' must be * or an integer >= 0" - } - } - } - - - set cidx [lindex [tcl::dict::keys $o_columndefs] $index_expression] - if {$cidx eq ""} { - return - } - - if {[tcl::dict::get $opts -cached]} { - set hwidest 0 - set bwidest 0 - set fwidest 0 - if {[tcl::dict::get $opts -headers]} { - if {$opt_colspan in {* unspecified}} { - set hwidest [tcl::dict::get $o_columnstates $cidx maxwidthheaderseen] - } else { - #this is not cached - # -- --- --- --- - set colheaders [tcl::dict::get $o_columndefs $cidx -headers] - set all_colspans_by_header [my header_colspans_numeric] - set hlist [list] - tcl::dict::for {hrow cspans} $all_colspans_by_header { - set s [lindex $cspans $cidx] - if {$s eq $opt_colspan} { - lappend hlist [lindex $colheaders $hrow] - } - } - if {[llength $hlist]} { - set hwidest [tcl::mathfunc::max {*}[lmap v $hlist {textblock::width $v}]] - } else { - set hwidest 0 - } - # -- --- --- --- - } - } - if {[tcl::dict::get $opts -data]} { - set bwidest [tcl::dict::get $o_columnstates $cidx maxwidthbodyseen] - } - if {[tcl::dict::get $opts -footers]} { - #TODO! - #set bwidest [tcl::dict::get $o_columnstates $cidx maxwidthfooterseen] - } - return [expr {max($hwidest,$bwidest,$fwidest)}] - } - - #assert cidx is >=0 integer in valid range of keys for o_columndefs - set values [list] - set hwidest 0 - if {[tcl::dict::get $opts -headers]} { - if {$opt_colspan in {* unspecified}} { - lappend values {*}[tcl::dict::get $o_columndefs $cidx -headers] - } else { - # -- --- --- --- - set colheaders [tcl::dict::get $o_columndefs $cidx -headers] - set all_colspans_by_header [my header_colspans_numeric] - set hlist [list] - tcl::dict::for {hrow cspans} $all_colspans_by_header { - set s [lindex $cspans $cidx] - if {$s eq $opt_colspan} { - lappend hlist [lindex $colheaders $hrow] - } - } - if {[llength $hlist]} { - set hwidest [tcl::mathfunc::max {*}[lmap v $hlist {textblock::width $v}]] - } else { - set hwidest 0 - } - # -- --- --- --- - } - } - if {[tcl::dict::get $opts -data]} { - if {[tcl::dict::exists $o_columndata $cidx]} { - lappend values {*}[tcl::dict::get $o_columndata $cidx] - } - } - if {[tcl::dict::get $opts -footers]} { - lappend values {*}[tcl::dict::get $o_columndefs $cidx -footers] - } - if {[llength $values]} { - set valwidest [tcl::mathfunc::max {*}[lmap v $values {textblock::width $v}]] - set widest [expr {max($valwidest,$hwidest)}] - } else { - set widest $hwidest - } - return $widest - } - #print1 uses basic column joining - useful for testing/debug especially with colspans - method print1 {args} { - if {![llength $args]} { - set cols [tcl::dict::keys $o_columndata] - } else { - set cols [list] - foreach colspec $args { - set allcols [tcl::dict::keys $o_columndata] - if {[tcl::string::first .. $colspec] >=0} { - set parts [punk::ansi::ta::_perlish_split {\.\.} $colspec] - if {[llength $parts] != 3} { - error "[namespace::current]::table error invalid print specification '$colspec'" - } - lassign $parts from _dd to - if {$from eq ""} {set from 0 } - if {$to eq ""} {set to end} - - set indices [lrange $allcols $from $to] - lappend cols {*}$indices - } else { - set c [lindex $allcols $colspec] - if {$c ne ""} { - lappend cols $c - } - } - } - } - set blocks [list] - set colposn 0 - set numposns [llength $cols] - foreach c $cols { - set flags [list] - if {$colposn == 0 && $colposn == $numposns-1} { - set flags [list -position solo] - } elseif {$colposn == 0} { - set flags [list -position left] - } elseif {$colposn == $numposns-1} { - set flags [list -position right] - } else { - set flags [list -position inner] - } - lappend blocks [my get_column_by_index $c {*}$flags] - incr colposn - } - if {[llength $blocks]} { - return [textblock::join -- {*}$blocks] - } else { - return "No columns matched" - } - } - method columncalc_spans {allocmethod} { - set colwidths [tcl::dict::create] ;# to use tcl::dict::incr - set colspace_added [tcl::dict::create] - - set ordered_spans [tcl::dict::create] - tcl::dict::for {col spandata} [my spangroups] { - set dwidth [my column_datawidth $col -data 1 -headers 0 -footers 0 -cached 1] - set minwidth [tcl::dict::get $o_columndefs $col -minwidth] - set maxwidth [tcl::dict::get $o_columndefs $col -maxwidth] - if {$minwidth ne ""} { - if {$dwidth < $minwidth} { - set dwidth $minwidth - } - } - if {$maxwidth ne ""} { - if {$dwidth > $maxwidth} { - set dwidth $maxwidth - } - } - tcl::dict::set colwidths $col $dwidth ;#spangroups is ordered by column - so colwidths dict will be correctly ordered - tcl::dict::set colspace_added $col 0 - - set spanlengths [tcl::dict::get $spandata spanlengths] - foreach slen $spanlengths { - set spans [tcl::dict::get $spandata spangroups $slen] - set spans [lsort -index 7 -integer $spans] - foreach s $spans { - set hwidth [tcl::dict::get $s headerwidth] - set hrow [tcl::dict::get $s hrow] - set scol [tcl::dict::get $s startcol] - tcl::dict::set ordered_spans $scol,$hrow membercols $col $dwidth - tcl::dict::set ordered_spans $scol,$hrow headerwidth $hwidth - } - } - } - - #safe jumptable test - #dict for {spanid spandata} $ordered_spans {} - tcl::dict::for {spanid spandata} $ordered_spans { - lassign [split $spanid ,] startcol hrow - set memcols [tcl::dict::get $spandata membercols] ;#dict with col and initial width - we ignore initial width, it's there in case we want to allocate space based on initial data width ratios - set colids [tcl::dict::keys $memcols] - set hwidth [tcl::dict::get $spandata headerwidth] - set num_cols_spanned [tcl::dict::size $memcols] - if {$num_cols_spanned == 1} { - set col [lindex $memcols 0] - set space_to_alloc [expr {$hwidth - [tcl::dict::get $colwidths $col]}] - if {$space_to_alloc > 0} { - set maxwidth [tcl::dict::get $o_columndefs $col -maxwidth] - if {$maxwidth ne ""} { - if {$maxwidth > [tcl::dict::get $colwidths $col]} { - set can_alloc [expr {$maxwidth - [tcl::dict::get $colwidths $col]}] - } else { - set can_alloc 0 - } - set will_alloc [expr {min($space_to_alloc,$can_alloc)}] - } else { - set will_alloc $space_to_alloc - } - if {$will_alloc} { - #tcl::dict::set colwidths $col $hwidth - tcl::dict::incr colwidths $col $will_alloc - tcl::dict::set colspace_added $col $will_alloc - } - #log! - #if {$will_alloc < $space_to_alloc} { - # #todo - debug only - # puts stderr "max width $maxwidth hit for col $col - cannot allocate extra [expr {$space_to_alloc - $will_alloc}]" - #} - } - } elseif {$num_cols_spanned > 1} { - set spannedwidth 0 - foreach col $colids { - incr spannedwidth [tcl::dict::get $colwidths $col] - } - set space_to_alloc [expr {$hwidth - $spannedwidth}] - if {[my Showing_vseps]} { - set sepcount [expr {$num_cols_spanned -1}] - incr space_to_alloc -$sepcount - } - #review - we want to reduce overallocation to earlier or later columns - hence the use of colspace_added - switch -- $allocmethod { - least { - #add to least-expanded each time - #safer than method 1 - pretty balanced - if {$space_to_alloc > 0} { - for {set i 0} {$i < $space_to_alloc} {incr i} { - set ordered_colspace_added [lsort -stride 2 -index 1 -integer $colspace_added] - set ordered_all_colids [tcl::dict::keys $ordered_colspace_added] - foreach testcolid $ordered_all_colids { - if {$testcolid in $colids} { - #assert - we will always find a match - set colid $testcolid - break - } - } - tcl::dict::incr colwidths $colid - tcl::dict::incr colspace_added $colid - } - } - } - least_unmaxed { - #TODO - fix header truncation/overflow issues when they are restricted by column maxwidth - #(we should be able to collapse column width to zero and have header colspans gracefully respond) - #add to least-expanded each time - #safer than method 1 - pretty balanced - if {$space_to_alloc > 0} { - for {set i 0} {$i < $space_to_alloc} {incr i} { - set ordered_colspace_added [lsort -stride 2 -index 1 -integer $colspace_added] - set ordered_all_colids [tcl::dict::keys $ordered_colspace_added] - set colid "" - foreach testcolid $ordered_all_colids { - set maxwidth [tcl::dict::get $o_columndefs $testcolid -maxwidth] - set can_alloc [expr {$maxwidth eq "" || $maxwidth > [tcl::dict::get $colwidths $testcolid]}] - if {$testcolid in $colids} { - if {$can_alloc} { - set colid $testcolid - break - } else { - #remove from future consideration in for loop - #log! - #puts stderr "max width $maxwidth hit for col $testcolid" - tcl::dict::unset colspace_added $testcolid - } - } - } - if {$colid ne ""} { - tcl::dict::incr colwidths $colid - tcl::dict::incr colspace_added $colid - } - } - } - } - all { - #adds space to all columns - not just those spanned - risk of underallocating and truncating some headers! - #probably not a good idea for tables with complex headers and spans - while {$space_to_alloc > 0} { - set ordered_colspace_added [lsort -stride 2 -index 1 -integer $colspace_added] - set ordered_colids [tcl::dict::keys $ordered_colspace_added] - - foreach col $ordered_colids { - tcl::dict::incr colwidths $col - tcl::dict::incr colspace_added $col - incr space_to_alloc -1 - if {$space_to_alloc == 0} { - break - } - } - } - - } - } - } - } - - set column_widths [tcl::dict::values $colwidths] - #todo - -maxwidth etc - set table_minwidth [tcl::dict::get $o_opts_table -minwidth] ;#min width including frame elements - if {[tcl::string::is integer -strict $table_minwidth]} { - set contentwidth [tcl::mathop::+ {*}$column_widths] - set twidth $contentwidth - if {[my Showing_vseps]} { - incr twidth [llength $column_widths] - incr twidth -1 - } - if {[tcl::dict::get $o_opts_table -show_edge]} { - incr twidth 2 - } - # - set shortfall [expr {$table_minwidth - $twidth}] - if {$shortfall > 0} { - set space_to_alloc $shortfall - while {$space_to_alloc > 0} { - set ordered_colspace_added [lsort -stride 2 -index 1 -integer $colspace_added] - set ordered_colids [tcl::dict::keys $ordered_colspace_added] - - foreach col $ordered_colids { - tcl::dict::incr colwidths $col - tcl::dict::incr colspace_added $col - incr space_to_alloc -1 - if {$space_to_alloc == 0} { - break - } - } - } - set column_widths [tcl::dict::values $colwidths] - } - - } - - return [list ordered_spans $ordered_spans colwidths $column_widths adjustments $colspace_added] - } - - #spangroups keyed by column - method spangroups {} { - set column_count [tcl::dict::size $o_columndefs] - set spangroups [tcl::dict::create] - set headerwidths [tcl::dict::create] ;#key on col,hrow - foreach c [tcl::dict::keys $o_columndefs] { - tcl::dict::set spangroups $c [list spanlengths {}] - set spanlist [my column_get_spaninfo $c] - set index_spanlen_val 5 - set spanlist [lsort -index $index_spanlen_val -integer $spanlist] - set ungrouped $spanlist - - while {[llength $ungrouped]} { - set spanlen [lindex $ungrouped 0 $index_spanlen_val] - set spangroup_posns [lsearch -all -index $index_spanlen_val $ungrouped $spanlen] - set sgroup [list] - foreach p $spangroup_posns { - set spaninfo [lindex $ungrouped $p] - set hcol [tcl::dict::get $spaninfo startcol] - set hrow [tcl::dict::get $spaninfo hrow] - set header [lindex [tcl::dict::get $o_columndefs $hcol -headers] $hrow] - if {[tcl::dict::exists $headerwidths $hcol,$hrow]} { - set hwidth [tcl::dict::get $headerwidths $hcol,$hrow] - } else { - set hwidth [textblock::width $header] - tcl::dict::set headerwidths $hcol,$hrow $hwidth - } - lappend spaninfo headerwidth $hwidth - lappend sgroup $spaninfo - } - set spanlengths [tcl::dict::get $spangroups $c spanlengths] - lappend spanlengths $spanlen - tcl::dict::set spangroups $c spanlengths $spanlengths - tcl::dict::set spangroups $c spangroups $spanlen $sgroup - set ungrouped [lremove $ungrouped {*}$spangroup_posns] - } - } - return $spangroups - } - method column_get_own_spans {cidx} { - set colspans_for_column [tcl::dict::get $o_columndefs $cidx -header_colspans] - } - method column_get_spaninfo {cidx} { - set spans_by_header [my header_colspans] - set colspans_for_column [tcl::dict::get $o_columndefs $cidx -header_colspans] - set spaninfo [list] - set numcols [tcl::dict::size $o_columndefs] - #note that 'any' can occur in positions other than column 0 - meaning any remaining until next non-zero span - tcl::dict::for {hrow rawspans} $spans_by_header { - set thiscol_spanval [lindex $rawspans $cidx] - if {$thiscol_spanval eq "any" || $thiscol_spanval > 0} { - set spanstartcol $cidx ;#own column - if {$thiscol_spanval eq "any"} { - #scan right to first non-zero to get actual length of 'any' span - #REVIEW! - set spanlen 1 - for {set i [expr {$cidx+1}]} {$i < $numcols} {incr i} { - #abort at next any or number or empty string - if {[lindex $rawspans $i] ne "0"} { - break - } - incr spanlen - } - #set spanlen [expr {$numcols - $cidx}] - } else { - set spanlen $thiscol_spanval - } - } else { - #look left til we see an any or a non-zero value - for {set i $cidx} {$i > -1} {incr i -1} { - set s [lindex $rawspans $i] - if {$s eq "any" || $s > 0} { - set spanstartcol $i - if {$s eq "any"} { - #REVIEW! - #set spanlen [expr {$numcols - $i}] - set spanlen 1 - #now scan right to see how long the 'any' actually is - for {set j [expr {$i+1}]} {$j < $numcols} {incr j} { - if {[lindex $rawspans $j] ne "0"} { - break - } - incr spanlen - } - } else { - set spanlen $s - } - break - } - } - } - #assert - we should always find 1 answer for each header row - lappend spaninfo [list hrow $hrow startcol $spanstartcol spanlen $spanlen] - } - return $spaninfo - } - method calculate_column_widths {args} { - set column_count [tcl::dict::size $o_columndefs] - - set opts [tcl::dict::create\ - -algorithm $o_column_width_algorithm\ - ] - foreach {k v} $args { - switch -- $k { - -algorithm { - tcl::dict::set opts $k $v - } - default { - error "Unknown option '$k'. Known options: [tcl::dict::keys $opts]" - } - } - } - set opt_algorithm [tcl::dict::get $opts -algorithm] - #puts stderr "--- recalculating column widths -algorithm $opt_algorithm" - set known_algorithms [list basic simplistic span span2] - switch -- $opt_algorithm { - basic { - #basic column by column - This allocates extra space to first span/column as they're encountered. - #This can leave the table quite unbalanced with regards to whitespace and the table is also not as compact as it could be especially with regards to header colspans - #The header values can extend over some of the spanned columns - but not optimally so. - set o_calculated_column_widths [list] - for {set c 0} {$c < $column_count} {incr c} { - lappend o_calculated_column_widths [my basic_column_width $c] - } - } - simplistic { - #just uses the widest column data or header element. - #this is even less compact than basic and doesn't allow header colspan values to extend beyond their first spanned column - #This is a conservative option potentially useful in testing/debugging. - set o_calculated_column_widths [list] - for {set c 0} {$c < $column_count} {incr c} { - lappend o_calculated_column_widths [my column_width_configured $c] - } - } - span { - #widest of smallest spans first method - #set calcresult [my columncalc_spans least] - set calcresult [my columncalc_spans least_unmaxed] - set o_calculated_column_widths [tcl::dict::get $calcresult colwidths] - } - span2 { - #allocates more evenly - but truncates headers sometimes - set calcresult [my columncalc_spans all] - set o_calculated_column_widths [tcl::dict::get $calcresult colwidths] - } - default { - error "calculate_column_widths unknown algorithm $opt_algorithm. Known algorithms: $known_algorithms" - } - } - #remember the last algorithm used - set o_column_width_algorithm $opt_algorithm - return $o_calculated_column_widths - } - method print2 {args} { - variable full_column_cache - set full_column_cache [tcl::dict::create] - - if {![llength $args]} { - set cols [tcl::dict::keys $o_columndata] - } else { - set cols [list] - foreach colspec $args { - set allcols [tcl::dict::keys $o_columndata] - if {[tcl::string::first .. $colspec] >=0} { - set parts [punk::ansi::ta::_perlish_split {\.\.} $colspec] - if {[llength $parts] != 3} { - error "[namespace::current]::table error invalid print specification '$colspec'" - } - lassign $parts from _dd to - if {$from eq ""} {set from 0} - if {$to eq ""} {set to end} - - set indices [lrange $allcols $from $to] - lappend cols {*}$indices - } else { - set c [lindex $allcols $colspec] - if {$c ne ""} { - lappend cols $c - } - } - } - } - set blocks [list] - set colposn 0 - set numposns [llength $cols] - set padwidth 0 - set table "" - foreach c $cols { - set flags [list] - if {$colposn == 0 && $colposn == $numposns-1} { - set flags [list -position solo] - } elseif {$colposn == 0} { - set flags [list -position left] - } elseif {$colposn == $numposns-1} { - set flags [list -position right] - } else { - set flags [list -position inner] - } - #lappend blocks [my get_column_by_index $c {*}$flags] - #todo - only check and store in cache if table has header or footer colspans > 1 - if {[tcl::dict::exists $full_column_cache $c]} { - #puts "!!print used full_column_cache for $c" - set columninfo [tcl::dict::get $full_column_cache $c] - } else { - set columninfo [my get_column_by_index $c -return dict {*}$flags] - tcl::dict::set full_column_cache $c $columninfo - } - set nextcol [tcl::string::cat [tcl::dict::get $columninfo header] \n [tcl::dict::get $columninfo body]] - set bodywidth [tcl::dict::get $columninfo bodywidth] - - if {$table eq ""} { - set table $nextcol - set height [textblock::height $table] ;#only need to get height once at start - } else { - set nextcol [textblock::join -- [textblock::block $padwidth $height $TSUB] $nextcol] - set table [overtype::renderspace -expand_right 1 -transparent $TSUB $table[unset table] $nextcol] - #JMN - - #set nextcol [textblock::join -- [textblock::block $padwidth $height "\uFFFF"] $nextcol] - #set table [overtype::renderspace -expand_right 1 -transparent \uFFFF $table $nextcol] - } - incr padwidth $bodywidth - incr colposn - } - - if {[llength $cols]} { - #return [textblock::join -- {*}$blocks] - if {[tcl::dict::get $o_opts_table -show_edge]} { - #title is considered part of the edge ? - set offset 1 ;#make configurable? - set titlepad [tcl::string::repeat $TSUB $offset] - if {[tcl::dict::get $o_opts_table -title] ne ""} { - set titlealign [tcl::dict::get $o_opts_table -titlealign] - switch -- $titlealign { - left { - set tstring $titlepad[tcl::dict::get $o_opts_table -title] - } - right { - set tstring [tcl::dict::get $o_opts_table -title]$titlepad - } - default { - set tstring [tcl::dict::get $o_opts_table -title] - } - } - set opt_titletransparent [tcl::dict::get $o_opts_table -titletransparent] - switch -- $opt_titletransparent { - 0 { - set mapchar "" - } - 1 { - set mapchar " " - } - default { - #won't work if not a single char - review - check also frame behaviour - set mapchar $opt_titletransparent - } - } - if {$mapchar ne ""} { - set tstring [tcl::string::map [list $mapchar $TSUB] $tstring] - } - set table [overtype::block -blockalign $titlealign -transparent $TSUB $table[unset table] $tstring] - } - } - return $table - } else { - return "No columns matched" - } - } - - # using -startcolumn to do slightly less work - method print3 {args} { - if {![llength $args]} { - set cols [tcl::dict::keys $o_columndata] - } else { - set cols [list] - foreach colspec $args { - set allcols [tcl::dict::keys $o_columndata] - if {[tcl::string::first .. $colspec] >=0} { - set parts [punk::ansi::ta::_perlish_split {\.\.} $colspec] - if {[llength $parts] != 3} { - error "[namespace::current]::table error invalid print specification '$colspec'" - } - lassign $parts from _dd to - if {$from eq ""} {set from 0} - if {$to eq ""} {set to end} - - set indices [lrange $allcols $from $to] - lappend cols {*}$indices - } else { - set c [lindex $allcols $colspec] - if {$c ne ""} { - lappend cols $c - } - } - } - } - set blocks [list] - set numposns [llength $cols] - set colposn 0 - set padwidth 0 - set table "" - foreach c $cols { - set flags [list] - if {$colposn == 0 && $colposn == $numposns-1} { - set flags [list -position solo] - } elseif {$colposn == 0} { - set flags [list -position left] - } elseif {$colposn == $numposns-1} { - set flags [list -position right] - } else { - set flags [list -position inner] - } - set columninfo [my get_column_by_index $c -return dict {*}$flags] - set nextcol [tcl::string::cat [tcl::dict::get $columninfo header] \n [tcl::dict::get $columninfo body]] - set bodywidth [tcl::dict::get $columninfo bodywidth] - - if {$table eq ""} { - set table $nextcol - set height [textblock::height $table] ;#only need to get height once at start - } else { - set table [overtype::renderspace -startcolumn [expr {$padwidth + 1}] -expand_right 1 -transparent $TSUB $table $nextcol] - } - incr padwidth $bodywidth - incr colposn - } - - if {[llength $cols]} { - #return [textblock::join -- {*}$blocks] - if {[tcl::dict::get $o_opts_table -show_edge]} { - #title is considered part of the edge ? - set offset 1 ;#make configurable? - set titlepad [tcl::string::repeat $TSUB $offset] - if {[tcl::dict::get $o_opts_table -title] ne ""} { - set titlealign [tcl::dict::get $o_opts_table -titlealign] - switch -- $titlealign { - left { - set tstring $titlepad[tcl::dict::get $o_opts_table -title] - } - right { - set tstring [tcl::dict::get $o_opts_table -title]$titlepad - } - default { - set tstring [tcl::dict::get $o_opts_table -title] - } - } - set opt_titletransparent [tcl::dict::get $o_opts_table -titletransparent] - switch -- $opt_titletransparent { - 0 { - set mapchar "" - } - 1 { - set mapchar " " - } - default { - #won't work if not a single char - review - check also frame behaviour - set mapchar $opt_titletransparent - } - } - if {$mapchar ne ""} { - set tstring [tcl::string::map [list $mapchar $TSUB] $tstring] - } - set table [overtype::block -blockalign $titlealign -transparent $TSUB $table[unset table] $tstring] - } - } - return $table - } else { - return "No columns matched" - } - } - - #print headers and body using different join mechanisms - # using -startcolumn to do slightly less work - method print {args} { - if {![llength $args]} { - set cols [tcl::dict::keys $o_columndata] - } else { - set cols [list] - foreach colspec $args { - set allcols [tcl::dict::keys $o_columndata] - if {[tcl::string::first .. $colspec] >=0} { - set parts [punk::ansi::ta::_perlish_split {\.\.} $colspec] - if {[llength $parts] != 3} { - error "[namespace::current]::table error invalid print specification '$colspec'" - } - lassign $parts from _dd to - if {$from eq ""} {set from 0} - if {$to eq ""} {set to end} - - set indices [lrange $allcols $from $to] - lappend cols {*}$indices - } else { - set c [lindex $allcols $colspec] - if {$c ne ""} { - lappend cols $c - } - } - } - } - set numposns [llength $cols] - set colposn 0 - set padwidth 0 - set header_build "" - set body_blocks [list] - set headerheight 0 - foreach c $cols { - set flags [list] - if {$colposn == 0 && $colposn == $numposns-1} { - set flags [list -position solo] - } elseif {$colposn == 0} { - set flags [list -position left] - } elseif {$colposn == $numposns-1} { - set flags [list -position right] - } else { - set flags [list -position inner] - } - set columninfo [my get_column_by_index $c -return dict {*}$flags] - #set nextcol [tcl::dict::get $columninfo column] - set bodywidth [tcl::dict::get $columninfo bodywidth] - set headerheight [tcl::dict::get $columninfo headerheight] - #set nextcol_lines [split $nextcol \n] - #set nextcol_header [join [lrange $nextcol_lines 0 $headerheight-1] \n] - #set nextcol_body [join [lrange $nextcol_lines $headerheight end] \n] - set nextcol_header [tcl::dict::get $columninfo header] - set nextcol_body [tcl::dict::get $columninfo body] - - if {$header_build eq "" && ![llength $body_blocks]} { - set header_build $nextcol_header - lappend body_blocks $nextcol_body - } else { - if {$headerheight > 0} { - set header_build [overtype::renderspace -startcolumn [expr {$padwidth + 1}] -expand_right 1 -transparent $TSUB $header_build[unset header_build] $nextcol_header[unset nextcol_header]] - } - lappend body_blocks $nextcol_body - #set body_build [textblock::join -- $body_build[unset body_build] $nextcol_body] - } - incr padwidth $bodywidth - incr colposn - } - if {![llength $body_blocks]} { - set body_build "" - } else { - #body blocks should not be ragged - so can use join_basic - set body_build [textblock::join_basic -- {*}$body_blocks] - } - if {$headerheight > 0} { - set table [tcl::string::cat $header_build \n $body_build] - } else { - set table $body_build - } - - if {[llength $cols]} { - if {[tcl::dict::get $o_opts_table -show_edge]} { - #title is considered part of the edge ? - set offset 1 ;#make configurable? - set titlepad [tcl::string::repeat $TSUB $offset] - if {[tcl::dict::get $o_opts_table -title] ne ""} { - set titlealign [tcl::dict::get $o_opts_table -titlealign] - switch -- $titlealign { - left { - set tstring $titlepad[tcl::dict::get $o_opts_table -title] - } - right { - set tstring [tcl::dict::get $o_opts_table -title]$titlepad - } - default { - set tstring [tcl::dict::get $o_opts_table -title] - } - } - set opt_titletransparent [tcl::dict::get $o_opts_table -titletransparent] - switch -- $opt_titletransparent { - 0 { - set mapchar "" - } - 1 { - set mapchar " " - } - default { - #won't work if not a single char - review - check also frame behaviour - set mapchar $opt_titletransparent - } - } - if {$mapchar ne ""} { - set tstring [tcl::string::map [list $mapchar $TSUB] $tstring] - } - set table [overtype::block -blockalign $titlealign -transparent $TSUB $table[unset table] $tstring] - } - } - return $table - } else { - return "No columns matched" - } - } - method print_bodymatrix {} { - set m [my as_matrix] - $m format 2string - } - - #*** !doctools - #[list_end] - }] - #*** !doctools - # [list_end] [comment {- end enumeration provider_classes }] - #[list_end] [comment {- end itemized list textblock::class groupings -}] - } - } -} -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# -#Note: A textblock does not necessarily have lines the same length - either in number of characters or print-width -# -tcl::namespace::eval textblock { - tcl::namespace::eval cd { - #todo - save and restore existing tcl::namespace::export in case macros::cd has default exports in future - tcl::namespace::eval ::term::ansi::code::macros::cd {tcl::namespace::export *} - tcl::namespace::import ::term::ansi::code::macros::cd::* - tcl::namespace::eval ::term::ansi::code::macros::cd {tcl::namespace::export -clear} - } - proc spantest {} { - set t [list_as_table -columns 5 -return tableobject {a b c d e aa bb cc dd ee X Y}] - $t configure_column 0 -headers [list span3 "1-span4\n2-span4 second line" span5/5 "span-all etc blah 123 hmmmmm" span2] - $t configure_column 0 -header_colspans {3 4 5 any 2} - $t configure_column 2 -headers {"" "" "" "" c2span2_etc} - $t configure_column 2 -header_colspans {0 0 0 0 2} - $t configure -show_header 1 -ansiborder_header [a+ cyan] - return $t - } - proc spantest1 {} { - set t [list_as_table -columns 5 -return tableobject {a b c d e aa bb cc dd ee X Y}] - $t configure_column 0 -headers [list "span3-any longer than other span any" "1-span4\n2-span4 second line" "span-any short aligned?" "span5/5 longest etc blah 123" span2] - $t configure_column 0 -header_colspans {any 4 any 5 2} - $t configure_column 2 -headers {"" "" "" "" c2span2_etc} - $t configure_column 2 -header_colspans {0 0 0 0 2} - $t configure_column 3 -header_colspans {1 0 0 0 0} - $t configure -show_header 1 -ansiborder_header [a+ cyan] - $t configure_column 0 -blockalign right ;#trigger KNOWN BUG overwrite of right edge by last char of spanning col (in this case fullspan from left - but also happens for any span extending to rhs) - return $t - } - - #more complex colspans - proc spantest2 {} { - set t [list_as_table -columns 5 -return tableobject {a b c d e aa bb cc dd ee X Y}] - $t configure_column 0 -headers {c0span3 c0span4 c0span1 "c0span-all etc blah 123 hmmmmm" c0span2} - $t configure_column 0 -header_colspans {3 4 1 any 2} - $t configure_column 1 -header_colspans {0 0 2 0 0} - $t configure_column 2 -headers {"" "" "" "" c2span2} - $t configure_column 2 -header_colspans {0 0 0 0 2} - $t configure_column 3 -header_colspans {1 0 2 0 0} - $t configure -show_header 1 -ansiborder_header [a+ cyan] - return $t - } - proc spantest3 {} { - set t [list_as_table -columns 5 -return tableobject {a b c d e aa bb cc dd ee X Y}] - $t configure_column 0 -headers {c0span3 c0span4 c0span1 "c0span-all etc blah 123 hmmmmm" "c0span2 etc blah" c0span1} - $t configure_column 0 -header_colspans {3 4 1 any 2 1} - $t configure_column 1 -header_colspans {0 0 4 0 0 1} - $t configure_column 1 -headers {"" "" "c1span4" "" "" "c1nospan"} - $t configure_column 2 -headers {"" "" "" "" "" c2span2} - $t configure_column 2 -header_colspans {0 0 0 0 1 2} - $t configure_column 4 -headers {"4" "444" "" "" "" "44"} - $t configure -show_header 1 -ansiborder_header [a+ cyan] - return $t - } - - - - proc periodic {args} { - #For an impressive interactive terminal app (javascript) - # see: https://github.com/spirometaxas/periodic-table-cli - set opts [dict get [punk::args::get_dict { - *proc -name textblock::periodic -help "A rudimentary periodic table - This is primarily a test of textblock::class::table" - - -return -default table\ - -choices {table tableobject}\ - -help "default choice 'table' returns the displayable table output" - -compact -default 1 -type boolean -help "compact true defaults: -show_vseps 0 -show_header 0 -show_edge 0" - -frame -default 1 -type boolean - -show_vseps -default "" -type boolean - -show_header -default "" -type boolean - -show_edge -default "" -type boolean - -forcecolour -default 0 -type boolean -help "If punk::colour is off - this enables the produced table to still be ansi coloured" - *values -min 0 -max 0 - } $args] opts] - - set opt_return [tcl::dict::get $opts -return] - if {[tcl::dict::get $opts -forcecolour]} { - set fc forcecolour - } else { - set fc "" - } - - #examples ptable.com - set elements [list\ - 1 H "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" He\ - 2 Li Be "" "" "" "" "" "" "" "" "" "" B C N O F Ne\ - 3 Na Mg "" "" "" "" "" "" "" "" "" "" Al Si P S Cl Ar\ - 4 K Ca Sc Ti V Cr Mn Fe Co Ni Cu Zn Ga Ge As Se Br Kr\ - 5 Rb Sr Y Zr Nb Mo Tc Ru Rh Pd Ag Cd In Sn Sb Te I Xe\ - 6 Cs Ba "" Hf Ta W Re Os Ir Pt Au Hg Tl Pb Bi Po At Rn\ - 7 Fr Ra "" Rf Db Sg Bh Hs Mt Ds Rg Cn Nh Fl Mc Lv Ts Og\ - " " " " " " " " " " " " " " " " " " " " " " " " "" "" "" "" "" "" ""\ - "" "" "" 6 La Ce Pr Nd Pm Sm Eu Gd Tb Dy Ho Er Tm Yb Lu\ - "" "" "" 7 Ac Th Pa U Np Pu Am Cm Bk Cf Es Fm Md No Lr\ - ] - - set type_colours [list] - - set ecat [tcl::dict::create] - - set cat_alkaline_earth [list Be Mg Ca Sr Ba Ra] - set ansi [a+ {*}$fc web-black Web-gold] - set val [list ansi $ansi cat alkaline_earth] - foreach e $cat_alkaline_earth { - tcl::dict::set ecat $e $val - } - - set cat_reactive_nonmetal [list H C N O F P S Cl Se Br I] - #set ansi [a+ {*}$fc web-black Web-lightgreen] - set ansi [a+ {*}$fc black Term-113] - set val [list ansi $ansi cat reactive_nonmetal] - foreach e $cat_reactive_nonmetal { - tcl::dict::set ecat $e $val - } - - set cat [list Li Na K Rb Cs Fr] - #set ansi [a+ {*}$fc web-black Web-Khaki] - set ansi [a+ {*}$fc black Term-lightgoldenrod2] - set val [list ansi $ansi cat alkali_metals] - foreach e $cat { - tcl::dict::set ecat $e $val - } - - set cat [list Sc Ti V Cr Mn Fe Co Ni Cu Zn Y Zr Nb Mo Tc Ru Rh Pd Ag Cd Hf Ta W Re Os Ir Pt Au Hg Rf Db Sg Bh Hs] - #set ansi [a+ {*}$fc web-black Web-lightsalmon] - set ansi [a+ {*}$fc black Term-orange1] - set val [list ansi $ansi cat transition_metals] - foreach e $cat { - tcl::dict::set ecat $e $val - } - - set cat [list Al Ga In Sn Tl Pb Bi Po] - set ansi [a+ {*}$fc web-black Web-lightskyblue] - set val [list ansi $ansi cat post_transition_metals] - foreach e $cat { - tcl::dict::set ecat $e $val - } - - set cat [list B Si Ge As Sb Te At] - #set ansi [a+ {*}$fc web-black Web-turquoise] - set ansi [a+ {*}$fc black Brightcyan] - set val [list ansi $ansi cat metalloids] - foreach e $cat { - tcl::dict::set ecat $e $val - } - - set cat [list He Ne Ar Kr Xe Rn] - set ansi [a+ {*}$fc web-black Web-orchid] - set val [list ansi $ansi cat noble_gases] - foreach e $cat { - tcl::dict::set ecat $e $val - } - - set cat [list Ac Th Pa U Np Pu Am Cm Bk Cf Es Fm Md No Lr] - set ansi [a+ {*}$fc web-black Web-plum] - set val [list ansi $ansi cat actinoids] - foreach e $cat { - tcl::dict::set ecat $e $val - } - - set cat [list La Ce Pr Nd Pm Sm Eu Gd Tb Dy Ho Er Tm Yb Lu] - #set ansi [a+ {*}$fc web-black Web-tan] - set ansi [a+ {*}$fc black Term-tan] - set val [list ansi $ansi cat lanthanoids] - foreach e $cat { - tcl::dict::set ecat $e $val - } - - set ansi [a+ {*}$fc web-black Web-whitesmoke] - set val [list ansi $ansi cat other] - foreach e [list Mt Ds Rg Cn Nh Fl Mc Lv Ts Og] { - tcl::dict::set ecat $e $val - } - - set elements1 [list] - set RST [a+] - foreach e $elements { - if {[tcl::dict::exists $ecat $e]} { - set ansi [tcl::dict::get $ecat $e ansi] - #lappend elements1 [textblock::pad $ansi$e -width 2 -which right] - #no need to pad here - table column_configure -textalign default of left will do the work of padding right anyway - lappend elements1 $ansi$e - } else { - lappend elements1 $e - } - } - - set t [list_as_table -columns 19 -return tableobject $elements1] - #(defaults to show_hseps 0) - - #todo - keep simple table with symbols as base - map symbols to descriptions etc for more verbose table options - - set header_0 [list 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18] - set c 0 - foreach h $header_0 { - $t configure_column $c -headers [list $h] -minwidth 2 - incr c - } - set ccount [$t column_count] - for {set c 0} {$c < $ccount} {incr c} { - $t configure_column $c -minwidth 3 - } - if {[tcl::dict::get $opts -compact]} { - #compact defaults - but let explicit arguments override - set conf [dict create -show_vseps 0 -show_header 0 -show_edge 0] - } else { - set conf [dict create -show_vseps 1 -show_header 1 -show_edge 1] - } - dict for {k v} $conf { - if {[dict get $opts $k] ne ""} { - dict set conf $k [dict get $opts $k] - } - } - $t configure {*}[dict get $conf] - - $t configure \ - -frametype_header light\ - -ansiborder_header [a+ {*}$fc brightwhite]\ - -ansibase_header [a+ {*}$fc Black]\ - -ansibase_body [a+ {*}$fc Black]\ - -ansiborder_body [a+ {*}$fc black]\ - -frametype block - - #-ansiborder_header [a+ {*}$fc web-white]\ - - if {$opt_return eq "table"} { - if {[dict get $opts -frame]} { - #set output [textblock::frame -ansiborder [a+ {*}$fc Black web-cornflowerblue] -type heavy -title "[a+ {*}$fc Black] Periodic Table " [$t print]] - #set output [textblock::frame -ansiborder [a+ {*}$fc Black term-deepskyblue2] -type heavy -title "[a+ {*}$fc Black] Periodic Table " [$t print]] - set output [textblock::frame -ansiborder [a+ {*}$fc Black cyan] -type heavy -title "[a+ {*}$fc Black] Periodic Table " [$t print]] - } else { - set output [$t print] - } - $t destroy - return $output - } - return $t - } - - proc list_as_table {args} { - set argd [punk::args::get_dict [string map [list $::textblock::frametypes] { - -return -default table -choices {table tableobject} - -frametype -default "" -help "frame type: or dict for custom frame" - -show_edge -default "" -type boolean -help "show outer border of table" - -show_seps -default "" -type boolean - -show_vseps -default "" -type boolean -help "Show vertical table separators" - -show_hseps -default "" -type boolean -help "Show horizontal table separators - (default 0 if no existing -table supplied)" - -table -default "" -type string -help "existing table object to use" - -headers -default "" -help "list of header values. Must match number of columns" - -show_header -default "" -help "Whether to show a header row. - Leave as empty string for unspecified/automatic, - in which case it will display only if -headers list was supplied." - -action -default "append" -choices {append replace} -help "row insertion method if existing -table is supplied - if append is chosen the new values will always start at the first column" - -columns -default "" -type integer -help "Number of table columns - Will default to 2 if not using an existing -table object" - *values -min 0 -max 1 - datalist -default {} -help "flat list of table cell values which will be wrapped based on -columns value" - }] $args] - set opts [dict get $argd opts] - set datalist [dict get $argd values datalist] - - set existing_table [dict get $opts -table] - set opt_columns [dict get $opts -columns] - #set opts [tcl::dict::create\ - # -return string\ - # -frametype \uFFEF\ - # -show_edge \uFFEF\ - # -show_seps \uFFEF\ - #] - #foreach {k v} $args { - # switch -- $k { - # -return - -show_edge - -show_seps - -frametype { - # tcl::dict::set opts $k $v - # } - # default { - # error "unrecognised option '$k'. Known options [tcl::dict::keys $opts]" - # } - # } - #} - - set count [llength $datalist] - - set is_new_table 0 - if {$existing_table ne ""} { - if {[tcl::namespace::tail [info object class $existing_table]] ne "table"} { - error "textblock::list_as_table error -table must be an existing table object (e.g set t \[textblock::class::table new\])" - } - set t $existing_table - foreach prop {-frametype -show_edge -show_seps -show_vseps -show_hseps} { - if {[tcl::dict::get $opts $prop] ne ""} { - $t configure $prop [tcl::dict::get $opts $prop] - } - } - if {[dict get $opts -action] eq "replace"} { - $t row_clear - } - set cols [$t column_count] - if {[tcl::string::is integer -strict $opt_columns]} { - if {$opt_columns > $cols} { - set extra [expr {$opt_columns - $cols}] - for {set c 0} {$c < $extra} {incr c} { - $t add_column - } - } elseif {$opt_columns < $cols} { - #todo - auto add blank values in the datalist - error "Number of columns requested: $opt_columns is less than existing number of columns $cols - not yet supported" - } - set cols [$t column_count] - } - } else { - set is_new_table 1 - set headers {} - if {[tcl::dict::get $opts -headers] ne ""} { - set headers [dict get $opts -headers] - if {[tcl::dict::get $opts -show_header] eq ""} { - set show_header 1 - } else { - set show_header [tcl::dict::get $opts -show_header] - } - } else { - if {[tcl::dict::get $opts -show_header] eq ""} { - set show_header 0 - } else { - set show_header [tcl::dict::get $opts -show_header] - } - } - - if {[tcl::string::is integer -strict $opt_columns]} { - set cols $opt_columns - if {[llength $headers] && $cols != [llength $headers]} { - error "list_as_table number of columns ($cols) doesn't match supplied number of headers ([llength $headers])" - } - } else { - #review - if {[llength $headers]} { - set cols [llength $headers] - } else { - set cols 2 ;#seems a reasonable default - } - } - #defaults for new table only - if {[tcl::dict::get $opts -frametype] eq ""} { - tcl::dict::set opts -frametype "light" - } - if {[tcl::dict::get $opts -show_edge] eq ""} { - tcl::dict::set opts -show_edge 1 - } - if {[tcl::dict::get $opts -show_seps] eq ""} { - tcl::dict::set opts -show_seps 1 - } - if {[tcl::dict::get $opts -show_vseps] eq ""} { - tcl::dict::set opts -show_vseps 1 - } - if {[tcl::dict::get $opts -show_hseps] eq ""} { - tcl::dict::set opts -show_hseps 0 - } - - set t [textblock::class::table new\ - -show_header $show_header\ - -show_edge [tcl::dict::get $opts -show_edge]\ - -frametype [tcl::dict::get $opts -frametype]\ - -show_seps [tcl::dict::get $opts -show_seps]\ - -show_vseps [tcl::dict::get $opts -show_vseps]\ - -show_hseps [tcl::dict::get $opts -show_hseps]\ - ] - if {[llength $headers]} { - for {set c 0} {$c < $cols} {incr c} { - $t add_column -headers [lindex $headers $c] - } - } else { - for {set c 0} {$c < $cols} {incr c} { - $t add_column -headers [list $c] - } - } - } - - set full_rows [expr {$count / $cols}] - set last_items [expr {$count % $cols}] - - - set rowdata [list] - set row [list] - set i 0 - if {$full_rows > 0} { - for {set r 0} {$r < $full_rows} {incr r} { - set j [expr {$i + ($cols -1)}] - set row [lrange $datalist $i $j] - incr i $cols - lappend rowdata $row - } - } - if {$last_items > 0} { - set idx [expr {$last_items -1}] - lappend rowdata [lrange $datalist end-$idx end] - } - foreach row $rowdata { - set shortfall [expr {$cols - [llength $row]}] - if {$shortfall > 0} { - set row [concat $row [lrepeat $shortfall ""]] - } - $t add_row $row - } - #puts stdout $rowdata - if {[tcl::dict::get $opts -return] eq "table"} { - set result [$t print] - if {$is_new_table} { - $t destroy - } - return $result - } else { - return $t - } - } - #return a homogenous block of characters - ie lines all same length, all same character - #printing-width in terminal columns is not necessarily same as blockwidth even if a single char is passed (could be full-width unicode character) - #This can have ansi SGR codes - but to repeat blocks containing ansi-movements, the block should first be rendered to a static output with something like overtype::left - proc block {blockwidth blockheight {char " "}} { - if {$blockwidth < 0} { - error "textblock::block blockwidth must be an integer greater than or equal to zero" - } - if {$blockheight <= 0} { - error "textblock::block blockheight must be a positive integer" - } - if {$char eq ""} {return ""} - #using tcl::string::length is ok - if {[tcl::string::length $char] == 1} { - set row [tcl::string::repeat $char $blockwidth] - set mtrx [lrepeat $blockheight $row] - return [::join $mtrx \n] - } else { - set charblock [tcl::string::map [list \r\n \n] $char] - if {[tcl::string::last \n $charblock] >= 0} { - if {$blockwidth > 1} { - #set row [.= val $charblock {*}[lrepeat [expr {$blockwidth -1}] |> piper_blockjoin $charblock]] ;#building a repeated "|> command arg" list to evaluate as a pipeline. (from before textblock::join could take arbitrary num of blocks ) - set row [textblock::join_basic -- {*}[lrepeat $blockwidth $charblock]] - } else { - set row $charblock - } - } else { - set row [tcl::string::repeat $char $blockwidth] - } - set mtrx [lrepeat $blockheight $row] - return [::join $mtrx \n] - } - } - proc testblock {size {colour ""}} { - if {$size <1 || $size > 15} { - error "textblock::testblock only sizes between 1 and 15 inclusive supported" - } - set rainbow_list [list] - lappend rainbow_list {30 47} ;#black White - lappend rainbow_list {31 46} ;#red Cyan - lappend rainbow_list {32 45} ;#green Purple - lappend rainbow_list {33 44} ;#yellow Blue - lappend rainbow_list {34 43} ;#blue Yellow - lappend rainbow_list {35 42} ;#purple Green - lappend rainbow_list {36 41} ;#cyan Red - lappend rainbow_list {37 40} ;#white Black - lappend rainbow_list {black Yellow} - lappend rainbow_list red - lappend rainbow_list green - lappend rainbow_list yellow - lappend rainbow_list blue - lappend rainbow_list purple - lappend rainbow_list cyan - lappend rainbow_list {white Red} - - set rainbow_direction "horizontal" - set vpos [lsearch $colour vertical] - if {$vpos >= 0} { - set rainbow_direction vertical - set colour [lremove $colour $vpos] - } - set hpos [lsearch $colour horizontal] - if {$hpos >=0} { - #horizontal is the default and superfluous but allowed for symmetry - set colour [lremove $colour $hpos] - } - - - - set chars [concat [punk::lib::range 1 9] A B C D E F] - set charsubset [lrange $chars 0 $size-1] - if {"noreset" in $colour} { - set RST "" - } else { - set RST [a] - } - if {"rainbow" in $colour && $rainbow_direction eq "vertical"} { - #column first - colour change each column - set c [::join $charsubset \n] - - set clist [list] - for {set i 0} {$i <$size} {incr i} { - set colour2 [tcl::string::map [list rainbow [lindex $rainbow_list $i]] $colour] - set ansi [a+ {*}$colour2] - - set ansicode [punk::ansi::codetype::sgr_merge_list "" $ansi] - lappend clist ${ansicode}$c$RST - } - if {"noreset" in $colour} { - return [textblock::join_basic -ansiresets 0 -- {*}$clist] - } else { - return [textblock::join_basic -- {*}$clist] - } - } elseif {"rainbow" in $colour} { - #direction must be horizontal - set block "" - for {set r 0} {$r < $size} {incr r} { - set colour2 [tcl::string::map [list rainbow [lindex $rainbow_list $r]] $colour] - set ansi [a+ {*}$colour2] - set ansicode [punk::ansi::codetype::sgr_merge_list "" $ansi] - set row "$ansicode" - foreach c $charsubset { - append row $c - } - append row $RST - append block $row\n - } - set block [tcl::string::trimright $block \n] - return $block - } else { - #row first - - set rows [list] - foreach ch $charsubset { - lappend rows [tcl::string::repeat $ch $size] - } - set block [::join $rows \n] - if {$colour ne ""} { - set block [a+ {*}$colour]$block$RST - } - return $block - } - } - interp alias {} testblock {} textblock::testblock - - #todo - consider 'elastic tabstops' for textblocks where tab acts as a column separator and adjacent lines with the same number of tabs form a sort of table - proc width {textblock} { - #backspaces, vertical tabs ? - if {$textblock eq ""} { - return 0 - } - #textutil::tabify is a reasonable hack when there are no ansi SGR codes - but probably not always what we want even then - review - if {[tcl::string::last \t $textblock] >= 0} { - if {[tcl::info::exists punk::console::tabwidth]} { - set tw $::punk::console::tabwidth - } else { - set tw 8 - } - set textblock [textutil::tabify::untabify2 $textblock $tw] - } - if {[punk::ansi::ta::detect $textblock]} { - #ansistripraw slightly faster than ansistrip - and won't affect width (avoid detect_g0/conversions) - set textblock [punk::ansi::ansistripraw $textblock] - } - if {[tcl::string::last \n $textblock] >= 0} { - return [tcl::mathfunc::max {*}[lmap v [split $textblock \n] {::punk::char::ansifreestring_width $v}]] - } - return [punk::char::ansifreestring_width $textblock] - } - #when we know the block is uniform in width - just examine topline - proc widthtopline {textblock} { - set firstnl [tcl::string::first \n $textblock] - if {$firstnl >= 0} { - set tl [tcl::string::range $textblock 0 $firstnl] - } else { - set tl $textblock - } - if {[punk::ansi::ta::detect $tl]} { - set tl [punk::ansi::ansistripraw $tl] - } - return [punk::char::ansifreestring_width $tl] - } - #uses tcl's tcl::string::length on each line. Length will include chars in ansi codes etc - this is not a 'width' determining function. - proc string_length_line_max textblock { - tcl::mathfunc::max {*}[lmap v [split $textblock \n] {tcl::string::length $v}] - } - proc string_length_line_min textblock { - tcl::mathfunc::min {*}[lmap v [split $textblock \n] {tcl::string::length $v}] - } - proc height {textblock} { - #This is the height as it will/would-be rendered - not the number of input lines purely in terms of le - #empty string still has height 1 (at least for left-right/right-left languages) - - #vertical tab on a proper terminal should move directly down. - #Whether or not the terminal in use actually does this - we need to calculate as if it does. (there might not even be a terminal) - - set num_le [expr {[tcl::string::length $textblock]-[tcl::string::length [tcl::string::map [list \n {} \v {}] $textblock]]}] ;#faster than splitting into single-char list - return [expr {$num_le + 1}] ;# one line if no le - 2 if there is one trailing le even if no data follows le - } - #MAINTENANCE - same as overtype::blocksize? - proc size {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 - } - #strangely - tcl::string::last (windows tcl8.7 anway) is faster than tcl::string::first for large strings when the needle not in the haystack - if {[tcl::string::last \t $textblock] >= 0} { - if {[tcl::info::exists punk::console::tabwidth]} { - set tw $::punk::console::tabwidth - } else { - set tw 8 - } - set textblock [textutil::tabify::untabify2 $textblock $tw] - } - #ansistripraw 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::ansistripraw $textblock] - } - if {[tcl::string::last \n $textblock] >= 0} { - #set width [tcl::mathfunc::max {*}[lmap v [punk::lib::lines_as_list -- $textblock] {::punk::char::ansifreestring_width $v}]] - set width [tcl::mathfunc::max {*}[lmap v [split $textblock \n] {::punk::char::ansifreestring_width $v}]] - } else { - set width [punk::char::ansifreestring_width $textblock] - } - set num_le [expr {[tcl::string::length $textblock]-[tcl::string::length [tcl::string::map [list \n {} \v {}] $textblock]]}] ;#faster than splitting into single-char list - #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 [tcl::dict::values [blocksize ]] width height - } - proc size_as_opts {textblock} { - set sz [size $textblock] - return [dict create -width [dict get $sz width] -height [dict get $sz height]] - } - proc size_as_list {textblock} { - set sz [size $textblock] - return [list [dict get $sz width] [dict get $sz height]] - } - #must be able to handle block as string with or without newlines - #if no newlines - attempt to treat as a list - #must handle whitespace-only string,list elements, and/or lines. - #reviewing 2024 - this seems like too much magic! - proc width1 {block} { - if {$block eq ""} { - return 0 - } - if {[tcl::info::exists punk::console::tabwidth]} { - set tw $::punk::console::tabwidth - } else { - set tw 8 - } - set block [textutil::tabify::untabify2 $block $tw] - if {[tcl::string::last \n $block] >= 0} { - return [tcl::mathfunc::max {*}[lmap v [punk::lib::lines_as_list -- $block] {::punk::char::string_width [ansistrip $v]}]] - } - if {[catch {llength $block}]} { - return [::punk::char::string_width [ansistrip $block]] - } - if {[llength $block] == 0} { - #could be just a whitespace string - return [tcl::string::length $block] - } - return [tcl::mathfunc::max {*}[lmap v $block {::punk::char::string_width [ansistrip $v]}]] - } - - #we shouldn't make textblock depend on the punk pipeline system - #pipealias ::textblock::padleft .= {list $input [tcl::string::repeat " " $indent]} |/0,padding/1> punk:lib::lines_as_list -- |> .= {lmap v $data {overtype::right $padding $v}} |> punk::lib::list_as_lines -- punk::lib::lines_as_list -- |> .= {lmap v $data {overtype::left $padding $v}} |> punk::lib::list_as_lines -- |? ?-which right|left|centre? ?-width auto|? ?-within_ansi 1|0?" - foreach {k v} $args { - switch -- $k { - -padchar - -which - -width - -overflow - -within_ansi { - tcl::dict::set opts $k $v - } - default { - error "textblock::pad unrecognised option '$k'. Usage: $usage" - } - } - } - # -- --- --- --- --- --- --- --- --- --- - set padchar [tcl::dict::get $opts -padchar] - #if padchar width (screen width) > 1 - length calculations will not be correct - #we will allow tokens longer than 1 - as the caller may want to post-process on the token whilst preserving previous leading/trailing spaces, e.g with a tcl::string::map - #The caller may also use ansi within the padchar - although it's unlikely to be efficient. - # -- --- --- --- --- --- --- --- --- --- - set known_whiches [list l left r right c center centre] - set opt_which [tcl::string::tolower [tcl::dict::get $opts -which]] - switch -- $opt_which { - center - centre - c { - set which c - } - left - l { - set which l - } - right - r { - set which r - } - default { - error "textblock::pad unrecognised value for -which option. Known values $known_whiches" - } - } - # -- --- --- --- --- --- --- --- --- --- - set opt_width [tcl::dict::get $opts -width] - switch -- $opt_width { - "" - auto { - set width auto - } - default { - if {![tcl::string::is integer -strict $opt_width] || $opt_width < 0} { - error "textblock::pad -width must be an integer >=0" - } - set width $opt_width - } - } - # -- --- --- --- --- --- --- --- --- --- - set opt_withinansi [tcl::dict::get $opts -within_ansi] - switch -- $opt_withinansi { - 0 - 1 {} - default { - set opt_withinansi 2 - } - } - # -- --- --- --- --- --- --- --- --- --- - - set datawidth [textblock::width $block] - if {$width eq "auto"} { - set width $datawidth - } - - set lines [list] - - set padcharsize [punk::ansi::printing_length $padchar] - set pad_has_ansi [punk::ansi::ta::detect $padchar] - if {$block eq ""} { - #we need to treat as a line - set repeats [expr {int(ceil($width / double($padcharsize)))}] ;#will overshoot by 1 whenever padcharsize not an exact divisor of width - #TODO - #review - what happens when padchar has ansi, or the width would split a double-wide unicode char? - #we shouldn't be using string range if there is ansi - (overtype? ansistring range?) - #we should use overtype with suitable replacement char (space?) for chopped double-wides - if {!$pad_has_ansi} { - return [tcl::string::range [tcl::string::repeat $padchar $repeats] 0 $width-1] - } else { - set base [tcl::string::repeat " " $width] - return [overtype::block -blockalign left -overflow 0 $base [tcl::string::repeat $padchar $repeats]] - } - } - - #review - tcl format can only pad with zeros or spaces? - #experimental fallback to supposedly faster simpler 'format' but we still need to compensate for double-width or non-printing chars - and it won't work on strings with ansi SGR codes - if 0 { - #review - surprisingly, this doesn't seem to be a performance win - #No detectable diff on small blocks - slightly worse on large blocks - if {($padchar eq " " || $padchar eq "0") && ![punk::ansi::ta::detect $block]} { - #This will still be wrong for example with diacritics on terminals that don't collapse the space following a diacritic, and don't correctly report cursor position - #(i.e as at 2024 - lots of them) wezterm on windows at least does the right thing. - set block [tcl::string::map [list \r\n \n] $block] - if {$which eq "l"} { - set fmt "%+${padchar}*s" - } else { - set fmt "%-${padchar}*s" - } - foreach ln [split $block \n] { - #set lnwidth [punk::char::ansifreestring_width $ln] - set lnwidth [punk::char::grapheme_width_cached $ln] - set lnlen [tcl::string::length $ln] - set diff [expr $lnwidth - $lnlen] - #we need trickwidth to get format to pad a string with a different terminal width compared to string length - set trickwidth [expr {$width - $diff}] ;#may 'subtract' a positive or negative int (ie will add to trickwidth if negative) - lappend lines [format $fmt $trickwidth $ln] - } - return [::join $lines \n] - } - } - - #todo? special case trailing double-reset - insert between resets? - set lnum 0 - if {[punk::ansi::ta::detect $block]} { - set parts [punk::ansi::ta::split_codes $block] - } else { - #single plaintext part - set parts [list $block] - } - set line_chunks [list] - set line_len 0 - set pad_cache [dict create] ;#key on value of 'missing' - which is width of required pad - foreach {pt ansi} $parts { - if {$pt ne ""} { - set has_nl [expr {[tcl::string::last \n $pt]>=0}] - if {$has_nl} { - set pt [tcl::string::map [list \r\n \n] $pt] - set partlines [split $pt \n] - } else { - set partlines [list $pt] - } - set last [expr {[llength $partlines]-1}] - set p 0 - foreach pl $partlines { - lappend line_chunks $pl - #incr line_len [punk::char::ansifreestring_width $pl] - incr line_len [punk::char::grapheme_width_cached $pl] ;#memleak - REVIEW - if {$p != $last} { - #do padding - set missing [expr {$width - $line_len}] - if {$missing > 0} { - #commonly in a block - many lines will have the same pad - cache based on missing - - #padchar may be more than 1 wide - because of 2wide unicode and or multiple chars - if {[tcl::dict::exists $pad_cache $missing]} { - set pad [tcl::dict::get $pad_cache $missing] - } else { - set repeats [expr {int(ceil($missing / double($padcharsize)))}] ;#will overshoot by 1 whenever padcharsize not an exact divisor of width - if {!$pad_has_ansi} { - set pad [tcl::string::range [tcl::string::repeat $padchar $repeats] 0 $missing-1] - } else { - set base [tcl::string::repeat " " $missing] - set pad [overtype::block -blockalign left -overflow 0 $base [tcl::string::repeat $padchar $repeats]] - } - dict set pad_cache $missing $pad - } - switch -- $which-$opt_withinansi { - r-0 { - lappend line_chunks $pad - } - r-1 { - if {[lindex $line_chunks end] eq ""} { - set line_chunks [linsert $line_chunks end-2 $pad] - } else { - lappend line_chunks $pad - } - } - r-2 { - lappend line_chunks $pad - } - l-0 { - set line_chunks [linsert $line_chunks 0 $pad] - } - l-1 { - if {[lindex $line_chunks 0] eq ""} { - set line_chunks [linsert $line_chunks 2 $pad] - } else { - set line_chunks [linsert $line_chunks 0 $pad] - } - } - l-2 { - if {$lnum == 0} { - if {[lindex $line_chunks 0] eq ""} { - set line_chunks [linsert $line_chunks 2 $pad] - } else { - set line_chunks [linsert $line_chunks 0 $pad] - } - } else { - set line_chunks [linsert $line_chunks 0 $pad] - } - } - } - } - lappend lines [::join $line_chunks ""] - set line_chunks [list] - set line_len 0 - incr lnum - } - incr p - } - } else { - #we need to store empties in order to insert text in the correct position relative to leading/trailing ansi codes - lappend line_chunks "" - } - #don't let trailing empty ansi affect the line_chunks length - if {$ansi ne ""} { - lappend line_chunks $ansi ;#don't update line_len - review - ansi codes with visible content? - } - } - #pad last line - set missing [expr {$width - $line_len}] - if {$missing > 0} { - if {[tcl::dict::exists $pad_cache $missing]} { - set pad [tcl::dict::get $pad_cache $missing] - } else { - set repeats [expr {int(ceil($missing / double($padcharsize)))}] ;#will overshoot by 1 whenever padcharsize not an exact divisor of width - if {!$pad_has_ansi} { - set pad [tcl::string::range [tcl::string::repeat $padchar $repeats] 0 $missing-1] - } else { - set base [tcl::string::repeat " " $missing] - set pad [overtype::block -blockalign left -overflow 0 $base [tcl::string::repeat $padchar $repeats]] - } - } - #set pad [tcl::string::repeat $padchar $missing] - switch -- $which-$opt_withinansi { - r-0 { - lappend line_chunks $pad - } - r-1 { - if {[lindex $line_chunks end] eq ""} { - set line_chunks [linsert $line_chunks end-2 $pad] - } else { - lappend line_chunks $pad - } - } - r-2 { - if {[lindex $line_chunks end] eq ""} { - set line_chunks [linsert $line_chunks end-2 $pad] - } else { - lappend line_chunks $pad - } - #lappend line_chunks $pad - } - l-0 { - #if {[lindex $line_chunks 0] eq ""} { - # set line_chunks [linsert $line_chunks 2 $pad] - #} else { - # set line_chunks [linsert $line_chunks 0 $pad] - #} - set line_chunks [linsert $line_chunks 0 $pad] - } - l-1 { - #set line_chunks [linsert $line_chunks 0 $pad] - set line_chunks [_insert_before_text_or_last_ansi $pad $line_chunks] - } - l-2 { - set line_chunks [linsert $line_chunks 0 $pad] - } - } - } - lappend lines [::join $line_chunks ""] - return [::join $lines \n] - } - - #left insertion into a list resulting from punk::ansi::ta::split_codes or split_codes_single - #resulting list is no longer a valid ansisplit list - proc _insert_before_text_or_last_ansi {str ansisplits} { - if {[llength $ansisplits] == 1} { - #ansisplits was a split on plaintext only - return [list $str [lindex $ansisplits 0]] - } elseif {[llength $ansisplits] == 0} { - return [list $str] - } - if {[llength $ansisplits] %2 != 1} { - error "_insert_before_text_or_last_ansi ansisplits list is not a valid resultlist from an ansi split - must be odd number of elements pt,ansi,pt,ansi...pt" - } - set out [list] - set i 0 - set i_last_code [expr {[llength $ansisplits]-3}] ;#would normally be -2 - but our i is jumping to each pt - not every element - foreach {pt code} $ansisplits { - if {$pt ne ""} { - return [lappend out $str {*}[lrange $ansisplits $i end]] - } - if {$i == $i_last_code} { - return [lappend out $str {*}[lrange $ansisplits $i end]] - } - #code being empty can only occur when we have reached last pt - #we have returned by then. - lappend out $code - incr i 2 - } - error "_insert_before_text_or_last_ansi failed on input str:[ansistring VIEW $str] ansisplits:[ansistring VIEW $ansisplits]" - } - proc pad_test {block} { - set width [textblock::width $block] - set padtowidth [expr {$width + 10}] - set left0 [textblock::pad $block -width $padtowidth -padchar . -which left -within_ansi 0] - set left1 [textblock::pad $block -width $padtowidth -padchar . -which left -within_ansi 1] - set left2 [textblock::pad $block -width $padtowidth -padchar . -which left -within_ansi 2] - set right0 [textblock::pad $block -width $padtowidth -padchar . -which right -within_ansi 0] - set right1 [textblock::pad $block -width $padtowidth -padchar . -which right -within_ansi 1] - set right2 [textblock::pad $block -width $padtowidth -padchar . -which right -within_ansi 2] - - set testlist [list "within_ansi 0" $left0 $right0 "within_ansi 1" $left1 $right1 "within_ansi 2" $left2 $right2] - - set t [textblock::list_as_table -columns 3 -return tableobject $testlist] - $t configure_column 0 -headers [list "ansi"] - $t configure_column 1 -headers [list "Left"] - $t configure_column 2 -headers [list "Right"] - $t configure -show_header 1 - puts stdout [$t print] - return $t - } - - proc pad_test_blocklist {blocklist args} { - set opts [tcl::dict::create\ - -description ""\ - -blockheaders ""\ - ] - foreach {k v} $args { - switch -- $k { - -description - -blockheaders { - tcl::dict::set opts $k $v - } - default { - error "pad_test_blocklist unrecognised option '$k'. Known options: [tcl::dict::keys $opts]" - } - } - } - set opt_blockheaders [tcl::dict::get $opts -blockheaders] - set bheaders [tcl::dict::create] - if {$opt_blockheaders ne ""} { - set b 0 - foreach h $opt_blockheaders { - if {$b < [llength $blocklist]} { - tcl::dict::set bheaders $b $h - } - incr b - } - } - - set b 0 - set blockinfo [tcl::dict::create] - foreach block $blocklist { - set width [textblock::width $block] - tcl::dict::set blockinfo $b width $width - set padtowidth [expr {$width + 3}] - tcl::dict::set blockinfo $b left0 [textblock::pad $block -width $padtowidth -padchar . -which left -within_ansi 0] - tcl::dict::set blockinfo $b left1 [textblock::pad $block -width $padtowidth -padchar . -which left -within_ansi 1] - tcl::dict::set blockinfo $b left2 [textblock::pad $block -width $padtowidth -padchar . -which left -within_ansi 2] - tcl::dict::set blockinfo $b right0 [textblock::pad $block -width $padtowidth -padchar . -which right -within_ansi 0] - tcl::dict::set blockinfo $b right1 [textblock::pad $block -width $padtowidth -padchar . -which right -within_ansi 1] - tcl::dict::set blockinfo $b right2 [textblock::pad $block -width $padtowidth -padchar . -which right -within_ansi 2] - incr b - } - - set r0 [list "0"] - set r1 [list "1"] - set r2 [list "2"] - set r3 [list "column\ncolours"] - - #1 - #test without table padding - #we need to textblock::join each item to ensure we don't get the table's own textblock::pad interfering - #(basically a mechanism to add extra resets at start and end of each line) - #dict for {b bdict} $blockinfo { - # lappend r0 [textblock::join [tcl::dict::get $blockinfo $b left0]] [textblock::join [tcl::dict::get $blockinfo $b right0]] - # lappend r1 [textblock::join [tcl::dict::get $blockinfo $b left1]] [textblock::join [tcl::dict::get $blockinfo $b right1]] - # lappend r2 [textblock::join [tcl::dict::get $blockinfo $b left2]] [textblock::join [tcl::dict::get $blockinfo $b right2]] - #} - - #2 - the more useful one? - tcl::dict::for {b bdict} $blockinfo { - lappend r0 [tcl::dict::get $blockinfo $b left0] [tcl::dict::get $blockinfo $b right0] - lappend r1 [tcl::dict::get $blockinfo $b left1] [tcl::dict::get $blockinfo $b right1] - lappend r2 [tcl::dict::get $blockinfo $b left2] [tcl::dict::get $blockinfo $b right2] - lappend r3 "" "" - } - - set rows [concat $r0 $r1 $r2 $r3] - - set column_ansi [a+ web-white Web-Gray] - - set t [textblock::list_as_table -columns [expr {1 + (2 * [tcl::dict::size $blockinfo])}] -return tableobject $rows] - $t configure_column 0 -headers [list [tcl::dict::get $opts -description] "within_ansi"] -ansibase $column_ansi - set col 1 - tcl::dict::for {b bdict} $blockinfo { - if {[tcl::dict::exists $bheaders $b]} { - set hdr [tcl::dict::get $bheaders $b] - } else { - set hdr "Block $b" - } - $t configure_column $col -headers [list $hdr "Left"] -minwidth [expr {$padtowidth + 2}] - $t configure_column $col -header_colspans 2 -ansibase $column_ansi - incr col - $t configure_column $col -headers [list "-" "Right"] -minwidth [expr {$padtowidth + 2}] -ansibase $column_ansi - incr col - } - $t configure -show_header 1 - puts stdout [$t print] - return $t - } - proc pad_example {} { - set headers [list] - set blocks [list] - - lappend blocks "[textblock::testblock 4 rainbow]" - lappend headers "rainbow 4x4\nresets at line extremes\nnothing trailing" - - lappend blocks "[textblock::testblock 4 rainbow][a]" - lappend headers "rainbow 4x4\nresets at line extremes\ntrailing reset" - - lappend blocks "[textblock::testblock 4 rainbow]\n[a+ Web-Green]" - lappend headers "rainbow 4x4\nresets at line extremes\ntrailing nl&green bg" - - lappend blocks "[textblock::testblock 4 {rainbow noreset}]" - lappend headers "rainbow 4x4\nno line resets\nnothing trailing" - - lappend blocks "[textblock::testblock 4 {rainbow noreset}][a]" - lappend headers "rainbow 4x4\nno line resets\ntrailing reset" - - lappend blocks "[textblock::testblock 4 {rainbow noreset}]\n[a+ Web-Green]" - lappend headers "rainbow 4x4\nno line resets\ntrailing nl&green bg" - - set t [textblock::pad_test_blocklist $blocks -description "trailing\nbg/reset\ntests" -blockheaders $headers] - } - proc pad_example2 {} { - set headers [list] - set blocks [list] - lappend blocks "[a+ web-red Web-steelblue][textblock::block 4 4 x]\n" - lappend headers "red on blue 4x4\nno inner resets\ntrailing nl" - - lappend blocks "[a+ web-red Web-steelblue][textblock::block 4 4 x]\n[a]" - lappend headers "red on blue 4x4\nno inner resets\ntrailing nl&reset" - - lappend blocks "[a+ web-red Web-steelblue][textblock::block 4 4 x]\n[a+ Web-Green]" - lappend headers "red on blue 4x4\nno inner resets\ntrailing nl&green bg" - - set t [textblock::pad_test_blocklist $blocks -description "trailing\nbg/reset\ntests" -blockheaders $headers] - } - - - #playing with syntax - - # pipealias ::textblock::join_width .= {list $lhs [tcl::string::repeat " " $w1] $rhs [tcl::string::repeat " " $w2]} {| - # /2,col1/1,col2/3 - # >} punk::lib::lines_as_list -- {| - # data2 - # >} .=lhs> punk::lib::lines_as_list -- {| - # >} .= {lmap v $data w $data2 {val "[overtype::left $col1 $v][overtype::left $col2 $w]"}} {| - # >} punk::lib::list_as_lines -- } .=> punk::lib::lines_as_list -- {| - # data2 - # >} .=lhs> punk::lib::lines_as_list -- {| - # >} .= {lmap v $data w $data2 {val "[overtype::left $col1 $v][overtype::left $col2 $w]"}} {| - # >} punk::lib::list_as_lines -- } .=> punk::lib::lines_as_list -- {| - # data2 - # >} .=lhs> punk::lib::lines_as_list -- {| - # >} .= {lmap v $data w $data2 {val "[overtype::right $col1 $v][overtype::right $col2 $w]"}} {| - # >} punk::lib::list_as_lines punk . lhs][a]\n\n[a+ rgb#FFFF00][>punk . rhs][a] - set ipunks [overtype::renderspace -width [textblock::width $punks] [punk::ansi::enable_inverse]$punks] - set testblock [textblock::testblock 15 rainbow] - set contents $ansi\n[textblock::join -- " " $table " " $punks " " $testblock " " $ipunks " " $punks] - set framed [textblock::frame -type arc -title [a+ cyan]Compositing[a] -subtitle [a+ red]ANSI[a] -ansiborder [a+ web-orange] $contents] - } - - - proc example {args} { - set opts [tcl::dict::create -forcecolour 0] - foreach {k v} $args { - switch -- $k { - -forcecolour { - tcl::dict::set opts $k $v - } - default { - error "textblock::example unrecognised option '$k'. Known-options: [tcl::dict::keys $opts]" - } - } - } - set opt_forcecolour 0 - if {[tcl::dict::get $opts -forcecolour]} { - set fc forcecolour - set opt_forcecolour 1 - } else { - set fc "" - } - set pleft [>punk . rhs] - set pright [>punk . lhs] - set prightair [>punk . lhs_air] - set red [a+ {*}$fc red]; set redb [a+ {*}$fc red bold] - set green [a+ {*}$fc green]; set greenb [a+ {*}$fc green bold] - set cyan [a+ {*}$fc cyan];set cyanb [a+ {*}$fc cyan bold] - set blue [a+ {*}$fc blue];set blueb [a+ {*}$fc blue bold] - set RST [a] - set gr0 [punk::ansi::g0 abcdefghijklm\nnopqrstuvwxyz] - set punks [textblock::join -- $pleft $pright] - set pleft_greenb $greenb$pleft$RST - set pright_redb $redb$pright$RST - set prightair_cyanb $cyanb$prightair$RST - set cpunks [textblock::join -- $pleft_greenb $pright_redb] - set out "" - append out $punks \n - append out $cpunks \n - append out [textblock::join -- $punks $cpunks] \n - set 2frames_a [textblock::join -- [textblock::frame $cpunks] [textblock::frame $punks]] - append out $2frames_a \n - set 2frames_b [textblock::join -- [textblock::frame -ansiborder $cyanb -title "plainpunks" $punks] [textblock::frame -ansiborder $greenb -title "fancypunks" $cpunks]] - append out [textblock::frame -title "punks" $2frames_b\n$RST$2frames_a] \n - set fancy [overtype::right [overtype::left [textblock::frame -ansiborder [a+ green bold] -type heavy -title ${redb}PATTERN$RST -subtitle ${redb}PUNK$RST $prightair_cyanb] "$blueb\n\n\P\nU\nN\nK$RST"] "$blueb\n\nL\nI\nF\nE"] - set spantable [[spantest] print] - append out [textblock::join -- $fancy " " $spantable] \n - #append out [textblock::frame -title gr $gr0] - append out [textblock::periodic -forcecolour $opt_forcecolour] - return $out - } - - proc example3 {{text "test\netc\nmore text"}} { - package require patternpunk - .= textblock::join -- [punk::lib::list_as_lines -- [list 1 2 3 4 5 6 7]] [>punk . lhs] |> .=>1 textblock::join -- " " |> .=>1 textblock::join -- $text |> .=>1 textblock::join -- [>punk . rhs] |> .=>1 textblock::join -- [punk::lib::list_as_lines -- [lrepeat 7 " | "]] - } - proc example2 {{text "test\netc\nmore text"}} { - package require patternpunk - .= textblock::join\ - --\ - [punk::lib::list_as_lines -- [list 1 2 3 4 5 6 7 8]]\ - [>punk . lhs]\ - " "\ - $text\ - [>punk . rhs]\ - [punk::lib::list_as_lines -- [lrepeat 8 " | "]] - } - proc table {args} { - #todo - use punk::args - upvar ::textblock::class::opts_table_defaults toptdefaults - set defaults [tcl::dict::create\ - -rows [list]\ - -headers [list]\ - -return string\ - ] - - - set defaults [tcl::dict::merge $defaults $toptdefaults] ;# -title -frametype -show_header etc - set opts [tcl::dict::merge $defaults $args] - # -- --- --- --- - set opt_return [tcl::dict::get $opts -return] - set opt_rows [tcl::dict::get $opts -rows] - set opt_headers [tcl::dict::get $opts -headers] - # -- --- --- --- - set topts [tcl::dict::create] - set toptkeys [tcl::dict::keys $toptdefaults] - tcl::dict::for {k v} $opts { - if {$k in $toptkeys} { - tcl::dict::set topts $k $v - } - } - set t [textblock::class::table new {*}$topts] - - foreach h $opt_headers { - $t add_column -headers [list $h] - } - if {[$t column_count] == 0} { - if {[llength $opt_rows]} { - set r0 [lindex $opt_rows 0] - foreach c $r0 { - $t add_column - } - } - } - foreach r $opt_rows { - $t add_row $r - } - - - - if {$opt_return eq "string"} { - set result [$t print] - $t destroy - return $result - } else { - return $t - } - } - - variable frametypes - set frametypes [list light heavy arc double block block1 block2 block2hack ascii altg] - #class::table needs to be able to determine valid frametypes - proc frametypes {} { - variable frametypes - return $frametypes - } - proc frametype {f} { - #set custom_keys [list hl hlt hlb vl vll vlr tlc trc blc brc] - switch -- $f { - light - heavy - arc - double - block - block1 - block2 - block2hack - ascii - altg { - return [tcl::dict::create category predefined type $f] - } - default { - set is_custom_dict_ok 1 - if {[llength $f] %2 == 0} { - #custom dict may leave out keys - but cannot have unknown keys - foreach {k v} $f { - switch -- $k { - hl - hlt - hlb - vl - vll - vlr - tlc - trc - blc - brc {} - default { - #k not in custom_keys - set is_custom_dict_ok 0 - break - } - } - } - } else { - set is_custom_dict_ok 0 - } - if {!$is_custom_dict_ok} { - error "frame option -type must be one of known types: $::textblock::frametypes or a dictionary with any of keys hl,hlt,hlb,vl,vll,vlr,tlc,trc,blc,brc" - } - set default_custom [tcl::dict::create hl " " vl " " tlc " " trc " " blc " " brc " "] - set custom_frame [tcl::dict::merge $default_custom $f] - return [tcl::dict::create category custom type $custom_frame] - } - } - } - variable framedef_cache [tcl::dict::create] - proc framedef {args} { - #unicode box drawing only provides enough characters for seamless joining of unicode boxes light and heavy. - #e.g with characters such as \u2539 Box Drawings Right Light and Left Up Heavy. - #the double glyphs in box drawing can do a limited set of joins to light lines - but not enough for seamless table layouts. - #the arc set can't even join to itself e.g with curved equivalents of T-like shapes - - #we use the simplest cache_key possible - performance sensitive as called multiple times in table building. - variable framedef_cache - set cache_key $args - if {[tcl::dict::exists $framedef_cache $cache_key]} { - return [tcl::dict::get $framedef_cache $cache_key] - } - - set argopts [lrange $args 0 end-1] - set f [lindex $args end] - - #here we avoid the punk::args usage on the happy path, even though punk::args is fairly fast, in favour of an even faster literal switch on the happy path - #this means we have some duplication in where our flags/opts are defined: here in opts, and in spec below to give nicer error output without affecting performance. - #It also means we can't specify checks on the option types etc - set opts [tcl::dict::create\ - -joins ""\ - -boxonly 0\ - ] - set bad_option 0 - foreach {k v} $argopts { - switch -- $k { - -joins - -boxonly { - tcl::dict::set opts $k $v - } - default { - set bad_option - break - } - } - } - if {[llength $args] % 2 == 0 || $bad_option} { - #no framedef supplied, or unrecognised opt seen - set spec [string map [list $::textblock::frametypes] { - *proc -name textblock::framedef - -joins -default "" -help "List of join directions, any of: up down left right - or those combined with another frametype e.g left-heavy down-light" - -boxonly -default 0 -help "-boxonly true restricts results to the corner,vertical and horizontal box elements - It excludes the extra top and side join elements htlj,hlbj,vllj,vlrj" - *values -min 1 -max 1 - frametype -choices "" -choiceprefix 0 -help "name from the predefined frametypes - or an adhoc dictionary." - }] - #append spec \n "frametype -help \"A predefined \"" - punk::args::get_dict $spec $args - return - } - - set joins [tcl::dict::get $opts -joins] - set boxonly [tcl::dict::get $opts -boxonly] - - - #sorted order down left right up - #1 x choose 4 - #4 x choose 3 - #6 x choose 2 - #4 x choose 1 - #15 combos - - set join_directions [list] - #targets - light,heavy (double?) - seem to be some required glyphs missing from unicode - #e.g down-light, up-heavy - set join_targets [tcl::dict::create left "" down "" right "" up ""] - foreach jt $joins { - lassign [split $jt -] direction target - if {$target ne ""} { - tcl::dict::set join_targets $direction $target - } - lappend join_directions $direction - } - set join_directions [lsort -unique $join_directions] - set do_joins [::join $join_directions _] - - - switch -- $f { - "altg" { - #old style ansi escape sequences with alternate graphics page G0 - set hl [cd::hl] - set hlt $hl - set hlb $hl - set vl [cd::vl] - set vll $vl - set vlr $vl - set tlc [cd::tlc] - set trc [cd::trc] - set blc [cd::blc] - set brc [cd::brc] - - #horizontal and vertical bar joins - set hltj $hlt - set hlbj $hlb - set vllj $vll - set vlrj $vlr - #No join targets available to join altg to other box styles - switch -- $do_joins { - down { - #1 - set blc [punk::ansi::g0 t] ;#(ltj) - set brc [punk::ansi::g0 u] ;#(rtj) - set hlbj [punk::ansi::g0 w] ;#(ttj) - } left { - #2 - set tlc [punk::ansi::g0 w] ;#(ttj) - set blc [punk::ansi::g0 v] ;#(btj) - set vllj [punk::ansi::g0 u] ;#(rtj) - } - right { - #3 - set trc [punk::ansi::g0 w] ;#(ttj) - set brc [punk::ansi::g0 v] ;#(btj) - set vlrj [punk::ansi::g0 t] ;#(ltj) - } - up { - #4 - set tlc [punk::ansi::g0 t] ;#(ltj) - set trc [punk::ansi::g0 u] ;#(rtj) - set hltj [punk::ansi::g0 v];#(btj) - } - down_left { - #5 - set blc [punk::ansi::g0 n] ;#(fwj) - set tlc [punk::ansi::g0 w] ;#(ttj) - set brc [punk::ansi::g0 u] ;#(rtj) - set hlbj [punk::ansi::g0 w] ;#(ttj) - set vllj [punk::ansi::g0 u] ;#(rtj) - } - down_right { - #6 - set blc [punk::ansi::g0 t] ;#(ltj) - set trc [punk::ansi::g0 w] ;#(ttj) - set brc [punk::ansi::g0 n] ;#(fwj) - set hlbj [punk::ansi::g0 w] ;#(ttj) - set vlrj [punk::ansi::g0 t] ;#(ltj) - } - down_up { - #7 - set blc [punk::ansi::g0 t] ;#(ltj) - set brc [punk::ansi::g0 u] ;#(rtj) - - set tlc [punk::ansi::g0 t] ;#(ltj) - set trc [punk::ansi::g0 u] ;#(rtj) - set hlbj [punk::ansi::g0 w] ;#(ttj) - set hltj [punk::ansi::g0 v];#(btj) - } - left_right { - #8 - #from 2 - set tlc [punk::ansi::g0 w] ;#(ttj) - set blc [punk::ansi::g0 v] ;#(btj) - #from3 - set trc [punk::ansi::g0 w] ;#(ttj) - set brc [punk::ansi::g0 v] ;#(btj) - set vllj [punk::ansi::g0 u] ;#(rtj) - set vlrj [punk::ansi::g0 t] ;#(ltj) - } - left_up { - #9 - set tlc [punk::ansi::g0 n] ;#(fwj) - set trc [punk::ansi::g0 u] ;#(rtj) - set blc [punk::ansi::g0 v] ;#(btj) - set vllj [punk::ansi::g0 u] ;#(rtj) - } - right_up { - #10 - set tlc [punk::ansi::g0 t] ;#(ltj) - set trc [punk::ansi::g0 n] ;#(fwj) - set brc [punk::ansi::g0 v] ;#(btj) - set hltj [punk::ansi::g0 v];#(btj) - set vlrj [punk::ansi::g0 t] ;#(ltj) - } - down_left_right { - #11 - set blc [punk::ansi::g0 n] ;#(fwj) - set brc [punk::ansi::g0 n] ;#(fwj) - set trc [punk::ansi::g0 w] ;#(ttj) - set tlc [punk::ansi::g0 w] ;#(ttj) - set vllj [punk::ansi::g0 u] ;#(rtj) - set vlrj [punk::ansi::g0 t] ;#(ltj) - set hlbj [punk::ansi::g0 w] ;#(ttj) - } - down_left_up { - #12 - set tlc [punk::ansi::g0 n] ;#(fwj) - set blc [punk::ansi::g0 n] ;#(fwj) - set trc [punk::ansi::g0 u] ;#(rtj) - set brc [punk::ansi::g0 u] ;#(rtj) - set vllj [punk::ansi::g0 u] ;#(rtj) - set hltj [punk::ansi::g0 v];#(btj) - set hlbj [punk::ansi::g0 w] ;#(ttj) - } - down_right_up { - #13 - set tlc [punk::ansi::g0 t] ;#(ltj) - set blc [punk::ansi::g0 t] ;#(ltj) - set trc [punk::ansi::g0 n] ;#(fwj) - set brc [punk::ansi::g0 n] ;#(fwj) - set hltj [punk::ansi::g0 v];#(btj) - set vlrj [punk::ansi::g0 t] ;#(ltj) - set hlbj [punk::ansi::g0 w] ;#(ttj) - } - left_right_up { - #14 - set tlc [punk::ansi::g0 n] ;#(fwj) - set trc [punk::ansi::g0 n] ;#(fwj) - set blc [punk::ansi::g0 v] ;#(btj) - set brc [punk::ansi::g0 v] ;#(btj) - set vllj [punk::ansi::g0 u] ;#(rtj) - set hltj [punk::ansi::g0 v];#(btj) - set vlrj [punk::ansi::g0 t] ;#(ltj) - } - down_left_right_up { - #15 - set tlc [punk::ansi::g0 n] ;#(fwj) - set blc [punk::ansi::g0 n] ;#(fwj) - set trc [punk::ansi::g0 n] ;#(fwj) - set brc [punk::ansi::g0 n] ;#(fwj) - set vllj [punk::ansi::g0 u] ;#(rtj) - set hltj [punk::ansi::g0 v];#(btj) - set vlrj [punk::ansi::g0 t] ;#(ltj) - set hlbj [punk::ansi::g0 w] ;#(ttj) - } - } - - - } - "ascii" { - set hl - - set hlt - - set hlb - - set vl | - set vll | - set vlr | - set tlc + - set trc + - set blc + - set brc + - #horizontal and vertical bar joins - #set hltj $hlt - #set hlbj $hlb - #set vllj $vll - #set vlrj $vlr - #ascii + is small - can reasonably be considered a join to anything? - set hltj + - set hlbj + - set vllj + - set vlrj + - #our corners are all + already - so we won't do anything for directions or targets - - } - "light" { - #unicode box drawing set - set hl [punk::char::charshort boxd_lhz] ;# light horizontal - set hlt $hl - set hlb $hl - set vl [punk::char::charshort boxd_lv] ;#light vertical - set vll $vl - set vlr $vl - set tlc [punk::char::charshort boxd_ldr] - set trc [punk::char::charshort boxd_ldl] - set blc [punk::char::charshort boxd_lur] - set brc [punk::char::charshort boxd_lul] - - #horizontal and vertical bar joins - set hltj $hlt - set hlbj $hlb - set vllj $vll - set vlrj $vlr - - #15 combos - #sort order: down left right up - #ltj,rtj,ttj,btj e.g left T junction etc. - #Look at from the perspective of a frame/table outline with a clean border and arms pointing inwards - - #set targetdown,targetleft,targetright,targetup vars - #default empty targets to current box type 'light' - foreach dir {down left right up} { - set target [tcl::dict::get $join_targets $dir] - switch -- $target { - "" - light { - set target$dir light - } - ascii - altg - arc { - set target$dir light - } - heavy { - set target$dir $target - } - default { - set target$dir other - } - } - } - switch -- $do_joins { - down { - #1 - switch -- $targetdown { - heavy { - set blc [punk::char::charshort boxd_dhrul] ;#\u251f down hieavy and right up light (ltj) - set brc \u2527 ;#boxd_dhlul down heavy and left up light (rtj) - set hlbj \u2530 ;# down heavy (ttj) - } - light { - set blc \u251c ;#[punk::char::charshort boxd_lvr] light vertical and right (ltj) - set brc [punk::char::charshort boxd_lvl] ;#light vertical and left (rtj) - set hlbj \u252c ;# (ttj) - } - } - } - left { - #2 - switch -- $targetleft { - heavy { - set tlc \u252d ;# Left Heavy and Right Down Light (ttj) - set blc \u2535 ;# Left Heavy and Right Up Light (btj) - set vllj \u2525 ;# left heavy (rtj) - } - light { - set tlc [punk::char::charshort boxd_ldhz] ;#T shape (ttj) - joinleft - set blc [punk::char::charshort boxd_luhz] ;#upside down T shape (btj) - set vllj \u2524 ;# (rtj) - } - } - } - right { - #3 - switch -- $targetright { - heavy { - set trc \u252e ;#Right Heavy and Left Down Light (ttj) - set brc \u2536 ;#Right Heavy and Left up Light (btj) - set vlrj \u251d;#right heavy (ltj) - } - light { - set trc [punk::char::charshort boxd_ldhz] ;#T shape (ttj) - set brc [punk::char::charshort boxd_luhz] ;#upside down T shape (btj) - set vlrj \u251c;# (ltj) - } - } - } - up { - #4 - switch -- $targetup { - heavy { - set tlc \u251e ;#up heavy (ltj) - set trc \u2526 ;#up heavy (rtj) - } - light { - set tlc [punk::char::charshort boxd_lvr] ;#light vertical and right (ltj) - set trc [punk::char::charshort boxd_lvl] ;#light vertical and left (rtj) - } - } - } - down_left { - #5 - switch -- $targetdown-$targetleft { - other-light { - set blc \u2534 ;#(btj) - set tlc \u252c ;#(ttj) - #brc - default corner - set vllj \u2524 ;# (rtj) - } - other-other { - #default corners - } - other-heavy { - set blc \u2535 ;# heavy left (btj) - set tlc \u252d ;#heavy left (ttj) - #brc default corner - set vllj \u2525 ;# heavy left (rtj) - } - heavy-light { - set blc \u2541 ;# heavy down (fwj) - set tlc \u252c ;# light (ttj) - set brc \u2527 ;# heavy down (rtj) - set vllj \u2524 ;# (rtj) - set hlbj \u2530 ;# heavy down (ttj) - } - heavy-other { - set blc \u251f ;#heavy down (ltj) - #tlc - default corner - set brc \u2527 ;#heavy down (rtj) - set hlbj \u2530 ;# heavy down (ttj) - } - heavy-heavy { - set blc \u2545 ;#heavy down and left (fwj) - set tlc \u252d ;#heavy left (ttj) - set brc \u2527 ;#heavy down (rtj) - set vllj \u2525 ;# heavy left (rtj) - set hlbj \u2530 ;# heavy down (ttj) - } - light-light { - set blc \u253c ;# [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) - set tlc \u252c ;# boxd_ldhz (ttj) - set brc \u2524 ;# boxd_lvl light vertical and left(rtj) - set vllj \u2524 ;# (rtj) - set hlbj \u252c ;# (ttj) - } - light-other { - set blc \u251c ;# (ltj) - #tlc - default corner - set brc \u2524 ;# boxd_lvl (rtj) - set hlbj \u252c ;# (ttj) - } - light-heavy { - set blc \u253d ;# heavy left (fwj) - set tlc \u252d ;# heavy left (ttj) - set brc \u2524 ;# light (rtj) - set vllj \u2525 ;# heavy left (rtj) - set hlbj \u252c ;# (ttj) - } - default { - set blc \u253c ;# [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) - set tlc \u252c ;# [punk::char::charshort boxd_ldhz] ;#T shape (ttj) - set brc \u2524 ;# [punk::char::charshort boxd_lvl] ;#light vertical and left (rtj) - } - } - } - down_right { - #6 - set blc [punk::char::charshort boxd_lvr] ;#light vertical and right (ltj) - set trc [punk::char::charshort boxd_ldhz] ;#T shape (ttj) - set brc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) - } - down_up { - #7 - set blc [punk::char::charshort boxd_lvr] ;#light vertical and right (ltj) - set brc [punk::char::charshort boxd_lvl] ;#light vertical and left (rtj) - - set tlc [punk::char::charshort boxd_lvr] ;#light vertical and right (ltj) - set trc [punk::char::charshort boxd_lvl] ;#light vertical and left (rtj) - } - left_right { - #8 - #from 2 - set tlc [punk::char::charshort boxd_ldhz] ;#T shape (ttj) - joinleft - set blc [punk::char::charshort boxd_luhz] ;#upside down T shape (btj) - #from3 - set trc [punk::char::charshort boxd_ldhz] ;#T shape (ttj) - set brc [punk::char::charshort boxd_luhz] ;#upside down T shape (btj) - } - left_up { - #9 - set tlc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) - set trc [punk::char::charshort boxd_lvl] ;#light vertical and left (rtj) - set blc [punk::char::charshort boxd_luhz] ;#upside down T shape (btj) - } - right_up { - #10 - set tlc [punk::char::charshort boxd_lvr] ;#light vertical and right (ltj) - set trc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) - set brc [punk::char::charshort boxd_luhz] ;#upside down T shape (btj) - } - down_left_right { - #11 - set blc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) - set brc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) - set trc [punk::char::charshort boxd_ldhz] ;#T shape (ttj) - set tlc [punk::char::charshort boxd_ldhz] ;#T shape (ttj) - - } - down_left_up { - #12 - set tlc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) - set blc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) - set trc [punk::char::charshort boxd_lvl] ;#light vertical and left (rtj) - set brc [punk::char::charshort boxd_lvl] ;#light vertical and left (rtj) - - } - down_right_up { - #13 - set tlc [punk::char::charshort boxd_lvr] ;#light vertical and right (ltj) - set blc [punk::char::charshort boxd_lvr] ;#light vertical and right (ltj) - set trc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) - set brc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) - } - left_right_up { - #14 - set tlc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) - set trc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) - set blc [punk::char::charshort boxd_luhz] ;#upside down T shape (btj) - set brc [punk::char::charshort boxd_luhz] ;#upside down T shape (btj) - - } - down_left_right_up { - #15 - set tlc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) - set blc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) - set trc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) - set brc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) - } - } - #four way junction (cd::fwj) (punk::ansi::g0 n) (punk::char::charshort lvhz) (+) - } - "heavy" { - #unicode box drawing set - set hl [punk::char::charshort boxd_hhz] ;# light horizontal - set hlt $hl - set hlb $hl - set vl [punk::char::charshort boxd_hv] ;#light vertical - set vll $vl - set vlr $vl - set tlc [punk::char::charshort boxd_hdr] - set trc [punk::char::charshort boxd_hdl] - set blc [punk::char::charshort boxd_hur] - set brc [punk::char::charshort boxd_hul] - #horizontal and vertical bar joins - set hltj $hlt - set hlbj $hlb - set vllj $vll - set vlrj $vlr - - #set targetdown,targetleft,targetright,targetup vars - #default empty targets to current box type 'heavy' - foreach dir {down left right up} { - set target [tcl::dict::get $join_targets $dir] - switch -- $target { - "" - heavy { - set target$dir heavy - } - light - ascii - altg - arc { - set target$dir light - } - default { - set target$dir other - } - } - } - switch -- $do_joins { - down { - #1 - switch -- $targetdown { - light { - set blc [punk::char::charshort boxd_dlruh] ;#\u2521 down light and right up heavy (ltj) - set brc [punk::char::charshort boxd_dlluh] ;#\u2529 down light and left up heavy (rtj) - set hlbj \u252F ;#down light (ttj) - } - heavy { - set blc [punk::char::charshort boxd_hvr] ;# (ltj) - set brc [punk::char::charshort boxd_hvl] ;# (rtj) - set hlbj \u2533 ;# down heavy (ttj) - } - } - } - left { - #2 - switch -- $targetleft { - light { - set tlc [punk::char::charshort boxd_llrdh] ;#\u2532 Left Light and Right Down Heavy (ttj) - set blc [punk::char::charshort boxd_llruh] ;#\u253a Left Light and Right Up Heavy (btj) - set vllj \u2528 ;# left light (rtj) - } - heavy { - set tlc [punk::char::charshort boxd_hdhz] ;# (ttj) - set blc [punk::char::charshort boxd_huhz] ;# (btj) - set vllj \u252b ;#(rtj) - } - } - } - right { - #3 - switch -- $targetright { - light { - set trc [punk::char::charshort boxd_rlldh] ;#\u2531 Right Light and Left Down Heavy (ttj) - set brc [punk::char::charshort boxd_rlluh] ;#\u2539 Right Light and Left Up Heavy(btj) - set vlrj \u2520 ;#right light (ltj) - } - heavy { - set trc [punk::char::charshort boxd_hdhz] ;#T shape (ttj) - set brc [punk::char::charshort boxd_huhz] ;# (btj) - set vlrj \u2523 ;# (ltj) - } - } - } - up { - #4 - switch -- $targetup { - light { - set tlc [punk::char::charshort boxd_ulrdh] ;#\u2522 Up Light and Right Down Heavy (ltj) - set trc [punk::char::charshort boxd_ulldh] ;#\u252a Up Light and Left Down Heavy (rtj) - set hltj \u2537 ;# up light (btj) - } - heavy { - set tlc [punk::char::charshort boxd_hvr] ;# (ltj) - set trc [punk::char::charshort boxd_hvl] ;# (rtj) - set hltj \u253b ;# (btj) - } - } - } - down_left { - #down_left is the main join type used for 'L' shaped cell border table building where we boxlimit to {vll hlb blc} - #5 - switch -- down-$targetdown-left-$targetleft { - down-light-left-heavy { - set blc [punk::char::charshort boxd_dluhzh] ;#down light and up horizontal heavy (fwj) - set brc [punk::char::charshort boxd_dlluh] ;#\u2529 down light and left up heavy (rtj) - set tlc [punk::char::charshort boxd_hdhz] ;# (ttj) (at tlc down stays heavy) - set hlbj \u252F ;# down light (ttj) - set vllj \u252b ;#(rtj) - } - down-heavy-left-light { - set blc [punk::char::charshort boxd_llrvh] ;# left light and right Vertical Heavy (fwj) - set brc [punk::char::charshort boxd_hvl] ;# (rtj) (at brc left must stay heavy) - set tlc [punk::char::charshort boxd_llrdh] ;#\u2532 Left Light and Right Down Heavy (ttj) - set hlbj \u2533 ;# down heavy (ttj) - set vllj \u2528 ;# left light (rtj) - } - down-light-left-light { - set blc [punk::char::charshort boxd_ruhldl] ;#\u2544 right up heavy and left down light (fwj) - set brc [punk::char::charshort boxd_dlluh] ;#\u2529 Down Light and left Up Heavy (rtj) (left must stay heavy) - set tlc [punk::char::charshort boxd_llrdh] ;#\u2532 Left Light and Right Down Heavy (ttj) (we are in heavy - so down must stay heavy at tlc) - set hlbj \u252F ;# down light (ttj) - set vllj \u2528 ;# left light (rtj) - } - down-heavy-left-heavy { - set blc [punk::char::charshort boxd_hvhz] ;# (fwj) - set brc [punk::char::charshort boxd_hvl] ;# (rtj) - set tlc [punk::char::charshort boxd_hdhz] ;# (ttj) - set hlbj \u2533 ;#(ttj) - set vllj \u252b ;#(rtj) - } - down-other-left-heavy { - set blc \u253b ;#boxd_huhz Heavy Up and Horizontal (btj) - #leave brc default corner - set tlc \u2533 ;#hdhz Heavy Down and Horizontal (ttj) - - set vllj \u252b ;#(rtj) - } - down-other-left-light { - set blc \u253a ;#llruh Left Light and Right Up Heavy (btj) - #leave brc default corner - set tlc \u2532 ;#llrdh Left Light and Right Down Heavy (ttj) - - set vllj \u2528 ;# left light (rtj) - } - down-heavy-left-other { - set blc \u2523 ;#hvr Heavy Vertical and Right (ltj) - set brc \u252b ;#hvl Heavy Veritcal and Left (rtj) - #leave tlc default corner - - set hlbj \u2533 ;#(ttj) - } - down-light-left-other { - set blc \u2521 ;#dlruh Down Light and Right Up Heavy (ltj) - set brc \u2529 ;#dlluh Down Light and Left Up Heavy (rtj) - #leave tlc default corner - - set hlbj \u252F ;# down light (ttj) - } - } - } - down_right { - #6 - set blc [punk::char::charshort boxd_hvr] ;# (ltj) (blc right&up stay heavy) - set trc [punk::char::charshort boxd_hdhz] ;# (ttj) (tlc down&left stay heavy) - set brc [punk::char::charshort boxd_hvhz] ;# (fwj) (brc left&up heavy) - } - down_up { - #7 - set blc [punk::char::charshort boxd_hvr] ;# (ltj) - set brc [punk::char::charshort boxd_hvl] ;# (rtj) - - set tlc [punk::char::charshort boxd_hvr] ;# (ltj) - set trc [punk::char::charshort boxd_hvl] ;# (rtj) - } - left_right { - #8 - #from 2 - set tlc [punk::char::charshort boxd_hdhz] ;# (ttj) - set blc [punk::char::charshort boxd_huhz] ;# (btj) - #from3 - set trc [punk::char::charshort boxd_hdhz] ;# (ttj) - set brc [punk::char::charshort boxd_huhz] ;# (btj) - } - left_up { - #9 - set tlc [punk::char::charshort boxd_hvhz] ;# (fwj) - set trc [punk::char::charshort boxd_hvl] ;# (rtj) - set blc [punk::char::charshort boxd_huhz] ;# (btj) - } - right_up { - #10 - set tlc [punk::char::charshort boxd_hvr] ;# (ltj) - set trc [punk::char::charshort boxd_hvhz] ;# (fwj) - set brc [punk::char::charshort boxd_huhz] ;# (btj) - } - down_left_right { - #11 - set blc [punk::char::charshort boxd_hvhz] ;# (fwj) - set brc [punk::char::charshort boxd_hvhz] ;# (fwj) - set trc [punk::char::charshort boxd_hdhz] ;# (ttj) - set tlc [punk::char::charshort boxd_hdhz] ;# (ttj) - - } - down_left_up { - #12 - set tlc [punk::char::charshort boxd_hvhz] ;# (fwj) - set blc [punk::char::charshort boxd_hvhz] ;# (fwj) - set trc [punk::char::charshort boxd_hvl] ;# (rtj) - set brc [punk::char::charshort boxd_hvl] ;# (rtj) - - } - down_right_up { - #13 - set tlc [punk::char::charshort boxd_hvr] ;# (ltj) - set blc [punk::char::charshort boxd_hvr] ;# (ltj) - set trc [punk::char::charshort boxd_hvhz] ;# (fwj) - set brc [punk::char::charshort boxd_hvhz] ;# (fwj) - } - left_right_up { - #14 - set tlc [punk::char::charshort boxd_hvhz] ;# (fwj) - set trc [punk::char::charshort boxd_hvhz] ;# (fwj) - set blc [punk::char::charshort boxd_huhz] ;# (btj) - set brc [punk::char::charshort boxd_huhz] ;# (btj) - - } - down_left_right_up { - #15 - set tlc [punk::char::charshort boxd_hvhz] ;# (fwj) - set blc [punk::char::charshort boxd_hvhz] ;# (fwj) - set trc [punk::char::charshort boxd_hvhz] ;# (fwj) - set brc [punk::char::charshort boxd_hvhz] ;# (fwj) - } - } - } - "double" { - #unicode box drawing set - set hl [punk::char::charshort boxd_dhz] ;# double horizontal \U2550 - set hlt $hl - set hlb $hl - set vl [punk::char::charshort boxd_dv] ;#double vertical \U2551 - set vll $vl - set vlr $vl - set tlc [punk::char::charshort boxd_ddr] ;#double down and right \U2554 - set trc [punk::char::charshort boxd_ddl] ;#double down and left \U2557 - set blc [punk::char::charshort boxd_dur] ;#double up and right \U255A - set brc [punk::char::charshort boxd_dul] ;#double up and left \U255D - - #horizontal and vertical bar joins - set hltj $hlt - set hlbj $hlb - set vllj $vll - set vlrj $vlr - - # \u256c (fwj) - - #set targetdown,targetleft,targetright,targetup vars - #default empty targets to current box type 'double' - foreach dir {down left right up} { - set target [tcl::dict::get $join_targets $dir] - switch -- $target { - "" - double { - set target$dir double - } - light { - set target$dir light - } - default { - set target$dir other - } - } - } - - #unicode provides no joining for double to anything else - #better to leave a gap by using default double corners if join target is not empty or double - switch -- $do_joins { - down { - #1 - switch -- $targetdown { - double { - set blc \u2560 ;# (ltj) - set brc \u2563 ;# (rtj) - set hlbj \u2566 ;# (ttj) - } - light { - set hlbj \u2564 ;# down light (ttj) - } - } - } - left { - #2 - switch -- $targetleft { - double { - set tlc \u2566 ;# (ttj) - set blc \u2569 ;# (btj) - set vllj \u2563 ;# (rtj) - } - light { - set vllj \u2562 ;# light left (rtj) - } - } - } - right { - #3 - switch -- $targetright { - double { - set trc \u2566 ;# (ttj) - set brc \u2569 ;# (btj) - } - light { - set vlrj \u255F ;# light right (ltj) - } - } - } - up { - #4 - switch -- $targetup { - double { - set tlc \u2560 ;# (ltj) - set trc \u2563 ;# (rtj) - set hltj \u2569 ;# (btj) - } - light { - set hltj \u2567 ;#up light (btj) - } - } - } - down_left { - #5 - switch -- $targetdown-$targetleft { - double-double { - set blc \u256c ;# (fwj) - set brc \u2563 ;# (rtj) - set tlc \u2566 ;# (ttj) - set hlbj \u2566 ;# (ttj) - } - double-light { - #no corner joins treat corners like 'other' - set blc \u2560 ;# (ltj) - set brc \u2563 ;# (rtj) - - set hlbj \u2566 ;# (ttj) - set vllj \u2562 ;# light left (rtj) - - } - double-other { - set blc \u2560 ;# (ltj) - set brc \u2563 ;# (rtj) - #leave tlc as ordinary double corner - } - light-double { - - set vllj \u2563 ;# (rtj) - set hlbj \u2564 ;# light down (ttj) - - } - light-light { - - set vllj \u2562 ;# light left (rtj) - set hlbj \u2564 ;# light down (ttj) - } - other-light { - set vllj \u2562 ;# light left (rtj) - } - other-double { - set blc \u2569 ;# (btj) - #leave brc as ordinary double corner - set tlc \u2566 ;# (ttj) - } - } - } - down_right { - #6 - switch -- $targetdown-$targetright { - double-double { - set blc \u2560 ;# (ltj) - set trc \u2566 ;# (ttj) - set brc \u256c ;# (fwj) - set hlbj \u2566 ;# (ttj) - } - double-other { - set blc \u2560 ;# (ltj) - #leave trc default - set brc \u2563 ;# (rtj) - } - other-double { - #leave blc default - set trc \u2566 ;# (ttj) - set brc \u2569 ;#(btj) - } - } - } - down_up { - #7 - switch -- $targetdown-$targetup { - double-double { - set blc \u2560 ;# (ltj) - set brc \u2563 ;# (rtj) - set tlc \u2560 ;# (ltj) - set trc \u2563 ;# (rtj) - set hltj \u2569 ;# (btj) - set hlbj \u2566 ;# (ttj) - } - } - } - left_right { - #8 - - #from 2 - set tlc [punk::char::charshort boxd_hdhz] ;# (ttj) - set blc [punk::char::charshort boxd_huhz] ;# (btj) - #from3 - set trc [punk::char::charshort boxd_hdhz] ;# (ttj) - set brc [punk::char::charshort boxd_huhz] ;# (btj) - } - left_up { - #9 - set tlc [punk::char::charshort boxd_hvhz] ;# (fwj) - set trc [punk::char::charshort boxd_hvl] ;# (rtj) - set blc [punk::char::charshort boxd_huhz] ;# (btj) - set hltj \u2569 ;# (btj) - set vllj \u2563 ;# (rtj) - } - right_up { - #10 - set tlc [punk::char::charshort boxd_hvr] ;# (ltj) - set trc [punk::char::charshort boxd_hvhz] ;# (fwj) - set brc [punk::char::charshort boxd_huhz] ;# (btj) - set hltj \u2569 ;# (btj) - set vlrj \u2560 ;# (ltj) - } - down_left_right { - #11 - set blc [punk::char::charshort boxd_hvhz] ;# (fwj) - set brc [punk::char::charshort boxd_hvhz] ;# (fwj) - set trc [punk::char::charshort boxd_hdhz] ;# (ttj) - set tlc [punk::char::charshort boxd_hdhz] ;# (ttj) - set hlbj \u2566 ;# (ttj) - set vlrj \u2560 ;# (ltj) - - } - down_left_up { - #12 - set tlc [punk::char::charshort boxd_hvhz] ;# (fwj) - set blc [punk::char::charshort boxd_hvhz] ;# (fwj) - set trc [punk::char::charshort boxd_hvl] ;# (rtj) - set brc [punk::char::charshort boxd_hvl] ;# (rtj) - set hltj \u2569 ;# (btj) - set hlbj \u2566 ;# (ttj) - - } - down_right_up { - #13 - set tlc [punk::char::charshort boxd_hvr] ;# (ltj) - set blc [punk::char::charshort boxd_hvr] ;# (ltj) - set trc [punk::char::charshort boxd_hvhz] ;# (fwj) - set brc [punk::char::charshort boxd_hvhz] ;# (fwj) - set hltj \u2569 ;# (btj) - set hlbj \u2566 ;# (ttj) - } - left_right_up { - #14 - set tlc [punk::char::charshort boxd_hvhz] ;# (fwj) - set trc [punk::char::charshort boxd_hvhz] ;# (fwj) - set blc [punk::char::charshort boxd_huhz] ;# (btj) - set brc [punk::char::charshort boxd_huhz] ;# (btj) - set hltj \u2569 ;# (btj) - - } - down_left_right_up { - #15 - set tlc [punk::char::charshort boxd_hvhz] ;# (fwj) - set blc [punk::char::charshort boxd_hvhz] ;# (fwj) - set trc [punk::char::charshort boxd_hvhz] ;# (fwj) - set brc [punk::char::charshort boxd_hvhz] ;# (fwj) - set hltj \u2569 ;# (btj) - set hlbj \u2566 ;# (ttj) - } - } - - } - "arc" { - #unicode box drawing set - - - set hl [punk::char::charshort boxd_lhz] ;# light horizontal - set hlt $hl - set hlb $hl - set vl [punk::char::charshort boxd_lv] ;#light vertical - set vll $vl - set vlr $vl - set tlc [punk::char::charshort boxd_ladr] ;#light arc down and right \U256D - set trc [punk::char::charshort boxd_ladl] ;#light arc down and left \U256E - set blc [punk::char::charshort boxd_laur] ;#light arc up and right \U2570 - set brc [punk::char::charshort boxd_laul] ;#light arc up and left \U256F - - #horizontal and vertical bar joins - set hltj $hlt - set hlbj $hlb - set vllj $vll - set vlrj $vlr - - #set targetdown,targetleft,targetright,targetup vars - #default empty targets to current box type 'arc' - foreach dir {down left right up} { - set target [tcl::dict::get $join_targets $dir] - switch -- $target { - "" - arc { - set target$dir self - } - default { - set target$dir other - } - } - } - - switch -- $do_joins { - down { - #1 - switch -- $targetdown { - self { - set blc \u251c ;# *light (ltj) - #set blc \u29FD ;# misc math right-pointing curved angle bracket (ltj) - positioned too far left - #set blc \u227b ;# math succeeds char. joins on right ok - gaps top and bottom - almost passable - #set blc \u22b1 ;#math succeeds under relation - looks 'ornate', sits too low to join horizontal - - #set brc \u2524 ;# *light(rtj) - #set brc \u29FC ;# misc math left-pointing curved angle bracket (rtj) - } - } - } - left { - #2 - switch -- $targetleft { - self { - set tlc \u252c ;# *light(ttj) - need a low positioned curved y shape - nothing apparent - #set blc \u2144 ;# (btj) - upside down y - positioning too low for arc - set blc \u2534 ;# *light (btj) - } - } - } - right { - #3 - switch -- $targetright { - self { - set trc \u252c ;# *light (ttj) - #set brc \u2144 ;# (btj) - set brc \u2534 ;# *light (btj) - } - } - } - up { - #4 - switch -- $targetup { - self { - set tlc \u251c ;# *light (ltj) - set trc \u2524 ;# *light(rtj) - } - } - } - down_left { - #5 - switch -- $targetdown-$targetleft { - self-self { - #set blc \u27e1 ;# white concave-sided diamond - positioned too far right - #set blc \u27e3 ;# concave sided diamond with rightwards tick - positioned too low, too right - big gaps - set brc \u2524 ;# *light (rtj) - set tlc \u252c ;# *light (ttj) - } - self-other { - #set blc \u2560 ;# (ltj) - #set brc \u2563 ;# (rtj) - #leave tlc as ordinary double corner - } - other-self { - #set blc \u2569 ;# (btj) - #leave brc as ordinary double corner - #set tlc \u2566 ;# (ttj) - } - } - } - } - } - block1 { - #box drawing as far as we can go without extra blocks from legacy computing unicode block - which is unfortunately not commonly supported - set hlt \u2581 ;# lower one eighth block - set hlb \u2594 ;# upper one eighth block - set vll \u258f ;# left one eighth block - set vlr \u2595 ;# right one eighth block - set tlc \u2581 ;# lower one eighth block - set trc \u2581 ;# lower one eighth block - set blc \u2594 ;# upper one eighth block - set brc \u2594 ;# upper one eight block - - #horizontal and vertical bar joins - set hltj $hlt - set hlbj $hlb - set vllj $vll - set vlrj $vlr - - } - block2 { - #the resultant table will have text appear towards top of each box - #with 'legacy' computing unicode block - hopefully these become more widely supported - as they are useful and fill in some gaps - set hlt \u2594 ;# upper one eighth block - set hlb \u2581 ;# lower one eighth block - set vlr \u2595 ;# right one eighth block - set vll \u258f ;# left one eighth block - - #some terminals (on windows as at 2024) miscount width of these single-width blocks internally - #resulting in extra spacing that is sometimes well removed from the character itself (e.g at next ansi reset) - #This was fixed in windows-terminal based systems (2021) but persists in others. - #https://github.com/microsoft/terminal/issues/11694 - set tlc \U1fb7d ;#legacy block - set trc \U1fb7e ;#legacy block - set blc \U1fb7c ;#legacy block - set brc \U1fb7f ;#legacy block - - #horizontal and vertical bar joins - set hltj $hlt - set hlbj $hlb - set vllj $vll - set vlrj $vlr - - } - block2hack { - #the resultant table will have text appear towards top of each box - #with 'legacy' computing unicode block - hopefully these become more widely supported - as they are useful and fill in some gaps - set hlt \u2594 ;# upper one eighth block - set hlb \u2581 ;# lower one eighth block - set vlr \u2595 ;# right one eighth block - set vll \u258f ;# left one eighth block - - #see comments in block2 regarding the problems in some terminals that this *may* hack around to some extent. - #the caller probably only needs block2hack if block2 doesn't work - - #1) - #review - this hack looks sort of promising - but overtype::renderline needs fixing ? - #set tlc \U1fb7d\b ;#legacy block - #set trc \U1fb7e\b ;#legacy block - #set blc \U1fb7c\b ;#legacy block - #set brc \U1fb7f\b ;#legacy block - - #2) - works on cmd.exe and some others - # a 'privacy message' is 'probably' also not supported on the old terminal but is on newer ones - #known exception - conemu on windows - displays junk for various ansi codes - (and slow terminal anyway) - #this hack has a reasonable chance of working - #except that the punk overtype library does recognise PMs - #A single backspace however is an unlikely and generally unuseful PM - so there is a corresponding hack in the renderline system to pass this PM through! - #ugly - in that we don't know the application specifics of what the PM data contains and where it's going. - set tlc \U1fb7d\x1b^\b\x1b\\ ;#legacy block - set trc \U1fb7e\x1b^\b\x1b\\ ;#legacy block - set blc \U1fb7c\x1b^\b\x1b\\ ;#legacy block - set brc \U1fb7f\x1b^\b\x1b\\ ;#legacy block - - #horizontal and vertical bar joins - set hltj $hlt - set hlbj $hlb - set vllj $vll - set vlrj $vlr - } - block { - set hlt \u2580 ;#upper half - set hlb \u2584 ;#lower half - set vll \u258c ;#left half - set vlr \u2590 ;#right half - - set tlc \u259b ;#upper left corner half - set trc \u259c - set blc \u2599 - set brc \u259f - - #horizontal and vertical bar joins - set hltj $hlt - set hlbj $hlb - set vllj $vll - set vlrj $vlr - } - default { - set default_custom [tcl::dict::create hl " " vl " " tlc " " trc " " blc " " brc " "] ;#only default the general types - these form defaults for more specific types if they're missing - if {[llength $f] % 2 != 0} { - #todo - retrieve usage from punk::args - error "textblock::frametype frametype '$f' is not one of the predefined frametypes: $::textblock::frametypes and does not appear to be a dictionary for a custom frametype" - } - #unknown order of keys specified by user - validate before creating vars as we need more general elements to be available as defaults - dict for {k v} $f { - switch -- $k { - hl - vl - tlc - trc - blc - brc - hlt - hlb - vll - vlr - hltj - hlbj - vllj - vlrj {} - default { - error "textblock::frametype '$f' has unknown element '$k'" - } - } - } - #verified keys - safe to extract as vars - set custom_frame [tcl::dict::merge $default_custom $f] - tcl::dict::with custom_frame {} ;#extract keys as vars - #longer j vars must be after their more specific counterparts in the list being processed by foreach - foreach t {hlt hlb vll vlr hltj hlbj vllj vlrj} { - if {[tcl::dict::exists $custom_frame $t]} { - set $t [tcl::dict::get $custom_frame $t] - } else { - #set more explicit type to it's more general counterpart if it's missing - #e.g hlt -> hl - #e.g hltj -> hlt - set $t [set [string range $t 0 end-1]] - } - } - #assert vars hl vl tlc trc blc brc hlt hlb vll vlr hltj hlbj vllj vlrj are all set - #horizontal and vertical bar joins - key/variable ends with 'j' - } - } - if {$boxonly} { - set result [tcl::dict::create\ - tlc $tlc hlt $hlt trc $trc\ - vll $vll vlr $vlr\ - blc $blc hlb $hlb brc $brc\ - ] - tcl::dict::set framedef_cache $cache_key $result - return $result - } else { - set result [tcl::dict::create\ - tlc $tlc hlt $hlt trc $trc\ - vll $vll vlr $vlr\ - blc $blc hlb $hlb brc $brc\ - hltj $hltj\ - hlbj $hlbj\ - vllj $vllj\ - vlrj $vlrj\ - ] - tcl::dict::set framedef_cache $cache_key $result - return $result - } - } - - variable frame_cache - set frame_cache [tcl::dict::create] - proc frame_cache {args} { - set argd [punk::args::get_dict { - -action -default "" -choices {clear} -help "Clear the textblock::frame_cache dictionary" - -pretty -default 1 -help "Use 'pdict textblock::frame_cache */*' for prettier output" - *values -min 0 -max 0 - } $args] - set action [dict get $argd opts -action] - - if {$action ni [list clear ""]} { - error "frame_cache action '$action' not understood. Valid actions: clear" - } - variable frame_cache - if {[dict get $argd opts -pretty]} { - set out [pdict -chan none frame_cache */*] - } else { - set out "" - if {[catch { - set termwidth [tcl::dict::get [punk::console::get_size] columns] - }]} { - set termwidth 80 - } - - tcl::dict::for {k v} $frame_cache { - lassign $v _f frame _used used - set fwidth [textblock::widthtopline $frame] - #review - are cached frames uniform width lines? - #set fwidth [textblock::width $frame] - set frameinfo "$k used:$used " - set allinone_width [expr {[tcl::string::length $frameinfo] + $fwidth}] - if {$allinone_width >= $termwidth} { - #split across 2 lines - append out "$frameinfo\n" - append out $frame \n - } else { - append out [textblock::join -- $frameinfo $frame]\n - } - append out \n ;# frames used to build tables often have joins - keep a line in between for clarity - } - } - if {$action eq "clear"} { - set frame_cache [tcl::dict::create] - append out \nCLEARED - } - return $out - } - - - #options before content argument - which is allowed to be absent - #frame performance (noticeable with complex tables even of modest size) is improved somewhat by frame_cache - but is still (2024) a fairly expensive operation. - # - #consider if we can use -sticky nsew instead of -blockalign (as per Tk grid -sticky option) - # This would require some sort of expand equivalent e.g for -sticky ew or -sticky ns - for which we have to decide a meaning for text.. e.g ansi padding? - #We are framing 'rendered' text - so we don't have access to for example an inner frame or table to tell it to expand - #we could refactor as an object and provide a -return object option, then use stored -sticky data to influence how another object renders into it - # - but we would need to maintain support for the rendered-string based operations too. - proc frame {args} { - variable frametypes - variable use_md5 - - #counterintuitively - in-proc dict create each time is generally slightly faster than linked namespace var - set opts [tcl::dict::create\ - -etabs 0\ - -type light\ - -boxlimits [list hl vl tlc blc trc brc]\ - -boxmap {}\ - -joins [list]\ - -title ""\ - -subtitle ""\ - -width ""\ - -height ""\ - -ansiborder ""\ - -ansibase ""\ - -blockalign "centre"\ - -textalign "left"\ - -ellipsis 1\ - -usecache 1\ - -buildcache 1\ - -pad 1\ - -crm_mode 0\ - ] - #-pad 1 is default so that simple 'textblock::frame "[a+ Red]a \nbbb[a]" extends the bg colour on the short ragged lines (and empty lines) - # for ansi art - -pad 0 is likely to be preferable - - set expect_optval 0 - set argposn 0 - set pmax [expr {[llength $args]-1}] - set has_contents 0 ;#differentiate between empty string and no content supplied - set contents "" - set arglist [list] - foreach a $args { - if {!$expect_optval} { - if {$argposn < $pmax} { - if {[tcl::string::match -* $a]} { - set expect_optval 1 - lappend arglist $a - } else { - error "textblock::frame expects -option pairs" - } - } else { - set has_contents 1 - set contents $a - } - } else { - lappend arglist $a - set expect_optval 0 - } - incr argposn - } - - #set contents [lindex $args end] - #set arglist [lrange $args 0 end-1] - if {[llength $arglist] % 2 != 0} { - error "Usage frame ?-type unicode|altg|ascii|? ?-title ? ?-subtitle ? ?-width ? ?-ansiborder ? ?-boxlimits hl|hlt|hlb|vl|vll|vlr|tlc|blc|brc? ?-joins left|right|up|down? " - } - #todo args -justify left|centre|right (center) - - #todo -blockalignbias -textalignbias? - #use -buildcache 1 with -usecache 0 for debugging cache issues so we can inspect using textblock::frame_cache - foreach {k v} $arglist { - switch -- $k { - -etabs - -type - -boxlimits - -boxmap - -joins - - -title - -subtitle - -width - -height - - -ansiborder - -ansibase - - -blockalign - -textalign - -ellipsis - - -crm_mode - - -usecache - -buildcache - -pad { - tcl::dict::set opts $k $v - } - default { - error "frame option '$k' not understood. Valid options are [tcl::dict::keys $opts]" - } - } - } - # -- --- --- --- --- --- - set opt_etabs [tcl::dict::get $opts -etabs] - set opt_type [tcl::dict::get $opts -type] - set opt_boxlimits [tcl::dict::get $opts -boxlimits] - set opt_joins [tcl::dict::get $opts -joins] - set opt_boxmap [tcl::dict::get $opts -boxmap] - set opt_usecache [tcl::dict::get $opts -usecache] - set opt_buildcache [tcl::dict::get $opts -buildcache] - set opt_pad [tcl::dict::get $opts -pad] - set opt_crm_mode [tcl::dict::get $opts -crm_mode] - set usecache $opt_usecache ;#may need to override - set buildcache $opt_buildcache - set custom_keys [list hl hlt hlb vl vll vlr tlc trc blc brc] - - set known_frametypes $frametypes ;# light, heavey etc as defined in the ::textblock::frametypes variable - set default_custom [tcl::dict::create hl " " vl " " tlc " " trc " " blc " " brc " "] - - lassign [textblock::frametype $opt_type] _cat category _type ftype - if {$category eq "custom"} { - set custom_frame $ftype - set frameset "custom" - set framedef $custom_frame - } else { - #category = predefined - set frameset $ftype ;# light,heavy etc - set framedef $ftype - } - - set is_boxlimits_ok 1 - set exact_boxlimits [list] - foreach v $opt_boxlimits { - switch -- $v { - hl { - lappend exact_boxlimits hlt hlb - } - vl { - lappend exact_boxlimits vll vlr - } - hlt - hlb - vll - vlr - tlc - trc - blc - brc { - lappend exact_boxlimits $v - } - default { - #k not in custom_keys - set is_boxlimits_ok 0 - break - } - } - } - if {!$is_boxlimits_ok} { - error "frame option -boxlimits '$opt_boxlimits' must contain only values from the set: hl,hlt,hlb,vl,vll,vlr,tlc,trc,blc,brc" - } - set exact_boxlimits [lsort -unique $exact_boxlimits] - - set is_joins_ok 1 - foreach v $opt_joins { - lassign [split $v -] direction target - switch -- $direction { - left - right - up - down {} - default { - set is_joins_ok 0 - break - } - } - switch -- $target { - "" - light - heavy - ascii - altg - arc - double - custom - block - block1 - block2 {} - default { - set is_joins_ok 0 - break - } - } - } - if {!$is_joins_ok} { - error "frame option -joins '$opt_joins' must contain only values from the set: left,right,up,down with targets heavy,light,ascii,altg,arc,double,block,block1,custom e.g down-light" - } - set is_boxmap_ok 1 - #safe jumptable test - #dict for {boxelement subst} $opt_boxmap {} - tcl::dict::for {boxelement subst} $opt_boxmap { - switch -- $boxelement { - hl - hlt - hlb - vl - vll - vlr - tlc - trc - blc - brc {} - default { - set is_boxmap_ok 0 - break - } - } - } - if {!$is_boxmap_ok} { - error "frame option -boxmap '$opt_boxmap' must contain only keys from the set: hl,hlt,hlb,vl,vll,vlr,tlc,trc,blc,brc" - } - - #sorted order down left right up - #1 x choose 4 - #4 x choose 3 - #6 x choose 2 - #4 x choose 1 - #15 combos - - set join_directions [list] - #targets - light,heavy (double?) - seem to be some required glyphs missing from unicode - #e.g down-light, up-heavy - set join_targets [tcl::dict::create left "" down "" right "" up ""] - foreach jt $opt_joins { - lassign [split $jt -] direction target - if {$target ne ""} { - tcl::dict::set join_targets $direction $target - } - lappend join_directions $direction - } - set join_directions [lsort -unique $join_directions] - set do_joins [::join $join_directions _] - - - # -- --- --- --- --- --- - set opt_title [tcl::dict::get $opts -title] - set opt_subtitle [tcl::dict::get $opts -subtitle] - set opt_width [tcl::dict::get $opts -width] - set opt_height [tcl::dict::get $opts -height] - # -- --- --- --- --- --- - set opt_blockalign [tcl::dict::get $opts -blockalign] - switch -- $opt_blockalign { - left - right - centre - center {} - default { - error "frame option -blockalign must be left|right|centre|center - received: $opt_blockalign" - } - } - #these are all valid commands for overtype:: - # -- --- --- --- --- --- - set opt_textalign [tcl::dict::get $opts -textalign] - switch -- $opt_textalign { - left - right - centre - center {} - default { - error "frame option -textalign must be left|right|centre|center - received: $opt_textalign" - } - } - # -- --- --- --- --- --- - - set opt_ansiborder [tcl::dict::get $opts -ansiborder] - set opt_ansibase [tcl::dict::get $opts -ansibase] ;#experimental - set opt_ellipsis [tcl::dict::get $opts -ellipsis] - # -- --- --- --- --- --- - - if {$has_contents} { - if {[tcl::string::last \t $contents] >= 0} { - if {[tcl::info::exists punk::console::tabwidth]} { - set tw $::punk::console::tabwidth - } else { - set tw 8 - } - if {$opt_etabs} { - set contents [textutil::tabify::untabify2 $contents $tw] - } - } - set contents [tcl::string::map [list \r\n \n] $contents] - if {$opt_crm_mode} { - if {$opt_height eq ""} { - set h [textblock::height $contents] - } else { - set h [expr {$opt_height -2}] - } - if {$opt_width eq ""} { - set w [textblock::width $contents] - } else { - set w [expr {$opt_width -2}] - } - set contents [overtype::renderspace -crm_mode 1 -wrap 1 -width $w -height $h "" $contents] - } - set actual_contentwidth [textblock::width $contents] ;#length of longest line in contents (contents can be ragged) - set actual_contentheight [textblock::height $contents] - } else { - set actual_contentwidth 0 - set actual_contentheight 0 - } - - if {$opt_title ne ""} { - set titlewidth [punk::ansi::printing_length $opt_title] - set content_or_title_width [expr {max($actual_contentwidth,$titlewidth)}] - } else { - set titlewith 0 - set content_or_title_width $actual_contentwidth - } - - if {$opt_width eq ""} { - set frame_inner_width $content_or_title_width - } else { - set frame_inner_width [expr {max(0,$opt_width - 2)}] ;#default - } - - if {$opt_height eq ""} { - set frame_inner_height $actual_contentheight - } else { - set frame_inner_height [expr {max(0,$opt_height -2)}] ;#default - } - if {$frame_inner_height == 0 && $frame_inner_width == 0} { - set has_contents 0 - } - #todo - render it with vertical overflow so we can process ansi moves? - #set linecount [textblock::height $contents] - set linecount $frame_inner_height - - # -- --- --- --- --- --- --- --- --- - variable frame_cache - #review - custom frame affects frame_inner_width - exclude from caching? - #set cache_key [concat $arglist $frame_inner_width $frame_inner_height] - set hashables [concat $arglist $frame_inner_width $frame_inner_height] - - if {$use_md5} { - #package require md5 ;#already required at package load - if {[package vsatisfies [package present md5] 2- ] } { - set hash [md5::md5 -hex [encoding convertto utf-8 $hashables]] ;#need fast and unique to content - not cryptographic - review - } else { - set hash [md5::md5 [encoding convertto utf-8 $hashables]] - } - } else { - set hash $hashables - } - - set cache_key "$hash-$frame_inner_width-$frame_inner_height-actualcontentwidth:$actual_contentwidth" - #should be in a unicode private range different to that used in table construction - #e.g BMP PUA U+E000 -> U+F8FF - although this is commonly used for example by nerdfonts - #also supplementary private use blocks - #however these display double wide on for example cmd terminal despite having wcswidth 1 (makes layout debugging difficult) - #U+F0000 -> U+FFFD - #U+100000 -> U+10FFFD - #FSUB options: \uf0ff \uF1FF \uf2ff (no nerdfont glyphs - should look like standard replacement char) \uF2DD (circular thingy) - #should be something someone is unlikely to use as part of a custom frame character. - #ideally a glyph that doesn't auto-expand into whitespace and is countable when in a string (narrower is better) - #As nerdfont glyphs tend to be mostly equal height & width - circular glyphs tend to be more distinguishable in a string - #terminal settings may need to be adjusted to stop auto glyph resizing - a rather annoying misfeature that some people seem to think they like. - #e.g in wezterm config: allow_square_glyphs_to_overflow_width = "Never" - #review - we could consider wasting a few cycles to check for a conflict and use a different FSUB - set FSUB \uF2DD - - - #this occurs commonly in table building with colspans - review - if {($actual_contentwidth > $frame_inner_width) || ($actual_contentheight != $frame_inner_height)} { - set usecache 0 - #set buildcache 0 ;#comment out for debug/analysis so we can see - #puts "--->> frame_inner_width:$frame_inner_width actual_contentwidth:$actual_contentwidth contents: '$contents'" - set cache_key [a+ Web-red web-white]$cache_key[a] - } - if {$buildcache && ($actual_contentwidth < $frame_inner_width)} { - #colourise cache_key to warn - if {$actual_contentwidth == 0} { - #we can still substitute with right length - set cache_key [a+ Web-steelblue web-black]$cache_key[a] - } else { - #actual_contentwidth is narrower than frame - check template's patternwidth - if {[tcl::dict::exists $frame_cache $cache_key]} { - set cache_patternwidth [tcl::dict::get $frame_cache $cache_key patternwidth] - } else { - set cache_patternwidth $actual_contentwidth - } - if {$actual_contentwidth < $cache_patternwidth} { - set usecache 0 - set cache_key [a+ Web-orange web-black]$cache_key[a] - } elseif {$actual_contentwidth == $cache_patternwidth} { - #set usecache 1 - } else { - #actual_contentwidth > pattern - set usecache 0 - set cache_key [a+ Web-red web-black]$cache_key[a] - } - } - } - - #JMN debug - #set usecache 0 - - set is_cached 0 - if {$usecache && [tcl::dict::exists $frame_cache $cache_key]} { - set cache_patternwidth [tcl::dict::get $frame_cache $cache_key patternwidth] - set template [tcl::dict::get $frame_cache $cache_key frame] - set used [tcl::dict::get $frame_cache $cache_key used] - tcl::dict::set frame_cache $cache_key used [expr {$used+1}] ;#update existing record - set is_cached 1 - - } - - # -- --- --- --- --- --- --- --- --- - if {!$is_cached} { - set rst [a] - #set column [tcl::string::repeat " " $frame_inner_width] ;#default - may need to override for custom frame - set underlayline [tcl::string::repeat " " $frame_inner_width] - set underlay [::join [lrepeat $linecount $underlayline] \n] - - - set vll_width 1 ;#default for all except custom (printing width) - set vlr_width 1 - - set framedef [textblock::framedef -joins $opt_joins $framedef] - tcl::dict::with framedef {} ;#extract vll,hlt,tlc etc vars - - #puts "---> $opt_boxmap" - #review - we handle double-wide in custom frames - what about for boxmaps? - tcl::dict::for {boxelement sub} $opt_boxmap { - if {$boxelement eq "vl"} { - set vll $sub - set vlr $sub - set hl $sub - } elseif {$boxelement eq "hl"} { - set hlt $sub - set hlb $sub - set hl $sub - } else { - set $boxelement $sub - } - } - - switch -- $frameset { - custom { - #REVIEW - textblock::table assumes that at least the vl elements are 1-wide - #generally supporting wider or taller custom frame elements would make for some interesting graphical possibilities though - #if no ansi, these widths are reasonable to maintain in grapheme_width_cached indefinitely - set vll_width [punk::ansi::printing_length $vll] - set hlb_width [punk::ansi::printing_length $hlb] - set hlt_width [punk::ansi::printing_length $hlt] - - set vlr_width [punk::ansi::printing_length $vlr] - - set tlc_width [punk::ansi::printing_length $tlc] - set trc_width [punk::ansi::printing_length $trc] - set blc_width [punk::ansi::printing_length $blc] - set brc_width [punk::ansi::printing_length $brc] - - - set framewidth [expr {$frame_inner_width + 2}] ;#reverse default assumption - if {$opt_width eq ""} { - #width wasn't specified - so user is expecting frame to adapt to title/contents - #content shouldn't truncate because of extra wide frame - #review - punk::console::get_size ? wrapping? quite hard to support with colspans - set frame_inner_width $content_or_title_width - set tbarwidth [expr {$content_or_title_width + 2 - $tlc_width - $trc_width - 2 + $vll_width + $vlr_width}] ;#+/2's for difference between border element widths and standard element single-width - set bbarwidth [expr {$content_or_title_width + 2 - $blc_width - $brc_width - 2 + $vll_width + $vlr_width}] - } else { - set frame_inner_width [expr $opt_width - $vll_width - $vlr_width] ;#content may be truncated - set tbarwidth [expr {$opt_width - $tlc_width - $trc_width}] - set bbarwidth [expr {$opt_width - $blc_width - $brc_width}] - } - #set column [tcl::string::repeat " " $frame_inner_width] - set underlayline [tcl::string::repeat " " $frame_inner_width] - set underlay [::join [lrepeat $linecount $underlayline] \n] - #cache? - - if {$hlt_width == 1} { - set tbar [tcl::string::repeat $hlt $tbarwidth] - } else { - #possibly mixed width chars that make up hlt - tcl::string::range won't get width right - set blank [tcl::string::repeat " " $tbarwidth] - if {$hlt_width > 0} { - set count [expr {($tbarwidth / $hlt_width) + 1}] - } else { - set count 0 - } - set tbar [tcl::string::repeat $hlt $count] - #set tbar [tcl::string::range $tbar 0 $tbarwidth-1] - set tbar [overtype::left -overflow 0 -exposed1 " " -exposed2 " " $blank $tbar];#spaces for exposed halves of 2w chars instead of default replacement character - } - if {$hlb_width == 1} { - set bbar [tcl::string::repeat $hlb $bbarwidth] - } else { - set blank [tcl::string::repeat " " $bbarwidth] - if {$hlb_width > 0} { - set count [expr {($bbarwidth / $hlb_width) + 1}] - } else { - set count 0 - } - set bbar [tcl::string::repeat $hlb $count] - #set bbar [tcl::string::range $bbar 0 $bbarwidth-1] - set bbar [overtype::left -overflow 0 -exposed1 " " -exposed2 " " $blank $bbar] - } - } - altg { - set tbar [tcl::string::repeat $hlt $frame_inner_width] - set tbar [cd::groptim $tbar] - set bbar [tcl::string::repeat $hlb $frame_inner_width] - set bbar [cd::groptim $bbar] - } - default { - set tbar [tcl::string::repeat $hlt $frame_inner_width] - set bbar [tcl::string::repeat $hlb $frame_inner_width] - - } - } - - set leftborder 0 - set rightborder 0 - set topborder 0 - set bottomborder 0 - # hl - hlt - hlb - vl - vll - vlr - tlc - trc - blc - brc {} - #puts "----->$exact_boxlimits" - foreach lim $exact_boxlimits { - switch -- $lim { - hlt { - set topborder 1 - } - hlb { - set bottomborder 1 - } - vll { - set leftborder 1 - } - vlr { - set rightborder 1 - } - tlc { - set topborder 1 - set leftborder 1 - } - trc { - set topborder 1 - set rightborder 1 - } - blc { - set bottomborder 1 - set leftborder 1 - } - brc { - set bottomborder 1 - set rightborder 1 - } - } - } - if {$opt_width ne "" && $opt_width < 2} { - set rightborder 0 - } - #keep lhs/rhs separate? can we do vertical text on sidebars? - set lhs [tcl::string::repeat $vll\n $linecount] - set lhs [tcl::string::range $lhs 0 end-1] - set rhs [tcl::string::repeat $vlr\n $linecount] - set rhs [tcl::string::range $rhs 0 end-1] - - - if {$opt_ansiborder ne ""} { - set tbar $opt_ansiborder$tbar$rst - set bbar $opt_ansiborder$bbar$rst - set tlc $opt_ansiborder$tlc$rst - set trc $opt_ansiborder$trc$rst - set blc $opt_ansiborder$blc$rst - set brc $opt_ansiborder$brc$rst - - set lhs $opt_ansiborder$lhs$rst ;#wrap the whole block and let textblock::join figure it out - set rhs $opt_ansiborder$rhs$rst - } - - #boxlimits used for partial borders in table generation - set all_exact_boxlimits [list vll vlr hlt hlb tlc blc trc brc] - set unspecified_limits [struct::set difference $all_exact_boxlimits $exact_boxlimits] - foreach lim $unspecified_limits { - switch -- $lim { - vll { - set blank_vll [tcl::string::repeat " " $vll_width] - set lhs [tcl::string::repeat $blank_vll\n $linecount] - set lhs [tcl::string::range $lhs 0 end-1] - } - vlr { - set blank_vlr [tcl::string::repeat " " $vlr_width] - set rhs [tcl::string::repeat $blank_vlr\n $linecount] - set rhs [tcl::string::range $rhs 0 end-1] - } - hlt { - set bar_width [punk::ansi::printing_length $tbar] - set tbar [tcl::string::repeat " " $bar_width] - } - tlc { - set tlc_width [punk::ansi::printing_length $tlc] - set tlc [tcl::string::repeat " " $tlc_width] - } - trc { - set trc_width [punk::ansi::printing_length $trc] - set trc [tcl::string::repeat " " $trc_width] - } - hlb { - set bar_width [punk::ansi::printing_length $bbar] - set bbar [tcl::string::repeat " " $bar_width] - } - blc { - set blc_width [punk::ansi::printing_length $blc] - set blc [tcl::string::repeat " " $blc_width] - } - brc { - set brc_width [punk::ansi::printing_length $brc] - set brc [tcl::string::repeat " " $brc_width] - } - } - } - - if {$opt_title ne ""} { - set topbar [overtype::centre -overflow 0 -exposed1 " " -exposed2 " " -ellipsis 1 -bias left $tbar $opt_title] ;#overtype supports gx0 on/off - } else { - set topbar $tbar - } - if {$opt_subtitle ne ""} { - set bottombar [overtype::centre -overflow 0 -exposed1 " " -exposed2 " " -ellipsis 1 -bias left $bbar $opt_subtitle] ;#overtype supports gx0 on/off - } else { - set bottombar $bbar - } - if {$opt_ansibase eq ""} { - set rstbase [a] - } else { - set rstbase [a]$opt_ansibase - } - - if {$opt_title ne ""} { - #title overrides -boxlimits for topborder - set topborder 1 - } - set fs "" - set fscached "" - set cache_patternwidth 0 - #todo - output nothing except maybe newlines depending on if opt_height 0 and/or opt_width 0? - if {$topborder} { - if {$leftborder && $rightborder} { - append fs $tlc$topbar$trc - } else { - if {$leftborder} { - append fs $tlc$topbar - } elseif {$rightborder} { - append fs $topbar$trc - } else { - append fs $topbar - } - } - } - append fscached $fs - if {$has_contents || $opt_height > 2} { - #if {$topborder && $fs ne "xx"} { - # append fs \n - #} - if {$topborder} { - append fs \n - append fscached \n - } - switch -- $opt_textalign { - right {set pad "left"} - left {set pad "right"} - default {set pad $opt_textalign} - } - #set textaligned_contents [textblock::pad $contents -width $actual_contentwidth -which $pad -within_ansi 1] - #set inner [overtype::block -blockalign $opt_blockalign -ellipsis $opt_ellipsis $opt_ansibase$underlay$rstbase $opt_ansibase$textaligned_contents] - - set cache_contentline [tcl::string::repeat $FSUB $actual_contentwidth] - set cache_patternwidth $actual_contentwidth - set cache_contentpattern [::join [lrepeat $linecount $cache_contentline] \n] - set cache_inner [overtype::block -blockalign $opt_blockalign -ellipsis $opt_ellipsis $opt_ansibase$underlay$rstbase $opt_ansibase$cache_contentpattern] - #after overtype::block - our actual patternwidth may be less - set cache_patternwidth [tcl::string::length [lindex [regexp -inline "\[^$FSUB]*(\[$FSUB]*).*" $cache_inner] 1]] - - if {$leftborder && $rightborder} { - #set bodyparts [list $lhs $inner $rhs] - set cache_bodyparts [list $lhs $cache_inner $rhs] - } else { - if {$leftborder} { - #set bodyparts [list $lhs $inner] - set cache_bodyparts [list $lhs $cache_inner] - } elseif {$rightborder} { - #set bodyparts [list $inner $rhs] - set cache_bodyparts [list $cache_inner $rhs] - } else { - #set bodyparts [list $inner] - set cache_bodyparts [list $cache_inner] - } - } - #set body [textblock::join -- {*}$bodyparts] - set cache_body [textblock::join -- {*}$cache_bodyparts] - append fscached $cache_body - #append fs $body - } - - if {$opt_height eq "" || $opt_height > 1} { - if {$opt_subtitle ne ""} { - #subtitle overrides boxlimits for bottomborder - set bottomborder 1 - } - if {$bottomborder} { - if {($topborder & $fs ne "xx" ) || ($has_contents || $opt_height > 2)} { - #append fs \n - append fscached \n - } - if {$leftborder && $rightborder} { - #append fs $blc$bottombar$brc - append fscached $blc$bottombar$brc - } else { - if {$leftborder} { - #append fs $blc$bottombar - append fscached $blc$bottombar - } elseif {$rightborder} { - #append fs $bottombar$brc - append fscached $bottombar$brc - } else { - #append fs $bottombar - append fscached $bottombar - } - } - } - } - set template $fscached - ;#end !$is_cached - } - - #use the same mechanism to build the final frame - whether from cache or template - if {$actual_contentwidth == 0} { - set fs [tcl::string::map [list $FSUB " "] $template] - } else { - set resultlines [list] - set overwritable [tcl::string::repeat $FSUB $cache_patternwidth] - set contentindex 0 - switch -- $opt_textalign { - left {set pad right} - right {set pad left} - default {set pad $opt_textalign} - } - - #review - if {[tcl::string::is integer -strict $opt_height] && $actual_contentheight < ($opt_height -2)} { - set diff [expr {($opt_height -2) - $actual_contentheight}] - append contents [::join [lrepeat $diff \n] ""] - } - - if {$opt_pad} { - set paddedcontents [textblock::pad $contents -which $pad -within_ansi 1] ;#autowidth to width of content (should match cache_patternwidth) - set paddedwidth [textblock::widthtopline $paddedcontents] - #review - horizontal truncation - if {$paddedwidth > $cache_patternwidth} { - set paddedcontents [overtype::renderspace -width $cache_patternwidth "" $paddedcontents] - } - #important to supply end of opts -- to textblock::join - particularly here with arbitrary data - set contentblock [textblock::join -- $paddedcontents] ;#make sure each line has ansi replays - } else { - set cwidth [textblock::width $contents] - if {$cwidth > $cache_patternwidth} { - set contents [overtype::renderspace -width $cache_patternwidth "" $contents] - } - set contentblock [textblock::join -- $contents] - } - - set tlines [split $template \n] - - #we will need to strip off the leading reset on each line when stitching together with template lines so that ansibase can come into play too. - #after textblock::join the reset will be a separate code ie should be exactly ESC[0m - set R [a] - set rlen [tcl::string::length $R] - set clines [split $contentblock \n] - - foreach tline $tlines { - if {[tcl::string::first $FSUB $tline] >= 0} { - set content_line [lindex $clines $contentindex] - if {[tcl::string::first $R $content_line] == 0} { - set content_line [tcl::string::range $content_line $rlen end] - } - #make sure to replay opt_ansibase to the right of the replacement - lappend resultlines [tcl::string::map [list $overwritable $content_line$opt_ansibase] $tline] - incr contentindex - } else { - lappend resultlines $tline - } - } - set fs [::join $resultlines \n] - } - - - if {$is_cached} { - return $fs - } else { - if {$buildcache} { - tcl::dict::set frame_cache $cache_key [list frame $template used 0 patternwidth $cache_patternwidth] - } - return $fs - } - } - proc gcross {args} { - set argd [punk::args::get_dict { - -max_cross_size -default 0 -type integer -help "Largest size cross to use to make up the block - Only cross sizes that divide the size of the overall block will be used. - e.g if the 'size' chosen is 19 (a prime number) - only 1 or the full size of 19 can be used as the crosses to make up the block. - Whereas for a block size of 24, -max_cross_size of 1,2,3,4,6,8,12 or 24 will work. (all divisors) - If a number chosen for -max_cross_size isn't a divisor, the largest divisor below the chosen value will be used. - " - *values -min 1 - size -default 1 -type integer - } $args] - set size [dict get $argd values size] - set opts [dict get $argd opts] - - if {$size == 0} { - return "" - } - - set opt_max_cross_size [tcl::dict::get $opts -max_cross_size] - - #set fit_size [punk::lib::greatestOddFactor $size] - set fit_size $size - if {$opt_max_cross_size == 0} { - set max_cross_size $fit_size - } else { - #todo - only allow divisors - #set testsize [expr {min($fit_size,$opt_max_cross_size)}] - - set factors [punk::lib::factors $size] - #pick odd size in list that is smaller or equal to test_size - set max_cross_size [lindex $factors end] - set last_ok [lindex $factors 0] - for {set i 0} {$i < [llength $factors]} {incr i} { - set s [lindex $factors $i] - if {$s > $opt_max_cross_size} { - break - } - set last_ok $s - } - set max_cross_size $last_ok - } - set crosscount [expr {$size / $max_cross_size}] - - package require punk::char - set x [punk::char::charshort boxd_ldc] - set bs [punk::char::charshort boxd_ldgullr] - set fs [punk::char::charshort boxd_ldgurll] - - set onecross "" - set crossrows [list] - set armsize [expr {int(floor($max_cross_size /2))}] - set row [lrepeat $max_cross_size " "] - #toparm - for {set i 0} {$i < $armsize} {incr i} { - set r $row - lset r $i $bs - lset r end-$i $fs - #append onecross [::join $r ""] \n - lappend crossrows [::join $r ""] - } - - if {$max_cross_size % 2 != 0} { - #only put centre cross in for odd sized crosses - set r $row - lset r $armsize $x - #append onecross [::join $r ""] \n - lappend crossrows [::join $r ""] - } - - for {set i [expr {$armsize -1}]} {$i >= 0} {incr i -1} { - set r $row - lset r $i $fs - lset r end-$i $bs - #append onecross [::join $r ""] \n - lappend crossrows [::join $r ""] - } - #set onecross [tcl::string::trimright $onecross \n] - set onecross [::join $crossrows \n] - - #fastest to do row first then columns - because textblock::join must do line by line - - if {$crosscount > 1} { - set row [textblock::join -- {*}[lrepeat $crosscount $onecross]] - set rows [lrepeat $crosscount $row] - set out [::join $rows \n] - } else { - set out $onecross - } - - return $out - } - - #Test we can join two coloured blocks - proc test_colour {} { - set b1 [a red]1\n2\n3[a] - set b2 [a green]a\nb\nc[a] - set result [textblock::join -- $b1 $b2] - puts $result - #return [list $b1 $b2 $result] - return [ansistring VIEW $result] - } - tcl::namespace::import ::punk::ansi::ansistrip -} - - -tcl::namespace::eval ::textblock::piper { - tcl::namespace::export * - proc join {rhs pipelinedata} { - tailcall ::textblock::join -- $pipelinedata $rhs - } -} -interp alias {} piper_blockjoin {} ::textblock::piper::join - - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready -package provide textblock [tcl::namespace::eval textblock { - variable version - set version 0.1.1 -}] -return - -#*** !doctools -#[manpage_end] - diff --git a/src/vfs/_vfscommon.vfs/modules/textblock-0.1.2.tm b/src/vfs/_vfscommon.vfs/modules/textblock-0.1.2.tm deleted file mode 100644 index a3d5b967..00000000 --- a/src/vfs/_vfscommon.vfs/modules/textblock-0.1.2.tm +++ /dev/null @@ -1,8520 +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) 2023 -# -# @@ Meta Begin -# Application textblock 0.1.2 -# Meta platform tcl -# Meta license -# @@ Meta End - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# doctools header -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -#*** !doctools -#[manpage_begin punkshell_module_textblock 0 0.1.2] -#[copyright "2024"] -#[titledesc {punk textblock functions}] [comment {-- Name section and table of contents description --}] -#[moddesc {punk textblock}] [comment {-- Description at end of page heading --}] -#[require textblock] -#[keywords module ansi text layout colour table frame console terminal] -#[description] -#[para] Ansi-aware terminal textblock manipulation - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - -#*** !doctools -#[section Overview] -#[para] overview of textblock -#[subsection Concepts] -#[para] - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Requirements -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - -#*** !doctools -#[subsection dependencies] -#[para] packages used by textblock -#[list_begin itemized] - -#*** !doctools -#[item] [package {Tcl 8.6-}] -#[item] [package {punk::args}] -#[item] [package {punk::char}] -#[item] [package {punk::ansi}] -#[item] [package {punk::lib}] -#[item] [package {overtype}] -#[item] [package {term::ansi::code::macros}] -#[item] [package {textutil}] - -## Requirements -package require Tcl 8.6- -package require punk::args -package require punk::char -package require punk::ansi -package require punk::lib -catch {package require patternpunk} -package require overtype - -#safebase interps as at 2024-08 can't access deeper paths - even though they are below the supposed safe list. -if {[catch { - package require term::ansi::code::macros ;#required for frame if old ansi g0 used - review - make package optional? -} errM]} { - #catch this too in case stderr not available - catch { - puts stderr "textblock package failed to load term::ansi::code::macros with error: $errM" - } -} -package require textutil - - -#*** !doctools -#[list_end] - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - -#*** !doctools -#[section API] - - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - -tcl::namespace::eval textblock { - #review - what about ansi off in punk::console? - tcl::namespace::import ::punk::ansi::a ::punk::ansi::a+ - tcl::namespace::export block frame frame_cache framedef frametypes gcross height width widthtopline join join_basic list_as_table pad testblock - - #NOTE sha1, although computationally more intensive, tends to be faster than md5 on modern cpus - #(more likely to be optimised for modern cpu features?) - #(This speed improvement may not apply for short strings) - - variable use_hash ;#framecache - set use_hash none ;#slightly faster but uglier layout for viewing frame_cache display - #if {![catch {package require sha1}]} { - # set use_hash sha1 - #} elseif {![catch {package require md5}]} { - # set use_hash md5 - #} else { - # set use_hash none - #} - - proc use_hash {args} { - set choices [list none] - set unavailable [list] - set pkgs [package names] - if {"md5" in $pkgs} { - lappend choices md5 - } else { - lappend unavailable md5 - } - if {"sha1" in $pkgs} { - lappend choices sha1 - } else { - lappend unavailable sha1 - } - set choicemsg "" - if {[llength $unavailable]} { - set choicemsg " (unavailable packages: $unavailable)" - } - set argd [punk::args::get_dict [tstr -return string { - @id -id ::textblock::use_hash - @cmd -name "textblock::use_hash" -help\ - "Hashing algorithm to use for framecache lookup. - 'none' may be slightly faster but less compact - when viewing textblock::framecache" - @values -min 0 -max 1 - hash_algorithm -choices {${$choices}} -optional 1 -help\ - "algorithm choice ${$choicemsg}" - }] $args] - variable use_hash - if {![dict exists $argd received hash_algorithm]} { - return $use_hash - } - set use_hash [dict get $argd values hash_algorithm] - } - tcl::namespace::eval class { - variable opts_table_defaults - set opts_table_defaults [tcl::dict::create\ - -title ""\ - -titlealign "left"\ - -titletransparent 0\ - -frametype "light"\ - -frametype_header ""\ - -ansibase_header ""\ - -ansibase_body ""\ - -ansibase_footer ""\ - -ansiborder_header ""\ - -ansiborder_body ""\ - -ansiborder_footer ""\ - -ansireset "\uFFeF"\ - -framelimits_header "vll vlr hlb hlt tlc trc blc brc"\ - -frametype_body ""\ - -framelimits_body "vll vlr hlb hlt tlc trc blc brc"\ - -framemap_body [list\ - topleft {} topinner {} topright {} topsolo {}\ - middleleft {} middleinner {} middleright {} middlesolo {}\ - bottomleft {} bottominner {} bottomright {} bottomsolo {}\ - onlyleft {} onlyinner {} onlyright {} onlysolo {}\ - ]\ - -framemap_header [list\ - topleft {} topinner {} topright {} topsolo {}\ - middleleft {} middleinner {} middleright {} middlesolo {}\ - bottomleft {} bottominner {} bottomright {} bottomsolo {}\ - onlyleft {} onlyinner {} onlyright {} onlysolo {}\ - ]\ - -show_edge 1\ - -show_seps 1\ - -show_hseps ""\ - -show_vseps ""\ - -show_header ""\ - -show_footer ""\ - -minwidth ""\ - -maxwidth ""\ - ] - variable opts_column_defaults - set opts_column_defaults [tcl::dict::create\ - -headers [list]\ - -header_colspans [list]\ - -footers [list]\ - -defaultvalue ""\ - -ansibase ""\ - -ansireset "\uFFEF"\ - -minwidth ""\ - -maxwidth ""\ - -blockalign centre\ - -textalign left\ - ] - #initialise -ansireset with replacement char so we can keep in appropriate dict position for initial configure and then treat as read-only - - - - #for 'L' shaped table building pattern (tables bigger than 4x4 will be mostly 'L' patterns) - #ie only vll,blc,hlb used for cells except top row and right column - #top right cell uses all 'O' shape, other top cells use 'C' shape (hlt,tlc,vll,blc,hlb) - #right cells use 'U' shape (vll,blc,hlb,brc,vlr) - #e.g for 4x4 - # C C C O - # L L L U - # L L L U - #anti-clockwise elements - set C [list hlt tlc vll blc hlb] - set O [list trc hlt tlc vll blc hlb brc vlr] - set L [list vll blc hlb] - set U [list vll blc hlb brc vlr] - set tops [list trc hlt tlc] - set lefts [list tlc vll blc] - set bottoms [list blc hlb brc] - set rights [list trc brc vlr] - - variable table_edge_parts - set table_edge_parts [tcl::dict::create\ - topleft [struct::set intersect $C [concat $tops $lefts]]\ - topinner [struct::set intersect $C $tops]\ - topright [struct::set intersect $O [concat $tops $rights]]\ - topsolo [struct::set intersect $O [concat $tops $lefts $rights]]\ - middleleft [struct::set intersect $L $lefts]\ - middleinner [list]\ - middleright [struct::set intersect $U $rights]\ - middlesolo [struct::set intersect $U [concat $lefts $rights]]\ - bottomleft [struct::set intersect $L [concat $lefts $bottoms]]\ - bottominner [struct::set intersect $L $bottoms]\ - bottomright [struct::set intersect $U [concat $bottoms $rights]]\ - bottomsolo [struct::set intersect $U [concat $lefts $bottoms $rights]]\ - onlyleft [struct::set intersect $C [concat $tops $lefts $bottoms]]\ - onlyinner [struct::set intersect $C [concat $tops $bottoms]]\ - onlyright [struct::set intersect $O [concat $tops $bottoms $rights]]\ - onlysolo [struct::set intersect $O [concat $tops $lefts $bottoms $rights]]\ - ] - - #for header rows - we don't consider the bottom border as part of the edge - even if table body has no rows - #The usual-case of a single header line is the 'onlyleft,onlyinner,onlyright,onlysolo' set. - variable header_edge_parts - set header_edge_parts [tcl::dict::create\ - topleft [struct::set intersect $C [list {*}$tops {*}$lefts]]\ - topinner [struct::set intersect $C $tops]\ - topright [struct::set intersect $O [list {*}$tops {*}$rights]]\ - topsolo [struct::set intersect $O [list {*}$tops {*}$lefts {*}$rights]]\ - middleleft [struct::set intersect $L $lefts]\ - middleinner [list]\ - middleright [struct::set intersect $U $rights]\ - middlesolo [struct::set intersect $U [list {*}$lefts {*}$rights]]\ - bottomleft [struct::set intersect $L $lefts]\ - bottominner [list]\ - bottomright [struct::set intersect $U $rights]\ - bottomsolo [struct::set intersect $U [list {*}$lefts {*}$rights]]\ - onlyleft [struct::set intersect $C [list {*}$tops {*}$lefts]]\ - onlyinner [struct::set intersect $C $tops]\ - onlyright [struct::set intersect $O [list {*}$tops {*}$rights]]\ - onlysolo [struct::set intersect $O [list {*}$tops {*}$lefts {*}$rights]]\ - ] - variable table_hseps - set table_hseps [tcl::dict::create\ - topleft [list blc hlb]\ - topinner [list blc hlb]\ - topright [list blc hlb brc]\ - topsolo [list blc hlb brc]\ - middleleft [list blc hlb]\ - middleinner [list blc hlb]\ - middleright [list blc hlb brc]\ - middlesolo [list blc hlb brc]\ - bottomleft [list]\ - bottominner [list]\ - bottomright [list]\ - bottomsolo [list]\ - onlyleft [list]\ - onlyinner [list]\ - onlyright [list]\ - onlysolo [list]\ - ] - variable table_vseps - set table_vseps [tcl::dict::create\ - topleft [list]\ - topinner [list vll tlc blc]\ - topright [list vll tlc blc]\ - topsolo [list]\ - middleleft [list]\ - middleinner [list vll tlc blc]\ - middleright [list vll tlc blc]\ - middlesolo [list]\ - bottomleft [list]\ - bottominner [list vll tlc blc]\ - bottomright [list vll tlc blc]\ - bottomsolo [list]\ - onlyleft [list]\ - onlyinner [list vll tlc blc]\ - onlyright [list vll tlc blc]\ - onlysolo [list]\ - ] - - #ensembles seem to be not compiled in safe interp - #https://core.tcl-lang.org/tcl/tktview/1095bf7f75 - #as we want textblock to be usable in safe interps - use tcl::dict::for as a partial workaround - #This at least means the script argument, especially switch statements can get compiled. - #It does however affect all ensemble commands - so even 'dict get/set' etc won't be as efficient in a safe interp. - - #e.g $t configure -framemap_body [table_edge_map " "] - - # -- --- --- --- --- - #unused? - proc table_edge_map {char} { - variable table_edge_parts - set map [list] - tcl::dict::for {celltype parts} $table_edge_parts { - set tmap [list] - foreach p $parts { - tcl::dict::set tmap $p $char - } - tcl::dict::set map $celltype $tmap - } - return $map - } - proc table_sep_map {char} { - variable table_hseps - set map [list] - tcl::dict::for {celltype parts} $table_hseps { - set tmap [list] - foreach p $parts { - tcl::dict::set tmap $p $char - } - tcl::dict::set map $celltype $tmap - } - return $map - } - proc header_edge_map {char} { - variable header_edge_parts - set map [list] - tcl::dict::for {celltype parts} $header_edge_parts { - set tmap [list] - foreach p $parts { - tcl::dict::set tmap $p $char - } - tcl::dict::set map $celltype $tmap - } - return $map - } - # -- --- --- --- --- - - if {[tcl::info::commands [tcl::namespace::current]::table] eq ""} { - #*** !doctools - #[subsection {Namespace textblock::class}] - #[para] class definitions - #[list_begin itemized] [comment {- textblock::class groupings -}] - # [item] - # [para] [emph {handler_classes}] - # [list_begin enumerated] - - #this makes new table objects a little faster when multiple opts specified as well as to configure - #as tables are a heavyweight thing, but handy to nest sometimes - we'll take what we can get - set topt_keys [tcl::dict::keys $::textblock::class::opts_table_defaults] - set switch_keys_valid_topts [punk::lib::lmapflat v $topt_keys {list $v -}] - set switch_keys_valid_topts [lrange $switch_keys_valid_topts 0 end-1] ;#remove last dash - - set copt_keys [tcl::dict::keys $::textblock::class::opts_column_defaults] - set switch_keys_valid_copts [punk::lib::lmapflat v $copt_keys {list $v -}] - set switch_keys_valid_copts [lrange $switch_keys_valid_copts 0 end-1] - - oo::class create [tcl::namespace::current]::table [tcl::string::map [list %topt_keys% $topt_keys %topt_switchkeys% $switch_keys_valid_topts %copt_keys% $copt_keys %copt_switchkeys% $switch_keys_valid_copts] { - - #*** !doctools - #[enum] CLASS [class textblock::class::table] - #[list_begin definitions] - #[para] Create a table suitable for terminal output with various border styles. - #[para] The table can contain multiline cells and ANSI colour and text style attributes. - #[para] Multiple header rows can be configured. - #[para] Header rows can span columns - data rows cannot. - #[para] The restriction on data rows is to maintain compatibility of the data with a Tcl matrix command - #[para] (see get_matrix command) - #[para] Both header and data cells can have various text and blockalignments configured. - # [para] [emph METHODS] - variable o_opts_table ;#options as configured by user (with exception of -ansireset) - variable o_opts_table_effective; #options in effect - e.g with defaults merged in. - - variable o_columndefs - variable o_columndata - variable o_columnstates - variable o_headerdefs - variable o_headerstates - - variable o_rowdefs - variable o_rowstates - - variable o_opts_table_defaults - variable o_opts_header_defaults ;# header data mostly stored in o_columndefs - variable o_opts_column_defaults - variable o_opts_row_defaults - variable TSUB ;#make configurable so user isn't stopped from using our default PUA-unicode char in content (nerdfonts overlap) - variable o_calculated_column_widths - variable o_column_width_algorithm - - - constructor {args} { - #*** !doctools - #[call class::table [method constructor] [arg args]] - #[para] TODO - document the many options - - set o_opts_table_defaults $::textblock::class::opts_table_defaults - set o_opts_column_defaults $::textblock::class::opts_column_defaults - - - if {[llength $args] == 1} { - set args [list -title [lindex $args 0]] - } - if {[llength $args] %2 !=0} { - error "[tcl::namespace::current]::table constructor - unexpected argument count. Require single value being title, or name value pairs" - } - - set o_opts_table $o_opts_table_defaults - set o_opts_table_effective $o_opts_table_defaults - - ##todo - test with punk::lib::show_jump_tables - how? - foreach {k v} $args { - switch -- $k { - %topt_switchkeys% { - tcl::dict::set o_opts_table $k $v - } - default { - error "[tcl::namespace::current]::table unrecognised option '$k'. Known values [tcl::dict::keys $o_opts_table_defaults]" - } - } - } - - #foreach {k v} $args { - # #todo - convert to literal switch using tcl::string::map so we don't have to define o_opts_table_defaults here. - # if {$k ni [tcl::dict::keys $o_opts_table_defaults]} { - # error "[tcl::namespace::current]::table unrecognised option '$k'. Known values [tcl::dict::keys $o_opts_table_defaults]" - # } - #} - #set o_opts_table [tcl::dict::merge $o_opts_table_defaults $args] - #my configure {*}[tcl::dict::merge $o_opts_table_defaults $args] - - set o_columndefs [tcl::dict::create] - set o_columndata [tcl::dict::create] ;#we store data by column even though it is often added row by row - set o_columnstates [tcl::dict::create] ;#store the maxwidthbodyseen etc as we add rows and maxwidthheaderseen etc as we add headers - it is needed often and expensive to calculate repeatedly - set o_headerdefs [tcl::dict::create] ;#by header-row - set o_headerstates [tcl::dict::create] - set o_rowdefs [tcl::dict::create] ;#user requested row data e.g -minheight -maxheight - set o_rowstates [tcl::dict::create] ;#actual row data such as -minheight and -maxheight detected from supplied row data - - set TSUB \uF111 ;#should be BMP PUA code to show as either replacement char or nerdfont glyph. See FSUB for comments regarding choices. - set o_calculated_column_widths [list] - set o_column_width_algorithm "span" - set o_opts_header_defaults [tcl::dict::create\ - -colspans {}\ - -values {}\ - -ansibase {}\ - -ansireset "\x1b\[m"\ - -minheight 1\ - -maxheight ""\ - ] - my configure {*}$o_opts_table - } - - method width_algorithm {{alg ""}} { - if {$alg eq ""} { - return $o_column_width_algorithm - } - if {$alg ne $o_column_width_algorithm} { - #invalidate cached widths - set o_calculated_column_widths [list] - } - set o_column_width_algorithm $alg - } - method Get_seps {} { - set requested_seps [tcl::dict::get $o_opts_table -show_seps] - set requested_seps_h [tcl::dict::get $o_opts_table -show_hseps] - set requested_seps_v [tcl::dict::get $o_opts_table -show_vseps] - set seps $requested_seps - set seps_h $requested_seps_h - set seps_v $requested_seps_v - if {$requested_seps eq ""} { - if {$requested_seps_h eq ""} { - set seps_h 1 - } - if {$requested_seps_v eq ""} { - set seps_v 1 - } - } else { - if {$requested_seps_h eq ""} { - set seps_h $seps - } - if {$requested_seps_v eq ""} { - set seps_v $seps - } - } - return [tcl::dict::create horizontal $seps_h vertical $seps_v] - } - method Get_frametypes {} { - set requested_ft [tcl::dict::get $o_opts_table -frametype] - set requested_ft_header [tcl::dict::get $o_opts_table -frametype_header] - set requested_ft_body [tcl::dict::get $o_opts_table -frametype_body] - set ft $requested_ft - set ft_header $requested_ft_header - set ft_body $requested_ft_body - switch -- $requested_ft { - light { - if {$requested_ft_header eq ""} { - set ft_header heavy - } - if {$requested_ft_body eq ""} { - set ft_body light - } - } - light_b { - if {$requested_ft_header eq ""} { - set ft_header heavy_b - } - if {$requested_ft_body eq ""} { - set ft_body light_b - } - } - light_c { - if {$requested_ft_header eq ""} { - set ft_header heavy_c - } - if {$requested_ft_body eq ""} { - set ft_body light_c - } - } - default { - if {$requested_ft_header eq ""} { - set ft_header $requested_ft - } - if {$requested_ft_body eq ""} { - set ft_body $requested_ft - } - } - } - return [tcl::dict::create header $ft_header body $ft_body] - } - method Set_effective_framelimits {} { - upvar ::textblock::class::opts_table_defaults tdefaults - set default_blims [tcl::dict::get $tdefaults -framelimits_body] - set default_hlims [tcl::dict::get $tdefaults -framelimits_header] - set eff_blims [tcl::dict::get $o_opts_table_effective -framelimits_body] - set eff_hlims [tcl::dict::get $o_opts_table_effective -framelimits_header] - - set requested_blims [tcl::dict::get $o_opts_table -framelimits_body] - set requested_hlims [tcl::dict::get $o_opts_table -framelimits_header] - set blims $eff_blims - set hlims $eff_hlims - switch -- $requested_blims { - "default" { - set blims $default_blims - } - default { - #set blims $requested_blims - set blims [list] - foreach lim $requested_blims { - switch -- $lim { - hl { - lappend blims hlt hlb - } - vl { - lappend blims vll vlr - } - default { - lappend blims $lim - } - } - } - set blims [lsort -unique $blims] - } - } - tcl::dict::set o_opts_table_effective -framelimits_body $blims - switch -- $requested_hlims { - "default" { - set hlims $default_hlims - } - default { - #set hlims $requested_hlims - set hlims [list] - foreach lim $requested_hlims { - switch -- $lim { - hl { - lappend hlims hlt hlb - } - vl { - lappend hlims vll vlr - } - default { - lappend hlims $lim - } - } - } - set hlims [lsort -unique $hlims] - } - } - tcl::dict::set o_opts_table_effective -framelimits_header $hlims - return [tcl::dict::create body $blims header $hlims] - } - method configure {args} { - #*** !doctools - #[call class::table [method configure] [arg args]] - #[para] get or set various table-level properties - - if {![llength $args]} { - return $o_opts_table - } - if {[llength $args] == 1} { - if {[lindex $args 0] in [list %topt_keys%]} { - #query single option - set k [lindex $args 0] - set val [tcl::dict::get $o_opts_table $k] - set returndict [tcl::dict::create option $k value $val ansireset "\x1b\[m"] - set infodict [tcl::dict::create] - switch -- $k { - -ansibase_header - -ansibase_body - -ansiborder_header - -ansiborder_body - -ansiborder_footer { - tcl::dict::set infodict debug [ansistring VIEW $val] - } - -framemap_body - -framemap_header - -framelimits_body - -framelimits_header { - tcl::dict::set returndict effective [tcl::dict::get $o_opts_table_effective $k] - } - } - tcl::dict::set returndict info $infodict - return $returndict - #return [tcl::dict::create option $k value $val ansireset "\x1b\[m" info $infodict] - } else { - error "textblock::table configure - unrecognised option '[lindex $args 0]'. Known values [tcl::dict::keys $o_opts_table_defaults]" - } - } - if {[llength $args] %2 != 0} { - error "[tcl::namespace::current]::table configure - unexpected argument count. Require name value pairs" - } - foreach {k v} $args { - switch -- $k { - %topt_switchkeys% {} - default { - error "[tcl::namespace::current]::table configure - unrecognised option '$k'. Known values [tcl::dict::keys $o_opts_table_defaults]" - } - } - #if {$k ni [tcl::dict::keys $o_opts_table_defaults]} { - # error "[tcl::namespace::current]::table configure - unrecognised option '$k'. Known values [tcl::dict::keys $o_opts_table_defaults]" - #} - } - set checked_opts [list] - foreach {k v} $args { - switch -- $k { - -ansibase_header - -ansibase_body - -ansiborder_header - -ansiborder-body - -ansiborder_footer { - set parts [punk::ansi::ta::split_codes_single $v] ;#caller may have supplied separated codes eg "[a+ Yellow][a+ red]" - set ansi_codes [list] ; - foreach {pt code} $parts { - if {$pt ne ""} { - #we don't expect plaintext in an ansibase - error "Unable to interpret $k value as ansi SGR codes. Plaintext detected. Consider using for example: '\[punk::ansi::a+ green]' (or alias '\[a+ green]') to build ansi. debug view: [punk::ansi::ansistring VIEW $v]" - } - if {$code ne ""} { - lappend ansi_codes $code - } - } - set ansival [punk::ansi::codetype::sgr_merge_singles $ansi_codes] - lappend checked_opts $k $ansival - } - -frametype - -frametype_header - -frametype_body { - #frametype will raise an error if v is not a valid custom dict or one of the known predefined types such as light,heavy,double etc - lassign [textblock::frametype $v] _cat category _type ftype - lappend checked_opts $k $v - } - -framemap_body - -framemap_header { - #upvar ::textblock::class::opts_table_defaults tdefaults - #set default_bmap [tcl::dict::get $tdefaults -framemap_body] - #todo - check keys and map - if {[llength $v] == 1} { - if {$v eq "default"} { - upvar ::textblock::class::opts_table_defaults tdefaults - set default_map [tcl::dict::get $tdefaults $k] - lappend checked_opts $k $default_map - } else { - error "textblock::table::configure invalid $k value $v. Expected the value 'default' or a dict e.g topleft {hl *}" - } - } else { - #safe jumptable test - #dict for {subk subv} $v {} - foreach {subk subv} $v { - switch -- $subk { - topleft - topinner - topright - topsolo - middleleft - middleinner - middleright - middlesolo - bottomleft - bottominner - bottomright - bottomsolo - onlyleft - onlyinner - onlyright - onlysolo {} - default { - error "textblock::table::configure invalid $subk. Known values {topleft topinner topright topsolo middleleft middleinner middleright middlesolo bottomleft bottominner bottomright bottomsolo onlyleft onlyinner onlyright onlysolo}" - } - } - #safe jumptable test - #dict for {seg subst} $subv {} - foreach {seg subst} $subv { - switch -- $seg { - hl - hlt - hlb - vl - vll - vlr - trc - tlc - blc - brc {} - default { - error "textblock::table::configure invalid $subk value $seg. Known values {hl hlt hlb vl vll vlr trc tlc blc brc}" - } - } - } - - } - lappend checked_opts $k $v - } - - } - -framelimits_body - -framelimits_header { - set specific_framelimits [list] - foreach fl $v { - switch -- $fl { - "default" { - lappend specific_framelimits trc hlt tlc vll blc hlb brc vlr - } - hl { - lappend specific_framelimits hlt hlb - } - vl { - lappend specific_framelimits vll vlr - } - hlt - hlb - vll - vlr - trc - tlc - blc - brc { - lappend specific_framelimits $fl - } - default { - error "textblock::table::configure invalid $k '$fl'. Known values {hl hlb hlt vl vll vlr trc tlc blc brc} (or default for all)" - } - } - } - lappend checked_opts $k $specific_framelimits - } - -ansireset { - if {$v eq "\uFFEF"} { - set RST "\x1b\[m" ;#[a] - lappend checked_opts $k $RST - } else { - error "textblock::table::configure -ansireset is read-only. It is present only to prevent unwanted colourised output in configure commands" - } - } - -show_hseps { - if {![tcl::string::is boolean $v]} { - error "textblock::table::configure invalid $k '$v'. Must be a boolean or empty string" - } - lappend checked_opts $k $v - #these don't affect column width calculations - } - -show_edge { - if {![tcl::string::is boolean $v]} { - error "textblock::table::configure invalid $k '$v'. Must be a boolean or empty string" - } - lappend checked_opts $k $v - #these don't affect column width calculations - except if table -minwidth/-maxwidth come into play - set o_calculated_column_widths [list] ;#invalidate cached column widths - a recalc will be forced when needed - } - -show_vseps { - #we allow empty string - so don't use -strict boolean check - if {![tcl::string::is boolean $v]} { - error "textblock::table::configure invalid $k '$v'. Must be a boolean or empty string" - } - #affects width calculations - set o_calculated_column_widths [list] - lappend checked_opts $k $v - } - -minwidth - -maxwidth { - set o_calculated_column_widths [list] - lappend checked_opts $k $v - } - default { - lappend checked_opts $k $v - } - } - } - #all options checked - ok to update o_opts_table and o_opts_table_effective - - #set o_opts_table [tcl::dict::merge $o_opts_table $checked_opts] - foreach {k v} $args { - switch -- $k { - -framemap_header - -framemap_body { - #framemaps don't require setting every key to update. - #e.g configure -framemaps {topleft } - #needs to merge with existing unspecified keys such as topright middleleft etc. - if {$v eq "default"} { - tcl::dict::set o_opts_table $k default - } else { - if {[tcl::dict::get $o_opts_table $k] eq "default"} { - tcl::dict::set o_opts_table $k $v - } else { - tcl::dict::set o_opts_table $k [tcl::dict::merge [tcl::dict::get $o_opts_table $k] $v] - } - } - } - -title { - set twidth [punk::ansi::printing_length $v] - if {[my width] < [expr {$twidth+2}]} { - set o_calculated_column_widths [list] - tcl::dict::set o_opts_table -minwidth [expr {$twidth+2}] - } - tcl::dict::set o_opts_table -title $v - } - default { - tcl::dict::set o_opts_table $k $v - } - } - } - #use values from checked_opts for the effective opts - #safe jumptable test - #dict for {k v} $checked_opts {} - #foreach {k v} $checked_opts {} - tcl::dict::for {k v} $checked_opts { - switch -- $k { - -framemap_body - -framemap_header { - set existing [tcl::dict::get $o_opts_table_effective $k] - #set updated $existing - #dict for {subk subv} $v { - # tcl::dict::set updated $subk $subv - #} - #tcl::dict::set o_opts_table_effective $k $updated - tcl::dict::set o_opts_table_effective $k [tcl::dict::merge $existing $v] - } - -framelimits_body - -framelimits_header { - #my Set_effective_framelimits - tcl::dict::set o_opts_table_effective $k $v - } - default { - tcl::dict::set o_opts_table_effective $k $v - } - } - } - #ansireset exception - tcl::dict::set o_opts_table -ansireset [tcl::dict::get $o_opts_table_effective -ansireset] - return $o_opts_table - } - - #integrate with struct::matrix - allows ::m format 2string $table - method printmatrix {matrix} { - #*** !doctools - #[call class::table [method printmatrix] [arg matrix]] - #[para] clear all table rows and print a matrix into the table - #[para] The rowxcolumn structure must match - - set matrix_rowcount [$matrix rows] - set matrix_colcount [$matrix columns] - set table_colcount [my column_count] - if {$table_colcount == 0} { - for {set c 0} {$c < $matrix_colcount} {incr c} { - my add_column -headers "" - } - } - set table_colcount [my column_count] - if {$table_colcount != $matrix_colcount} { - error "textblock::table::printmatrix column count of table doesn't match column count of matrix" - } - if {[my row_count] > 0} { - my row_clear - } - for {set r 0} {$r < $matrix_rowcount} {incr r} { - my add_row [$matrix get row $r] - } - my print - } - method as_matrix {{cmd ""}} { - #*** !doctools - #[call class::table [method as_matrix] [arg ?cmd?]] - #[para] return a struct::matrix command representing the data portion of the table. - - if {$cmd eq ""} { - set m [struct::matrix] - } else { - set m [struct::matrix $cmd] - } - $m add columns [tcl::dict::size $o_columndata] - $m add rows [tcl::dict::size $o_rowdefs] - tcl::dict::for {k v} $o_columndata { - $m set column $k $v - } - return $m - } - method add_column {args} { - #*** !doctools - #[call class::table [method add_column] [arg args]] - - - if {[llength $args] %2 != 0} { - error "[tcl::namespace::current]::table::add_column unexpected argument count. Require name value pairs. Known options: %copt_keys%" - } - set opts $o_opts_column_defaults - foreach {k v} $args { - switch -- $k { - %copt_switchkeys% { - tcl::dict::set opts $k $v - } - default { - error "[tcl::namespace::current]::table::add_column unknown option '$k'. Known options: %copt_keys%" - } - } - } - set colcount [tcl::dict::size $o_columndefs] - - - tcl::dict::set o_columndata $colcount [list] - #tcl::dict::set o_columndefs $colcount $defaults ;#ensure record exists - tcl::dict::set o_columndefs $colcount $o_opts_column_defaults ;#ensure record exists - - - tcl::dict::set o_columnstates $colcount [tcl::dict::create minwidthbodyseen 0 maxwidthbodyseen 0 maxwidthheaderseen 0] - set prev_calculated_column_widths $o_calculated_column_widths - if {[catch { - my configure_column $colcount {*}$opts - } errMsg]} { - #configure failed - ensure o_columndata and o_columndefs entries are removed - tcl::dict::unset o_columndata $colcount - tcl::dict::unset o_columndefs $colcount - tcl::dict::unset o_columnstates $colcount - #undo cache invalidation - set o_calculated_column_widths $prev_calculated_column_widths - error "add_column failed to configure with supplied options $opts. Err:\n$errMsg" - } - #any add_column that succeeds should invalidate the calculated column widths - set o_calculated_column_widths [list] - set numrows [my row_count] - if {$numrows > 0} { - #fill column with default values - #puts ">>> adding default values for column $colcount" - set dval [tcl::dict::get $opts -defaultvalue] - set width [textblock::width $dval] - tcl::dict::set o_columndata $colcount [lrepeat $numrows $dval] - tcl::dict::set o_columnstates $colcount maxwidthbodyseen $width - tcl::dict::set o_columnstates $colcount minwidthbodyseen $width - } - return $colcount - } - method column_count {} { - #*** !doctools - #[call class::table [method column_count]] - #[para] return the number of columns - return [tcl::dict::size $o_columndefs] - } - method configure_column {index_expression args} { - #*** !doctools - #[call class::table [method configure_column] [arg index_expression] [arg args]] - #[para] - undocumented - - set cidx [lindex [tcl::dict::keys $o_columndefs] $index_expression] - if {$cidx eq ""} { - error "textblock::table::configure_column - no column defined at index '$cidx'.Use add_column to define columns" - } - if {![llength $args]} { - return [tcl::dict::get $o_columndefs $cidx] - } else { - if {[llength $args] == 1} { - if {[lindex $args 0] in [list %copt_keys%]} { - #query single option - set k [lindex $args 0] - set val [tcl::dict::get $o_columndefs $cidx $k] - set returndict [tcl::dict::create option $k value $val ansireset "\x1b\[m"] - set infodict [tcl::dict::create] - switch -- $k { - -ansibase { - tcl::dict::set infodict debug [ansistring VIEW $val] - } - } - tcl::dict::set returndict info $infodict - return $returndict - } else { - error "textblock::table configure_column - unrecognised option '[lindex $args 0]'. Known values %copt_keys%" - } - } - if {[llength $args] %2 != 0} { - error "textblock::table configure_column unexpected argument count. Require name value pairs. Known options: %copt_keys%" - } - foreach {k v} $args { - switch -- $k { - %copt_switchkeys% {} - default { - error "[tcl::namespace::current]::table configure_column unknown option '$k'. Known options: %copt_keys%" - } - } - } - set checked_opts [tcl::dict::get $o_columndefs $cidx] ;#copy of current state - - set hstates $o_headerstates ;#operate on a copy - set colstate [tcl::dict::get $o_columnstates $cidx] - set args_got_headers 0 - set args_got_header_colspans 0 - foreach {k v} $args { - switch -- $k { - -headers { - set args_got_headers 1 - set i 0 - set maxseen 0 ;#don't compare with cached colstate maxwidthheaderseen - we have all the headers for the column right here and need to refresh the colstate maxwidthheaderseen values completely. - foreach hdr $v { - set currentmax [my header_height_calc $i $cidx] ;#exclude current column - ie look at heights for this header in all other columns - #set this_header_height [textblock::height $hdr] - lassign [textblock::size $hdr] _w this_header_width _h this_header_height - - if {$this_header_height >= $currentmax} { - tcl::dict::set hstates $i maxheightseen $this_header_height - } else { - tcl::dict::set hstates $i maxheightseen $currentmax - } - if {$this_header_width >= $maxseen} { - set maxseen $this_header_width - } - #if {$this_header_width > [tcl::dict::get $colstate maxwidthheaderseen]} { - # tcl::dict::set colstate maxwidthheaderseen $this_header_width - #} - incr i - } - tcl::dict::set colstate maxwidthheaderseen $maxseen - #review - we could avoid some recalcs if we check current width range compared to previous - set o_calculated_column_widths [list] ;#invalidate cached column widths - a recalc will be forced when needed - tcl::dict::set checked_opts $k $v - } - -header_colspans { - set args_got_header_colspans 1 - #check columns to left to make sure each new colspan for this column makes sense in the overall context - #user may have to adjust colspans in order left to right to avoid these check errors - #note that 'any' represents span all up to the next non-zero defined colspan. - set cspans [my header_colspans] - set h 0 - if {[llength $v] > [tcl::dict::size $cspans]} { - error "configure_column $cidx -header_colspans. Only [tcl::dict::size $cspans] headers exist. Too many values supplied" - } - foreach s $v { - if {$cidx == 0} { - if {[tcl::string::is integer -strict $s]} { - if {$s < 1} { - error "configure_column $cidx -header_colspans bad first value '$s' for header '$h' . First column cannot have span less than 1. use 'any' or a positive integer" - } - } else { - if {$s ne "any" && $s ne ""} { - error "configure_column $cidx -header_colspans unrecognised value '$s' for header '$h' - must be a positive integer or the keyword 'any'" - } - } - } else { - #if {![tcl::string::is integer -strict $s]} { - # if {$s ne "any" && $s ne ""} { - # error "configure_column $cidx -header_colspans unrecognised value '$s' for header '$h' - must be a positive integer or the keyword 'any'" - # } - #} else { - set header_spans [tcl::dict::get $cspans $h] - set remaining [lindex $header_spans 0] - if {$remaining ne "any"} { - incr remaining -1 - } - #look at spans defined for previous cols - #we are presuming previous column entries are valid - and only validating if our new entry is ok under that assumption - for {set c 0} {$c < $cidx} {incr c} { - set span [lindex $header_spans $c] - if {$span eq "any"} { - set remaining "any" - } else { - if {$remaining eq "any"} { - if {$span ne "0"} { - #a previous column has ended the 'any' span - set remaining [expr {$span -1}] - } - } else { - if {$span eq "0"} { - incr remaining -1 - } else { - set remaining [expr {$span -1}] - } - #allow to go negative - } - } - } - if {$remaining eq "any"} { - #any int >0 ok - what about 'any' immediately following any? - } else { - if {$remaining > 0} { - if {$s ne "0" && $s ne ""} { - error "configure_column $cidx -header_colspans bad span $s for header '$h'. Remaining span is '$remaining' - so a zero colspan is required" - } - } else { - if {$s == 0} { - error "configure_column $cidx -header_colspans bad span $s for header '$h'. No span in place - need >=1 or 'any'" - } - } - } - #} - } - incr h - } - #todo - avoid recalc if no change - set o_calculated_column_widths [list] ;#invalidate cached column widths - a recalc will be forced when needed - tcl::dict::set checked_opts $k $v - } - -minwidth { - set o_calculated_column_widths [list] ;#invalidate cached column widths - a recalc will be forced when needed - tcl::dict::set checked_opts $k $v - } - -maxwidth { - set o_calculated_column_widths [list] ;#invalidate cached column widths - a recalc will be forced when needed - tcl::dict::set checked_opts $k $v - } - -ansibase { - set parts [punk::ansi::ta::split_codes_single $v] ;#caller may have supplied separated codes eg "[a+ Yellow][a+ red]" - set col_ansibase_items [list] ; - foreach {pt code} $parts { - if {$pt ne ""} { - #we don't expect plaintext in an ansibase - error "Unable to interpret -ansibase value as ansi SGR codes. Plaintext detected. Consider using for example: '\[punk::ansi::a+ green]' (or alias '\[a+ green]') to build ansi. debug view: [punk::ansi::ansistring VIEW $v]" - } - if {$code ne ""} { - lappend col_ansibase_items $code - } - } - set col_ansibase [punk::ansi::codetype::sgr_merge_singles $col_ansibase_items] - tcl::dict::set checked_opts $k $col_ansibase - } - -ansireset { - if {$v eq "\uFFEF"} { - tcl::dict::set checked_opts $k "\x1b\[m" ;# [a] - } else { - error "textblock::table::configure_column -ansireset is read-only. It is present only to prevent unwanted colourised output in configure commands" - } - } - -blockalign - -textalign { - switch -- $v { - left - right { - tcl::dict::set checked_opts $k $v - } - centre - centre { - tcl::dict::set checked_opts $k centre - } - } - } - default { - tcl::dict::set checked_opts $k $v - } - } - } - #args checked - ok to update headerstates, headerdefs and columndefs and columnstates - tcl::dict::set o_columndefs $cidx $checked_opts - set o_headerstates $hstates - dict for {hidx hstate} $hstates { - #configure_header - if {![dict exists $o_headerdefs $hidx]} { - #remove calculated members -values -colspans - set hdefaults [dict remove $o_opts_header_defaults -values -colspans] - dict set o_headerdefs $hidx $hdefaults - } - } - - tcl::dict::set o_columnstates $cidx $colstate - - if {$args_got_headers} { - #if the headerlist length for this column has shrunk,and it was the longest - we may now have excess entries in o_headerstates - set zero_heights [list] - tcl::dict::for {hidx _v} $o_headerstates { - #pass empty string for exclude_column so we don't exclude our own column - if {[my header_height_calc $hidx ""] == 0} { - lappend zero_heights $hidx - } - } - foreach zidx $zero_heights { - tcl::dict::unset o_headerstates $zidx - } - } - if {$args_got_headers || $args_got_header_colspans} { - #check and adjust header_colspans for all columns - - } - - return [tcl::dict::get $o_columndefs $cidx] - } - } - - method header_count {} { - #*** !doctools - #[call class::table [method header_count]] - #[para] return the number of header rows - return [tcl::dict::size $o_headerstates] - } - method header_count_calc {} { - set max_headers 0 - tcl::dict::for {k cdef} $o_columndefs { - set num_headers [llength [tcl::dict::get $cdef -headers]] - set max_headers [expr {max($max_headers,$num_headers)}] - } - return $max_headers - } - method header_height {header_index} { - #*** !doctools - #[call class::table [method header_height] [arg header_index]] - #[para] return the height of a header as the number of content-lines - - set idx [lindex [tcl::dict::keys $o_headerstates $header_index]] - return [tcl::dict::get $o_headerstates $idx maxheightseen] - } - - #review - use maxwidth (considering colspans) of each column to determine height after wrapping - # -need to consider whether vertical expansion allowed / maxheight? - method header_height_calc {header_index {exclude_column ""}} { - set dataheight 0 - if {$exclude_column eq ""} { - set exclude_colidx "" - } else { - set exclude_colidx [lindex [tcl::dict::keys $o_columndefs] $exclude_column] - } - tcl::dict::for {cidx cdef} $o_columndefs { - if {$exclude_colidx == $cidx} { - continue - } - set headerlist [tcl::dict::get $cdef -headers] - if {$header_index < [llength $headerlist]} { - set this_height [textblock::height [lindex $headerlist $header_index]] - set dataheight [expr {max($dataheight,$this_height)}] - } - } - return $dataheight - } - - #return a dict keyed on header index with values representing colspans - #e.g - # 0 {any 0 0 0} 1 {1 1 1 1} 2 {2 0 1 1} 3 {3 0 0 1} - # - method header_colspans {} { - #*** !doctools - #[call class::table [method header_colspans]] - #[para] Show the colspans configured for all headers - - #set num_headers [my header_count_calc] - set num_headers [my header_count] - set colspans_by_header [tcl::dict::create] - tcl::dict::for {cidx cdef} $o_columndefs { - set headerlist [tcl::dict::get $cdef -headers] - set colspans_for_column [tcl::dict::get $cdef -header_colspans] - for {set h 0} {$h < $num_headers} {incr h} { - set headerspans [punk::lib::dict_getdef $colspans_by_header $h [list]] - set defined_span [lindex $colspans_for_column $h] - set i 0 - set spanremaining [lindex $headerspans 0] - if {$spanremaining ne "any"} { - if {$spanremaining eq ""} { - set spanremaining 1 - } - incr spanremaining -1 - } - foreach s $headerspans { - if {$s eq "any"} { - set spanremaining "any" - } elseif {$s == 0} { - if {$spanremaining ne "any"} { - incr spanremaining -1 - } - } else { - set spanremaining [expr {$s - 1}] - } - incr i - } - if {$defined_span eq ""} { - if {$spanremaining eq "0"} { - lappend headerspans 1 - } else { - #"any" or an integer - lappend headerspans 0 - } - } else { - lappend headerspans $defined_span - } - tcl::dict::set colspans_by_header $h $headerspans - } - } - return $colspans_by_header - } - - #e.g - # 0 {any 0 0 0} 1 {1 1 1 1} 2 {2 0 any 1} 3 {any 0 0 1} - #convert to - # 0 {4 0 0 0} 1 {1 1 1 1} 2 {2 0 1 1} 3 {3 0 0 1} - method header_colspans_numeric {} { - set hcolspans [my header_colspans] - if {![tcl::dict::size $hcolspans]} { - return - } - set numcols [llength [tcl::dict::get $hcolspans 0]] ;#assert: all are the same - tcl::dict::for {h spans} $hcolspans { - set c 0 ;#column index - foreach s $spans { - if {$s eq "any"} { - set spanlen 1 - for {set i [expr {$c+1}]} {$i < $numcols} {incr i} { - #next 'any' or non-zero ends an 'any' span - if {[lindex $spans $i] ne "0"} { - break - } - incr spanlen - } - #overwrite the 'any' with it's actual span - set modified_spans [dict get $hcolspans $h] - lset modified_spans $c $spanlen - dict set hcolspans $h $modified_spans - } - incr c - } - } - return $hcolspans - } - - method configure_header {index_expression args} { - #*** !doctools - #[call class::table [method configure_header]] - #[para] - configure header row-wise - - #the header data being configured or returned here is mostly derived from the column defs and if necessary written to the column defs. - #It can also be set column by column - but it is much easier (especially for colspans) to configure them on a header-row basis - #e.g o_headerstates: 0 {maxheightseen 1} 1 {maxheightseen 2} - set num_headers [my header_count_calc] - set hidx [lindex [tcl::dict::keys $o_headerstates] $index_expression] - if {$hidx eq ""} { - error "textblock::table::configure_header - no header row defined at index '$index_expression'." - } - if {$hidx > $num_headers -1} { - #assert - shouldn't happen - error "textblock::table::configure_header error headerstates data is out of sync" - } - - if {![llength $args]} { - set colspans_by_header [my header_colspans] - set result [tcl::dict::create] - tcl::dict::set result -colspans [tcl::dict::get $colspans_by_header $hidx] - set header_row_items [list] - tcl::dict::for {cidx cdef} $o_columndefs { - set colheaders [tcl::dict::get $cdef -headers] - set relevant_header [lindex $colheaders $hidx] - #The -headers element of the column def is allowed to have less elements than the total, even be empty. Number of headers is defined by the longest -header list in the set of columns - lappend header_row_items $relevant_header ;#may be empty string because column had nothing at that index, or may be empty string stored in that column. We don't differentiate. - } - tcl::dict::set result -values $header_row_items - - #review - ensure always a headerdef record for each header? - if {[tcl::dict::exists $o_headerdefs $hidx]} { - set result [tcl::dict::merge $result [tcl::dict::get $o_headerdefs $hidx]] - } else { - #warn for now - puts stderr "no headerdef record for header $hidx" - } - return $result - } - if {[llength $args] == 1} { - if {[lindex $args 0] in [tcl::dict::keys $o_opts_header_defaults]} { - #query single option - set k [lindex $args 0] - #set val [tcl::dict::get $o_rowdefs $ridx $k] - - set infodict [tcl::dict::create] - #todo - # -blockalignments and -textalignments lists - # must match number of values if not empty? - e.g -blockalignments {left right "" centre left ""} - #if there is a value it overrides alignments specified on the column - switch -- $k { - -values { - set header_row_items [list] - tcl::dict::for {cidx cdef} $o_columndefs { - set colheaders [tcl::dict::get $cdef -headers] - set relevant_header [lindex $colheaders $hidx] - #The -headers element of the column def is allowed to have less elements than the total, even be empty. Number of headers is defined by the longest -header list in the set of columns - lappend header_row_items $relevant_header ;#may be empty string because column had nothing at that index, or may be empty string stored in that column. We don't differentiate. - - } - set val $header_row_items - set returndict [tcl::dict::create option $k value $val ansireset "\x1b\[m"] - } - -colspans { - set colspans_by_header [my header_colspans] - set result [tcl::dict::create] - set val [tcl::dict::get $colspans_by_header $hidx] - #ansireset not required - set returndict [tcl::dict::create option $k value $val] - } - -ansibase { - set val ??? - set returndict [tcl::dict::create option $k value $val ansireset "\x1b\[m"] - tcl::dict::set infodict debug [ansistring VIEW $val] - } - } - tcl::dict::set returndict info $infodict - return $returndict - #return [tcl::dict::create option $k value $val ansireset "\x1b\[m" info $infodict] - } else { - error "textblock::table configure_header - unrecognised option '[lindex $args 0]'. Known values [tcl::dict::keys $o_opts_header_defaults]" - } - } - if {[llength $args] %2 != 0} { - error "textblock::table configure_header incorrect number of options following index_expression. Require name value pairs. Known options: [tcl::dict::keys $o_opts_header_defaults]" - } - foreach {k v} $args { - if {$k ni [tcl::dict::keys $o_opts_header_defaults]} { - error "[tcl::namespace::current]::table configure_row unknown option '$k'. Known options: [tcl::dict::keys $o_opts_header_defaults]" - } - } - - set checked_opts [list] - #safe jumptable test - #dict for {k v} $args {} - foreach {k v} $args { - switch -- $k { - -ansibase { - set parts [punk::ansi::ta::split_codes_single $v] ;#caller may have supplied separated codes eg "[a+ Yellow][a+ red]" - set header_ansibase_items [list] ; - foreach {pt code} $parts { - if {$pt ne ""} { - #we don't expect plaintext in an ansibase - error "Unable to interpret -ansibase value as ansi SGR codes. Plaintext detected. Consider using for example: '\[punk::ansi::a+ green]' (or alias '\[a+ green]') to build ansi. debug view: [punk::ansi::ansistring VIEW $v]" - } - if {$code ne ""} { - lappend header_ansibase_items $code - } - } - set header_ansibase [punk::ansi::codetype::sgr_merge_singles $header_ansibase_items] - lappend checked_opts $k $header_ansibase - } - -ansireset { - if {$v eq "\uFFEF"} { - lappend checked_opts $k "\x1b\[m" ;# [a] - } else { - error "textblock::table::configure_header -ansireset is read-only. It is present only to prevent unwanted colourised output in configure commands" - } - } - -values { - if {[llength $v] > [tcl::dict::size $o_columndefs]} { - error "textblock::table::configure_header -values length ([llength $v]) is longer than number of columns ([tcl::dict::size $o_columndefs])" - } - lappend checked_opts $k $v - } - -colspans { - set numcols [tcl::dict::size $o_columndefs] - if {[llength $v] > $numcols} { - error "textblock::table::configure_header -colspans length ([llength $v]) is longer than number of columns ([tcl::dict::size $o_columndefs])" - } - if {[llength $v] < $numcols} { - puts stderr "textblock::table::configure_header warning - only [llength $v] spans specified for [tcl::dict::size $o_columndefs] columns." - puts stderr "It is recommended to set all spans explicitly. (auto-calc not implemented)" - } - if {[llength $v]} { - set firstspan [lindex $v 0] - set first_is_ok 0 - if {$firstspan eq "any"} { - set first_is_ok 1 - } elseif {[tcl::string::is integer -strict $firstspan] && $firstspan > 0 && $firstspan <= $numcols} { - set first_is_ok 1 - } - if {!$first_is_ok} { - error "textblock::table::configure_header -colspans first value '$firstspan' must be integer > 0 & <= $numcols or the string \"any\"" - } - #we don't mind if there are less colspans specified than columns.. the tail can be deduced from the leading ones specified (review) - set remaining $firstspan - if {$remaining ne "any"} { - incr remaining -1 - } - set spanview $v - set sidx 1 - #because we allow 'any' - be careful when doing < or > comparisons - as we are mixing integer and string comparisons if we don't test for 'any' first - foreach span [lrange $v 1 end] { - if {$remaining eq "any"} { - if {$span eq "any"} { - set remaining "any" - } elseif {$span > 0} { - #ok to reset to higher val immediately or after an any and any number of following zeros - if {$span > ($numcols - $sidx)} { - lset spanview $sidx [a+ web-red]$span[a] - error "textblock::table::configure_header -colspans sequence incorrect at span '$span'. Require span <= [expr {$numcols-$sidx}] or \"any\".[a] $spanview" - } - set remaining $span - incr remaining -1 - } else { - #zero following an any - leave remaining as any - } - } else { - if {$span eq "0"} { - if {$remaining eq "0"} { - lset spanview $sidx [a+ web-red]$span[a] - error "textblock::table::configure_header -colspans sequence incorrect at span '$span' remaining is $remaining. Require positive or \"any\" value.[a] $spanview" - } else { - incr remaining -1 - } - } else { - if {$remaining eq "0"} { - #ok for new span value of any or > 0 - if {$span ne "any" && $span > ($numcols - $sidx)} { - lset spanview $sidx [a+ web-red]$span[a] - error "textblock::table::configure_header -colspans sequence incorrect at span '$span'. Require span <= [expr {$numcols-$sidx}] or \"any\".[a] $spanview" - } - set remaining $span - if {$remaining ne "any"} { - incr remaining -1 - } - } else { - lset spanview $sidx [a+ web-red]$span[a] - error "textblock::table::configure_header -colspans sequence incorrect at span '$span' remaining is $remaining. Require zero value span.[a] $spanview" - } - } - } - incr sidx - } - } - #empty -colspans list should be ok - - #error "sorry - -colspans not yet implemented for header rows - set manually in vertical order via configure_column for now" - lappend checked_opts $k $v - } - default { - lappend checked_opts $k $v - } - } - } - - #configured opts all good - #safe jumptable test - #dict for {k v} $checked_opts {} - #foreach {k v} $checked_opts {} - - # headerdefs excludes -values and -colspans - set update_hdefs [tcl::dict::get $o_headerdefs $hidx] - - tcl::dict::for {k v} $checked_opts { - switch -- $k { - -values { - set c 0 - foreach hval $v { - #retrieve -headers from relevant col, insert at header index, and write back. - set thiscol_headers_vertical [tcl::dict::get $o_columndefs $c -headers] - set missing [expr {($hidx +1) - [llength $thiscol_headers_vertical]}] - if {$missing > 0} { - lappend thiscol_headers_vertical {*}[lrepeat $missing ""] - } - lset thiscol_headers_vertical $hidx $hval - tcl::dict::set o_columndefs $c -headers $thiscol_headers_vertical - #invalidate column width cache - set o_calculated_column_widths [list] - # -- -- -- -- -- -- - #also update maxwidthseen & maxheightseen - set i 0 - set maxwidthseen 0 - #set maxheightseen 0 - foreach hdr $thiscol_headers_vertical { - lassign [textblock::size $hdr] _w this_header_width _h this_header_height - set maxheightseen [punk::lib::dict_getdef $o_headerstates $i maxheightseen 0] - if {$this_header_height >= $maxheightseen} { - tcl::dict::set o_headerstates $i maxheightseen $this_header_height - } else { - tcl::dict::set o_headerstates $i maxheightseen $maxheightseen - } - if {$this_header_width >= $maxwidthseen} { - set maxwidthseen $this_header_width - } - incr i - } - tcl::dict::set o_columnstates $c maxwidthheaderseen $maxwidthseen - # -- -- -- -- -- -- - incr c - } - } - -colspans { - #sequence has been verified above - we need to split it and store across columns - set c 0 ;#column index - foreach span $v { - set colspans [tcl::dict::get $o_columndefs $c -header_colspans] - if {$hidx > [llength $colspans]-1} { - set colspans_by_header [my header_colspans] - #puts ">>>>>?$colspans_by_header" - #we are allowed to lset only one beyond the current length to append - #but there may be even less or no entries present in a column - # - the ability to underspecify and calculate the missing values makes setting the values complicated. - #use the header_colspans calculation to update only those entries necessary - set spanlist [list] - for {set h 0} {$h < $hidx} {incr h} { - set cspans [tcl::dict::get $colspans_by_header $h] - set requiredval [lindex $cspans $c] - lappend spanlist $requiredval - } - tcl::dict::set o_columndefs $c -header_colspans $spanlist - - set colspans [tcl::dict::get $o_columndefs $c -header_colspans] - } - - lset colspans $hidx $span - tcl::dict::set o_columndefs $c -header_colspans $colspans - incr c - } - } - default { - dict set update_hdefs $k $v - } - } - } - set opt_minh [tcl::dict::get $update_hdefs -minheight] - set opt_maxh [tcl::dict::get $update_hdefs -maxheight] - - #todo - allow zero values to hide/collapse - # - see also configure_row - if {![tcl::string::is integer $opt_minh] || ($opt_maxh ne "" && ![tcl::string::is integer -strict $opt_maxh])} { - error "[tcl::namespace::current]::table::configure_header error -minheight '$opt_minh' and -maxheight '$opt_maxh' must be integers greater than or equal to 1 (for now)" - } - if {$opt_minh < 1 || ($opt_maxh ne "" && $opt_maxh < 1)} { - error "[tcl::namespace::current]::table::configure_header error -minheight '$opt_minh' and -maxheight '$opt_maxh' must both be 1 or greater (for now)" - } - if {$opt_maxh ne "" && $opt_maxh < $opt_minh} { - error "[tcl::namespace::current]::table::configure_header error -maxheight '$opt_maxh' must greater than -minheight '$opt_minh'" - } - - #set o_headerstate $hidx -minheight? -maxheight? ??? - tcl::dict::set o_headerdefs $hidx $update_hdefs - } - - method add_row {valuelist args} { - #*** !doctools - #[call class::table [method add_row]\ - # [arg valuelist]\ - # [opt "[option -minheight] [arg int_minheight]"]\ - # [opt "[option -maxheight] [arg int_maxheight]"]\ - # [opt "[option -ansibase] [arg ansicode]"]\ - #] - if {[tcl::dict::size $o_columndefs] > 0 && ([llength $valuelist] && [llength $valuelist] != [tcl::dict::size $o_columndefs])} { - set msg "" - append msg "add_row - invalid number ([llength $valuelist]) of values in row - Must match existing column count: [tcl::dict::size $o_columndefs]" \n - append msg "rowdata: $valuelist" - error $msg - } - if {[tcl::dict::size $o_columndefs] == 0 && ![llength $valuelist]} { - error "add_row - no values supplied, and no columns defined, so cannot use default column values" - } - - set defaults [tcl::dict::create\ - -minheight 1\ - -maxheight ""\ - -ansibase ""\ - -ansireset "\uFFEF"\ - ] - set o_opts_row_defaults $defaults - - if {[llength $args] %2 !=0} { - error "[tcl::namespace::current]::table::add_row unexpected argument count. Require name value pairs. Known options: [tcl::dict::keys $defaults]" - } - #safe jumptable test - #dict for {k v} $args {} - foreach {k v} $args { - switch -- $k { - -minheight - -maxheight - -ansibase - -ansireset {} - default { - error "Invalid option '$k' Known options: [tcl::dict::keys $defaults] (-ansireset is read-only)" - } - } - } - set opts [tcl::dict::merge $defaults $args] - - set auto_columns 0 - if {[tcl::dict::size $o_columndefs] == 0} { - set auto_columns 1 - #no columns defined - auto define with defaults for each column in first supplied row - #auto define columns only valid if no existing columns - #the autocolumns must be added before configure_row - but if configure_row fails - we need to remove them! - foreach el $valuelist { - my add_column - } - } else { - if {![llength $valuelist]} { - tcl::dict::for {k coldef} $o_columndefs { - lappend valuelist [tcl::dict::get $coldef -defaultvalue] - } - } - } - set rowcount [tcl::dict::size $o_rowdefs] - tcl::dict::set o_rowdefs $rowcount $defaults ;# ensure record exists before configure - - if {[catch { - my configure_row $rowcount {*}$opts - } errMsg]} { - #undo anything we saved before configure_row - tcl::dict::unset o_rowdefs $rowcount - #remove auto_columns - if {$auto_columns} { - set o_columndata [tcl::dict::create] - set o_columndefs [tcl::dict::create] - set o_columnstate [tcl::dict::create] - } - error "add_row failed to configure with supplied options $opts. Err:\n$errMsg" - } - - - set c 0 - set max_height_seen 1 - foreach v $valuelist { - set prev_maxwidth [tcl::dict::get $o_columnstates $c maxwidthbodyseen] - set prev_minwidth [tcl::dict::get $o_columnstates $c minwidthbodyseen] - - tcl::dict::lappend o_columndata $c $v - lassign [textblock::size_as_list $v] valwidth valheight - if {$valheight > $max_height_seen} { - set max_height_seen $valheight - } - if {$valwidth > [tcl::dict::get $o_columnstates $c maxwidthbodyseen]} { - tcl::dict::set o_columnstates $c maxwidthbodyseen $valwidth - } - if {$valwidth < [tcl::dict::get $o_columnstates $c minwidthbodyseen]} { - tcl::dict::set o_columnstates $c minwidthbodyseen $valwidth - } - - if {[tcl::dict::get $o_columnstates $c maxwidthbodyseen] > $prev_maxwidth || [tcl::dict::get $o_columnstates $c minwidthbodyseen] < $prev_minwidth} { - #invalidate calculated column width cache if any new value was outside the previous range of widths - set o_calculated_column_widths [list] - } - incr c - } - - set opt_maxh [tcl::dict::get $o_rowdefs $rowcount -maxheight] - if {$opt_maxh ne ""} { - tcl::dict::set o_rowstates $rowcount -maxheight [expr {min($opt_maxh,$max_height_seen)}] - } else { - tcl::dict::set o_rowstates $rowcount -maxheight $max_height_seen - } - - return $rowcount - } - method configure_row {index_expression args} { - #*** !doctools - #[call class::table [method configure_row]\ - # [arg index_expression]\ - # [opt "[option -minheight] [arg int_minheight]"]\ - # [opt "[option -maxheight] [arg int_maxheight]"]\ - # [opt "[option -ansibase] [arg ansicode]"]\ - #] - set ridx [lindex [tcl::dict::keys $o_rowdefs] $index_expression] - if {$ridx eq ""} { - error "textblock::table::configure_row - no row defined at index '$ridx'.Use add_row to define rows" - } - if {![llength $args]} { - return [tcl::dict::get $o_rowdefs $ridx] - } - if {[llength $args] == 1} { - if {[lindex $args 0] in [tcl::dict::keys $o_opts_row_defaults]} { - #query single option - set k [lindex $args 0] - set val [tcl::dict::get $o_rowdefs $ridx $k] - set returndict [tcl::dict::create option $k value $val ansireset "\x1b\[m"] - set infodict [tcl::dict::create] - switch -- $k { - -ansibase { - tcl::dict::set infodict debug [ansistring VIEW $val] - } - } - tcl::dict::set returndict info $infodict - return $returndict - #return [tcl::dict::create option $k value $val ansireset "\x1b\[m" info $infodict] - } else { - error "textblock::table configure_row - unrecognised option '[lindex $args 0]'. Known values [tcl::dict::keys $o_opts_row_defaults]" - } - } - if {[llength $args] %2 != 0} { - error "textblock::table configure_row incorrect number of options following index_expression. Require name value pairs. Known options: [tcl::dict::keys $o_opts_row_defaults]" - } - foreach {k v} $args { - if {$k ni [tcl::dict::keys $o_opts_row_defaults]} { - error "[tcl::namespace::current]::table configure_row unknown option '$k'. Known options: [tcl::dict::keys $o_opts_row_defaults]" - } - } - set checked_opts [list] - foreach {k v} $args { - switch -- $k { - -ansibase { - set parts [punk::ansi::ta::split_codes_single $v] ;#caller may have supplied separated codes eg "[a+ Yellow][a+ red]" - set row_ansibase_items [list] ; - foreach {pt code} $parts { - if {$pt ne ""} { - #we don't expect plaintext in an ansibase - error "Unable to interpret -ansibase value as ansi SGR codes. Plaintext detected. Consider using for example: '\[punk::ansi::a+ green]' (or alias '\[a+ green]') to build ansi. debug view: [punk::ansi::ansistring VIEW $v]" - } - if {$code ne ""} { - lappend row_ansibase_items $code - } - } - set row_ansibase [punk::ansi::codetype::sgr_merge_singles $row_ansibase_items] - lappend checked_opts $k $row_ansibase - } - -ansireset { - if {$v eq "\uFFEF"} { - lappend checked_opts $k "\x1b\[m" ;# [a] - } else { - error "textblock::table::configure_row -ansireset is read-only. It is present only to prevent unwanted colourised output in configure commands" - } - } - default { - lappend checked_opts $k $v - } - } - } - - set current_opts [tcl::dict::get $o_rowdefs $ridx] - set opts [tcl::dict::merge $current_opts $checked_opts] - - #check minheight and maxheight together - set opt_minh [tcl::dict::get $opts -minheight] - set opt_maxh [tcl::dict::get $opts -maxheight] - - #todo - allow zero values to hide/collapse rows as is possible with columns - if {![tcl::string::is integer $opt_minh] || ($opt_maxh ne "" && ![tcl::string::is integer -strict $opt_maxh])} { - error "[tcl::namespace::current]::table::configure_row error -minheight '$opt_minh' and -maxheight '$opt_maxh' must be integers greater than or equal to 1 (for now)" - } - if {$opt_minh < 1 || ($opt_maxh ne "" && $opt_maxh < 1)} { - error "[tcl::namespace::current]::table::configure_row error -minheight '$opt_minh' and -maxheight '$opt_maxh' must both be 1 or greater (for now)" - } - if {$opt_maxh ne "" && $opt_maxh < $opt_minh} { - error "[tcl::namespace::current]::table::configure_row error -maxheight '$opt_maxh' must greater than -minheight '$opt_minh'" - } - tcl::dict::set o_rowstates $ridx -minheight $opt_minh - - - tcl::dict::set o_rowdefs $ridx $opts - } - method row_count {} { - #*** !doctools - #[call class::table [method row_count]] - #[para] return the number of data rows in the table. - return [tcl::dict::size $o_rowdefs] - } - method row_clear {} { - #*** !doctools - #[call class::table [method row_clear]] - #[para] Remove all rows without resetting column data. - #[para] When adding new rows the number of entries will need to match the existing column count. - set o_rowdefs [tcl::dict::create] - set o_rowstates [tcl::dict::create] - #The data values are stored by column regardless of whether added row by row - tcl::dict::for {cidx records} $o_columndata { - tcl::dict::set o_columndata $cidx [list] - #reset only the body fields in o_columnstates - tcl::dict::set o_columnstates $cidx minwidthbodyseen 0 - tcl::dict::set o_columnstates $cidx maxwidthbodyseen 0 - } - set o_calculated_column_widths [list] - } - method clear {} { - #*** !doctools - #[call class::table [method clear]] - #[para] Remove all row and column data. - #[para] If a subsequent call to add_row is made it can contain any number of values. - #[para] Further calls to add_row will need to contain the same number of values - #[para] as the first call unless default values have been set for the missing columns (review - in flux). - my row_clear - set o_columndefs [tcl::dict::create] - set o_columndata [tcl::dict::create] - set o_columnstates [tcl::dict::create] - } - - - - #method Get_columns_by_name {namematch_list} { - #} - - #specify range with x..y - method Get_columns_by_indices {index_list} { - foreach spec $index_list { - if {[tcl::string::is integer -strict $c]} { - set colidx $c - } else { - tcl::dict::for {colidx coldef} $o_columndefs { - #if {[tcl::string::match x x]} {} - } - } - } - } - method Get_boxlimits_and_joins {position fname_body} { - #fname_body will be "custom" or one of the predefined types light,heavy etc - switch -- $position { - left { - return [tcl::dict::create \ - boxlimits [list hlb blc vll]\ - boxlimits_top [list hlb blc vll hlt tlc]\ - joins [list down]\ - bodyjoins [list down-$fname_body]\ - ] - } - inner { - return [tcl::dict::create \ - boxlimits [list hlb blc vll]\ - boxlimits_top [list hlb blc vll hlt tlc]\ - joins [list down left]\ - bodyjoins [list left down-$fname_body] - ] - } - right { - return [tcl::dict::create \ - boxlimits [list hlb blc vll vlr brc]\ - boxlimits_top [list hlb blc vll vlr brc hlt tlc trc]\ - joins [list down left]\ - bodyjoins [list left down-$fname_body]\ - ] - } - solo { - return [tcl::dict::create \ - boxlimits [list hlb blc vll vlr brc]\ - boxlimits_top [list hlb blc vll vlr brc hlt tlc trc]\ - joins [list down]\ - bodyjoins [list down-$fname_body]\ - ] - } - default { - error "Get_boxlimits_and_joins unrecognised position '$position' expected: left inner right solo" - } - } - } - method Get_boxlimits_and_joins1 {position fname_body} { - #fname_body will be "custom" or one of the predefined types light,heavy etc - switch -- $position { - left { - #set header_boxlimits {hlb hlt tlc blc vll} - set header_body_joins [list down-$fname_body] - set boxlimits_position [list hlb blc vll] - #set boxlimits_toprow [concat $boxlimits_position {hlt tlc}] - set boxlimits_toprow [list hlb blc vll hlt tlc] - set joins [list down] - } - inner { - #set header_boxlimits {hlb hlt tlc blc vll} - set header_body_joins [list left down-$fname_body] - set boxlimits_position [list hlb blc vll] - #set boxlimits_toprow [concat $boxlimits_position {hlt tlc}] - set boxlimits_toprow [list hlb blc vll hlt tlc] - set joins [list down left] - } - right { - #set header_boxlimits {hlb hlt tlc blc vll vlr trc brc} - set header_body_joins [list left down-$fname_body] - set boxlimits_position [list hlb blc vll vlr brc] - #set boxlimits_toprow [concat $boxlimits_position {hlt tlc trc}] - set boxlimits_toprow [list hlb blc vll vlr brc hlt tlc trc] - set joins [list down left] - } - solo { - #set header_boxlimits {hlb hlt tlc blc vll vlr trc brc} - set header_body_joins [list down-$fname_body] - set boxlimits_position [list hlb blc vll vlr brc] - #set boxlimits_toprow [concat $boxlimits_position {hlt tlc trc}] - set boxlimits_toprow [list hlb blc vll vlr brc hlt tlc trc] - set joins [list down] - } - } - return [tcl::dict::create boxlimits $boxlimits_position boxlimits_top $boxlimits_toprow joins $joins bodyjoins $header_body_joins ] - } - method get_column_by_index {index_expression args} { - #puts "+++> get_column_by_index $index_expression $args [tcl::namespace::current]" - #index_expression may be something like end-1 or 2+2 - we can't directly use it as a lookup for dicts. - set opts [tcl::dict::create\ - -position "inner"\ - -return "string"\ - ] - foreach {k v} $args { - switch -- $k { - -position - -return { - tcl::dict::set opts $k $v - } - default { - error "[tcl::namespace::current]::table::get_column_by_index error invalid option '$k'. Known options [tcl::dict::keys $opts]" - } - } - } - set opt_posn [tcl::dict::get $opts -position] - set opt_return [tcl::dict::get $opts -return] - - switch -- $opt_posn { - left - inner - right - solo {} - default { - error "[tcl::namespace::current]::table::get_column_by_index error invalid value '$opt_posn' for -position. Valid values: [list left inner right solo]" - } - } - switch -- $opt_return { - string - dict {} - default { - error "[tcl::namespace::current]::table::get_column_by_index error invalid value '$opt_return' for -return. Valid values: string dict" - } - } - - set columninfo [my get_column_cells_by_index $index_expression] - set header_list [tcl::dict::get $columninfo headers] - #puts "===== header_list: $header_list" - set cells [tcl::dict::get $columninfo cells] - - set topt_show_header [tcl::dict::get $o_opts_table -show_header] - if {$topt_show_header eq ""} { - set allheaders 0 - set all_cols [tcl::dict::keys $o_columndefs] - foreach c $all_cols { - incr allheaders [llength [tcl::dict::get $o_columndefs $c -headers]] - } - if {$allheaders == 0} { - set do_show_header 0 - } else { - set do_show_header 1 - } - } else { - set do_show_header $topt_show_header - } - set topt_show_footer [tcl::dict::get $o_opts_table -show_footer] - - - set output "" - set part_header "" - set part_body "" - set part_footer "" - - set boxlimits "" - set joins "" - set header_boxlimits [list] - set header_body_joins [list] - - - set ftypes [my Get_frametypes] - set ftype_body [tcl::dict::get $ftypes body] - if {[llength $ftype_body] >= 2} { - set fname_body "custom" - } else { - set fname_body $ftype_body - } - set ftype_header [tcl::dict::get $ftypes header] - if {[llength $ftype_header] >= 2} { - set fname_header "custom" - } else { - set fname_header $ftype_header - } - - set limj [my Get_boxlimits_and_joins $opt_posn $fname_body] - set header_body_joins [tcl::dict::get $limj bodyjoins] - set joins [tcl::dict::get $limj joins] - set boxlimits_position [tcl::dict::get $limj boxlimits] - set boxlimits_toprow [tcl::dict::get $limj boxlimits_top] - #use struct::set instead of simple for loop - will be faster at least when critcl available - set boxlimits [struct::set intersect [tcl::dict::get $o_opts_table_effective -framelimits_body] $boxlimits_position] - set boxlimits_headerless [struct::set intersect [tcl::dict::get $o_opts_table_effective -framelimits_body] $boxlimits_toprow] - set header_boxlimits [struct::set intersect [tcl::dict::get $o_opts_table_effective -framelimits_header] $boxlimits_position] - set header_boxlimits_toprow [struct::set intersect [tcl::dict::get $o_opts_table_effective -framelimits_header] $boxlimits_toprow] - - set fmap [tcl::dict::get $o_opts_table_effective -framemap_body] - set hmap [tcl::dict::get $o_opts_table_effective -framemap_header] - - #if {![tcl::dict::get $o_opts_table -show_edge]} { - # set body_edgemap [textblock::class::table_edge_map ""] - # dict for {k v} $fmap { - # #tcl::dict::set fmap $k [tcl::dict::merge $v [tcl::dict::get $body_edgemap $k]] - # } - # set header_edgemap [textblock::class::header_edge_map ""] - # dict for {k v} $hmap { - # #tcl::dict::set hmap $k [tcl::dict::merge $v [tcl::dict::get $header_edgemap $k]] - # } - #} - set sep_elements_horizontal $::textblock::class::table_hseps - set sep_elements_vertical $::textblock::class::table_vseps - - set topmap [tcl::dict::get $fmap top$opt_posn] - set botmap [tcl::dict::get $fmap bottom$opt_posn] - set midmap [tcl::dict::get $fmap middle$opt_posn] - set onlymap [tcl::dict::get $fmap only$opt_posn] - - set hdrmap [tcl::dict::get $hmap only${opt_posn}] - - set topseps_h [tcl::dict::get $sep_elements_horizontal top$opt_posn] - set midseps_h [tcl::dict::get $sep_elements_horizontal middle$opt_posn] - set topseps_v [tcl::dict::get $sep_elements_vertical top$opt_posn] - set midseps_v [tcl::dict::get $sep_elements_vertical middle$opt_posn] - set botseps_v [tcl::dict::get $sep_elements_vertical bottom$opt_posn] - set onlyseps_v [tcl::dict::get $sep_elements_vertical only$opt_posn] - - #top should work for all header rows regarding vseps - as we only use it to reduce the box elements, and lower headers have same except for tlc which isn't present anyway - set headerseps_v [tcl::dict::get $sep_elements_vertical top$opt_posn] - - lassign [my Get_seps] _h show_seps_h _v show_seps_v - set return_headerheight 0 - set return_headerwidth 0 - set cidx [lindex [tcl::dict::keys $o_columndefs] $index_expression] - - set colwidth [my column_width $cidx] - - set col_blockalign [tcl::dict::get $o_columndefs $cidx -blockalign] - - if {$do_show_header} { - #puts "boxlimitsinfo header $opt_posn: -- boxlimits $header_boxlimits -- boxmap $hdrmap" - set ansibase_header [tcl::dict::get $o_opts_table -ansibase_header] ;#merged to single during configure - set ansiborder_header [tcl::dict::get $o_opts_table -ansiborder_header] - if {[tcl::dict::get $o_opts_table -frametype_header] eq "block"} { - set extrabg [punk::ansi::codetype::sgr_merge_singles [list $ansibase_header] -filter_fg 1] - set ansiborder_final $ansibase_header$ansiborder_header$extrabg - } else { - set ansiborder_final $ansibase_header$ansiborder_header - } - set RST [punk::ansi::a] - - - set hcolwidth $colwidth - #set hcolwidth [my column_width_configured $cidx] - set hcell_line_blank [tcl::string::repeat " " $hcolwidth] - - set all_colspans [my header_colspans_numeric] - - #put our framedef calls together - set fdef_header [textblock::framedef $ftype_header] - set framedef_leftbox [textblock::framedef -joins left $ftype_header] - set framedef_headerdown_same [textblock::framedef -joins {down} $ftype_header] - set framedef_headerdown_body [textblock::framedef -joins [list down-$fname_body] $ftype_header] - #default span_extend_map - used as base to customise with specific joins - set span_extend_map [tcl::dict::create \ - vll " "\ - tlc [tcl::dict::get $fdef_header hlt]\ - blc [tcl::dict::get $fdef_header hlb]\ - ] - - - #used for colspan-zero header frames - set framesub_map [list hl $TSUB vll $TSUB vlr $TSUB tlc $TSUB blc $TSUB trc $TSUB brc $TSUB] ;# a debug test - - set hrow 0 - set hmax [expr {[llength $header_list] -1}] - foreach header $header_list { - set headerspans [tcl::dict::get $all_colspans $hrow] - set this_span [lindex $headerspans $cidx] - #set hval $ansibase_header$header ;#no reset - set hval $header - set rowh [my header_height $hrow] - - if {$hrow == 0} { - set hlims $header_boxlimits_toprow - set rowpos "top" - if {$hrow == $hmax} { - set rowpos "only" - } - } else { - set hlims $header_boxlimits - set rowpos "middle" - if {$hrow == $hmax} { - set rowpos "bottom" - } - } - if {!$show_seps_v} { - set hlims [struct::set difference $hlims $headerseps_v] - } - if {$hrow == $hmax} { - set header_joins $header_body_joins - } else { - set header_joins $joins - } - if {![tcl::dict::get $o_opts_table -show_edge]} { - set hlims [struct::set difference $hlims [tcl::dict::get $::textblock::class::header_edge_parts $rowpos$opt_posn] ] - } - #puts ">>> headerspans: $headerspans cidx: $cidx" - - #if {$this_span eq "any" || $this_span > 0} {} - #changed to processing only numeric colspans - - if {$this_span > 0} { - set startmap [tcl::dict::get $hmap $rowpos${opt_posn}] - #look at spans in header below to determine joins required at blc - if {$show_seps_v} { - if {[tcl::dict::exists $all_colspans [expr {$hrow+1}]]} { - set next_spanlist [tcl::dict::get $all_colspans [expr {$hrow+1}]] - set spanbelow [lindex $next_spanlist $cidx] - if {$spanbelow == 0} { - #we don't want a down-join for blc - use a framedef with only left joins - tcl::dict::set startmap blc [tcl::dict::get $framedef_leftbox blc] - } - } else { - set next_spanlist [list] - } - } - - #supporting wrapping in headers might be a step too difficult for little payoff. - #we would need a flag to enable/disable - plus language-based wrapping alg (see tcllib) - #The interaction with colspans and width calculations makes it likely to have a heavy performance impact and make the code even more complex. - #May be better to require user to pre-wrap as needed - ##set hval [textblock::renderspace -width $colwidth -wrap 1 "" $hval] - - #review - contentwidth of hval can be greater than $colwidth+2 - if so frame function will detect and frame_cache will not be used - #This ellipsis 0 makes a difference (unwanted ellipsis at rhs of header column that starts span) - - # -width is always +2 - as the boxlimits take into account show_vseps and show_edge - #set header_cell_startspan [textblock::frame -ellipsis 0 -usecache 1 -width [expr {$hcolwidth+2}] -type [tcl::dict::get $ftypes header]\ - # -ansibase $ansibase_header -ansiborder $ansiborder_final\ - # -boxlimits $hlims -boxmap $startmap -joins $header_joins $hval\ - # ] - - if {$this_span == 1} { - #write the actual value now - set cellcontents $hval - } else { - #just write an empty vertical placeholder. The spanned value will be overtyped below - set cellcontents [::join [lrepeat [llength [split $hval \n]] ""] \n] - } - set header_cell_startspan [textblock::frame -checkargs 0 -blockalign $col_blockalign -ellipsis 0 -usecache 1 -width [expr {$hcolwidth+2}] -type [tcl::dict::get $ftypes header]\ - -ansibase $ansibase_header -ansiborder $ansiborder_final\ - -boxlimits $hlims -boxmap $startmap -joins $header_joins $cellcontents\ - ] - - if {$this_span != 1} { - #puts "===>\n$header_cell_startspan\n<===" - set spanned_parts [list $header_cell_startspan] - #assert this_span == "any" or >1 ie a header that spans other columns - #therefore more parts to append - #set remaining_cols [lrange [tcl::dict::keys $o_columndefs] $cidx end] - set remaining_spans [lrange $headerspans $cidx+1 end] - set spanval [join $remaining_spans ""] ;#so we can test for all zeros - set spans_to_rhs 0 - if {[expr {$spanval}] == 0} { - #puts stderr "SPANS TO RHS" - set spans_to_rhs 1 - } - - #puts ">> remaining_spans: $remaining_spans" - set spancol [expr {$cidx + 1}] - set h_lines [lrepeat $rowh ""] - set hcell_blank [::join $h_lines \n] ;#todo - just use -height option of frame? review - currently doesn't cache with -height and no contents - slow - - - - set last [expr {[llength $remaining_spans] -1}] - set i 0 - foreach s $remaining_spans { - if {$s == 0} { - if {$i == $last} { - set next_posn right - #set next_posn inner - } else { - set next_posn inner - } - - set next_headerseps_v [tcl::dict::get $sep_elements_vertical top$next_posn] ;#static top ok - - set limj [my Get_boxlimits_and_joins $next_posn $fname_body] - set span_joins_body [tcl::dict::get $limj bodyjoins] - set span_joins [tcl::dict::get $limj joins] - set span_boxlimits [tcl::dict::get $limj boxlimits] - set span_boxlimits_top [tcl::dict::get $limj boxlimits_top] - #use struct::set instead of simple for loop - will be faster at least when critcl available - #set span_boxlimits [struct::set intersect [tcl::dict::get $o_opts_table_effective -framelimits_body] $span_boxlimits] - #set span_boxlimits_top [struct::set intersect [tcl::dict::get $o_opts_table_effective -framelimits_body] $span_boxlimits_top] - set header_span_boxlimits [struct::set intersect [tcl::dict::get $o_opts_table_effective -framelimits_header] $span_boxlimits] - set header_span_boxlimits_top [struct::set intersect [tcl::dict::get $o_opts_table_effective -framelimits_header] $span_boxlimits_top] - if {$hrow == 0} { - set hlims $header_span_boxlimits_top - } else { - set hlims $header_span_boxlimits - } - - set this_span_map $span_extend_map - if {!$show_seps_v} { - set hlims [struct::set difference $hlims $next_headerseps_v] - } else { - if {[llength $next_spanlist]} { - set spanbelow [lindex $next_spanlist $spancol] - if {$spanbelow != 0} { - tcl::dict::set this_span_map blc [tcl::dict::get $framedef_headerdown_same hlbj] ;#horizontal line bottom with down join - to same frametype - } - } else { - #join to body - tcl::dict::set this_span_map blc [tcl::dict::get $framedef_headerdown_body hlbj] ;#horizontal line bottom with down join - from header frametype to body frametype - } - } - - if {$hrow == $hmax} { - set header_joins $span_joins_body - } else { - set header_joins $span_joins - } - if {![tcl::dict::get $o_opts_table -show_edge]} { - set hlims [struct::set difference $hlims [tcl::dict::get $::textblock::class::header_edge_parts $rowpos$next_posn] ] - } - - set contentwidth [my column_width $spancol] - set header_cell [textblock::frame -ellipsis 0 -width [expr {$contentwidth + 2}] -type [tcl::dict::get $ftypes header]\ - -ansibase $ansibase_header -ansiborder $ansiborder_final\ - -boxlimits $hlims -boxmap $this_span_map -joins $header_joins $hcell_blank\ - ] - lappend spanned_parts $header_cell - } else { - break - } - incr spancol - incr i - } - - #JMN - #spanned_parts are all built with textblock::frame - therefore uniform-width lines - can use join_basic - set spanned_frame [textblock::join_basic -- {*}$spanned_parts] - - if {$spans_to_rhs} { - if {$cidx == 0} { - set fake_posn solo - } else { - set fake_posn right - } - set x_limj [my Get_boxlimits_and_joins $fake_posn $fname_body] - if {$hrow == 0} { - set x_boxlimits_toprow [tcl::dict::get $x_limj boxlimits_top] - set hlims [struct::set intersect [tcl::dict::get $o_opts_table_effective -framelimits_header] $x_boxlimits_toprow] - } else { - set x_boxlimits_position [tcl::dict::get $x_limj boxlimits] - set hlims [struct::set intersect [tcl::dict::get $o_opts_table_effective -framelimits_header] $x_boxlimits_position] - } - } else { - if {$hrow == 0} { - set hlims $header_boxlimits_toprow - } else { - set hlims $header_boxlimits - } - } - if {!$show_seps_v} { - set hlims [struct::set difference $hlims $headerseps_v] - } - if {![tcl::dict::get $o_opts_table -show_edge]} { - if {$spans_to_rhs} { - #assert fake_posn has been set above based on cidx and spans_to_rhs - set hlims [struct::set difference $hlims [tcl::dict::get $::textblock::class::header_edge_parts ${rowpos}$fake_posn] ] - } else { - #use the edge_parts corresponding to the column being written to ie use opt_posn - set hlims [struct::set difference $hlims [tcl::dict::get $::textblock::class::header_edge_parts $rowpos$opt_posn] ] - } - } - - set spacemap [list hl " " vl " " tlc " " blc " " trc " " brc " "] ;#transparent overlay elements - #set spacemap [list hl * vl * tlc * blc * trc * brc *] - #-usecache 1 ok - #hval is not raw headerval - it has been padded to required width and has ansi applied - set hblock [textblock::frame -checkargs 0 -ellipsis 0 -type $spacemap -boxlimits $hlims -ansibase $ansibase_header $hval] ;#review -ansibase - #puts "==>boxlimits:'$hlims' hval_width:[tcl::string::length $hval] blockwidth:[textblock::width $hblock]" - #puts $hblock - #puts "==>hval:'$hval'[a]" - #puts "==>hval:'[ansistring VIEW $hval]'" - #set spanned_frame [overtype::renderspace -transparent 1 $spanned_frame $hblock] - - #spanned values default left - todo make configurable - - #TODO - #consider that currently blockaligning for spanned columns must always use the blockalign value from the starting column of the span - #we could conceivably have an override that could be set somehow with configure_header for customization of alignments of individual spans or span sizes? - #this seems like a likely requirement. The first spanned column may well have different alignment requirements than the span. - #(e.g if first spanned col happens to be numeric it probably warrants right textalign (if not blockalign) but we don't necessarily want the spanning header or even a non-spanning header to be right aligned) - - set spanned_frame [overtype::block -blockalign $col_blockalign -overflow 1 -transparent 1 $spanned_frame $hblock] - #POTENTIAL BUG (fixed with spans_to_rhs above) - #when -blockalign right and colspan extends to rhs - last char of longest of that spanlength will overlap right edge (if show_edge 1) - #we need to shift 1 to the left when doing our overtype with blockalign right - #we normally do this by using the hlims based on position - effectively we need a rhs position set of hlims for anything that colspans to the right edge - #(even though the column position may be left or inner) - - - - } else { - #this_span == 1 - set spanned_frame [textblock::join_basic -- $header_cell_startspan] - } - - - append part_header $spanned_frame - append part_header \n - } else { - #zero span header directly in this column ie one that is being colspanned by some column to our left - #previous col will already have built lines for this in it's own header rhs overhang - #we need a block of TSUB chars of the right height and width in this column so that we can join this column to the left ones with the TSUBs being transparent. - - #set padwidth [my column_datawidth $cidx -headers 0 -data 1 -cached 1] - - #if there are no header elements above then we will need a minimum of the column width - #may be extended to the widest portion of the header in the loop below - set padwidth [my column_width $cidx] - - - #under assumption we are building table using L frame method and that horizontal borders are only ever 1 high - # - we can avoid using a frame - but we potentially need to manually adjust for show_hpos show_edge etc - #avoiding frame here is faster.. but not by much (<10%? on textblock::spantest2 ) - if 0 { - #breaks -show_edge 0 - if {$rowpos eq "top" && [tcl::dict::get $o_opts_table -show_edge]} { - set padheight [expr {$rowh + 2}] - } else { - set padheight [expr {$rowh + 1}] - } - set bline [tcl::string::repeat $TSUB [expr {$padwidth +1}]] - set h_lines [lrepeat $padheight $bline] - set hcell_blank [::join $h_lines \n] - set header_frame $hcell_blank - } else { - set bline [tcl::string::repeat $TSUB $padwidth] - set h_lines [lrepeat $rowh $bline] - set hcell_blank [::join $h_lines \n] - # -usecache 1 ok - #frame borders will never display - so use the simplest frametype and don't apply any ansi - #puts "===>zerospan hlims: $hlims" - set header_frame [textblock::frame -checkargs 0 -ellipsis 0 -width [expr {$padwidth+2}] -type ascii\ - -boxlimits $hlims -boxmap $framesub_map $hcell_blank\ - ] - } - - append part_header $header_frame\n - - } - incr hrow - } - if {![llength $header_list]} { - #no headers - but we've been asked to show_header - #display a zero content-height header (ie outline if edge is being shown - or bottom bar) - set hlims $header_boxlimits_toprow - if {!$show_seps_v} { - set hlims [struct::set difference $hlims $headerseps_v] - } - if {![tcl::dict::get $o_opts_table -show_edge]} { - set hlims [struct::set difference $hlims [tcl::dict::get $::textblock::class::header_edge_parts only$opt_posn] ] - } - set header_joins $header_body_joins - set header_frame [textblock::frame -checkargs 0 -width [expr {$hcolwidth+2}] -type [tcl::dict::get $ftypes header]\ - -ansibase $ansibase_header -ansiborder $ansiborder_final\ - -boxlimits $hlims -boxmap $hdrmap -joins $header_joins\ - ] - append part_header $header_frame\n - } - set part_header [tcl::string::trimright $part_header \n] - lassign [textblock::size $part_header] _w return_headerwidth _h return_headerheight - - set padline [tcl::string::repeat $TSUB $return_headerwidth] - set adjusted_lines [list] - foreach ln [split $part_header \n] { - if {[tcl::string::first $TSUB $ln] >=0} { - lappend adjusted_lines $padline - } else { - lappend adjusted_lines $ln - } - } - set part_header [::join $adjusted_lines \n] - #append output $part_header \n - } - - set r 0 - set rmax [expr {[llength $cells]-1}] - - - set blims_mid $boxlimits - set blims_top $boxlimits - set blims_bot $boxlimits - set blims_top_headerless $boxlimits_headerless - set blims_only $boxlimits - set blims_only_headerless $boxlimits_headerless - if {!$show_seps_h} { - set blims_mid [struct::set difference $blims_mid $midseps_h] - set blims_top [struct::set difference $blims_top $topseps_h] - set blims_top_headerless [struct::set difference $blims_top_headerless $topseps_h] - } - if {!$show_seps_v} { - set blims_mid [struct::set difference $blims_mid $midseps_v] - set blims_top [struct::set difference $blims_top $topseps_v] - set blims_top_headerless [struct::set difference $blims_top_headerless $topseps_v] - set blims_bot [struct::set difference $blims_bot $botseps_v] - set blims_only [struct::set difference $blims_only $onlyseps_v] - set blims_only_headerless [struct::set difference $blims_only_headerless $onlyseps_v] - } - - set colidx [lindex [tcl::dict::keys $o_columndefs] $index_expression] ;#convert possible end-1,2+2 etc expression to >= 0 integer in dict range - - set opt_col_ansibase [tcl::dict::get $o_columndefs $colidx -ansibase] ;#ordinary merge of codes already done in configure_column - #set colwidth [my column_width $colidx] - - set body_ansibase [tcl::dict::get $o_opts_table -ansibase_body] - #set ansibase [punk::ansi::codetype::sgr_merge_singles [list $body_ansibase $opt_col_ansibase]] ;#allow col to override body - set body_ansiborder [tcl::dict::get $o_opts_table -ansiborder_body] - if {[tcl::dict::get $o_opts_table -frametype] eq "block"} { - #block is the only style where bg colour can fill the frame content area exactly if the L-shaped border elements are styled - #we need to only accept background ansi codes from the columndef ansibase for this - set col_bg [punk::ansi::codetype::sgr_merge_singles [list $opt_col_ansibase] -filter_fg 1] ;#special merge for block borders - don't override fg colours - set border_ansi $body_ansibase$body_ansiborder$col_bg - } else { - set border_ansi $body_ansibase$body_ansiborder - } - - - set r 0 - set ftblock [expr {[tcl::dict::get $o_opts_table -frametype] eq "block"}] - foreach c $cells { - #cells in column - each new c is in a different row - set row_ansibase [tcl::dict::get $o_rowdefs $r -ansibase] - set row_bg "" - if {$row_ansibase ne ""} { - set row_bg [punk::ansi::codetype::sgr_merge_singles [list $row_ansibase] -filter_fg 1] - } - - set ansibase $body_ansibase$opt_col_ansibase - #todo - joinleft,joinright,joindown based on opts in args - set cell_ansibase "" - - set ansiborder_body_col_row $border_ansi$row_bg - set ansiborder_final $ansiborder_body_col_row - #$c will always have ansi resets due to overtype behaviour ? - #todo - review overtype - if {[punk::ansi::ta::detect $c]} { - #use only the last ansi sequence in the cell value - #Filter out foreground and use background for ansiborder override - set parts [punk::ansi::ta::split_codes_single $c] - #we have detected ansi - so there will always be at least 3 parts beginning and ending with pt pt,ansi,pt,ansi...,pt - set codes [list] - foreach {pt cd} $parts { - if {$cd ne ""} { - lappend codes $cd - } - } - #set takebg [lindex $parts end-1] - #set cell_bg [punk::ansi::codetype::sgr_merge_singles [list $takebg] -filter_fg 1] - set cell_bg [punk::ansi::codetype::sgr_merge_singles $codes -filter_fg 1 -filter_reset 1] - #puts --->[ansistring VIEW $codes] - - if {[punk::ansi::codetype::is_sgr_reset [lindex $codes end]]} { - if {[punk::ansi::codetype::is_sgr_reset [lindex $codes end-1]]} { - #special case double reset at end of content - set cell_ansi_tail [punk::ansi::codetype::sgr_merge_singles $codes] ;#no filters - set ansibase "" - set row_ansibase "" - if {$ftblock} { - set ansiborder_final [punk::ansi::codetype::sgr_merge [list $ansiborder_body_col_row] -filter_bg 1] - } - set cell_ansibase $cell_ansi_tail - } else { - #single trailing reset in content - set cell_ansibase "" ;#cell doesn't contribute to frame's ansibase - } - } else { - if {$ftblock} { - #no resets - use cell's bg to extend to the border - only for block frames - set ansiborder_final $ansiborder_body_col_row$cell_bg - } - set cell_ansibase $cell_bg - } - } - - set ansibase_final $ansibase$row_ansibase$cell_ansibase - - if {$r == 0} { - if {$r == $rmax} { - set joins [lremove $joins [lsearch $joins down*]] - set bmap $onlymap - if {$do_show_header} { - set blims $blims_only - } else { - set blims $blims_only_headerless - } - if {![tcl::dict::get $o_opts_table -show_edge]} { - set blims [struct::set difference $blims [tcl::dict::get $::textblock::class::table_edge_parts only$opt_posn] ] - } - } else { - set bmap $topmap - if {$do_show_header} { - set blims $blims_top - } else { - set blims $blims_top_headerless - } - if {![tcl::dict::get $o_opts_table -show_edge]} { - set blims [struct::set difference $blims [tcl::dict::get $::textblock::class::table_edge_parts top$opt_posn] ] - } - } - set rowframe [textblock::frame -checkargs 0 -type [tcl::dict::get $ftypes body] -width [expr {$colwidth+2}] -blockalign $col_blockalign -ansibase $ansibase_final -ansiborder $ansiborder_final -boxlimits $blims -boxmap $bmap -joins $joins $c] - set return_bodywidth [textblock::widthtopline $rowframe] ;#frame lines always same width - just look at top line - append part_body $rowframe \n - } else { - if {$r == $rmax} { - set joins [lremove $joins [lsearch $joins down*]] - set bmap $botmap - set blims $blims_bot - if {![tcl::dict::get $o_opts_table -show_edge]} { - set blims [struct::set difference $blims [tcl::dict::get $::textblock::class::table_edge_parts bottom$opt_posn] ] - } - } else { - set bmap $midmap - set blims $blims_mid ;#will only be reduced from boxlimits if -show_seps was processed above - if {![tcl::dict::get $o_opts_table -show_edge]} { - set blims [struct::set difference $blims [tcl::dict::get $::textblock::class::table_edge_parts middle$opt_posn] ] - } - } - append part_body [textblock::frame -checkargs 0 -type [tcl::dict::get $ftypes body] -width [expr {$colwidth+2}] -blockalign $col_blockalign -ansibase $ansibase_final -ansiborder $ansiborder_final -boxlimits $blims -boxmap $bmap -joins $joins $c]\n - } - incr r - } - #return empty (zero content height) row if no rows - if {![llength $cells]} { - set joins [lremove $joins [lsearch $joins down*]] - #we need to know the width of the column to setup the empty cell properly - #even if no header displayed - we should take account of any defined column widths - set colwidth [my column_width $index_expression] - - if {$do_show_header} { - set blims $blims_only - } else { - append part_body \n - set blims $blims_only_headerless - } - #note that if show_edge is 0 - then for this empty line - we will not expect to see any bars - #This is because the frame with no data had vertical components made entirely of corner elements - #we could just append a newline when -show_edge is zero, but we want the correct width even when empty - for proper column joins when there are colspanned headers. - # - if {![tcl::dict::get $o_opts_table -show_edge]} { - #set blims [struct::set difference $blims [tcl::dict::get $::textblock::class::table_edge_parts only$opt_posn] ] - #append output [textblock::frame -width [expr {$colwidth + 2}] -type [tcl::dict::get $ftypes body] -boxlimits $blims -boxmap $onlymap -joins $joins]\n - append part_body [tcl::string::repeat " " $colwidth] \n - set return_bodywidth $colwidth - } else { - set emptyframe [textblock::frame -checkargs 0 -width [expr {$colwidth + 2}] -type [tcl::dict::get $ftypes body] -boxlimits $blims -boxmap $onlymap -joins $joins] - append part_body $emptyframe \n - set return_bodywidth [textblock::width $emptyframe] - } - } - #assert bodywidth is integer >=0 whether there are rows or not - - #trim only 1 newline - if {[tcl::string::index $part_body end] eq "\n"} { - set part_body [tcl::string::range $part_body 0 end-1] - } - set return_bodyheight [textblock::height $part_body] - #append output $part_body - - if {$opt_return eq "string"} { - if {$part_header ne ""} { - set output $part_header - if {$part_body ne ""} { - append output \n $part_body - } - } else { - set output $part_body - } - return $output - } else { - return [tcl::dict::create header $part_header body $part_body headerwidth $return_headerwidth headerheight $return_headerheight bodywidth $return_bodywidth bodyheight $return_bodyheight] - } - } - - method get_column_cells_by_index {index_expression} { - #*** !doctools - #[call class::table [method get_column_cells_by_index] [arg index_expression]] - #[para] Return a dict with keys 'headers' and 'cells' giving column header and data values - - set cidx [lindex [tcl::dict::keys $o_columndefs] $index_expression] - if {$cidx eq ""} { - set range "" - if {[tcl::dict::size $o_columndefs] > 0} { - set range "0..[expr {[tcl::dict::size $o_columndefs] -1}]" - } else { - set range empty - } - error "table::get_column_cells_by_index no such index $index_expression. Valid range is $range" - } - #assert cidx is integer >=0 - set num_header_rows [my header_count] - set cdef [tcl::dict::get $o_columndefs $cidx] - set headerlist [tcl::dict::get $cdef -headers] - set ansibase_col [tcl::dict::get $cdef -ansibase] - set textalign [tcl::dict::get $cdef -textalign] - switch -- $textalign { - left {set pad right} - right {set pad left} - default { - set pad "centre" ;#todo? - } - } - - #set ansibase_body [tcl::dict::get $o_opts_table -ansibase_body] - #set ansibase_header [tcl::dict::get $o_opts_table -ansibase_header] - - #set header_underlay $ansibase_header$cell_line_blank - - #set hdrwidth [my column_width_configured $cidx] - #set all_colspans [my header_colspans] - #we need to replace the 'any' entries with their actual span lengths before passing any -colspan values to column_datawidth - hence use header_colspans_numeric - set all_colspans [my header_colspans_numeric] - #JMN - #store configured widths so we don't look up for each header line - #set configured_widths [list] - #foreach c [tcl::dict::keys $o_columndefs] { - # #lappend configured_widths [my column_width $c] - # #we don't just want the width of the column in the body - or the headers will get truncated - # lappend configured_widths [my column_width_configured $c] - #} - - set output [tcl::dict::create] - tcl::dict::set output headers [list] - - set showing_vseps [my Showing_vseps] - for {set hrow 0} {$hrow < $num_header_rows} {incr hrow} { - set hdr [lindex $headerlist $hrow] - #jjj - set header_maxdataheight [tcl::dict::get $o_headerstates $hrow maxheightseen] - #set header_maxdataheight [my header_height $hrow] ;#from cached headerstates - set headerdefminh [tcl::dict::get $o_headerdefs $hrow -minheight] - set headerdefmaxh [tcl::dict::get $o_headerdefs $hrow -maxheight] - if {"$headerdefminh$headerdefmaxh" ne "" && $headerdefminh eq $headerdefmaxh} { - set headerh $headerdefminh ;#exact height defined for the row - } else { - if {$headerdefminh eq ""} { - if {$headerdefmaxh eq ""} { - #both defs empty - set headerh $header_maxdataheight - } else { - set headerh [expr {min(1,$headerdefmaxh,$header_maxdataheight)}] - } - } else { - if {$headerdefmaxh eq ""} { - set headerh [expr {max($headerdefminh,$header_maxdataheight)}] - } else { - if {$header_maxdataheight < $headerdefminh} { - set headerh $headerdefminh - } else { - set headerh [expr {max($headerdefminh,$header_maxdataheight)}] - } - } - } - } - - - set headerrow_colspans [tcl::dict::get $all_colspans $hrow] - set this_span [lindex $headerrow_colspans $cidx] - - #set this_hdrwidth [lindex $configured_widths $cidx] - set this_hdrwidth [my column_datawidth $cidx -headers 1 -colspan $this_span -cached 1] ;#widest of headers in this col with same span - allows textalign to work with blockalign - - set hcell_line_blank [tcl::string::repeat " " $this_hdrwidth] - set hcell_lines [lrepeat $header_maxdataheight $hcell_line_blank] - set hval_lines [split $hdr \n] - #jmn concat - #set hval_lines [concat $hval_lines $hcell_lines] - set hval_lines [list {*}$hval_lines {*}$hcell_lines] - set hval_lines [lrange $hval_lines 0 $header_maxdataheight-1] ;#vertical align top - set hval_block [::join $hval_lines \n] - set hcell [textblock::pad $hval_block -width $this_hdrwidth -padchar " " -within_ansi 1 -which $pad] - tcl::dict::lappend output headers $hcell - } - - - #set colwidth [my column_width $cidx] - #set cell_line_blank [tcl::string::repeat " " $colwidth] - set datawidth [my column_datawidth $cidx -headers 0 -footers 0 -data 1 -cached 1] - set cell_line_blank [tcl::string::repeat " " $datawidth] - - - - set items [tcl::dict::get $o_columndata $cidx] - #puts "---> columndata $o_columndata" - - #set opt_row_ansibase [tcl::dict::get $o_rowdefs $r -ansibase] - #set cell_ansibase $ansibase_body$ansibase_col$opt_row_ansibase - - tcl::dict::set output cells [list];#ensure we return something for cells key if no items in list - set r 0 - foreach cval $items { - #todo move to row_height method ? - set maxdataheight [tcl::dict::get $o_rowstates $r -maxheight] - set rowdefminh [tcl::dict::get $o_rowdefs $r -minheight] - set rowdefmaxh [tcl::dict::get $o_rowdefs $r -maxheight] - if {"$rowdefminh$rowdefmaxh" ne "" && $rowdefminh eq $rowdefmaxh} { - set rowh $rowdefminh ;#an exact height is defined for the row - } else { - if {$rowdefminh eq ""} { - if {$rowdefmaxh eq ""} { - #both defs empty - set rowh $maxdataheight - } else { - set rowh [expr {min(1,$rowdefmaxh,$maxdataheight)}] - } - } else { - if {$rowdefmaxh eq ""} { - set rowh [expr {max($rowdefminh,$maxdataheight)}] - } else { - if {$maxdataheight < $rowdefminh} { - set rowh $rowdefminh - } else { - set rowh [expr {max($rowdefminh,$maxdataheight)}] - } - } - } - } - - set cell_lines [lrepeat $rowh $cell_line_blank] - #set cell_blank [join $cell_lines \n] - - - set cval_lines [split $cval \n] - #jmn - #set cval_lines [concat $cval_lines $cell_lines] - lappend cval_lines {*}$cell_lines - set cval_lines [lrange $cval_lines 0 $rowh-1] - set cval_block [::join $cval_lines \n] - - #//JMN assert widest cval_line = datawidth = known_blockwidth - set cell [textblock::pad $cval_block -known_blockwidth $datawidth -width $datawidth -padchar " " -within_ansi 1 -which $pad] - #set cell [textblock::pad $cval_block -width $colwidth -padchar " " -within_ansi 0 -which left] - tcl::dict::lappend output cells $cell - - incr r - } - return $output - } - method get_column_values_by_index {index_expression} { - #*** !doctools - #[call class::table [method get_column_values_by_index] [arg index_expression]] - #[para] List the cell values of a column from the data area only (no header values) - - set cidx [lindex [tcl::dict::keys $o_columndefs] $index_expression] - if {$cidx eq ""} { - return - } - return [tcl::dict::get $o_columndata $cidx] - } - method debug {args} { - #*** !doctools - #[call class::table [method debug]] - #[para] display lots of debug information about how the table is constructed. - - #nice to lay this out with tables - but this is the one function where we really should provide the ability to avoid tables in case things get really broken (e.g major refactor) - set defaults [tcl::dict::create\ - -usetables 1\ - ] - foreach {k v} $args { - switch -- $k { - -usetables {} - default { - error "table debug unrecognised option '$k'. Known options: [tcl::dict::keys $defaults]" - } - } - } - set opts [tcl::dict::merge $defaults $args] - set opt_usetables [tcl::dict::get $opts -usetables] - - puts stdout "rowdefs: $o_rowdefs" - puts stdout "rowstates: $o_rowstates" - #puts stdout "columndefs: $o_columndefs" - puts stdout "columndefs:" - if {!$opt_usetables} { - tcl::dict::for {k v} $o_columndefs { - puts " $k $v" - } - } else { - set t [textblock::class::table new] - $t add_column -headers "Col" - tcl::dict::for {col coldef} $o_columndefs { - foreach property [tcl::dict::keys $coldef] { - if {$property eq "-ansireset"} { - continue - } - $t add_column -headers $property - } - break - } - - #build our inner tables first so we can sync widths - set col_header_tables [tcl::dict::create] - set max_widths [tcl::dict::create 0 0 1 0 2 0 3 0] ;#max inner table column widths - tcl::dict::for {col coldef} $o_columndefs { - set row [list $col] - set colheaders [tcl::dict::get $coldef -headers] - #inner table probably overkill here ..but just as easy - set htable [textblock::class::table new] - $htable configure -show_header 1 -show_edge 0 -show_hseps 0 - $htable add_column -headers row - $htable add_column -headers text - $htable add_column -headers WxH - $htable add_column -headers span - set hnum 0 - set spans [tcl::dict::get $o_columndefs $col -header_colspans] - foreach h $colheaders s $spans { - lassign [textblock::size $h] _w width _h height - $htable add_row [list "$hnum " $h "${width}x${height}" $s] - incr hnum - } - $htable configure_column 0 -ansibase [a+ web-dimgray] - tcl::dict::set col_header_tables $col $htable - set colwidths [$htable column_widths] - set icol 0 - foreach w $colwidths { - if {$w > [tcl::dict::get $max_widths $icol]} { - tcl::dict::set max_widths $icol $w - } - incr icol - } - } - - #safe jumptable test - #dict for {col coldef} $o_columndefs {} - tcl::dict::for {col coldef} $o_columndefs { - set row [list $col] - #safe jumptable test - #dict for {property val} $coldef {} - tcl::dict::for {property val} $coldef { - switch -- $property { - -ansireset {continue} - -headers { - set htable [tcl::dict::get $col_header_tables $col] - tcl::dict::for {innercol maxw} $max_widths { - $htable configure_column $innercol -minwidth $maxw -blockalign left - } - lappend row [$htable print] - $htable destroy - } - default { - lappend row $val - } - } - } - $t add_row $row - } - - - - - $t configure -show_header 1 - puts stdout [$t print] - $t destroy - } - puts stdout "columnstates: $o_columnstates" - puts stdout "headerdefs: $o_headerdefs" - puts stdout "headerstates: $o_headerstates" - tcl::dict::for {k coldef} $o_columndefs { - if {[tcl::dict::exists $o_columndata $k]} { - set headerlist [tcl::dict::get $coldef -headers] - set coldata [tcl::dict::get $o_columndata $k] - set colinfo "rowcount: [llength $coldata]" - set allfields [concat $headerlist $coldata] - if {[llength $allfields]} { - set widest [tcl::mathfunc::max {*}[lmap v $allfields {textblock::width $v}]] - } else { - set widest 0 - } - append colinfo " widest of headers and data: $widest" - } else { - set colinfo "WARNING - no columndata record for column key '$k'" - } - puts stdout "column $k columndata info: $colinfo" - } - set result "" - set cols [list] - set max [expr {[tcl::dict::size $o_columndefs]-1}] - foreach c [tcl::dict::keys $o_columndefs] { - if {$c == 0} { - lappend cols [my get_column_by_index $c -position left] " " - } elseif {$c == $max} { - lappend cols [my get_column_by_index $c -position right] - } else { - lappend cols [my get_column_by_index $c -position inner] " " - } - } - append result [textblock::join -- {*}$cols] - return $result - } - #column width including headers - but without colspan consideration - method column_width_configured {index_expression} { - set cidx [lindex [tcl::dict::keys $o_columndefs] $index_expression] - if {$cidx eq ""} { - return - } - #assert cidx is now >=0 integer within the range of defined columns - set cdef [tcl::dict::get $o_columndefs $cidx] - set defminw [tcl::dict::get $cdef -minwidth] - set defmaxw [tcl::dict::get $cdef -maxwidth] - if {"$defminw$defmaxw" ne "" && $defminw eq $defmaxw} { - #an exact width is defined for the column - no need to look at data width - set colwidth $defminw - } else { - #set widest [my column_datawidth $cidx -headers 1 -data 1 -footers 1] - set hwidest [tcl::dict::get $o_columnstates $cidx maxwidthheaderseen] - #set hwidest [my column_datawidth $cidx -headers 1 -colspan 1 -data 0 -footers 1] - #set hwidest_singlespan ?? - set bwidest [tcl::dict::get $o_columnstates $cidx maxwidthbodyseen] - set widest [expr {max($hwidest,$bwidest)}] - #todo - predetermine if any items in column contain newlines and are truncated vertically due to o_rowdefs configuration. - #if so - a truncated line shouldn't be included in our width calculation - if {$defminw eq ""} { - if {$defmaxw eq ""} { - set colwidth $widest - } else { - set colwidth [expr {min($defmaxw,$widest)}] - } - } else { - if {$defmaxw eq ""} { - set colwidth [expr {max($defminw,$widest)}] - } else { - if {$widest < $defminw} { - set colwidth $defminw - } else { - if {$widest > $defmaxw} { - set colwidth $defmaxw - } else { - set colwidth [expr {max($defminw,$widest)}] - } - } - } - } - } - return $colwidth - } - - method column_width {index_expression} { - #*** !doctools - #[call class::table [method column_width] [arg index_expression]] - #[para] inner width of column ie the available cell-width without borders/separators - - if {[llength $o_calculated_column_widths] != [tcl::dict::size $o_columndefs]} { - my calculate_column_widths -algorithm $o_column_width_algorithm - } - return [lindex $o_calculated_column_widths $index_expression] - } - method column_widths {} { - #*** !doctools - #[call class::table [method column_width]] - #[para] ordered list of column widths (inner widths) - - if {[llength $o_calculated_column_widths] != [tcl::dict::size $o_columndefs]} { - my calculate_column_widths -algorithm $o_column_width_algorithm - } - return $o_calculated_column_widths - } - - #width of a table includes borders and seps - #whereas width of a column refers to the borderless width (inner width) - method width {} { - #*** !doctools - #[call class::table [method width]] - #[para] width of the table including borders and separators - #[para] calculate width based on assumption frame verticals are 1 screen-column wide - #[para] (review - consider possibility of custom unicode double-wide frame?) - - set colwidths [my column_widths] - set contentwidth [tcl::mathop::+ {*}$colwidths] - set twidth $contentwidth - if {[my Showing_vseps]} { - incr twidth [llength $colwidths] - incr twidth -1 - } - if {[tcl::dict::get $o_opts_table -show_edge]} { - incr twidth 2 - } - return $twidth - } - - #column *body* content width - method basic_column_width {index_expression} { - set cidx [lindex [tcl::dict::keys $o_columndefs] $index_expression] - if {$cidx eq ""} { - return - } - #puts "===column_width $index_expression" - #assert cidx is now >=0 integer within the range of defined columns - set cdef [tcl::dict::get $o_columndefs $cidx] - set defminw [tcl::dict::get $cdef -minwidth] - set defmaxw [tcl::dict::get $cdef -maxwidth] - if {"$defminw$defmaxw" ne "" && $defminw eq $defmaxw} { - #an exact width is defined for the column - no need to look at data width - #review - this can result in truncation of spanning headers - even though there is enough width in the span-cell to place the full header - set colwidth $defminw - } else { - #set widest [my column_datawidth $cidx -headers 0 -data 1 -footers 0] - set widest [tcl::dict::get $o_columnstates $cidx maxwidthbodyseen] - #todo - predetermine if any items in column contain newlines and are truncated vertically due to o_rowdefs configuration. - #if so - a truncated line shouldn't be included in our width calculation - if {$defminw eq ""} { - if {$defmaxw eq ""} { - set colwidth $widest - } else { - set colwidth [expr {min($defmaxw,$widest)}] - } - } else { - if {$defmaxw eq ""} { - set colwidth [expr {max($defminw,$widest)}] - } else { - if {$widest < $defminw} { - set colwidth $defminw - } else { - if {$widest > $defmaxw} { - set colwidth $defmaxw - } else { - set colwidth [expr {max($defminw,$widest)}] - } - } - } - } - } - set configured_widths [list] - foreach c [tcl::dict::keys $o_columndefs] { - lappend configured_widths [my column_width_configured $c] - } - set header_colspans [my header_colspans] - set width_max $colwidth - set test_width $colwidth - set showing_vseps [my Showing_vseps] - set thiscol_widest_header [tcl::dict::get $o_columnstates $cidx maxwidthheaderseen] - tcl::dict::for {h colspans} $header_colspans { - set spanc [lindex $colspans $cidx] - #set headers [tcl::dict::get $cdef -headers] - #set thiscol_widest_header 0 - #if {[llength $headers] > 0} { - # set thiscol_widest_header [tcl::mathfunc::max {*}[lmap v $headers {textblock::width $v}]] - #} - if {$spanc eq "1"} { - if {$thiscol_widest_header > $colwidth} { - set test_width [expr {max($thiscol_widest_header,$colwidth)}] - if {$defmaxw ne ""} { - set test_width [expr {min($colwidth,$defmaxw)}] - } - } - set width_max [expr {max($test_width,$width_max)}] - continue - } - if {$spanc eq "any" || $spanc > 1} { - set spanned [list] ;#spanned is other columns spanned - not including this one - set cnext [expr {$cidx +1}] - set spanlength [lindex $colspans $cnext] - while {$spanlength eq "0" && $cnext < [llength $colspans]} { - lappend spanned $cnext - incr cnext - set spanlength [lindex $colspans $cnext] - } - set others_width 0 - foreach col $spanned { - incr others_width [lindex $configured_widths $col] - if {$showing_vseps} { - incr others_width 1 - } - } - set total_spanned_width [expr {$width_max + $others_width}] - if {$thiscol_widest_header > $total_spanned_width} { - #this just allocates the extra space in the current column - which is not great. - #A proper algorithm for distributing width created by headers to all the spanned columns is needed. - #This is a tricky problem with multiple header lines and arbitrary spans. - #The calculation should probably be done on the table as a whole first and this function should just look up that result. - #Trying to calculate on a specific column only is unlikely to be easy or efficient. - set needed [expr {$thiscol_widest_header - $total_spanned_width}] - #puts "-->>col $cidx needed ($thiscol_widest_header - $total_spanned_width): $needed (spanned $spanned)" - if {$defmaxw ne ""} { - set test_width [expr {min($colwidth+$needed,$defmaxw)}] - } else { - set test_width [expr {$colwidth + $needed}] - } - } - } - set width_max [expr {max($test_width,$width_max)}] - } - - #alternative to all the above shennanigans.. let the body cell data determine the size and just wrap the headers - #could also split the needed width amongst the spanned columns? configurable for whether cells expand? - set expand_first_column 1 - if {$expand_first_column} { - set colwidth $width_max - } - - #puts "---column_width $cidx = $colwidth" - return $colwidth - } - method Showing_vseps {} { - #review - show_seps and override mechanism for show_vseps show_hseps - document. - set seps [tcl::dict::get $o_opts_table -show_seps] - set vseps [tcl::dict::get $o_opts_table -show_vseps] - if {$seps eq ""} { - if {$vseps eq "" || $vseps} { - return true - } - } elseif {$seps} { - if {$vseps eq "" || $vseps} { - return true - } - } else { - if {$vseps ne "" && $vseps} { - return true - } - } - return false - } - - method column_datawidth {index_expression args} { - set opts [tcl::dict::create\ - -headers 0\ - -footers 0\ - -colspan unspecified\ - -data 1\ - -cached 1\ - ] - #NOTE: -colspan any is not the same as * - # - #-colspan is relevant to header/footer data only - foreach {k v} $args { - switch -- $k { - -headers - -footers - -colspan - -data - -cached { - tcl::dict::set opts $k $v - } - default { - error "column_datawidth unrecognised flag '$k'. Known flags: [tcl::dict::keys $opts]" - } - } - } - set opt_colspan [tcl::dict::get $opts -colspan] - switch -- $opt_colspan { - * - unspecified {} - any { - error "method column_datawidth invalid -colspan '$opt_colspan' must be * or an integer >= 0 (use header_colspans_numeric to get actual spans)" - } - default { - if {![string is integer -strict $opt_colspan]} { - error "method column_datawidth invalid -colspan '$opt_colspan' must be * or an integer >= 0" - } - } - } - - - set cidx [lindex [tcl::dict::keys $o_columndefs] $index_expression] - if {$cidx eq ""} { - return - } - - if {[tcl::dict::get $opts -cached]} { - set hwidest 0 - set bwidest 0 - set fwidest 0 - if {[tcl::dict::get $opts -headers]} { - if {$opt_colspan in {* unspecified}} { - set hwidest [tcl::dict::get $o_columnstates $cidx maxwidthheaderseen] - } else { - #this is not cached - # -- --- --- --- - set colheaders [tcl::dict::get $o_columndefs $cidx -headers] - set all_colspans_by_header [my header_colspans_numeric] - set hlist [list] - tcl::dict::for {hrow cspans} $all_colspans_by_header { - set s [lindex $cspans $cidx] - if {$s eq $opt_colspan} { - lappend hlist [lindex $colheaders $hrow] - } - } - if {[llength $hlist]} { - set hwidest [tcl::mathfunc::max {*}[lmap v $hlist {textblock::width $v}]] - } else { - set hwidest 0 - } - # -- --- --- --- - } - } - if {[tcl::dict::get $opts -data]} { - set bwidest [tcl::dict::get $o_columnstates $cidx maxwidthbodyseen] - } - if {[tcl::dict::get $opts -footers]} { - #TODO! - #set bwidest [tcl::dict::get $o_columnstates $cidx maxwidthfooterseen] - } - return [expr {max($hwidest,$bwidest,$fwidest)}] - } - - #assert cidx is >=0 integer in valid range of keys for o_columndefs - set values [list] - set hwidest 0 - if {[tcl::dict::get $opts -headers]} { - if {$opt_colspan in {* unspecified}} { - lappend values {*}[tcl::dict::get $o_columndefs $cidx -headers] - } else { - # -- --- --- --- - set colheaders [tcl::dict::get $o_columndefs $cidx -headers] - set all_colspans_by_header [my header_colspans_numeric] - set hlist [list] - tcl::dict::for {hrow cspans} $all_colspans_by_header { - set s [lindex $cspans $cidx] - if {$s eq $opt_colspan} { - lappend hlist [lindex $colheaders $hrow] - } - } - if {[llength $hlist]} { - set hwidest [tcl::mathfunc::max {*}[lmap v $hlist {textblock::width $v}]] - } else { - set hwidest 0 - } - # -- --- --- --- - } - } - if {[tcl::dict::get $opts -data]} { - if {[tcl::dict::exists $o_columndata $cidx]} { - lappend values {*}[tcl::dict::get $o_columndata $cidx] - } - } - if {[tcl::dict::get $opts -footers]} { - lappend values {*}[tcl::dict::get $o_columndefs $cidx -footers] - } - if {[llength $values]} { - set valwidest [tcl::mathfunc::max {*}[lmap v $values {textblock::width $v}]] - set widest [expr {max($valwidest,$hwidest)}] - } else { - set widest $hwidest - } - return $widest - } - #print1 uses basic column joining - useful for testing/debug especially with colspans - method print1 {args} { - if {![llength $args]} { - set cols [tcl::dict::keys $o_columndata] - } else { - set cols [list] - foreach colspec $args { - set allcols [tcl::dict::keys $o_columndata] - if {[tcl::string::first .. $colspec] >=0} { - set parts [punk::ansi::ta::_perlish_split {\.\.} $colspec] - if {[llength $parts] != 3} { - error "[namespace::current]::table error invalid print specification '$colspec'" - } - lassign $parts from _dd to - if {$from eq ""} {set from 0 } - if {$to eq ""} {set to end} - - set indices [lrange $allcols $from $to] - lappend cols {*}$indices - } else { - set c [lindex $allcols $colspec] - if {$c ne ""} { - lappend cols $c - } - } - } - } - set blocks [list] - set colposn 0 - set numposns [llength $cols] - foreach c $cols { - set flags [list] - if {$colposn == 0 && $colposn == $numposns-1} { - set flags [list -position solo] - } elseif {$colposn == 0} { - set flags [list -position left] - } elseif {$colposn == $numposns-1} { - set flags [list -position right] - } else { - set flags [list -position inner] - } - lappend blocks [my get_column_by_index $c {*}$flags] - incr colposn - } - if {[llength $blocks]} { - return [textblock::join -- {*}$blocks] - } else { - return "No columns matched" - } - } - method columncalc_spans {allocmethod} { - set colwidths [tcl::dict::create] ;# to use tcl::dict::incr - set colspace_added [tcl::dict::create] - - set ordered_spans [tcl::dict::create] - tcl::dict::for {col spandata} [my spangroups] { - set dwidth [my column_datawidth $col -data 1 -headers 0 -footers 0 -cached 1] - set minwidth [tcl::dict::get $o_columndefs $col -minwidth] - set maxwidth [tcl::dict::get $o_columndefs $col -maxwidth] - if {$minwidth ne ""} { - if {$dwidth < $minwidth} { - set dwidth $minwidth - } - } - if {$maxwidth ne ""} { - if {$dwidth > $maxwidth} { - set dwidth $maxwidth - } - } - tcl::dict::set colwidths $col $dwidth ;#spangroups is ordered by column - so colwidths dict will be correctly ordered - tcl::dict::set colspace_added $col 0 - - set spanlengths [tcl::dict::get $spandata spanlengths] - foreach slen $spanlengths { - set spans [tcl::dict::get $spandata spangroups $slen] - set spans [lsort -index 7 -integer $spans] - foreach s $spans { - set hwidth [tcl::dict::get $s headerwidth] - set hrow [tcl::dict::get $s hrow] - set scol [tcl::dict::get $s startcol] - tcl::dict::set ordered_spans $scol,$hrow membercols $col $dwidth - tcl::dict::set ordered_spans $scol,$hrow headerwidth $hwidth - } - } - } - - #safe jumptable test - #dict for {spanid spandata} $ordered_spans {} - tcl::dict::for {spanid spandata} $ordered_spans { - lassign [split $spanid ,] startcol hrow - set memcols [tcl::dict::get $spandata membercols] ;#dict with col and initial width - we ignore initial width, it's there in case we want to allocate space based on initial data width ratios - set colids [tcl::dict::keys $memcols] - set hwidth [tcl::dict::get $spandata headerwidth] - set num_cols_spanned [tcl::dict::size $memcols] - if {$num_cols_spanned == 1} { - set col [lindex $memcols 0] - set space_to_alloc [expr {$hwidth - [tcl::dict::get $colwidths $col]}] - if {$space_to_alloc > 0} { - set maxwidth [tcl::dict::get $o_columndefs $col -maxwidth] - if {$maxwidth ne ""} { - if {$maxwidth > [tcl::dict::get $colwidths $col]} { - set can_alloc [expr {$maxwidth - [tcl::dict::get $colwidths $col]}] - } else { - set can_alloc 0 - } - set will_alloc [expr {min($space_to_alloc,$can_alloc)}] - } else { - set will_alloc $space_to_alloc - } - if {$will_alloc} { - #tcl::dict::set colwidths $col $hwidth - tcl::dict::incr colwidths $col $will_alloc - tcl::dict::set colspace_added $col $will_alloc - } - #log! - #if {$will_alloc < $space_to_alloc} { - # #todo - debug only - # puts stderr "max width $maxwidth hit for col $col - cannot allocate extra [expr {$space_to_alloc - $will_alloc}]" - #} - } - } elseif {$num_cols_spanned > 1} { - set spannedwidth 0 - foreach col $colids { - incr spannedwidth [tcl::dict::get $colwidths $col] - } - set space_to_alloc [expr {$hwidth - $spannedwidth}] - if {[my Showing_vseps]} { - set sepcount [expr {$num_cols_spanned -1}] - incr space_to_alloc -$sepcount - } - #review - we want to reduce overallocation to earlier or later columns - hence the use of colspace_added - switch -- $allocmethod { - least { - #add to least-expanded each time - #safer than method 1 - pretty balanced - if {$space_to_alloc > 0} { - for {set i 0} {$i < $space_to_alloc} {incr i} { - set ordered_colspace_added [lsort -stride 2 -index 1 -integer $colspace_added] - set ordered_all_colids [tcl::dict::keys $ordered_colspace_added] - foreach testcolid $ordered_all_colids { - if {$testcolid in $colids} { - #assert - we will always find a match - set colid $testcolid - break - } - } - tcl::dict::incr colwidths $colid - tcl::dict::incr colspace_added $colid - } - } - } - least_unmaxed { - #TODO - fix header truncation/overflow issues when they are restricted by column maxwidth - #(we should be able to collapse column width to zero and have header colspans gracefully respond) - #add to least-expanded each time - #safer than method 1 - pretty balanced - if {$space_to_alloc > 0} { - for {set i 0} {$i < $space_to_alloc} {incr i} { - set ordered_colspace_added [lsort -stride 2 -index 1 -integer $colspace_added] - set ordered_all_colids [tcl::dict::keys $ordered_colspace_added] - set colid "" - foreach testcolid $ordered_all_colids { - set maxwidth [tcl::dict::get $o_columndefs $testcolid -maxwidth] - set can_alloc [expr {$maxwidth eq "" || $maxwidth > [tcl::dict::get $colwidths $testcolid]}] - if {$testcolid in $colids} { - if {$can_alloc} { - set colid $testcolid - break - } else { - #remove from future consideration in for loop - #log! - #puts stderr "max width $maxwidth hit for col $testcolid" - tcl::dict::unset colspace_added $testcolid - } - } - } - if {$colid ne ""} { - tcl::dict::incr colwidths $colid - tcl::dict::incr colspace_added $colid - } - } - } - } - all { - #adds space to all columns - not just those spanned - risk of underallocating and truncating some headers! - #probably not a good idea for tables with complex headers and spans - while {$space_to_alloc > 0} { - set ordered_colspace_added [lsort -stride 2 -index 1 -integer $colspace_added] - set ordered_colids [tcl::dict::keys $ordered_colspace_added] - - foreach col $ordered_colids { - tcl::dict::incr colwidths $col - tcl::dict::incr colspace_added $col - incr space_to_alloc -1 - if {$space_to_alloc == 0} { - break - } - } - } - - } - } - } - } - - set column_widths [tcl::dict::values $colwidths] - #todo - -maxwidth etc - set table_minwidth [tcl::dict::get $o_opts_table -minwidth] ;#min width including frame elements - if {[tcl::string::is integer -strict $table_minwidth]} { - set contentwidth [tcl::mathop::+ {*}$column_widths] - set twidth $contentwidth - if {[my Showing_vseps]} { - incr twidth [llength $column_widths] - incr twidth -1 - } - if {[tcl::dict::get $o_opts_table -show_edge]} { - incr twidth 2 - } - # - set shortfall [expr {$table_minwidth - $twidth}] - if {$shortfall > 0} { - set space_to_alloc $shortfall - while {$space_to_alloc > 0} { - set ordered_colspace_added [lsort -stride 2 -index 1 -integer $colspace_added] - set ordered_colids [tcl::dict::keys $ordered_colspace_added] - - foreach col $ordered_colids { - tcl::dict::incr colwidths $col - tcl::dict::incr colspace_added $col - incr space_to_alloc -1 - if {$space_to_alloc == 0} { - break - } - } - } - set column_widths [tcl::dict::values $colwidths] - } - - } - - return [list ordered_spans $ordered_spans colwidths $column_widths adjustments $colspace_added] - } - - #spangroups keyed by column - method spangroups {} { - #*** !doctools - #[call class::table [method spangroups]] - #[para] return a dict keyed by column-index showing advanced span information - #[para] (debug tool) - - set column_count [tcl::dict::size $o_columndefs] - set spangroups [tcl::dict::create] - set headerwidths [tcl::dict::create] ;#key on col,hrow - foreach c [tcl::dict::keys $o_columndefs] { - tcl::dict::set spangroups $c [list spanlengths {}] - set spanlist [my column_get_spaninfo $c] - set index_spanlen_val 5 - set spanlist [lsort -index $index_spanlen_val -integer $spanlist] - set ungrouped $spanlist - - while {[llength $ungrouped]} { - set spanlen [lindex $ungrouped 0 $index_spanlen_val] - set spangroup_posns [lsearch -all -index $index_spanlen_val $ungrouped $spanlen] - set sgroup [list] - foreach p $spangroup_posns { - set spaninfo [lindex $ungrouped $p] - set hcol [tcl::dict::get $spaninfo startcol] - set hrow [tcl::dict::get $spaninfo hrow] - set header [lindex [tcl::dict::get $o_columndefs $hcol -headers] $hrow] - if {[tcl::dict::exists $headerwidths $hcol,$hrow]} { - set hwidth [tcl::dict::get $headerwidths $hcol,$hrow] - } else { - set hwidth [textblock::width $header] - tcl::dict::set headerwidths $hcol,$hrow $hwidth - } - lappend spaninfo headerwidth $hwidth - lappend sgroup $spaninfo - } - set spanlengths [tcl::dict::get $spangroups $c spanlengths] - lappend spanlengths $spanlen - tcl::dict::set spangroups $c spanlengths $spanlengths - tcl::dict::set spangroups $c spangroups $spanlen $sgroup - set ungrouped [lremove $ungrouped {*}$spangroup_posns] - } - } - return $spangroups - } - method column_get_own_spans {cidx} { - set colspans_for_column [tcl::dict::get $o_columndefs $cidx -header_colspans] - } - method column_get_spaninfo {cidx} { - set spans_by_header [my header_colspans] - set colspans_for_column [tcl::dict::get $o_columndefs $cidx -header_colspans] - set spaninfo [list] - set numcols [tcl::dict::size $o_columndefs] - #note that 'any' can occur in positions other than column 0 - meaning any remaining until next non-zero span - tcl::dict::for {hrow rawspans} $spans_by_header { - set thiscol_spanval [lindex $rawspans $cidx] - if {$thiscol_spanval eq "any" || $thiscol_spanval > 0} { - set spanstartcol $cidx ;#own column - if {$thiscol_spanval eq "any"} { - #scan right to first non-zero to get actual length of 'any' span - #REVIEW! - set spanlen 1 - for {set i [expr {$cidx+1}]} {$i < $numcols} {incr i} { - #abort at next any or number or empty string - if {[lindex $rawspans $i] ne "0"} { - break - } - incr spanlen - } - #set spanlen [expr {$numcols - $cidx}] - } else { - set spanlen $thiscol_spanval - } - } else { - #look left til we see an any or a non-zero value - for {set i $cidx} {$i > -1} {incr i -1} { - set s [lindex $rawspans $i] - if {$s eq "any" || $s > 0} { - set spanstartcol $i - if {$s eq "any"} { - #REVIEW! - #set spanlen [expr {$numcols - $i}] - set spanlen 1 - #now scan right to see how long the 'any' actually is - for {set j [expr {$i+1}]} {$j < $numcols} {incr j} { - if {[lindex $rawspans $j] ne "0"} { - break - } - incr spanlen - } - } else { - set spanlen $s - } - break - } - } - } - #assert - we should always find 1 answer for each header row - lappend spaninfo [list hrow $hrow startcol $spanstartcol spanlen $spanlen] - } - return $spaninfo - } - method calculate_column_widths {args} { - set column_count [tcl::dict::size $o_columndefs] - - set opts [tcl::dict::create\ - -algorithm $o_column_width_algorithm\ - ] - foreach {k v} $args { - switch -- $k { - -algorithm { - tcl::dict::set opts $k $v - } - default { - error "Unknown option '$k'. Known options: [tcl::dict::keys $opts]" - } - } - } - set opt_algorithm [tcl::dict::get $opts -algorithm] - #puts stderr "--- recalculating column widths -algorithm $opt_algorithm" - set known_algorithms [list basic simplistic span span2] - switch -- $opt_algorithm { - basic { - #basic column by column - This allocates extra space to first span/column as they're encountered. - #This can leave the table quite unbalanced with regards to whitespace and the table is also not as compact as it could be especially with regards to header colspans - #The header values can extend over some of the spanned columns - but not optimally so. - set o_calculated_column_widths [list] - for {set c 0} {$c < $column_count} {incr c} { - lappend o_calculated_column_widths [my basic_column_width $c] - } - } - simplistic { - #just uses the widest column data or header element. - #this is even less compact than basic and doesn't allow header colspan values to extend beyond their first spanned column - #This is a conservative option potentially useful in testing/debugging. - set o_calculated_column_widths [list] - for {set c 0} {$c < $column_count} {incr c} { - lappend o_calculated_column_widths [my column_width_configured $c] - } - } - span { - #widest of smallest spans first method - #set calcresult [my columncalc_spans least] - set calcresult [my columncalc_spans least_unmaxed] - set o_calculated_column_widths [tcl::dict::get $calcresult colwidths] - } - span2 { - #allocates more evenly - but truncates headers sometimes - set calcresult [my columncalc_spans all] - set o_calculated_column_widths [tcl::dict::get $calcresult colwidths] - } - default { - error "calculate_column_widths unknown algorithm $opt_algorithm. Known algorithms: $known_algorithms" - } - } - #remember the last algorithm used - set o_column_width_algorithm $opt_algorithm - return $o_calculated_column_widths - } - method print2 {args} { - variable full_column_cache - set full_column_cache [tcl::dict::create] - - if {![llength $args]} { - set cols [tcl::dict::keys $o_columndata] - } else { - set cols [list] - foreach colspec $args { - set allcols [tcl::dict::keys $o_columndata] - if {[tcl::string::first .. $colspec] >=0} { - set parts [punk::ansi::ta::_perlish_split {\.\.} $colspec] - if {[llength $parts] != 3} { - error "[namespace::current]::table error invalid print specification '$colspec'" - } - lassign $parts from _dd to - if {$from eq ""} {set from 0} - if {$to eq ""} {set to end} - - set indices [lrange $allcols $from $to] - lappend cols {*}$indices - } else { - set c [lindex $allcols $colspec] - if {$c ne ""} { - lappend cols $c - } - } - } - } - set blocks [list] - set colposn 0 - set numposns [llength $cols] - set padwidth 0 - set table "" - foreach c $cols { - set flags [list] - if {$colposn == 0 && $colposn == $numposns-1} { - set flags [list -position solo] - } elseif {$colposn == 0} { - set flags [list -position left] - } elseif {$colposn == $numposns-1} { - set flags [list -position right] - } else { - set flags [list -position inner] - } - #lappend blocks [my get_column_by_index $c {*}$flags] - #todo - only check and store in cache if table has header or footer colspans > 1 - if {[tcl::dict::exists $full_column_cache $c]} { - #puts "!!print used full_column_cache for $c" - set columninfo [tcl::dict::get $full_column_cache $c] - } else { - set columninfo [my get_column_by_index $c -return dict {*}$flags] - tcl::dict::set full_column_cache $c $columninfo - } - set nextcol [tcl::string::cat [tcl::dict::get $columninfo header] \n [tcl::dict::get $columninfo body]] - set bodywidth [tcl::dict::get $columninfo bodywidth] - - if {$table eq ""} { - set table $nextcol - set height [textblock::height $table] ;#only need to get height once at start - } else { - set nextcol [textblock::join -- [textblock::block $padwidth $height $TSUB] $nextcol] - set table [overtype::renderspace -expand_right 1 -transparent $TSUB $table[unset table] $nextcol] - #JMN - - #set nextcol [textblock::join -- [textblock::block $padwidth $height "\uFFFF"] $nextcol] - #set table [overtype::renderspace -expand_right 1 -transparent \uFFFF $table $nextcol] - } - incr padwidth $bodywidth - incr colposn - } - - if {[llength $cols]} { - #return [textblock::join -- {*}$blocks] - if {[tcl::dict::get $o_opts_table -show_edge]} { - #title is considered part of the edge ? - set offset 1 ;#make configurable? - set titlepad [tcl::string::repeat $TSUB $offset] - if {[tcl::dict::get $o_opts_table -title] ne ""} { - set titlealign [tcl::dict::get $o_opts_table -titlealign] - switch -- $titlealign { - left { - set tstring $titlepad[tcl::dict::get $o_opts_table -title] - } - right { - set tstring [tcl::dict::get $o_opts_table -title]$titlepad - } - default { - set tstring [tcl::dict::get $o_opts_table -title] - } - } - set opt_titletransparent [tcl::dict::get $o_opts_table -titletransparent] - switch -- $opt_titletransparent { - 0 { - set mapchar "" - } - 1 { - set mapchar " " - } - default { - #won't work if not a single char - review - check also frame behaviour - set mapchar $opt_titletransparent - } - } - if {$mapchar ne ""} { - set tstring [tcl::string::map [list $mapchar $TSUB] $tstring] - } - set table [overtype::block -blockalign $titlealign -transparent $TSUB $table[unset table] $tstring] - } - } - return $table - } else { - return "No columns matched" - } - } - - # using -startcolumn to do slightly less work - method print3 {args} { - if {![llength $args]} { - set cols [tcl::dict::keys $o_columndata] - } else { - set cols [list] - foreach colspec $args { - set allcols [tcl::dict::keys $o_columndata] - if {[tcl::string::first .. $colspec] >=0} { - set parts [punk::ansi::ta::_perlish_split {\.\.} $colspec] - if {[llength $parts] != 3} { - error "[namespace::current]::table error invalid print specification '$colspec'" - } - lassign $parts from _dd to - if {$from eq ""} {set from 0} - if {$to eq ""} {set to end} - - set indices [lrange $allcols $from $to] - lappend cols {*}$indices - } else { - set c [lindex $allcols $colspec] - if {$c ne ""} { - lappend cols $c - } - } - } - } - set blocks [list] - set numposns [llength $cols] - set colposn 0 - set padwidth 0 - set table "" - foreach c $cols { - set flags [list] - if {$colposn == 0 && $colposn == $numposns-1} { - set flags [list -position solo] - } elseif {$colposn == 0} { - set flags [list -position left] - } elseif {$colposn == $numposns-1} { - set flags [list -position right] - } else { - set flags [list -position inner] - } - set columninfo [my get_column_by_index $c -return dict {*}$flags] - set nextcol [tcl::string::cat [tcl::dict::get $columninfo header] \n [tcl::dict::get $columninfo body]] - set bodywidth [tcl::dict::get $columninfo bodywidth] - - if {$table eq ""} { - set table $nextcol - set height [textblock::height $table] ;#only need to get height once at start - } else { - set table [overtype::renderspace -startcolumn [expr {$padwidth + 1}] -expand_right 1 -transparent $TSUB $table $nextcol] - } - incr padwidth $bodywidth - incr colposn - } - - if {[llength $cols]} { - #return [textblock::join -- {*}$blocks] - if {[tcl::dict::get $o_opts_table -show_edge]} { - #title is considered part of the edge ? - set offset 1 ;#make configurable? - set titlepad [tcl::string::repeat $TSUB $offset] - if {[tcl::dict::get $o_opts_table -title] ne ""} { - set titlealign [tcl::dict::get $o_opts_table -titlealign] - switch -- $titlealign { - left { - set tstring $titlepad[tcl::dict::get $o_opts_table -title] - } - right { - set tstring [tcl::dict::get $o_opts_table -title]$titlepad - } - default { - set tstring [tcl::dict::get $o_opts_table -title] - } - } - set opt_titletransparent [tcl::dict::get $o_opts_table -titletransparent] - switch -- $opt_titletransparent { - 0 { - set mapchar "" - } - 1 { - set mapchar " " - } - default { - #won't work if not a single char - review - check also frame behaviour - set mapchar $opt_titletransparent - } - } - if {$mapchar ne ""} { - set tstring [tcl::string::map [list $mapchar $TSUB] $tstring] - } - set table [overtype::block -blockalign $titlealign -transparent $TSUB $table[unset table] $tstring] - } - } - return $table - } else { - return "No columns matched" - } - } - - #print headers and body using different join mechanisms - # using -startcolumn to do slightly less work - method print {args} { - #*** !doctools - #[call class::table [method print]] - #[para] Return the table as text suitable for console display - - if {![llength $args]} { - set cols [tcl::dict::keys $o_columndata] - } else { - set cols [list] - foreach colspec $args { - set allcols [tcl::dict::keys $o_columndata] - if {[tcl::string::first .. $colspec] >=0} { - set parts [punk::ansi::ta::_perlish_split {\.\.} $colspec] - if {[llength $parts] != 3} { - error "[namespace::current]::table error invalid print specification '$colspec'" - } - lassign $parts from _dd to - if {$from eq ""} {set from 0} - if {$to eq ""} {set to end} - - set indices [lrange $allcols $from $to] - lappend cols {*}$indices - } else { - set c [lindex $allcols $colspec] - if {$c ne ""} { - lappend cols $c - } - } - } - } - set numposns [llength $cols] - set colposn 0 - set padwidth 0 - set header_build "" - set body_blocks [list] - set headerheight 0 - foreach c $cols { - set flags [list] - if {$colposn == 0 && $colposn == $numposns-1} { - set flags [list -position solo] - } elseif {$colposn == 0} { - set flags [list -position left] - } elseif {$colposn == $numposns-1} { - set flags [list -position right] - } else { - set flags [list -position inner] - } - set columninfo [my get_column_by_index $c -return dict {*}$flags] - #set nextcol [tcl::dict::get $columninfo column] - set bodywidth [tcl::dict::get $columninfo bodywidth] - set headerheight [tcl::dict::get $columninfo headerheight] - #set nextcol_lines [split $nextcol \n] - #set nextcol_header [join [lrange $nextcol_lines 0 $headerheight-1] \n] - #set nextcol_body [join [lrange $nextcol_lines $headerheight end] \n] - set nextcol_header [tcl::dict::get $columninfo header] - set nextcol_body [tcl::dict::get $columninfo body] - - if {$header_build eq "" && ![llength $body_blocks]} { - set header_build $nextcol_header - } else { - if {$headerheight > 0} { - set header_build [overtype::renderspace -startcolumn [expr {$padwidth + 1}] -expand_right 1 -transparent $TSUB $header_build[unset header_build] $nextcol_header[unset nextcol_header]] - } - #set body_build [textblock::join -- $body_build[unset body_build] $nextcol_body] - } - lappend body_blocks $nextcol_body - incr padwidth $bodywidth - incr colposn - } - if {![llength $body_blocks]} { - set body_build "" - } else { - #body blocks should not be ragged - so can use join_basic - set body_build [textblock::join_basic -- {*}$body_blocks] - } - if {$headerheight > 0} { - set table [tcl::string::cat $header_build \n $body_build] - } else { - set table $body_build - } - - if {[llength $cols]} { - if {[tcl::dict::get $o_opts_table -show_edge]} { - #title is considered part of the edge ? - set offset 1 ;#make configurable? - set titlepad [tcl::string::repeat $TSUB $offset] - if {[tcl::dict::get $o_opts_table -title] ne ""} { - set titlealign [tcl::dict::get $o_opts_table -titlealign] - switch -- $titlealign { - left { - set tstring $titlepad[tcl::dict::get $o_opts_table -title] - } - right { - set tstring [tcl::dict::get $o_opts_table -title]$titlepad - } - default { - set tstring [tcl::dict::get $o_opts_table -title] - } - } - set opt_titletransparent [tcl::dict::get $o_opts_table -titletransparent] - switch -- $opt_titletransparent { - 0 { - set mapchar "" - } - 1 { - set mapchar " " - } - default { - #won't work if not a single char - review - check also frame behaviour - set mapchar $opt_titletransparent - } - } - if {$mapchar ne ""} { - set tstring [tcl::string::map [list $mapchar $TSUB] $tstring] - } - set table [overtype::block -blockalign $titlealign -transparent $TSUB $table[unset table] $tstring] - } - } - return $table - } else { - return "No columns matched" - } - } - method print_bodymatrix {} { - #*** !doctools - #[call class::table [method print_bodymatrix]] - #[para] output the matrix string corresponding to the body data using the matrix 2string format - #[para] this will be a table without borders,headers,title etc and will exclude additional ANSI applied due to table, row or column settings. - #[para] If the original cell data itself contains ANSI - the output will still contain those ansi codes. - # - - - set m [my as_matrix] - $m format 2string - } - - #*** !doctools - #[list_end] - }] - #*** !doctools - # [list_end] [comment {- end enumeration provider_classes }] - #[list_end] [comment {- end itemized list textblock::class groupings -}] - } - } -} -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# -#Note: A textblock does not necessarily have lines the same length - either in number of characters or print-width -# -tcl::namespace::eval textblock { - variable frametypes - set frametypes [list light light_b light_c heavy heavy_b heavy_c arc arc_b arc_c double block block1 block2 block2hack ascii altg] - #class::table needs to be able to determine valid frametypes - proc frametypes {} { - variable frametypes - return $frametypes - } - - tcl::namespace::eval cd { - #todo - save and restore existing tcl::namespace::export in case macros::cd has default exports in future - tcl::namespace::eval ::term::ansi::code::macros::cd {tcl::namespace::export *} - tcl::namespace::import ::term::ansi::code::macros::cd::* - tcl::namespace::eval ::term::ansi::code::macros::cd {tcl::namespace::export -clear} - } - proc spantest {} { - set t [list_as_table -columns 5 -return tableobject {a b c d e aa bb cc dd ee X Y}] - $t configure_column 0 -headers [list span3 "1-span4\n2-span4 second line" span5/5 "span-all etc blah 123 hmmmmm" span2] - $t configure_column 0 -header_colspans {3 4 5 any 2} - $t configure_column 2 -headers {"" "" "" "" c2span2_etc} - $t configure_column 2 -header_colspans {0 0 0 0 2} - $t configure -show_header 1 -ansiborder_header [a+ cyan] - return $t - } - proc spantest1 {} { - set t [list_as_table -columns 5 -return tableobject {a b c d e aa bb cc dd ee X Y}] - $t configure_column 0 -headers [list "span3-any longer than other span any" "1-span4\n2-span4 second line" "span-any short aligned?" "span5/5 longest etc blah 123" span2] - $t configure_column 0 -header_colspans {any 4 any 5 2} - $t configure_column 2 -headers {"" "" "" "" c2span2_etc} - $t configure_column 2 -header_colspans {0 0 0 0 2} - $t configure_column 3 -header_colspans {1 0 0 0 0} - $t configure -show_header 1 -ansiborder_header [a+ cyan] - $t configure_column 0 -blockalign right ;#trigger KNOWN BUG overwrite of right edge by last char of spanning col (in this case fullspan from left - but also happens for any span extending to rhs) - return $t - } - - #more complex colspans - proc spantest2 {} { - set t [list_as_table -columns 5 -return tableobject {a b c d e aa bb cc dd ee X Y}] - $t configure_column 0 -headers {c0span3 c0span4 c0span1 "c0span-all etc blah 123 hmmmmm" c0span2} - $t configure_column 0 -header_colspans {3 4 1 any 2} - $t configure_column 1 -header_colspans {0 0 2 0 0} - $t configure_column 2 -headers {"" "" "" "" c2span2} - $t configure_column 2 -header_colspans {0 0 0 0 2} - $t configure_column 3 -header_colspans {1 0 2 0 0} - $t configure -show_header 1 -ansiborder_header [a+ cyan] - return $t - } - proc spantest3 {} { - set t [list_as_table -columns 5 -return tableobject {a b c d e aa bb cc dd ee X Y}] - $t configure_column 0 -headers {c0span3 c0span4 c0span1 "c0span-all etc blah 123 hmmmmm" "c0span2 etc blah" c0span1} - $t configure_column 0 -header_colspans {3 4 1 any 2 1} - $t configure_column 1 -header_colspans {0 0 4 0 0 1} - $t configure_column 1 -headers {"" "" "c1span4" "" "" "c1nospan"} - $t configure_column 2 -headers {"" "" "" "" "" c2span2} - $t configure_column 2 -header_colspans {0 0 0 0 1 2} - $t configure_column 4 -headers {"4" "444" "" "" "" "44"} - $t configure -show_header 1 -ansiborder_header [a+ cyan] - return $t - } - - punk::args::definition { - @id -id ::textblock::periodic - @cmd -name textblock::periodic -help "A rudimentary periodic table - This is primarily a test of textblock::class::table" - - -return -default table\ - -choices {table tableobject}\ - -help "default choice 'table' returns the displayable table output" - -compact -default 1 -type boolean -help "compact true defaults: -show_vseps 0 -show_header 0 -show_edge 0" - -frame -default 1 -type boolean - -show_vseps -default "" -type boolean - -show_header -default "" -type boolean - -show_edge -default "" -type boolean - -forcecolour -default 0 -type boolean -help "If punk::colour is off - this enables the produced table to still be ansi coloured" - @values -min 0 -max 0 - } - - proc periodic {args} { - #For an impressive interactive terminal app (javascript) - # see: https://github.com/spirometaxas/periodic-table-cli - set opts [dict get [punk::args::get_by_id ::textblock::periodic $args] opts] - set opt_return [tcl::dict::get $opts -return] - if {[tcl::dict::get $opts -forcecolour]} { - set fc forcecolour - } else { - set fc "" - } - - #examples ptable.com - set elements [list\ - 1 H "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" He\ - 2 Li Be "" "" "" "" "" "" "" "" "" "" B C N O F Ne\ - 3 Na Mg "" "" "" "" "" "" "" "" "" "" Al Si P S Cl Ar\ - 4 K Ca Sc Ti V Cr Mn Fe Co Ni Cu Zn Ga Ge As Se Br Kr\ - 5 Rb Sr Y Zr Nb Mo Tc Ru Rh Pd Ag Cd In Sn Sb Te I Xe\ - 6 Cs Ba "" Hf Ta W Re Os Ir Pt Au Hg Tl Pb Bi Po At Rn\ - 7 Fr Ra "" Rf Db Sg Bh Hs Mt Ds Rg Cn Nh Fl Mc Lv Ts Og\ - " " " " " " " " " " " " " " " " " " " " " " " " "" "" "" "" "" "" ""\ - "" "" "" 6 La Ce Pr Nd Pm Sm Eu Gd Tb Dy Ho Er Tm Yb Lu\ - "" "" "" 7 Ac Th Pa U Np Pu Am Cm Bk Cf Es Fm Md No Lr\ - ] - - set type_colours [list] - - set ecat [tcl::dict::create] - - set cat_alkaline_earth [list Be Mg Ca Sr Ba Ra] - set ansi [a+ {*}$fc web-black Web-gold] - set val [list ansi $ansi cat alkaline_earth] - foreach e $cat_alkaline_earth { - tcl::dict::set ecat $e $val - } - - set cat_reactive_nonmetal [list H C N O F P S Cl Se Br I] - #set ansi [a+ {*}$fc web-black Web-lightgreen] - set ansi [a+ {*}$fc black Term-113] - set val [list ansi $ansi cat reactive_nonmetal] - foreach e $cat_reactive_nonmetal { - tcl::dict::set ecat $e $val - } - - set cat [list Li Na K Rb Cs Fr] - #set ansi [a+ {*}$fc web-black Web-Khaki] - set ansi [a+ {*}$fc black Term-lightgoldenrod2] - set val [list ansi $ansi cat alkali_metals] - foreach e $cat { - tcl::dict::set ecat $e $val - } - - set cat [list Sc Ti V Cr Mn Fe Co Ni Cu Zn Y Zr Nb Mo Tc Ru Rh Pd Ag Cd Hf Ta W Re Os Ir Pt Au Hg Rf Db Sg Bh Hs] - #set ansi [a+ {*}$fc web-black Web-lightsalmon] - set ansi [a+ {*}$fc black Term-orange1] - set val [list ansi $ansi cat transition_metals] - foreach e $cat { - tcl::dict::set ecat $e $val - } - - set cat [list Al Ga In Sn Tl Pb Bi Po] - set ansi [a+ {*}$fc web-black Web-lightskyblue] - set val [list ansi $ansi cat post_transition_metals] - foreach e $cat { - tcl::dict::set ecat $e $val - } - - set cat [list B Si Ge As Sb Te At] - #set ansi [a+ {*}$fc web-black Web-turquoise] - set ansi [a+ {*}$fc black Brightcyan] - set val [list ansi $ansi cat metalloids] - foreach e $cat { - tcl::dict::set ecat $e $val - } - - set cat [list He Ne Ar Kr Xe Rn] - set ansi [a+ {*}$fc web-black Web-orchid] - set val [list ansi $ansi cat noble_gases] - foreach e $cat { - tcl::dict::set ecat $e $val - } - - set cat [list Ac Th Pa U Np Pu Am Cm Bk Cf Es Fm Md No Lr] - set ansi [a+ {*}$fc web-black Web-plum] - set val [list ansi $ansi cat actinoids] - foreach e $cat { - tcl::dict::set ecat $e $val - } - - set cat [list La Ce Pr Nd Pm Sm Eu Gd Tb Dy Ho Er Tm Yb Lu] - #set ansi [a+ {*}$fc web-black Web-tan] - set ansi [a+ {*}$fc black Term-tan] - set val [list ansi $ansi cat lanthanoids] - foreach e $cat { - tcl::dict::set ecat $e $val - } - - set ansi [a+ {*}$fc web-black Web-whitesmoke] - set val [list ansi $ansi cat other] - foreach e [list Mt Ds Rg Cn Nh Fl Mc Lv Ts Og] { - tcl::dict::set ecat $e $val - } - - set elements1 [list] - set RST [a+] - foreach e $elements { - if {[tcl::dict::exists $ecat $e]} { - set ansi [tcl::dict::get $ecat $e ansi] - #lappend elements1 [textblock::pad $ansi$e -width 2 -which right] - #no need to pad here - table column_configure -textalign default of left will do the work of padding right anyway - lappend elements1 $ansi$e - } else { - lappend elements1 $e - } - } - - set t [list_as_table -columns 19 -return tableobject $elements1] - #(defaults to show_hseps 0) - - #todo - keep simple table with symbols as base - map symbols to descriptions etc for more verbose table options - - set header_0 [list 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18] - set c 0 - foreach h $header_0 { - $t configure_column $c -headers [list $h] -minwidth 2 - incr c - } - set ccount [$t column_count] - for {set c 0} {$c < $ccount} {incr c} { - $t configure_column $c -minwidth 3 - } - if {[tcl::dict::get $opts -compact]} { - #compact defaults - but let explicit arguments override - set conf [dict create -show_vseps 0 -show_header 0 -show_edge 0] - } else { - set conf [dict create -show_vseps 1 -show_header 1 -show_edge 1] - } - dict for {k v} $conf { - if {[dict get $opts $k] ne ""} { - dict set conf $k [dict get $opts $k] - } - } - - set moreopts [dict create\ - -frametype_header light\ - -ansiborder_header [a+ {*}$fc brightwhite]\ - -ansibase_header [a+ {*}$fc Black]\ - -ansibase_body [a+ {*}$fc Black]\ - -ansiborder_body [a+ {*}$fc black]\ - -frametype block - ] - $t configure {*}[dict merge $conf $moreopts] - - #-ansiborder_header [a+ {*}$fc web-white]\ - - if {$opt_return eq "table"} { - if {[dict get $opts -frame]} { - #set output [textblock::frame -ansiborder [a+ {*}$fc Black web-cornflowerblue] -type heavy -title "[a+ {*}$fc Black] Periodic Table " [$t print]] - #set output [textblock::frame -ansiborder [a+ {*}$fc Black term-deepskyblue2] -type heavy -title "[a+ {*}$fc Black] Periodic Table " [$t print]] - set output [textblock::frame -checkargs 0 -ansiborder [a+ {*}$fc Black cyan] -type heavy -title "[a+ {*}$fc Black] Periodic Table " [$t print]] - } else { - set output [$t print] - } - $t destroy - return $output - } - return $t - } - - proc bookend_lines {block start {end "\x1b\[m"}} { - set out "" - foreach ln [split $block \n] { - append out $start $ln $end \n - } - return [string range $out 0 end-1] - } - proc ansibase_lines {block {newprefix ""}} { - set base "" - set out "" - if {$newprefix eq ""} { - foreach ln [split $block \n] { - set parts [punk::ansi::ta::split_codes $ln] - if {[lindex $parts 0] eq ""} { - if {[lindex $parts 1] ne "" && ![punk::ansi::codetype::is_sgr_reset [lindex $parts 1]]} { - set base [lindex $parts 1] - append out $base - } else { - append out $base - } - } else { - #leading plaintext - maintain our base - append out $base [lindex $parts 0] [lindex $parts 1] - } - - set code_idx 3 - foreach {pt code} [lrange $parts 2 end] { - if {[punk::ansi::codetype::is_sgr_reset $code]} { - set parts [linsert $parts $code_idx+1 $base] - } - incr code_idx 2 - } - append out {*}[lrange $parts 2 end] \n - } - return [string range $out 0 end-1] - } else { - set base $newprefix - foreach ln [split $block \n] { - set parts [punk::ansi::ta::split_codes $ln] - set code_idx 1 - set offset 0 - foreach {pt code} $parts { - if {$code_idx == 1} { - #first pt & code - if {$pt ne ""} { - #leading plaintext - set parts [linsert $parts 0 $base] - incr offset - } - } - if {[punk::ansi::codetype::is_sgr_reset $code]} { - set parts [linsert $parts [expr {$code_idx+1+$offset}] $base] - incr offset - } - incr code_idx 2 - } - append out {*}$parts \n - } - return [string range $out 0 end-1] - } - } - - set FRAMETYPES [textblock::frametypes] - punk::args::definition [punk::lib::tstr -return string { - @id -id ::textblock::list_as_table - @cmd -name "textblock::list_as_table" -help\ - "Display a list in a bordered table - " - - -return -default table -choices {table tableobject} - -frametype -default "light" -type dict -choices {${$FRAMETYPES}} -choicerestricted 0\ - -help "frame type or dict for custom frame" - -show_edge -default "" -type boolean\ - -help "show outer border of table" - -show_seps -default "" -type boolean - -show_vseps -default "" -type boolean\ - -help "Show vertical table separators" - -show_hseps -default "" -type boolean\ - -help "Show horizontal table separators - (default 0 if no existing -table supplied)" - -table -default "" -type string\ - -help "existing table object to use" - -colheaders -default "" -type list\ - -help "list of lists. list of column header values. Outer list must match number of columns" - -header -default "" -type list -multiple 1\ - -help "Each supplied -header argument is a header row. - The number of values for each must be <= number of columns" - -show_header -type boolean\ - -help "Whether to show a header row. - Omit for unspecified/automatic, - in which case it will display only if -headers list was supplied." - -action -default "append" -choices {append replace}\ - -help "row insertion method if existing -table is supplied - if append is chosen the new values will always start at the first column" - -columns -default "" -type integer\ - -help "Number of table columns - Will default to 2 if not using an existing -table object" - - @values -min 0 -max 1 - datalist -default {} -type list -help "flat list of table cell values which will be wrapped based on -columns value" - }] - - proc list_as_table {args} { - set FRAMETYPES [textblock::frametypes] - set argd [punk::args::get_by_id ::textblock::list_as_table $args] - - set opts [dict get $argd opts] - set datalist [dict get $argd values datalist] - - set existing_table [dict get $opts -table] - set opt_columns [dict get $opts -columns] - set count [llength $datalist] - - set is_new_table 0 - if {$existing_table ne ""} { - if {[tcl::namespace::tail [info object class $existing_table]] ne "table"} { - error "textblock::list_as_table error -table must be an existing table object (e.g set t \[textblock::class::table new\])" - } - set t $existing_table - foreach prop {-frametype -show_edge -show_seps -show_vseps -show_hseps} { - if {[tcl::dict::get $opts $prop] ne ""} { - $t configure $prop [tcl::dict::get $opts $prop] - } - } - if {[dict get $opts -action] eq "replace"} { - $t row_clear - } - set cols [$t column_count] - if {[tcl::string::is integer -strict $opt_columns]} { - if {$opt_columns > $cols} { - set extra [expr {$opt_columns - $cols}] - for {set c 0} {$c < $extra} {incr c} { - $t add_column - } - } elseif {$opt_columns < $cols} { - #todo - auto add blank values in the datalist - error "Number of columns requested: $opt_columns is less than existing number of columns $cols - not yet supported" - } - set cols [$t column_count] - } - } else { - set is_new_table 1 - set colheaders {} - if {[tcl::dict::get $opts -colheaders] ne ""} { - set colheaders [dict get $opts -colheaders] - } else { - set colheaders [list] - } - set r 0 - foreach ch $colheaders { - set rows [llength $ch] - if {$r < $rows} { - set r $rows - } - } - if {[llength [tcl::dict::get $opts -header]]} { - foreach hrow [tcl::dict::get $opts -header] { - set c 0 - foreach cell $hrow { - if {[llength $colheaders] < $c+1} { - lappend colheaders [lrepeat $r {}] - } - set colinfo [lindex $colheaders $c] - if {$r > [llength $colinfo]} { - set diff [expr {$r - [llength $colinfo]}] - lappend colinfo {*}[lrepeat $diff {}] - } - lappend colinfo $cell - lset colheaders $c $colinfo - incr c - } - incr r - } - } - - - if {[llength $colheaders] > 0} { - if {![tcl::dict::exists $opts received -show_header]} { - set show_header 1 - } else { - set show_header [tcl::dict::get $opts -show_header] - } - } else { - if {![tcl::dict::exists $opts received -show_header]} { - set show_header 0 - } else { - set show_header [tcl::dict::get $opts -show_header] - } - } - - if {[tcl::string::is integer -strict $opt_columns]} { - set cols $opt_columns - if {[llength $colheaders] && $cols != [llength $colheaders]} { - error "list_as_table number of columns ($cols) doesn't match supplied number of headers ([llength $colheaders])" - } - } else { - #review - if {[llength $colheaders]} { - set cols [llength $colheaders] - } else { - set cols 2 ;#seems a reasonable default - } - } - #defaults for new table only - #if {[tcl::dict::get $opts -show_seps] eq ""} { - # tcl::dict::set opts -show_seps 1 - #} - if {[tcl::dict::get $opts -show_edge] eq ""} { - tcl::dict::set opts -show_edge 1 - } - if {[tcl::dict::get $opts -show_vseps] eq ""} { - tcl::dict::set opts -show_vseps 1 - } - if {[tcl::dict::get $opts -show_hseps] eq ""} { - tcl::dict::set opts -show_hseps 0 - } - - set t [textblock::class::table new\ - -show_header $show_header\ - -show_edge [tcl::dict::get $opts -show_edge]\ - -frametype [tcl::dict::get $opts -frametype]\ - -show_seps [tcl::dict::get $opts -show_seps]\ - -show_vseps [tcl::dict::get $opts -show_vseps]\ - -show_hseps [tcl::dict::get $opts -show_hseps]\ - ] - if {[llength $colheaders]} { - for {set c 0} {$c < $cols} {incr c} { - $t add_column -headers [lindex $colheaders $c] - } - } else { - for {set c 0} {$c < $cols} {incr c} { - $t add_column -headers [list $c] - } - } - } - - set full_rows [expr {$count / $cols}] - set last_items [expr {$count % $cols}] - - - set rowdata [list] - set row [list] - set i 0 - if {$full_rows > 0} { - for {set r 0} {$r < $full_rows} {incr r} { - set j [expr {$i + ($cols -1)}] - set row [lrange $datalist $i $j] - incr i $cols - lappend rowdata $row - } - } - if {$last_items > 0} { - set idx [expr {$last_items -1}] - lappend rowdata [lrange $datalist end-$idx end] - } - foreach row $rowdata { - set shortfall [expr {$cols - [llength $row]}] - if {$shortfall > 0} { - #set row [concat $row [lrepeat $shortfall ""]] - lappend row {*}[lrepeat $shortfall ""] - } - $t add_row $row - } - #puts stdout $rowdata - if {[tcl::dict::get $opts -return] eq "table"} { - set result [$t print] - if {$is_new_table} { - $t destroy - } - return $result - } else { - return $t - } - } - #return a homogenous block of characters - ie lines all same length, all same character - #printing-width in terminal columns is not necessarily same as blockwidth even if a single char is passed (could be full-width unicode character) - #This can have ansi SGR codes - but to repeat blocks containing ansi-movements, the block should first be rendered to a static output with something like overtype::left - proc block {blockwidth blockheight {char " "}} { - if {$blockwidth < 0} { - error "textblock::block blockwidth must be an integer greater than or equal to zero" - } - if {$blockheight <= 0} { - error "textblock::block blockheight must be a positive integer" - } - if {$char eq ""} {return ""} - #using tcl::string::length is ok - if {[tcl::string::length $char] == 1} { - set row [tcl::string::repeat $char $blockwidth] - set mtrx [lrepeat $blockheight $row] - return [::join $mtrx \n] - } else { - set charblock [tcl::string::map [list \r\n \n] $char] - if {[tcl::string::last \n $charblock] >= 0} { - if {$blockwidth > 1} { - #set row [.= val $charblock {*}[lrepeat [expr {$blockwidth -1}] |> piper_blockjoin $charblock]] ;#building a repeated "|> command arg" list to evaluate as a pipeline. (from before textblock::join could take arbitrary num of blocks ) - set row [textblock::join_basic -- {*}[lrepeat $blockwidth $charblock]] - } else { - set row $charblock - } - } else { - set row [tcl::string::repeat $char $blockwidth] - } - set mtrx [lrepeat $blockheight $row] - return [::join $mtrx \n] - } - } - proc testblock {size {colour ""}} { - if {$size <1 || $size > 15} { - error "textblock::testblock only sizes between 1 and 15 inclusive supported" - } - set rainbow_list [list] - lappend rainbow_list {30 47} ;#black White - lappend rainbow_list {31 46} ;#red Cyan - lappend rainbow_list {32 45} ;#green Purple - lappend rainbow_list {33 44} ;#yellow Blue - lappend rainbow_list {34 43} ;#blue Yellow - lappend rainbow_list {35 42} ;#purple Green - lappend rainbow_list {36 41} ;#cyan Red - lappend rainbow_list {37 40} ;#white Black - lappend rainbow_list {black Yellow} - lappend rainbow_list red - lappend rainbow_list green - lappend rainbow_list yellow - lappend rainbow_list blue - lappend rainbow_list purple - lappend rainbow_list cyan - lappend rainbow_list {white Red} - - set rainbow_direction "horizontal" - set vpos [lsearch $colour vertical] - if {$vpos >= 0} { - set rainbow_direction vertical - set colour [lremove $colour $vpos] - } - set hpos [lsearch $colour horizontal] - if {$hpos >=0} { - #horizontal is the default and superfluous but allowed for symmetry - set colour [lremove $colour $hpos] - } - - - - set chars [list {*}[punk::lib::range 1 9] A B C D E F] - set charsubset [lrange $chars 0 $size-1] - if {"noreset" in $colour} { - set RST "" - } else { - set RST [a] - } - if {"rainbow" in $colour && $rainbow_direction eq "vertical"} { - #column first - colour change each column - set c [::join $charsubset \n] - - set clist [list] - for {set i 0} {$i <$size} {incr i} { - set colour2 [tcl::string::map [list rainbow [lindex $rainbow_list $i]] $colour] - set ansi [a+ {*}$colour2] - - set ansicode [punk::ansi::codetype::sgr_merge_list "" $ansi] - lappend clist ${ansicode}$c$RST - } - if {"noreset" in $colour} { - return [textblock::join_basic -ansiresets 0 -- {*}$clist] - } else { - return [textblock::join_basic -- {*}$clist] - } - } elseif {"rainbow" in $colour} { - #direction must be horizontal - set block "" - for {set r 0} {$r < $size} {incr r} { - set colour2 [tcl::string::map [list rainbow [lindex $rainbow_list $r]] $colour] - set ansi [a+ {*}$colour2] - set ansicode [punk::ansi::codetype::sgr_merge_list "" $ansi] - set row "$ansicode" - foreach c $charsubset { - append row $c - } - append row $RST - append block $row\n - } - set block [tcl::string::trimright $block \n] - return $block - } else { - #row first - - set rows [list] - foreach ch $charsubset { - lappend rows [tcl::string::repeat $ch $size] - } - set block [::join $rows \n] - if {$colour ne ""} { - set block [a+ {*}$colour]$block$RST - } - return $block - } - } - interp alias {} testblock {} textblock::testblock - - #todo - consider 'elastic tabstops' for textblocks where tab acts as a column separator and adjacent lines with the same number of tabs form a sort of table - proc width {textblock} { - #backspaces, vertical tabs ? - if {$textblock eq ""} { - return 0 - } - #textutil::tabify is a reasonable hack when there are no ansi SGR codes - but probably not always what we want even then - review - if {[tcl::string::last \t $textblock] >= 0} { - if {[tcl::info::exists punk::console::tabwidth]} { - set tw $::punk::console::tabwidth - } else { - set tw 8 - } - set textblock [textutil::tabify::untabify2 $textblock $tw] - } - if {[string length $textblock] > 1 && [punk::ansi::ta::detect $textblock]} { - #ansistripraw slightly faster than ansistrip - and won't affect width (avoid detect_g0/conversions) - set textblock [punk::ansi::ansistripraw $textblock] - } - if {[tcl::string::last \n $textblock] >= 0} { - return [tcl::mathfunc::max {*}[lmap v [split $textblock \n] {::punk::char::ansifreestring_width $v}]] - } - return [punk::char::ansifreestring_width $textblock] - } - #gather info about whether ragged (samewidth each line = false) and min width - proc widthinfo {textblock} { - #backspaces, vertical tabs ? - if {$textblock eq ""} { - return [dict create width 0 minwidth 0 ragged 0] - } - #textutil::tabify is a reasonable hack when there are no ansi SGR codes - but probably not always what we want even then - review - if {[tcl::string::last \t $textblock] >= 0} { - if {[tcl::info::exists punk::console::tabwidth]} { - set tw $::punk::console::tabwidth - } else { - set tw 8 - } - set textblock [textutil::tabify::untabify2 $textblock $tw] - } - if {[string length $textblock] > 1 && [punk::ansi::ta::detect $textblock]} { - #ansistripraw slightly faster than ansistrip - and won't affect width (avoid detect_g0/conversions) - set textblock [punk::ansi::ansistripraw $textblock] - } - if {[tcl::string::last \n $textblock] >= 0} { - #return [tcl::mathfunc::max {*}[lmap v [split $textblock \n] {::punk::char::ansifreestring_width $v}]] - set widths [lmap v [split $textblock \n] {::punk::char::ansifreestring_width $v}] - set max [tcl::mathfunc::max {*}$widths] - set min [tcl::mathfunc::min {*}$widths] - set ragged [expr {$min != $max}] - return [dict create width $max minwidth $min ragged $ragged] - } - #single line - set w [punk::char::ansifreestring_width $textblock] - return [dict create width $w minwidth $w ragged 0] - } - #when we know the block is uniform in width - just examine topline - proc widthtopline {textblock} { - set firstnl [tcl::string::first \n $textblock] - if {$firstnl >= 0} { - set tl [tcl::string::range $textblock 0 $firstnl] - } else { - set tl $textblock - } - if {[punk::ansi::ta::detect $tl]} { - set tl [punk::ansi::ansistripraw $tl] - } - return [punk::char::ansifreestring_width $tl] - } - #uses tcl's tcl::string::length on each line. Length will include chars in ansi codes etc - this is not a 'width' determining function. - proc string_length_line_max {textblock} { - #tcl::mathfunc::max {*}[lmap v [split $textblock \n] {tcl::string::length $v}] - set max 0 - foreach ln [split $textblock \n] { - if {[tcl::string::length $ln] > $max} {set max [tcl::string::length $ln]} - } - return $max - } - #*slightly* slower - #proc string_length_line_max {textblock} { - # tcl::mathfunc::max {*}[lmap v [split $textblock \n] {tcl::string::length $v}] - #} - proc string_length_line_min textblock { - tcl::mathfunc::min {*}[lmap v [split $textblock \n] {tcl::string::length $v}] - } - - proc height {textblock} { - #This is the height as it will/would-be rendered - not the number of input lines purely in terms of le - #empty string still has height 1 (at least for left-right/right-left languages) - - #vertical tab on a proper terminal should move directly down. - #Whether or not the terminal in use actually does this - we need to calculate as if it does. (there might not even be a terminal) - - set num_le [expr {[tcl::string::length $textblock]-[tcl::string::length [tcl::string::map [list \n {} \v {}] $textblock]]}] ;#faster than splitting into single-char list - return [expr {$num_le + 1}] ;# one line if no le - 2 if there is one trailing le even if no data follows le - } - #MAINTENANCE - same as overtype::blocksize? - proc size {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 - } - #strangely - tcl::string::last (windows tcl8.7 anway) is faster than tcl::string::first for large strings when the needle not in the haystack - if {[tcl::string::last \t $textblock] >= 0} { - if {[tcl::info::exists punk::console::tabwidth]} { - set tw $::punk::console::tabwidth - } else { - set tw 8 - } - set textblock [textutil::tabify::untabify2 $textblock $tw] - } - #ansistripraw on entire block in one go rather than line by line - result should be the same - review - make tests - if {[string length $textblock] > 1 && [punk::ansi::ta::detect $textblock]} { - set textblock [punk::ansi::ansistripraw $textblock] - } - if {[tcl::string::last \n $textblock] >= 0} { - #set width [tcl::mathfunc::max {*}[lmap v [punk::lib::lines_as_list -- $textblock] {::punk::char::ansifreestring_width $v}]] - set width [tcl::mathfunc::max {*}[lmap v [split $textblock \n] {::punk::char::ansifreestring_width $v}]] - } else { - set width [punk::char::ansifreestring_width $textblock] - } - set num_le [expr {[tcl::string::length $textblock]-[tcl::string::length [tcl::string::map [list \n {} \v {}] $textblock]]}] ;#faster than splitting into single-char list - #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 [tcl::dict::values [blocksize ]] width height - } - proc size2 {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 - } - #strangely - tcl::string::last (windows tcl8.7 anway) is faster than tcl::string::first for large strings when the needle not in the haystack - if {[tcl::string::last \t $textblock] >= 0} { - if {[tcl::info::exists punk::console::tabwidth]} { - set tw $::punk::console::tabwidth - } else { - set tw 8 - } - set textblock [textutil::tabify::untabify2 $textblock $tw] - } - #ansistripraw on entire block in one go rather than line by line - result should be the same - review - make tests - if {[string length $textblock] > 1 && [punk::ansi::ta::detect $textblock]} { - set textblock [punk::ansi::ansistripraw $textblock] - } - if {[tcl::string::last \n $textblock] >= 0} { - #set width [tcl::mathfunc::max {*}[lmap v [punk::lib::lines_as_list -- $textblock] {::punk::char::ansifreestring_width $v}]] - set lines [split $textblock \n] - set num_le [expr {[llength $lines]-1}] - #set width [tcl::mathfunc::max {*}[lmap v $lines {::punk::char::ansifreestring_width $v}]] - set width 0 - foreach ln $lines { - set w [::punk::char::ansifreestring_width $ln] - if {$w > $width} { - set width $w - } - } - } else { - set num_le 0 - set width [punk::char::ansifreestring_width $textblock] - } - #set num_le [expr {[tcl::string::length $textblock]-[tcl::string::length [tcl::string::map [list \n {} \v {}] $textblock]]}] ;#faster than splitting into single-char list - #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 [tcl::dict::values [blocksize ]] width height - } - proc size_as_opts {textblock} { - set sz [size $textblock] - return [dict create -width [dict get $sz width] -height [dict get $sz height]] - } - proc size_as_list {textblock} { - set sz [size $textblock] - return [list [dict get $sz width] [dict get $sz height]] - } - #must be able to handle block as string with or without newlines - #if no newlines - attempt to treat as a list - #must handle whitespace-only string,list elements, and/or lines. - #reviewing 2024 - this seems like too much magic! - proc width1 {block} { - if {$block eq ""} { - return 0 - } - if {[tcl::info::exists punk::console::tabwidth]} { - set tw $::punk::console::tabwidth - } else { - set tw 8 - } - set block [textutil::tabify::untabify2 $block $tw] - if {[tcl::string::last \n $block] >= 0} { - return [tcl::mathfunc::max {*}[lmap v [punk::lib::lines_as_list -- $block] {::punk::char::string_width [ansistrip $v]}]] - } - if {[catch {llength $block}]} { - return [::punk::char::string_width [ansistrip $block]] - } - if {[llength $block] == 0} { - #could be just a whitespace string - return [tcl::string::length $block] - } - return [tcl::mathfunc::max {*}[lmap v $block {::punk::char::string_width [ansistrip $v]}]] - } - - #we shouldn't make textblock depend on the punk pipeline system - #pipealias ::textblock::padleft .= {list $input [tcl::string::repeat " " $indent]} |/0,padding/1> punk:lib::lines_as_list -- |> .= {lmap v $data {overtype::right $padding $v}} |> punk::lib::list_as_lines -- punk::lib::lines_as_list -- |> .= {lmap v $data {overtype::left $padding $v}} |> punk::lib::list_as_lines -- |? ?-which right|left|centre? ?-known_hasansi \"\"|? ?-known_blockwidth \"\"|? ?-width auto|? ?-within_ansi 1|0?" - foreach {k v} $args { - switch -- $k { - -padchar - -which - -known_hasansi - -known_samewidth - -known_blockwidth - -width - -overflow - -within_ansi { - tcl::dict::set opts $k $v - } - default { - error "textblock::pad unrecognised option '$k'. Usage: $usage" - } - } - } - # -- --- --- --- --- --- --- --- --- --- - set padchar [tcl::dict::get $opts -padchar] - #if padchar width (screen width) > 1 - length calculations will not be correct - #we will allow tokens longer than 1 - as the caller may want to post-process on the token whilst preserving previous leading/trailing spaces, e.g with a tcl::string::map - #The caller may also use ansi within the padchar - although it's unlikely to be efficient. - # -- --- --- --- --- --- --- --- --- --- - set known_whiches [list l left r right c center centre] - set opt_which [tcl::string::tolower [tcl::dict::get $opts -which]] - switch -- $opt_which { - center - centre - c { - set which c - } - left - l { - set which l - } - right - r { - set which r - } - default { - error "textblock::pad unrecognised value for -which option. Known values $known_whiches" - } - } - # -- --- --- --- --- --- --- --- --- --- - set opt_width [tcl::dict::get $opts -width] - switch -- $opt_width { - "" - auto { - set width auto - } - default { - if {![tcl::string::is integer -strict $opt_width] || $opt_width < 0} { - error "textblock::pad -width must be an integer >=0" - } - set width $opt_width - } - } - # -- --- --- --- --- --- --- --- --- --- - set opt_withinansi [tcl::dict::get $opts -within_ansi] - switch -- $opt_withinansi { - 0 - 1 {} - default { - set opt_withinansi 2 - } - } - # -- --- --- --- --- --- --- --- --- --- - set known_blockwidth [tcl::dict::get $opts -known_blockwidth] - set known_samewidth [tcl::dict::get $opts -known_samewidth] ;# if true - we have a known non-ragged block, if false - could be either. - set datawidth "" - if {$width eq "auto"} { - #for auto - we - if {$known_blockwidth eq ""} { - if {$known_samewidth ne "" && $known_samewidth} { - set datawidth [textblock::widthtopline $block] - } else { - #set datawidth [textblock::width $block] - set widthinfo [textblock::widthinfo $block] - set known_samewidth [expr {![dict get $widthinfo ragged]}] ;#review - a false value here is definite, distinguished from unknown which would be empty string - so we can take advantage of it - set datawidth [dict get $widthinfo width] - } - } else { - set datawidth $known_blockwidth - } - set width $datawidth ;# this is the width we want to pad out to - #assert datawidth has been set to widest line, taking ansi & 2wide chars into account - } else { - #only call width functions if known_samewidth - otherwise let the pad algorithm below determine it as we go - if {$known_samewidth ne "" && $known_samewidth} { - if {$known_blockwidth eq ""} { - set datawidth [textblock::widthtopline $block - } else { - set datawidth $known_blockwidth - } - } - #assert datawidth may still be empty string - } - #assertion - #we can now use the states of datawidth and known_samewidth to determine if algorithm below should calculate widths as it goes. - - set lines [list] - - set padcharsize [punk::ansi::printing_length $padchar] - set pad_has_ansi [punk::ansi::ta::detect $padchar] - if {$block eq ""} { - #we need to treat as a line - set repeats [expr {int(ceil($width / double($padcharsize)))}] ;#will overshoot by 1 whenever padcharsize not an exact divisor of width - #TODO - #review - what happens when padchar has ansi, or the width would split a double-wide unicode char? - #we shouldn't be using string range if there is ansi - (overtype? ansistring range?) - #we should use overtype with suitable replacement char (space?) for chopped double-wides - if {!$pad_has_ansi} { - return [tcl::string::range [tcl::string::repeat $padchar $repeats] 0 $width-1] - } else { - set base [tcl::string::repeat " " $width] - return [overtype::block -blockalign left -overflow 0 $base [tcl::string::repeat $padchar $repeats]] - } - } - - #review - tcl format can only pad with zeros or spaces? - #experimental fallback to supposedly faster simpler 'format' but we still need to compensate for double-width or non-printing chars - and it won't work on strings with ansi SGR codes - #review - surprisingly, this doesn't seem to be a performance win - #No detectable diff on small blocks - slightly worse on large blocks - # if {($padchar eq " " || $padchar eq "0") && ![punk::ansi::ta::detect $block]} { - # #This will still be wrong for example with diacritics on terminals that don't collapse the space following a diacritic, and don't correctly report cursor position - # #(i.e as at 2024 - lots of them) wezterm on windows at least does the right thing. - # set block [tcl::string::map [list \r\n \n] $block] - # if {$which eq "l"} { - # set fmt "%+${padchar}*s" - # } else { - # set fmt "%-${padchar}*s" - # } - # foreach ln [split $block \n] { - # #set lnwidth [punk::char::ansifreestring_width $ln] - # set lnwidth [punk::char::grapheme_width_cached $ln] - # set lnlen [tcl::string::length $ln] - # set diff [expr $lnwidth - $lnlen] - # #we need trickwidth to get format to pad a string with a different terminal width compared to string length - # set trickwidth [expr {$width - $diff}] ;#may 'subtract' a positive or negative int (ie will add to trickwidth if negative) - # lappend lines [format $fmt $trickwidth $ln] - # } - # return [::join $lines \n] - # } - - #todo? special case trailing double-reset - insert between resets? - set lnum 0 - - set known_hasansi [tcl::dict::get $opts -known_hasansi] - if {$known_hasansi eq ""} { - set block_has_ansi [punk::ansi::ta::detect $block] - } else { - set block_has_ansi $known_hasansi - } - if {$block_has_ansi} { - set parts [punk::ansi::ta::split_codes $block] - } else { - #single plaintext part - set parts [list $block] - } - - set line_chunks [list] - set line_len 0 - set pad_cache [dict create] ;#key on value of 'missing' - which is width of required pad - foreach {pt ansi} $parts { - if {$pt ne ""} { - set has_nl [expr {[tcl::string::last \n $pt]>=0}] - if {$has_nl} { - set pt [tcl::string::map [list \r\n \n] $pt] - set partlines [split $pt \n] - } else { - set partlines [list $pt] - } - set last [expr {[llength $partlines]-1}] - set p 0 - foreach pl $partlines { - lappend line_chunks $pl - #incr line_len [punk::char::ansifreestring_width $pl] - if {$known_samewidth eq "" || ($known_samewidth ne "" && !$known_samewidth) || $datawidth eq ""} { - incr line_len [punk::char::grapheme_width_cached $pl] ;#memleak - REVIEW - } - if {$p != $last} { - #do padding - if {$known_samewidth eq "" || ($known_samewidth ne "" && !$known_samewidth) || $datawidth eq ""} { - set missing [expr {$width - $line_len}] - } else { - set missing [expr {$width - $datawidth}] - } - if {$missing > 0} { - #commonly in a block - many lines will have the same pad - cache based on missing - - #padchar may be more than 1 wide - because of 2wide unicode and or multiple chars - if {[tcl::dict::exists $pad_cache $missing]} { - set pad [tcl::dict::get $pad_cache $missing] - } else { - set repeats [expr {int(ceil($missing / double($padcharsize)))}] ;#will overshoot by 1 whenever padcharsize not an exact divisor of width - if {!$pad_has_ansi} { - set pad [tcl::string::range [tcl::string::repeat $padchar $repeats] 0 $missing-1] - } else { - set base [tcl::string::repeat " " $missing] - set pad [overtype::block -blockalign left -overflow 0 $base [tcl::string::repeat $padchar $repeats]] - } - dict set pad_cache $missing $pad - } - switch -- $which-$opt_withinansi { - r-0 { - lappend line_chunks $pad - } - r-1 { - if {[lindex $line_chunks end] eq ""} { - set line_chunks [linsert $line_chunks end-2 $pad] - } else { - lappend line_chunks $pad - } - } - r-2 { - lappend line_chunks $pad - } - l-0 { - set line_chunks [linsert $line_chunks 0 $pad] - } - l-1 { - if {[lindex $line_chunks 0] eq ""} { - set line_chunks [linsert $line_chunks 2 $pad] - } else { - set line_chunks [linsert $line_chunks 0 $pad] - } - } - l-2 { - if {$lnum == 0} { - if {[lindex $line_chunks 0] eq ""} { - set line_chunks [linsert $line_chunks 2 $pad] - } else { - set line_chunks [linsert $line_chunks 0 $pad] - } - } else { - set line_chunks [linsert $line_chunks 0 $pad] - } - } - } - } - lappend lines [::join $line_chunks ""] - set line_chunks [list] - set line_len 0 - incr lnum - } - incr p - } - } else { - #we need to store empties in order to insert text in the correct position relative to leading/trailing ansi codes - lappend line_chunks "" - } - #don't let trailing empty ansi affect the line_chunks length - if {$ansi ne ""} { - lappend line_chunks $ansi ;#don't update line_len - review - ansi codes with visible content? - } - } - #pad last line - if {$known_samewidth eq "" || ($known_samewidth ne "" && !$known_samewidth) || $datawidth eq ""} { - set missing [expr {$width - $line_len}] - } else { - set missing [expr {$width - $datawidth}] - } - if {$missing > 0} { - if {[tcl::dict::exists $pad_cache $missing]} { - set pad [tcl::dict::get $pad_cache $missing] - } else { - set repeats [expr {int(ceil($missing / double($padcharsize)))}] ;#will overshoot by 1 whenever padcharsize not an exact divisor of width - if {!$pad_has_ansi} { - set pad [tcl::string::range [tcl::string::repeat $padchar $repeats] 0 $missing-1] - } else { - set base [tcl::string::repeat " " $missing] - set pad [overtype::block -blockalign left -overflow 0 $base [tcl::string::repeat $padchar $repeats]] - } - } - #set pad [tcl::string::repeat $padchar $missing] - switch -- $which-$opt_withinansi { - r-0 { - lappend line_chunks $pad - } - r-1 { - if {[lindex $line_chunks end] eq ""} { - set line_chunks [linsert $line_chunks end-2 $pad] - } else { - lappend line_chunks $pad - } - } - r-2 { - if {[lindex $line_chunks end] eq ""} { - set line_chunks [linsert $line_chunks end-2 $pad] - } else { - lappend line_chunks $pad - } - #lappend line_chunks $pad - } - l-0 { - #if {[lindex $line_chunks 0] eq ""} { - # set line_chunks [linsert $line_chunks 2 $pad] - #} else { - # set line_chunks [linsert $line_chunks 0 $pad] - #} - set line_chunks [linsert $line_chunks 0 $pad] - } - l-1 { - #set line_chunks [linsert $line_chunks 0 $pad] - set line_chunks [_insert_before_text_or_last_ansi $pad $line_chunks] - } - l-2 { - set line_chunks [linsert $line_chunks 0 $pad] - } - } - } - lappend lines [::join $line_chunks ""] - return [::join $lines \n] - } - - #left insertion into a list resulting from punk::ansi::ta::split_codes or split_codes_single - #resulting list is no longer a valid ansisplit list - proc _insert_before_text_or_last_ansi {str ansisplits} { - if {[llength $ansisplits] == 1} { - #ansisplits was a split on plaintext only - return [list $str [lindex $ansisplits 0]] - } elseif {[llength $ansisplits] == 0} { - return [list $str] - } - if {[llength $ansisplits] %2 != 1} { - error "_insert_before_text_or_last_ansi ansisplits list is not a valid resultlist from an ansi split - must be odd number of elements pt,ansi,pt,ansi...pt" - } - set out [list] - set i 0 - set i_last_code [expr {[llength $ansisplits]-3}] ;#would normally be -2 - but our i is jumping to each pt - not every element - foreach {pt code} $ansisplits { - if {$pt ne ""} { - return [lappend out $str {*}[lrange $ansisplits $i end]] - } - if {$i == $i_last_code} { - return [lappend out $str {*}[lrange $ansisplits $i end]] - } - #code being empty can only occur when we have reached last pt - #we have returned by then. - lappend out $code - incr i 2 - } - error "_insert_before_text_or_last_ansi failed on input str:[ansistring VIEW $str] ansisplits:[ansistring VIEW $ansisplits]" - } - proc pad_test {block} { - set width [textblock::width $block] - set padtowidth [expr {$width + 10}] - set left0 [textblock::pad $block -known_blockwidth $width -width $padtowidth -padchar . -which left -within_ansi 0] - set left1 [textblock::pad $block -known_blockwidth $width -width $padtowidth -padchar . -which left -within_ansi 1] - set left2 [textblock::pad $block -known_blockwidth $width -width $padtowidth -padchar . -which left -within_ansi 2] - set right0 [textblock::pad $block -known_blockwidth $width -width $padtowidth -padchar . -which right -within_ansi 0] - set right1 [textblock::pad $block -known_blockwidth $width -width $padtowidth -padchar . -which right -within_ansi 1] - set right2 [textblock::pad $block -known_blockwidth $width -width $padtowidth -padchar . -which right -within_ansi 2] - - set testlist [list "within_ansi 0" $left0 $right0 "within_ansi 1" $left1 $right1 "within_ansi 2" $left2 $right2] - - set t [textblock::list_as_table -columns 3 -return tableobject $testlist] - $t configure_column 0 -headers [list "ansi"] - $t configure_column 1 -headers [list "Left"] - $t configure_column 2 -headers [list "Right"] - $t configure -show_header 1 - puts stdout [$t print] - return $t - } - - proc pad_test_blocklist {blocklist args} { - set opts [tcl::dict::create\ - -description ""\ - -blockheaders ""\ - ] - foreach {k v} $args { - switch -- $k { - -description - -blockheaders { - tcl::dict::set opts $k $v - } - default { - error "pad_test_blocklist unrecognised option '$k'. Known options: [tcl::dict::keys $opts]" - } - } - } - set opt_blockheaders [tcl::dict::get $opts -blockheaders] - set bheaders [tcl::dict::create] - if {$opt_blockheaders ne ""} { - set b 0 - foreach h $opt_blockheaders { - if {$b < [llength $blocklist]} { - tcl::dict::set bheaders $b $h - } - incr b - } - } - - set b 0 - set blockinfo [tcl::dict::create] - foreach block $blocklist { - set width [textblock::width $block] - tcl::dict::set blockinfo $b width $width - set padtowidth [expr {$width + 3}] - tcl::dict::set blockinfo $b left0 [textblock::pad $block -width $padtowidth -padchar . -which left -within_ansi 0] - tcl::dict::set blockinfo $b left1 [textblock::pad $block -width $padtowidth -padchar . -which left -within_ansi 1] - tcl::dict::set blockinfo $b left2 [textblock::pad $block -width $padtowidth -padchar . -which left -within_ansi 2] - tcl::dict::set blockinfo $b right0 [textblock::pad $block -width $padtowidth -padchar . -which right -within_ansi 0] - tcl::dict::set blockinfo $b right1 [textblock::pad $block -width $padtowidth -padchar . -which right -within_ansi 1] - tcl::dict::set blockinfo $b right2 [textblock::pad $block -width $padtowidth -padchar . -which right -within_ansi 2] - incr b - } - - set r0 [list "0"] - set r1 [list "1"] - set r2 [list "2"] - set r3 [list "column\ncolours"] - - #1 - #test without table padding - #we need to textblock::join each item to ensure we don't get the table's own textblock::pad interfering - #(basically a mechanism to add extra resets at start and end of each line) - #dict for {b bdict} $blockinfo { - # lappend r0 [textblock::join [tcl::dict::get $blockinfo $b left0]] [textblock::join [tcl::dict::get $blockinfo $b right0]] - # lappend r1 [textblock::join [tcl::dict::get $blockinfo $b left1]] [textblock::join [tcl::dict::get $blockinfo $b right1]] - # lappend r2 [textblock::join [tcl::dict::get $blockinfo $b left2]] [textblock::join [tcl::dict::get $blockinfo $b right2]] - #} - - #2 - the more useful one? - tcl::dict::for {b bdict} $blockinfo { - lappend r0 [tcl::dict::get $blockinfo $b left0] [tcl::dict::get $blockinfo $b right0] - lappend r1 [tcl::dict::get $blockinfo $b left1] [tcl::dict::get $blockinfo $b right1] - lappend r2 [tcl::dict::get $blockinfo $b left2] [tcl::dict::get $blockinfo $b right2] - lappend r3 "" "" - } - - set rows [concat $r0 $r1 $r2 $r3] - - set column_ansi [a+ web-white Web-Gray] - - set t [textblock::list_as_table -columns [expr {1 + (2 * [tcl::dict::size $blockinfo])}] -return tableobject $rows] - $t configure_column 0 -headers [list [tcl::dict::get $opts -description] "within_ansi"] -ansibase $column_ansi - set col 1 - tcl::dict::for {b bdict} $blockinfo { - if {[tcl::dict::exists $bheaders $b]} { - set hdr [tcl::dict::get $bheaders $b] - } else { - set hdr "Block $b" - } - $t configure_column $col -headers [list $hdr "Left"] -minwidth [expr {$padtowidth + 2}] - $t configure_column $col -header_colspans 2 -ansibase $column_ansi - incr col - $t configure_column $col -headers [list "-" "Right"] -minwidth [expr {$padtowidth + 2}] -ansibase $column_ansi - incr col - } - $t configure -show_header 1 - puts stdout [$t print] - return $t - } - proc pad_example {} { - set headers [list] - set blocks [list] - - lappend blocks "[textblock::testblock 4 rainbow]" - lappend headers "rainbow 4x4\nresets at line extremes\nnothing trailing" - - lappend blocks "[textblock::testblock 4 rainbow][a]" - lappend headers "rainbow 4x4\nresets at line extremes\ntrailing reset" - - lappend blocks "[textblock::testblock 4 rainbow]\n[a+ Web-Green]" - lappend headers "rainbow 4x4\nresets at line extremes\ntrailing nl&green bg" - - lappend blocks "[textblock::testblock 4 {rainbow noreset}]" - lappend headers "rainbow 4x4\nno line resets\nnothing trailing" - - lappend blocks "[textblock::testblock 4 {rainbow noreset}][a]" - lappend headers "rainbow 4x4\nno line resets\ntrailing reset" - - lappend blocks "[textblock::testblock 4 {rainbow noreset}]\n[a+ Web-Green]" - lappend headers "rainbow 4x4\nno line resets\ntrailing nl&green bg" - - set t [textblock::pad_test_blocklist $blocks -description "trailing\nbg/reset\ntests" -blockheaders $headers] - } - proc pad_example2 {} { - set headers [list] - set blocks [list] - lappend blocks "[a+ web-red Web-steelblue][textblock::block 4 4 x]\n" - lappend headers "red on blue 4x4\nno inner resets\ntrailing nl" - - lappend blocks "[a+ web-red Web-steelblue][textblock::block 4 4 x]\n[a]" - lappend headers "red on blue 4x4\nno inner resets\ntrailing nl&reset" - - lappend blocks "[a+ web-red Web-steelblue][textblock::block 4 4 x]\n[a+ Web-Green]" - lappend headers "red on blue 4x4\nno inner resets\ntrailing nl&green bg" - - set t [textblock::pad_test_blocklist $blocks -description "trailing\nbg/reset\ntests" -blockheaders $headers] - } - - - #playing with syntax - - # pipealias ::textblock::join_width .= {list $lhs [tcl::string::repeat " " $w1] $rhs [tcl::string::repeat " " $w2]} {| - # /2,col1/1,col2/3 - # >} punk::lib::lines_as_list -- {| - # data2 - # >} .=lhs> punk::lib::lines_as_list -- {| - # >} .= {lmap v $data w $data2 {val "[overtype::left $col1 $v][overtype::left $col2 $w]"}} {| - # >} punk::lib::list_as_lines -- } .=> punk::lib::lines_as_list -- {| - # data2 - # >} .=lhs> punk::lib::lines_as_list -- {| - # >} .= {lmap v $data w $data2 {val "[overtype::left $col1 $v][overtype::left $col2 $w]"}} {| - # >} punk::lib::list_as_lines -- $rowcount} { - set rowcount [llength $bl] - } - lappend blocklists $bl - } - set outlines [list] - for {set r 0} {$r < $rowcount} {incr r} { - set row "" - for {set c 0} {$c < [llength $blocks]} {incr c} { - append row [lindex $blocklists $c $r] - } - lappend outlines $row - } - return [::join $outlines \n] - } - proc ::textblock::join_basic2 {args} { - #@cmd -name textblock::join_basic -help "Join blocks line by line but don't add padding on each line to enforce uniform width. - # Already uniform blocks will join faster than textblock::join, and ragged blocks will join in a ragged manner - #" - set argd [punk::args::get_dict { - -- -type none -optional 0 -help "end of options marker -- is mandatory because joined blocks may easily conflict with flags" - -ansiresets -type any -default auto - blocks -type any -multiple 1 - } $args] - set ansiresets [tcl::dict::get $argd opts -ansiresets] - set blocks [tcl::dict::get $argd values blocks] - - #-ansireplays is always on (if ansi detected) - - # -- is a legimate block - #this makes for a somewhat messy api.. -- is required if first block is actually -- (or the very unlikely case the first block is intended to be -ansiresets) - - if {![llength $blocks]} { - return - } - set idx 0 - set fordata [list] - set colindices [list] - foreach b $blocks { - if {[punk::ansi::ta::detect $b]} { - lappend fordata "v($idx)" [punk::lib::lines_as_list -ansireplays 1 -ansiresets $ansiresets -- $b] - } else { - lappend fordata "v($idx)" [split $b \n] - } - lappend colindices $idx - incr idx - } - set outlines [list] - foreach {*}$fordata { - set row {} - foreach colidx $colindices { - lappend row $v($colidx) - } - lappend outlines [::join $row ""] - } - return [::join $outlines \n] - } - #for joining 'rendered' blocks of plain or ansi text. Being 'rendered' means they are without ansi movement sequences as these have been processed - #they may however still be 'ragged' ie differing line lengths - proc ::textblock::join {args} { - #set argd [punk::args::get_dict { - # blocks -type string -multiple 1 - #} $args] - #set opts [tcl::dict::get $argd opts] - #set blocks [tcl::dict::get $argd values blocks] - - #-ansireplays is always on (if ansi detected) - - #we will support -- at posn 0 and 2 only to allow an optional single option pair for -ansiresets - #textblock::join is already somewhat expensive - we don't want to do much argument processing - #also "--" is a legitimate joining block - so we need to support that too without too much risk of misinterpretation - #this makes for a somewhat messy api.. -- is required if first block is actually -- (or the very unlikely case the first block is intended to be -ansiresets) - set ansiresets auto - switch -- [lindex $args 0] { - -- { - set blocks [lrange $args 1 end] - } - -ansiresets { - if {[lindex $args 2] eq "--"} { - set blocks [lrange $args 3 end] - set ansiresets [lindex $args 1] - } else { - error "end of opts marker -- is mandatory." - } - } - default { - if {[catch {tcl::prefix::match {-ansiresets} [lindex $args 0]} fullopt]} { - error "first flag must be -ansiresets or end of opts marker --" - } else { - if {[lindex $args 2] eq "--"} { - set blocks [lrange $args 3 end] - set ansiresets [lindex $args 1] - } else { - error "end of opts marker -- is mandatory" - } - } - } - } - - if {![llength $blocks]} { - return - } - - set idx 0 - set blocklists [list] - set rowcount 0 - foreach b $blocks { - #we need the width of a rendered block for per-row renderline calls or padding - #we may as well use widthinfo to also determine raggedness state to pass on to pad function - #set bwidth [width $b] - set widthinfo [widthinfo $b] - set bwidth [dict get $widthinfo width] - set is_samewidth [expr {![dict get $widthinfo ragged]}] - - #set c($idx) [tcl::string::repeat " " [set w($idx)]] - #fairly commonly a block may be a vertical list of chars e.g something like 1\n2\n3 or -\n-\n-\n- - #for determining a shortcut to avoid unnecessary ta::detect - (e.g width <=1) we can't use result of textblock::width as it strips ansi. - #testing of any decent size block line by line - even with max_string_length_line is slower than ta::detect anyway. - - #blocks passed to join can be ragged - so we can't pass -known_samewidth to pad - if {[punk::ansi::ta::detect $b]} { - # - we need to join to use pad - even though we then need to immediately resplit REVIEW (make line list version of pad?) - set replay_block [::join [punk::lib::lines_as_list -ansireplays 1 -ansiresets $ansiresets -- $b] \n] - set bl [split [textblock::pad $replay_block -known_hasansi 1 -known_samewidth $is_samewidth -known_blockwidth $bwidth -width $bwidth -which right -padchar " "] \n] - } else { - #each block is being rendered into its own empty column - we don't need resets if it has no ansi, even if blocks to left and right do have ansi - set bl [split [textblock::pad $b -known_hasansi 0 -known_samewidth $is_samewidth -known_blockwidth $bwidth -width $bwidth -which right -padchar " "] \n] - } - set rowcount [expr {max($rowcount,[llength $bl])}] - lappend blocklists $bl - set width($idx) $bwidth - incr idx - } - - set outlines [list] - for {set r 0} {$r < $rowcount} {incr r} { - set row "" - for {set c 0} {$c < [llength $blocklists]} {incr c} { - set cell [lindex $blocklists $c $r] - if {$cell eq ""} { - set cell [string repeat " " $width($c)] - } - append row $cell - } - lappend outlines $row - } - return [::join $outlines \n] - } - - proc ::textblock::join2 {args} { - #set argd [punk::args::get_dict { - # blocks -type string -multiple 1 - #} $args] - #set opts [tcl::dict::get $argd opts] - #set blocks [tcl::dict::get $argd values blocks] - - #-ansireplays is always on (if ansi detected) - - #we will support -- at posn 0 and 2 only to allow an optional single option pair for -ansiresets - #textblock::join is already somewhat expensive - we don't want to do much argument processing - #also "--" is a legitimate joining block - so we need to support that too without too much risk of misinterpretation - #this makes for a somewhat messy api.. -- is required if first block is actually -- (or the very unlikely case the first block is intended to be -ansiresets) - set ansiresets auto - switch -- [lindex $args 0] { - -- { - set blocks [lrange $args 1 end] - } - -ansiresets { - if {[lindex $args 2] eq "--"} { - set blocks [lrange $args 3 end] - set ansiresets [lindex $args 1] - } else { - error "end of opts marker -- is mandatory." - } - } - default { - if {[catch {tcl::prefix::match {-ansiresets} [lindex $args 0]} fullopt]} { - error "first flag must be -ansiresets or end of opts marker --" - } else { - if {[lindex $args 2] eq "--"} { - set blocks [lrange $args 3 end] - set ansiresets [lindex $args 1] - } else { - error "end of opts marker -- is mandatory" - } - } - } - } - - if {![llength $blocks]} { - return - } - - set idx 0 - set fordata [list] - set colindices [list] - foreach b $blocks { - set w($idx) [width $b] ;#we need the width of a rendered block for per-row renderline calls or padding - #set c($idx) [tcl::string::repeat " " [set w($idx)]] - #fairly commonly a block may be a vertical list of chars e.g something like 1\n2\n3 or -\n-\n-\n- - #for determining a shortcut to avoid unnecessary ta::detect - (e.g width <=1) we can't use result of textblock::width as it strips ansi. - #testing of any decent size block line by line - even with max_string_length_line is slower than ta::detect anyway. - if {[punk::ansi::ta::detect $b]} { - #lappend fordata "v($idx)" [punk::lib::lines_as_list -ansireplays 1 -ansiresets $ansiresets -- $b] - - # - we need to join to use pad - even though we then need to immediately resplit REVIEW (make line list version of pad?) - set replay_block [::join [punk::lib::lines_as_list -ansireplays 1 -ansiresets $ansiresets -- $b] \n] - lappend fordata "v($idx)" [split [textblock::pad $replay_block -known_hasansi 1 -known_blockwidth $w($idx) -width $w($idx) -which right -padchar " "] \n] - } else { - #each block is being rendered into its own empty column - we don't need resets if it has no ansi, even if blocks to left and right do have ansi - #lappend fordata "v($idx)" [split $b \n] - lappend fordata "v($idx)" [split [textblock::pad $b -known_hasansi 0 -known_blockwidth $w($idx) -width $w($idx) -which right -padchar " "] \n] - } - lappend colindices $idx - incr idx - } - - - - - set outlines [list] - #set colindices [lsort -integer -increasing [array names c]] - foreach {*}$fordata { - set row "" - foreach colidx $colindices { - #we know we have a single line, no ansi in underlay and no overflow required - so we can use renderline directly - #append row [overtype::renderline -width $w($colidx) -insert_mode 0 -info 0 $c($colidx) $v($colidx)] - #append row [textblock::pad $v($colidx) -width $w($colidx) -which right -padchar " "] - - #short blocks need to have empty lines padded too - if {$v($colidx) eq ""} { - append row [string repeat " " $w($colidx)] - } else { - append row $v($colidx) - } - } - lappend outlines $row - } - return [::join $outlines \n] - } - # This calls textblock::pad per cell :/ - proc ::textblock::join3 {args} { - #set argd [punk::args::get_dict { - # blocks -type string -multiple 1 - #} $args] - #set opts [tcl::dict::get $argd opts] - #set blocks [tcl::dict::get $argd values blocks] - - #-ansireplays is always on (if ansi detected) - - #we will support -- at posn 0 and 2 only to allow an optional single option pair for -ansiresets - #textblock::join is already somewhat expensive - we don't want to do much argument processing - #also "--" is a legitimate joining block - so we need to support that too without too much risk of misinterpretation - #this makes for a somewhat messy api.. -- is required if first block is actually -- (or the very unlikely case the first block is intended to be -ansiresets) - set ansiresets auto - switch -- [lindex $args 0] { - -- { - set blocks [lrange $args 1 end] - } - -ansiresets { - if {[lindex $args 2] eq "--"} { - set blocks [lrange $args 3 end] - set ansiresets [lindex $args 1] - } else { - error "end of opts marker -- is mandatory." - } - } - default { - if {[catch {tcl::prefix::match {-ansiresets} [lindex $args 0]} fullopt]} { - error "first flag must be -ansiresets or end of opts marker --" - } else { - if {[lindex $args 2] eq "--"} { - set blocks [lrange $args 3 end] - set ansiresets [lindex $args 1] - } else { - error "end of opts marker -- is mandatory" - } - } - } - } - - if {![llength $blocks]} { - return - } - - set idx 0 - set fordata [list] - set colindices [list] - foreach b $blocks { - set w($idx) [width $b] ;#we need the width of a rendered block for per-row renderline calls or padding - #set c($idx) [tcl::string::repeat " " [set w($idx)]] - #fairly commonly a block may be a vertical list of chars e.g something like 1\n2\n3 or -\n-\n-\n- - #for determining a shortcut to avoid unnecessary ta::detect - (e.g width <=1) we can't use result of textblock::width as it strips ansi. - #testing of any decent size block line by line - even with max_string_length_line is slower than ta::detect anyway. - if {[punk::ansi::ta::detect $b]} { - lappend fordata "v($idx)" [punk::lib::lines_as_list -ansireplays 1 -ansiresets $ansiresets -- $b] - } else { - #each block is being rendered into its own empty column - we don't need resets if it has no ansi, even if blocks to left and right do have ansi - lappend fordata "v($idx)" [split $b \n] - } - lappend colindices $idx - incr idx - } - set outlines [list] - #set colindices [lsort -integer -increasing [array names c]] - foreach {*}$fordata { - set row "" - foreach colidx $colindices { - #we know we have a single line, no ansi in underlay and no overflow required - so we can use renderline directly - #append row [overtype::renderline -width $w($colidx) -insert_mode 0 -info 0 $c($colidx) $v($colidx)] - append row [textblock::pad $v($colidx) -width $w($colidx) -which right -padchar " "] - } - lappend outlines $row - } - #puts stderr "--->outlines len: [llength $outlines]" - return [::join $outlines \n] - } - - proc ::textblock::trim {block} { - error "textblock::trim unimplemented" - set trimlines "" - } - - #pipealias ::textblock::join_right .= {list $lhs [tcl::string::repeat " " [width $lhs]] $rhs [tcl::string::repeat " " [width $rhs]]} {| - # /2,col1/1,col2/3 - # >} .=> punk::lib::lines_as_list -- {| - # data2 - # >} .=lhs> punk::lib::lines_as_list -- {| - # >} .= {lmap v $data w $data2 {val "[overtype::right $col1 $v][overtype::right $col2 $w]"}} {| - # >} punk::lib::list_as_lines punk . lhs][a]\n\n[a+ rgb#FFFF00][>punk . rhs][a] - set ipunks [overtype::renderspace -width [textblock::width $punks] [punk::ansi::enable_inverse]$punks] - set testblock [textblock::testblock 15 rainbow] - set contents $ansi\n[textblock::join -- " " $table " " $punks " " $testblock " " $ipunks " " $punks] - set framed [textblock::frame -checkargs 0 -type arc -title [a+ cyan]Compositing[a] -subtitle [a+ red]ANSI[a] -ansiborder [a+ web-orange] $contents] - } - - - proc example {args} { - set opts [tcl::dict::create -forcecolour 0] - foreach {k v} $args { - switch -- $k { - -forcecolour { - tcl::dict::set opts $k $v - } - default { - error "textblock::example unrecognised option '$k'. Known-options: [tcl::dict::keys $opts]" - } - } - } - set opt_forcecolour 0 - if {[tcl::dict::get $opts -forcecolour]} { - set fc forcecolour - set opt_forcecolour 1 - } else { - set fc "" - } - set pleft [>punk . rhs] - set pright [>punk . lhs] - set prightair [>punk . lhs_air] - set red [a+ {*}$fc red]; set redb [a+ {*}$fc red bold] - set green [a+ {*}$fc green]; set greenb [a+ {*}$fc green bold] - set cyan [a+ {*}$fc cyan];set cyanb [a+ {*}$fc cyan bold] - set blue [a+ {*}$fc blue];set blueb [a+ {*}$fc blue bold] - set RST [a] - set gr0 [punk::ansi::g0 abcdefghijklm\nnopqrstuvwxyz] - set punks [textblock::join -- $pleft $pright] - set pleft_greenb $greenb$pleft$RST - set pright_redb $redb$pright$RST - set prightair_cyanb $cyanb$prightair$RST - set cpunks [textblock::join -- $pleft_greenb $pright_redb] - set out "" - append out $punks \n - append out $cpunks \n - append out [textblock::join -- $punks $cpunks] \n - set 2frames_a [textblock::join -- [textblock::frame -checkargs 0 $cpunks] [textblock::frame -checkargs 0 $punks]] - append out $2frames_a \n - set 2frames_b [textblock::join -- [textblock::frame -checkargs 0 -ansiborder $cyanb -title "plainpunks" $punks] [textblock::frame -checkargs 0 -ansiborder $greenb -title "fancypunks" $cpunks]] - append out [textblock::frame -checkargs 0 -title "punks" $2frames_b\n$RST$2frames_a] \n - set punkdeck [overtype::right [overtype::left [textblock::frame -checkargs 0 -ansiborder [a+ green bold] -type heavy -title ${redb}PATTERN$RST -subtitle ${redb}PUNK$RST $prightair_cyanb] "$blueb\n\n\P\nU\nN\nK$RST"] "$blueb\n\nD\nE\nC\nK"] - set spantable [[spantest] print] - append out [textblock::join -- $punkdeck " " $spantable] \n - #append out [textblock::frame -title gr $gr0] - append out [textblock::periodic -forcecolour $opt_forcecolour] - return $out - } - - proc example3 {{text "test\netc\nmore text"}} { - package require patternpunk - .= textblock::join -- [punk::lib::list_as_lines -- [list 1 2 3 4 5 6 7]] [>punk . lhs] |> .=>1 textblock::join -- " " |> .=>1 textblock::join -- $text |> .=>1 textblock::join -- [>punk . rhs] |> .=>1 textblock::join -- [punk::lib::list_as_lines -- [lrepeat 7 " | "]] - } - proc example2 {{text "test\netc\nmore text"}} { - package require patternpunk - .= textblock::join\ - --\ - [punk::lib::list_as_lines -- [list 1 2 3 4 5 6 7 8]]\ - [>punk . lhs]\ - " "\ - $text\ - [>punk . rhs]\ - [punk::lib::list_as_lines -- [lrepeat 8 " | "]] - } - proc table {args} { - #todo - use punk::args - upvar ::textblock::class::opts_table_defaults toptdefaults - set defaults [tcl::dict::create\ - -rows [list]\ - -headers [list]\ - -return string\ - ] - - - set defaults [tcl::dict::merge $defaults $toptdefaults] ;# -title -frametype -show_header etc - set opts [tcl::dict::merge $defaults $args] - # -- --- --- --- - set opt_return [tcl::dict::get $opts -return] - set opt_rows [tcl::dict::get $opts -rows] - set opt_headers [tcl::dict::get $opts -headers] - # -- --- --- --- - set topts [tcl::dict::create] - set toptkeys [tcl::dict::keys $toptdefaults] - tcl::dict::for {k v} $opts { - if {$k in $toptkeys} { - tcl::dict::set topts $k $v - } - } - set t [textblock::class::table new {*}$topts] - - foreach h $opt_headers { - $t add_column -headers [list $h] - } - if {[$t column_count] == 0} { - if {[llength $opt_rows]} { - set r0 [lindex $opt_rows 0] - foreach c $r0 { - $t add_column - } - } - } - foreach r $opt_rows { - $t add_row $r - } - - - - if {$opt_return eq "string"} { - set result [$t print] - $t destroy - return $result - } else { - return $t - } - } - - proc frametype {f} { - #set custom_keys [list hl hlt hlb vl vll vlr tlc trc blc brc] - switch -- $f { - light - light_b - light_c - heavy - heavy_b - heavy_c - arc - arc_b - arc_c - double - block - block1 - block2 - block2hack - ascii - altg { - return [tcl::dict::create category predefined type $f] - } - default { - set is_custom_dict_ok 1 - if {[llength $f] %2 == 0} { - #custom dict may leave out keys - but cannot have unknown keys - foreach {k v} $f { - switch -- $k { - all - hl - hlt - hlb - vl - vll - vlr - tlc - trc - blc - brc {} - hltj - hlbj - vllj - vlrj { - #also allow extra join arguments - } - default { - #k not in custom_keys - set is_custom_dict_ok 0 - break - } - } - } - } else { - set is_custom_dict_ok 0 - } - if {!$is_custom_dict_ok} { - error "frame option -type must be one of known types: $::textblock::frametypes or a dictionary with any of keys all,hl,hlt,hlb,vl,vll,vlr,tlc,trc,blc,brc" - } - if {[dict exists $f all]} { - return [tcl::dict::create category custom type $f] - } else { - set default_custom [tcl::dict::create hl " " vl " " tlc " " trc " " blc " " brc " "] - set custom_frame [tcl::dict::merge $default_custom $f] - return [tcl::dict::create category custom type $custom_frame] - } - } - } - } - variable framedef_cache [tcl::dict::create] - proc framedef {args} { - #unicode box drawing only provides enough characters for seamless joining of unicode boxes light and heavy. - #e.g with characters such as \u2539 Box Drawings Right Light and Left Up Heavy. - #the double glyphs in box drawing can do a limited set of joins to light lines - but not enough for seamless table layouts. - #the arc set can't even join to itself e.g with curved equivalents of T-like shapes - - #we use the simplest cache_key possible - performance sensitive as called multiple times in table building. - variable framedef_cache - set cache_key $args - if {[tcl::dict::exists $framedef_cache $cache_key]} { - return [tcl::dict::get $framedef_cache $cache_key] - } - - - #here we avoid the punk::args usage on the happy path, even though punk::args is fairly fast, in favour of an even faster literal switch on the happy path - #this means we have some duplication in where our flags/opts are defined: here in opts, and in spec below to give nicer error output without affecting performance. - #It also means we can't specify checks on the option types etc - set opts [tcl::dict::create\ - -joins ""\ - -boxonly 0\ - ] - set bad_option 0 - set values [list] - for {set i 0} {$i < [llength $args]} {incr i} { - set a [lindex $args $i] - set a2 [tcl::prefix match -error "" {-- -joins -boxonly} $a] - switch -- $a2 { - -joins - -boxonly { - tcl::dict::set opts $a2 [lindex $args [incr i]] - } - -- { - set values [lrange $args $i+1 end] - break - } - default { - if {[string match -* $a]} { - set bad_option 1 - } else { - set values [lrange $args $i end] - } - break - } - } - } - set f [lindex $values 0] - set rawglobs [lrange $values 1 end] - if {![llength $rawglobs] || "all" in $rawglobs || "*" in $rawglobs} { - set globs * - } else { - set globs [list] - foreach g $rawglobs { - switch -- $g { - hl - hlt - hlb - vl - vll - vlr - tlc - trc - blc - brc - - hltj - hlbj - vllj - vlrj { - lappend globs $g - } - corner - corners { - lappend globs tlc blc trc brc - } - noncorner - noncorners { - #same as verticals + horizontals - lappend globs hl* vl* - } - vertical - verticals { - #we don't consider the corners part of this - lappend globs vl* - } - horizontal - horizontals { - lappend globs hl* - } - top - tops { - lappend globs tlc trc hlt* - } - bottom - bottoms { - lappend globs blc brc hlb* - } - left - lefts - lhs { - lappend globs tlc blc vll* - } - right - rights - rhs { - lappend globs trc brc vlr* - } - default { - #must look like a glob search if not one of the above - if {[regexp {[*?\[\]]} $g]} { - lappend globs $g - } else { - set bad_option 1 - } - } - } - } - } - if {$bad_option || [llength $values] == 0} { - #no framedef supplied, or unrecognised opt seen - set spec [string map [list $::textblock::frametypes] { - @id -id ::textblock::framedef - @cmd -name textblock::framedef\ - -help "Return a dict of the elements that make up a frame border. - May return a subset of available elements based on memberglob values." - - -joins -default "" -type list\ - -help "List of join directions, any of: up down left right - or those combined with another frametype e.g left-heavy down-light." - -boxonly -default 0 -type boolean\ - -help "-boxonly true restricts results to the corner,vertical and horizontal box elements - It excludes the extra top and side join elements htlj,hlbj,vllj,vlrj." - - @values -min 1 - frametype -choices "" -choiceprefix 0 -choicerestricted 0 -type dict\ - -help "name from the predefined frametypes or an adhoc dictionary." - memberglob -type globstring -optional 1 -multiple 1 -choiceprefix 0 -choicerestricted 0 -choices { - corner noncorner top bottom vertical horizontal left right - hl hlt hlb vsl vll vlr tlc trc blc brc hltj hlbj vllj vlrj - }\ - -help "restrict to keys matching memberglob." - }] - #append spec \n "frametype -help \"A predefined \"" - punk::args::get_dict $spec $args - return - } - - set joins [tcl::dict::get $opts -joins] - set boxonly [tcl::dict::get $opts -boxonly] - - - #sorted order down left right up - #1 x choose 4 - #4 x choose 3 - #6 x choose 2 - #4 x choose 1 - #15 combos - - set join_directions [list] - #targets - light,heavy (double?) - seem to be some required glyphs missing from unicode - #e.g down-light, up-heavy - set join_targets [tcl::dict::create left "" down "" right "" up ""] - foreach jt $joins { - lassign [split $jt -] direction target - if {$target ne ""} { - tcl::dict::set join_targets $direction $target - } - lappend join_directions $direction - } - set join_directions [lsort -unique $join_directions] - set do_joins [::join $join_directions _] - - - switch -- $f { - "altg" { - #old style ansi escape sequences with alternate graphics page G0 - set hl [cd::hl] - set hlt $hl - set hlb $hl - set vl [cd::vl] - set vll $vl - set vlr $vl - set tlc [cd::tlc] - set trc [cd::trc] - set blc [cd::blc] - set brc [cd::brc] - - #horizontal and vertical bar joins - set hltj $hlt - set hlbj $hlb - set vllj $vll - set vlrj $vlr - #No join targets available to join altg to other box styles - switch -- $do_joins { - down { - #1 - set blc [punk::ansi::g0 t] ;#(ltj) - set brc [punk::ansi::g0 u] ;#(rtj) - set hlbj [punk::ansi::g0 w] ;#(ttj) - } left { - #2 - set tlc [punk::ansi::g0 w] ;#(ttj) - set blc [punk::ansi::g0 v] ;#(btj) - set vllj [punk::ansi::g0 u] ;#(rtj) - } - right { - #3 - set trc [punk::ansi::g0 w] ;#(ttj) - set brc [punk::ansi::g0 v] ;#(btj) - set vlrj [punk::ansi::g0 t] ;#(ltj) - } - up { - #4 - set tlc [punk::ansi::g0 t] ;#(ltj) - set trc [punk::ansi::g0 u] ;#(rtj) - set hltj [punk::ansi::g0 v];#(btj) - } - down_left { - #5 - set blc [punk::ansi::g0 n] ;#(fwj) - set tlc [punk::ansi::g0 w] ;#(ttj) - set brc [punk::ansi::g0 u] ;#(rtj) - set hlbj [punk::ansi::g0 w] ;#(ttj) - set vllj [punk::ansi::g0 u] ;#(rtj) - } - down_right { - #6 - set blc [punk::ansi::g0 t] ;#(ltj) - set trc [punk::ansi::g0 w] ;#(ttj) - set brc [punk::ansi::g0 n] ;#(fwj) - set hlbj [punk::ansi::g0 w] ;#(ttj) - set vlrj [punk::ansi::g0 t] ;#(ltj) - } - down_up { - #7 - set blc [punk::ansi::g0 t] ;#(ltj) - set brc [punk::ansi::g0 u] ;#(rtj) - - set tlc [punk::ansi::g0 t] ;#(ltj) - set trc [punk::ansi::g0 u] ;#(rtj) - set hlbj [punk::ansi::g0 w] ;#(ttj) - set hltj [punk::ansi::g0 v];#(btj) - } - left_right { - #8 - #from 2 - set tlc [punk::ansi::g0 w] ;#(ttj) - set blc [punk::ansi::g0 v] ;#(btj) - #from3 - set trc [punk::ansi::g0 w] ;#(ttj) - set brc [punk::ansi::g0 v] ;#(btj) - set vllj [punk::ansi::g0 u] ;#(rtj) - set vlrj [punk::ansi::g0 t] ;#(ltj) - } - left_up { - #9 - set tlc [punk::ansi::g0 n] ;#(fwj) - set trc [punk::ansi::g0 u] ;#(rtj) - set blc [punk::ansi::g0 v] ;#(btj) - set vllj [punk::ansi::g0 u] ;#(rtj) - } - right_up { - #10 - set tlc [punk::ansi::g0 t] ;#(ltj) - set trc [punk::ansi::g0 n] ;#(fwj) - set brc [punk::ansi::g0 v] ;#(btj) - set hltj [punk::ansi::g0 v];#(btj) - set vlrj [punk::ansi::g0 t] ;#(ltj) - } - down_left_right { - #11 - set blc [punk::ansi::g0 n] ;#(fwj) - set brc [punk::ansi::g0 n] ;#(fwj) - set trc [punk::ansi::g0 w] ;#(ttj) - set tlc [punk::ansi::g0 w] ;#(ttj) - set vllj [punk::ansi::g0 u] ;#(rtj) - set vlrj [punk::ansi::g0 t] ;#(ltj) - set hlbj [punk::ansi::g0 w] ;#(ttj) - } - down_left_up { - #12 - set tlc [punk::ansi::g0 n] ;#(fwj) - set blc [punk::ansi::g0 n] ;#(fwj) - set trc [punk::ansi::g0 u] ;#(rtj) - set brc [punk::ansi::g0 u] ;#(rtj) - set vllj [punk::ansi::g0 u] ;#(rtj) - set hltj [punk::ansi::g0 v];#(btj) - set hlbj [punk::ansi::g0 w] ;#(ttj) - } - down_right_up { - #13 - set tlc [punk::ansi::g0 t] ;#(ltj) - set blc [punk::ansi::g0 t] ;#(ltj) - set trc [punk::ansi::g0 n] ;#(fwj) - set brc [punk::ansi::g0 n] ;#(fwj) - set hltj [punk::ansi::g0 v];#(btj) - set vlrj [punk::ansi::g0 t] ;#(ltj) - set hlbj [punk::ansi::g0 w] ;#(ttj) - } - left_right_up { - #14 - set tlc [punk::ansi::g0 n] ;#(fwj) - set trc [punk::ansi::g0 n] ;#(fwj) - set blc [punk::ansi::g0 v] ;#(btj) - set brc [punk::ansi::g0 v] ;#(btj) - set vllj [punk::ansi::g0 u] ;#(rtj) - set hltj [punk::ansi::g0 v];#(btj) - set vlrj [punk::ansi::g0 t] ;#(ltj) - } - down_left_right_up { - #15 - set tlc [punk::ansi::g0 n] ;#(fwj) - set blc [punk::ansi::g0 n] ;#(fwj) - set trc [punk::ansi::g0 n] ;#(fwj) - set brc [punk::ansi::g0 n] ;#(fwj) - set vllj [punk::ansi::g0 u] ;#(rtj) - set hltj [punk::ansi::g0 v];#(btj) - set vlrj [punk::ansi::g0 t] ;#(ltj) - set hlbj [punk::ansi::g0 w] ;#(ttj) - } - } - - - } - "ascii" { - set hl - - set hlt - - set hlb - - set vl | - set vll | - set vlr | - set tlc + - set trc + - set blc + - set brc + - #horizontal and vertical bar joins - #set hltj $hlt - #set hlbj $hlb - #set vllj $vll - #set vlrj $vlr - #ascii + is small - can reasonably be considered a join to anything? - set hltj + - set hlbj + - set vllj + - set vlrj + - #our corners are all + already - so we won't do anything for directions or targets - - } - "light" { - #unicode box drawing set - set hl [punk::char::charshort boxd_lhz] ;# light horizontal - set hlt $hl - set hlb $hl - set vl [punk::char::charshort boxd_lv] ;#light vertical - set vll $vl - set vlr $vl - set tlc [punk::char::charshort boxd_ldr] - set trc [punk::char::charshort boxd_ldl] - set blc [punk::char::charshort boxd_lur] - set brc [punk::char::charshort boxd_lul] - - #horizontal and vertical bar joins - set hltj $hlt - set hlbj $hlb - set vllj $vll - set vlrj $vlr - - #15 combos - #sort order: down left right up - #ltj,rtj,ttj,btj e.g left T junction etc. - #Look at from the perspective of a frame/table outline with a clean border and arms pointing inwards - - #set targetdown,targetleft,targetright,targetup vars - #default empty targets to current box type 'light' - foreach dir {down left right up} { - set rawtarget [tcl::dict::get $join_targets $dir] - lassign [split $rawtarget _] target ;# treat variants light light_b lightc the same - switch -- $target { - "" - light { - set target$dir light - } - ascii - altg - arc { - set target$dir light - } - heavy { - set target$dir $target - } - default { - set target$dir other - } - } - } - switch -- $do_joins { - down { - #1 - switch -- $targetdown { - heavy { - set blc [punk::char::charshort boxd_dhrul] ;#\u251f down hieavy and right up light (ltj) - set brc \u2527 ;#boxd_dhlul down heavy and left up light (rtj) - set hlbj \u2530 ;# down heavy (ttj) - } - light { - set blc \u251c ;#[punk::char::charshort boxd_lvr] light vertical and right (ltj) - set brc [punk::char::charshort boxd_lvl] ;#light vertical and left (rtj) - set hlbj \u252c ;# (ttj) - } - } - } - left { - #2 - switch -- $targetleft { - heavy { - set tlc \u252d ;# Left Heavy and Right Down Light (ttj) - set blc \u2535 ;# Left Heavy and Right Up Light (btj) - set vllj \u2525 ;# left heavy (rtj) - } - light { - set tlc [punk::char::charshort boxd_ldhz] ;#T shape (ttj) - joinleft - set blc [punk::char::charshort boxd_luhz] ;#upside down T shape (btj) - set vllj \u2524 ;# (rtj) - } - } - } - right { - #3 - switch -- $targetright { - heavy { - set trc \u252e ;#Right Heavy and Left Down Light (ttj) - set brc \u2536 ;#Right Heavy and Left up Light (btj) - set vlrj \u251d;#right heavy (ltj) - } - light { - set trc [punk::char::charshort boxd_ldhz] ;#T shape (ttj) - set brc [punk::char::charshort boxd_luhz] ;#upside down T shape (btj) - set vlrj \u251c;# (ltj) - } - } - } - up { - #4 - switch -- $targetup { - heavy { - set tlc \u251e ;#up heavy (ltj) - set trc \u2526 ;#up heavy (rtj) - } - light { - set tlc [punk::char::charshort boxd_lvr] ;#light vertical and right (ltj) - set trc [punk::char::charshort boxd_lvl] ;#light vertical and left (rtj) - } - } - } - down_left { - #5 - switch -- $targetdown-$targetleft { - other-light { - set blc \u2534 ;#(btj) - set tlc \u252c ;#(ttj) - #brc - default corner - set vllj \u2524 ;# (rtj) - } - other-other { - #default corners - } - other-heavy { - set blc \u2535 ;# heavy left (btj) - set tlc \u252d ;#heavy left (ttj) - #brc default corner - set vllj \u2525 ;# heavy left (rtj) - } - heavy-light { - set blc \u2541 ;# heavy down (fwj) - set tlc \u252c ;# light (ttj) - set brc \u2527 ;# heavy down (rtj) - set vllj \u2524 ;# (rtj) - set hlbj \u2530 ;# heavy down (ttj) - } - heavy-other { - set blc \u251f ;#heavy down (ltj) - #tlc - default corner - set brc \u2527 ;#heavy down (rtj) - set hlbj \u2530 ;# heavy down (ttj) - } - heavy-heavy { - set blc \u2545 ;#heavy down and left (fwj) - set tlc \u252d ;#heavy left (ttj) - set brc \u2527 ;#heavy down (rtj) - set vllj \u2525 ;# heavy left (rtj) - set hlbj \u2530 ;# heavy down (ttj) - } - light-light { - set blc \u253c ;# [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) - set tlc \u252c ;# boxd_ldhz (ttj) - set brc \u2524 ;# boxd_lvl light vertical and left(rtj) - set vllj \u2524 ;# (rtj) - set hlbj \u252c ;# (ttj) - } - light-other { - set blc \u251c ;# (ltj) - #tlc - default corner - set brc \u2524 ;# boxd_lvl (rtj) - set hlbj \u252c ;# (ttj) - } - light-heavy { - set blc \u253d ;# heavy left (fwj) - set tlc \u252d ;# heavy left (ttj) - set brc \u2524 ;# light (rtj) - set vllj \u2525 ;# heavy left (rtj) - set hlbj \u252c ;# (ttj) - } - default { - set blc \u253c ;# [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) - set tlc \u252c ;# [punk::char::charshort boxd_ldhz] ;#T shape (ttj) - set brc \u2524 ;# [punk::char::charshort boxd_lvl] ;#light vertical and left (rtj) - } - } - } - down_right { - #6 - set blc [punk::char::charshort boxd_lvr] ;#light vertical and right (ltj) - set trc [punk::char::charshort boxd_ldhz] ;#T shape (ttj) - set brc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) - } - down_up { - #7 - set blc [punk::char::charshort boxd_lvr] ;#light vertical and right (ltj) - set brc [punk::char::charshort boxd_lvl] ;#light vertical and left (rtj) - - set tlc [punk::char::charshort boxd_lvr] ;#light vertical and right (ltj) - set trc [punk::char::charshort boxd_lvl] ;#light vertical and left (rtj) - } - left_right { - #8 - #from 2 - set tlc [punk::char::charshort boxd_ldhz] ;#T shape (ttj) - joinleft - set blc [punk::char::charshort boxd_luhz] ;#upside down T shape (btj) - #from3 - set trc [punk::char::charshort boxd_ldhz] ;#T shape (ttj) - set brc [punk::char::charshort boxd_luhz] ;#upside down T shape (btj) - - - switch -- $targetleft-$targetright { - heavy-light { - set tlc \u252d ;# Left Heavy and Right Down Light (ttj) - set blc \u2535 ;# Left Heavy and Right Up Light (btj) - set vllj \u2525 ;# left heavy (rtj) - set vlrj \u251c;#right light (ltj) - } - heavy-other { - set tlc \u252d ;# Left Heavy and Right Down Light (ttj) - set blc \u2535 ;# Left Heavy and Right Up Light (btj) - set vllj \u2525 ;# left heavy (rtj) - } - heavy-heavy { - set vllj \u2525 ;# left heavy (rtj) - set vlrj \u251d;#right heavy (ltj) - set tlc \u252d ;# Left Heavy and Right Down Light (ttj) - set blc \u2535 ;# Left Heavy and Right Up Light (btj) - set trc \u252e ;#Right Heavy and Left Down Light (ttj) - set brc \u2536 ;#Right Heavy and Left up Light (btj) - } - light-heavy { - set trc \u252e ;#Right Heavy and Left Down Light (ttj) - set brc \u2536 ;#Right Heavy and Left up Light (btj) - set vlrj \u251d;#right heavy (ltj) - set vllj \u2524 ;# left light (rtj) - } - light-other { - set vllj \u2524 ;# left light (rtj) - } - light-light { - set vllj \u2524 ;# left light (rtj) - set vlrj \u251c;#right light (ltj) - } - } - #set vllj \u2525 ;# left heavy (rtj) - #set vllj \u2524 ;# left light (rtj) - #set vlrj \u251d;#right heavy (ltj) - #set vlrj \u251c;#right light (ltj) - } - left_up { - #9 - set tlc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) - set trc [punk::char::charshort boxd_lvl] ;#light vertical and left (rtj) - set blc [punk::char::charshort boxd_luhz] ;#upside down T shape (btj) - } - right_up { - #10 - set tlc [punk::char::charshort boxd_lvr] ;#light vertical and right (ltj) - set trc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) - set brc [punk::char::charshort boxd_luhz] ;#upside down T shape (btj) - } - down_left_right { - #11 - set blc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) - set brc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) - set trc [punk::char::charshort boxd_ldhz] ;#T shape (ttj) - set tlc [punk::char::charshort boxd_ldhz] ;#T shape (ttj) - - } - down_left_up { - #12 - set tlc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) - set blc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) - set trc [punk::char::charshort boxd_lvl] ;#light vertical and left (rtj) - set brc [punk::char::charshort boxd_lvl] ;#light vertical and left (rtj) - - } - down_right_up { - #13 - set tlc [punk::char::charshort boxd_lvr] ;#light vertical and right (ltj) - set blc [punk::char::charshort boxd_lvr] ;#light vertical and right (ltj) - set trc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) - set brc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) - } - left_right_up { - #14 - set tlc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) - set trc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) - set blc [punk::char::charshort boxd_luhz] ;#upside down T shape (btj) - set brc [punk::char::charshort boxd_luhz] ;#upside down T shape (btj) - - } - down_left_right_up { - #15 - set tlc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) - set blc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) - set trc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) - set brc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) - } - } - #four way junction (cd::fwj) (punk::ansi::g0 n) (punk::char::charshort lvhz) (+) - } - light_b { - set hl " " - set hlt " " - set hlb " " - set vl " " - set vll " " - set vlr " " - set tlc " " - set trc " " - set blc " " - set brc " " - #horizontal and vertical bar joins - set hltj " " - set hlbj " " - set vllj " " - set vlrj " " - - set arcframe [textblock::framedef -boxonly $boxonly -joins $joins light corner vll vlr vllj vlrj] - tcl::dict::with arcframe {} ;#extract keys as vars - } - light_c { - set hl " " - set hlt " " - set hlb " " - set vl " " - set vll " " - set vlr " " - set tlc " " - set trc " " - set blc " " - set brc " " - #horizontal and vertical bar joins - set hltj " " - set hlbj " " - set vllj " " - set vlrj " " - - set arcframe [textblock::framedef -boxonly $boxonly -joins $joins light corner] - tcl::dict::with arcframe {} ;#extract keys as vars - } - "heavy" { - #unicode box drawing set - set hl [punk::char::charshort boxd_hhz] ;# light horizontal - set hlt $hl - set hlb $hl - set vl [punk::char::charshort boxd_hv] ;#light vertical - set vll $vl - set vlr $vl - set tlc [punk::char::charshort boxd_hdr] - set trc [punk::char::charshort boxd_hdl] - set blc [punk::char::charshort boxd_hur] - set brc [punk::char::charshort boxd_hul] - #horizontal and vertical bar joins - set hltj $hlt - set hlbj $hlb - set vllj $vll - set vlrj $vlr - - #set targetdown,targetleft,targetright,targetup vars - #default empty targets to current box type 'heavy' - foreach dir {down left right up} { - set target [tcl::dict::get $join_targets $dir] - switch -- $target { - "" - heavy { - set target$dir heavy - } - light - ascii - altg - arc { - set target$dir light - } - default { - set target$dir other - } - } - } - switch -- $do_joins { - down { - #1 - switch -- $targetdown { - light { - set blc [punk::char::charshort boxd_dlruh] ;#\u2521 down light and right up heavy (ltj) - set brc [punk::char::charshort boxd_dlluh] ;#\u2529 down light and left up heavy (rtj) - set hlbj \u252F ;#down light (ttj) - } - heavy { - set blc [punk::char::charshort boxd_hvr] ;# (ltj) - set brc [punk::char::charshort boxd_hvl] ;# (rtj) - set hlbj \u2533 ;# down heavy (ttj) - } - } - } - left { - #2 - switch -- $targetleft { - light { - set tlc [punk::char::charshort boxd_llrdh] ;#\u2532 Left Light and Right Down Heavy (ttj) - set blc [punk::char::charshort boxd_llruh] ;#\u253a Left Light and Right Up Heavy (btj) - set vllj \u2528 ;# left light (rtj) - } - heavy { - set tlc [punk::char::charshort boxd_hdhz] ;# (ttj) - set blc [punk::char::charshort boxd_huhz] ;# (btj) - set vllj \u252b ;#(rtj) - } - } - } - right { - #3 - switch -- $targetright { - light { - set trc [punk::char::charshort boxd_rlldh] ;#\u2531 Right Light and Left Down Heavy (ttj) - set brc [punk::char::charshort boxd_rlluh] ;#\u2539 Right Light and Left Up Heavy(btj) - set vlrj \u2520 ;#right light (ltj) - } - heavy { - set trc [punk::char::charshort boxd_hdhz] ;#T shape (ttj) - set brc [punk::char::charshort boxd_huhz] ;# (btj) - set vlrj \u2523 ;# (ltj) - } - } - } - up { - #4 - switch -- $targetup { - light { - set tlc [punk::char::charshort boxd_ulrdh] ;#\u2522 Up Light and Right Down Heavy (ltj) - set trc [punk::char::charshort boxd_ulldh] ;#\u252a Up Light and Left Down Heavy (rtj) - set hltj \u2537 ;# up light (btj) - } - heavy { - set tlc [punk::char::charshort boxd_hvr] ;# (ltj) - set trc [punk::char::charshort boxd_hvl] ;# (rtj) - set hltj \u253b ;# (btj) - } - } - } - down_left { - #down_left is the main join type used for 'L' shaped cell border table building where we boxlimit to {vll hlb blc} - #5 - switch -- down-$targetdown-left-$targetleft { - down-light-left-heavy { - set blc [punk::char::charshort boxd_dluhzh] ;#down light and up horizontal heavy (fwj) - set brc [punk::char::charshort boxd_dlluh] ;#\u2529 down light and left up heavy (rtj) - set tlc [punk::char::charshort boxd_hdhz] ;# (ttj) (at tlc down stays heavy) - set hlbj \u252F ;# down light (ttj) - set vllj \u252b ;#(rtj) - } - down-heavy-left-light { - set blc [punk::char::charshort boxd_llrvh] ;# left light and right Vertical Heavy (fwj) - set brc [punk::char::charshort boxd_hvl] ;# (rtj) (at brc left must stay heavy) - set tlc [punk::char::charshort boxd_llrdh] ;#\u2532 Left Light and Right Down Heavy (ttj) - set hlbj \u2533 ;# down heavy (ttj) - set vllj \u2528 ;# left light (rtj) - } - down-light-left-light { - set blc [punk::char::charshort boxd_ruhldl] ;#\u2544 right up heavy and left down light (fwj) - set brc [punk::char::charshort boxd_dlluh] ;#\u2529 Down Light and left Up Heavy (rtj) (left must stay heavy) - set tlc [punk::char::charshort boxd_llrdh] ;#\u2532 Left Light and Right Down Heavy (ttj) (we are in heavy - so down must stay heavy at tlc) - set hlbj \u252F ;# down light (ttj) - set vllj \u2528 ;# left light (rtj) - } - down-heavy-left-heavy { - set blc [punk::char::charshort boxd_hvhz] ;# (fwj) - set brc [punk::char::charshort boxd_hvl] ;# (rtj) - set tlc [punk::char::charshort boxd_hdhz] ;# (ttj) - set hlbj \u2533 ;#(ttj) - set vllj \u252b ;#(rtj) - } - down-other-left-heavy { - set blc \u253b ;#boxd_huhz Heavy Up and Horizontal (btj) - #leave brc default corner - set tlc \u2533 ;#hdhz Heavy Down and Horizontal (ttj) - - set vllj \u252b ;#(rtj) - } - down-other-left-light { - set blc \u253a ;#llruh Left Light and Right Up Heavy (btj) - #leave brc default corner - set tlc \u2532 ;#llrdh Left Light and Right Down Heavy (ttj) - - set vllj \u2528 ;# left light (rtj) - } - down-heavy-left-other { - set blc \u2523 ;#hvr Heavy Vertical and Right (ltj) - set brc \u252b ;#hvl Heavy Veritcal and Left (rtj) - #leave tlc default corner - - set hlbj \u2533 ;#(ttj) - } - down-light-left-other { - set blc \u2521 ;#dlruh Down Light and Right Up Heavy (ltj) - set brc \u2529 ;#dlluh Down Light and Left Up Heavy (rtj) - #leave tlc default corner - - set hlbj \u252F ;# down light (ttj) - } - } - } - down_right { - #6 - set blc [punk::char::charshort boxd_hvr] ;# (ltj) (blc right&up stay heavy) - set trc [punk::char::charshort boxd_hdhz] ;# (ttj) (tlc down&left stay heavy) - set brc [punk::char::charshort boxd_hvhz] ;# (fwj) (brc left&up heavy) - } - down_up { - #7 - set blc [punk::char::charshort boxd_hvr] ;# (ltj) - set brc [punk::char::charshort boxd_hvl] ;# (rtj) - - set tlc [punk::char::charshort boxd_hvr] ;# (ltj) - set trc [punk::char::charshort boxd_hvl] ;# (rtj) - } - left_right { - #8 - #from 2 - set tlc [punk::char::charshort boxd_hdhz] ;# (ttj) - set blc [punk::char::charshort boxd_huhz] ;# (btj) - #from3 - set trc [punk::char::charshort boxd_hdhz] ;# (ttj) - set brc [punk::char::charshort boxd_huhz] ;# (btj) - } - left_up { - #9 - set tlc [punk::char::charshort boxd_hvhz] ;# (fwj) - set trc [punk::char::charshort boxd_hvl] ;# (rtj) - set blc [punk::char::charshort boxd_huhz] ;# (btj) - } - right_up { - #10 - set tlc [punk::char::charshort boxd_hvr] ;# (ltj) - set trc [punk::char::charshort boxd_hvhz] ;# (fwj) - set brc [punk::char::charshort boxd_huhz] ;# (btj) - } - down_left_right { - #11 - set blc [punk::char::charshort boxd_hvhz] ;# (fwj) - set brc [punk::char::charshort boxd_hvhz] ;# (fwj) - set trc [punk::char::charshort boxd_hdhz] ;# (ttj) - set tlc [punk::char::charshort boxd_hdhz] ;# (ttj) - - } - down_left_up { - #12 - set tlc [punk::char::charshort boxd_hvhz] ;# (fwj) - set blc [punk::char::charshort boxd_hvhz] ;# (fwj) - set trc [punk::char::charshort boxd_hvl] ;# (rtj) - set brc [punk::char::charshort boxd_hvl] ;# (rtj) - - } - down_right_up { - #13 - set tlc [punk::char::charshort boxd_hvr] ;# (ltj) - set blc [punk::char::charshort boxd_hvr] ;# (ltj) - set trc [punk::char::charshort boxd_hvhz] ;# (fwj) - set brc [punk::char::charshort boxd_hvhz] ;# (fwj) - } - left_right_up { - #14 - set tlc [punk::char::charshort boxd_hvhz] ;# (fwj) - set trc [punk::char::charshort boxd_hvhz] ;# (fwj) - set blc [punk::char::charshort boxd_huhz] ;# (btj) - set brc [punk::char::charshort boxd_huhz] ;# (btj) - - } - down_left_right_up { - #15 - set tlc [punk::char::charshort boxd_hvhz] ;# (fwj) - set blc [punk::char::charshort boxd_hvhz] ;# (fwj) - set trc [punk::char::charshort boxd_hvhz] ;# (fwj) - set brc [punk::char::charshort boxd_hvhz] ;# (fwj) - } - } - } - heavy_b { - set hl " " - set hlt " " - set hlb " " - set vl " " - set vll " " - set vlr " " - set tlc " " - set trc " " - set blc " " - set brc " " - #horizontal and vertical bar joins - set hltj " " - set hlbj " " - set vllj " " - set vlrj " " - - set arcframe [textblock::framedef -boxonly $boxonly -joins $joins heavy corner vll vlr vllj vlrj] - tcl::dict::with arcframe {} ;#extract keys as vars - } - heavy_c { - set hl " " - set hlt " " - set hlb " " - set vl " " - set vll " " - set vlr " " - set tlc " " - set trc " " - set blc " " - set brc " " - #horizontal and vertical bar joins - set hltj " " - set hlbj " " - set vllj " " - set vlrj " " - - set arcframe [textblock::framedef -boxonly $boxonly -joins $joins heavy corner] - tcl::dict::with arcframe {} ;#extract keys as vars - } - "double" { - #unicode box drawing set - set hl [punk::char::charshort boxd_dhz] ;# double horizontal \U2550 - set hlt $hl - set hlb $hl - set vl [punk::char::charshort boxd_dv] ;#double vertical \U2551 - set vll $vl - set vlr $vl - set tlc [punk::char::charshort boxd_ddr] ;#double down and right \U2554 - set trc [punk::char::charshort boxd_ddl] ;#double down and left \U2557 - set blc [punk::char::charshort boxd_dur] ;#double up and right \U255A - set brc [punk::char::charshort boxd_dul] ;#double up and left \U255D - - #horizontal and vertical bar joins - set hltj $hlt - set hlbj $hlb - set vllj $vll - set vlrj $vlr - - # \u256c (fwj) - - #set targetdown,targetleft,targetright,targetup vars - #default empty targets to current box type 'double' - foreach dir {down left right up} { - set target [tcl::dict::get $join_targets $dir] - switch -- $target { - "" - double { - set target$dir double - } - light { - set target$dir light - } - default { - set target$dir other - } - } - } - - #unicode provides no joining for double to anything else - #better to leave a gap by using default double corners if join target is not empty or double - switch -- $do_joins { - down { - #1 - switch -- $targetdown { - double { - set blc \u2560 ;# (ltj) - set brc \u2563 ;# (rtj) - set hlbj \u2566 ;# (ttj) - } - light { - set hlbj \u2564 ;# down light (ttj) - } - } - } - left { - #2 - switch -- $targetleft { - double { - set tlc \u2566 ;# (ttj) - set blc \u2569 ;# (btj) - set vllj \u2563 ;# (rtj) - } - light { - set vllj \u2562 ;# light left (rtj) - } - } - } - right { - #3 - switch -- $targetright { - double { - set trc \u2566 ;# (ttj) - set brc \u2569 ;# (btj) - } - light { - set vlrj \u255F ;# light right (ltj) - } - } - } - up { - #4 - switch -- $targetup { - double { - set tlc \u2560 ;# (ltj) - set trc \u2563 ;# (rtj) - set hltj \u2569 ;# (btj) - } - light { - set hltj \u2567 ;#up light (btj) - } - } - } - down_left { - #5 - switch -- $targetdown-$targetleft { - double-double { - set blc \u256c ;# (fwj) - set brc \u2563 ;# (rtj) - set tlc \u2566 ;# (ttj) - set hlbj \u2566 ;# (ttj) - } - double-light { - #no corner joins treat corners like 'other' - set blc \u2560 ;# (ltj) - set brc \u2563 ;# (rtj) - - set hlbj \u2566 ;# (ttj) - set vllj \u2562 ;# light left (rtj) - - } - double-other { - set blc \u2560 ;# (ltj) - set brc \u2563 ;# (rtj) - #leave tlc as ordinary double corner - } - light-double { - - set vllj \u2563 ;# (rtj) - set hlbj \u2564 ;# light down (ttj) - - } - light-light { - - set vllj \u2562 ;# light left (rtj) - set hlbj \u2564 ;# light down (ttj) - } - other-light { - set vllj \u2562 ;# light left (rtj) - } - other-double { - set blc \u2569 ;# (btj) - #leave brc as ordinary double corner - set tlc \u2566 ;# (ttj) - } - } - } - down_right { - #6 - switch -- $targetdown-$targetright { - double-double { - set blc \u2560 ;# (ltj) - set trc \u2566 ;# (ttj) - set brc \u256c ;# (fwj) - set hlbj \u2566 ;# (ttj) - } - double-other { - set blc \u2560 ;# (ltj) - #leave trc default - set brc \u2563 ;# (rtj) - } - other-double { - #leave blc default - set trc \u2566 ;# (ttj) - set brc \u2569 ;#(btj) - } - } - } - down_up { - #7 - switch -- $targetdown-$targetup { - double-double { - set blc \u2560 ;# (ltj) - set brc \u2563 ;# (rtj) - set tlc \u2560 ;# (ltj) - set trc \u2563 ;# (rtj) - set hltj \u2569 ;# (btj) - set hlbj \u2566 ;# (ttj) - } - } - } - left_right { - #8 - - #from 2 - #set tlc [punk::char::charshort boxd_hdhz] ;# (ttj) - set tlc \U2566 ;# (ttj) - #set blc [punk::char::charshort boxd_huhz] ;# (btj) - set blc \u2569 ;# (btj) - #from3 - set trc [punk::char::charshort boxd_ddhz] ;# (ttj) - set brc [punk::char::charshort boxd_duhz] ;# (btj) - } - left_up { - #9 - set tlc [punk::char::charshort boxd_dvhz] ;# (fwj) - set trc [punk::char::charshort boxd_dvl] ;# (rtj) - set blc [punk::char::charshort boxd_duhz] ;# (btj) - set hltj \u2569 ;# (btj) - set vllj \u2563 ;# (rtj) - } - right_up { - #10 - set tlc [punk::char::charshort boxd_dvr] ;# (ltj) - set trc [punk::char::charshort boxd_dvhz] ;# (fwj) - set brc [punk::char::charshort boxd_duhz] ;# (btj) - set hltj \u2569 ;# (btj) - set vlrj \u2560 ;# (ltj) - } - down_left_right { - #11 - set blc [punk::char::charshort boxd_dvhz] ;# (fwj) - set brc [punk::char::charshort boxd_dvhz] ;# (fwj) - set trc [punk::char::charshort boxd_ddhz] ;# (ttj) - set tlc [punk::char::charshort boxd_ddhz] ;# (ttj) - set hlbj \u2566 ;# (ttj) - set vlrj \u2560 ;# (ltj) - - } - down_left_up { - #12 - set tlc [punk::char::charshort boxd_dvhz] ;# (fwj) - set blc [punk::char::charshort boxd_dvhz] ;# (fwj) - set trc [punk::char::charshort boxd_dvl] ;# (rtj) - set brc [punk::char::charshort boxd_dvl] ;# (rtj) - set hltj \u2569 ;# (btj) - set hlbj \u2566 ;# (ttj) - - } - down_right_up { - #13 - set tlc [punk::char::charshort boxd_dvr] ;# (ltj) - set blc [punk::char::charshort boxd_dvr] ;# (ltj) - set trc [punk::char::charshort boxd_dvhz] ;# (fwj) - set brc [punk::char::charshort boxd_dvhz] ;# (fwj) - set hltj \u2569 ;# (btj) - set hlbj \u2566 ;# (ttj) - } - left_right_up { - #14 - set tlc [punk::char::charshort boxd_dvhz] ;# (fwj) - set trc [punk::char::charshort boxd_dvhz] ;# (fwj) - set blc [punk::char::charshort boxd_duhz] ;# (btj) - set brc [punk::char::charshort boxd_duhz] ;# (btj) - set hltj \u2569 ;# (btj) - - } - down_left_right_up { - #15 - set tlc [punk::char::charshort boxd_dvhz] ;# (fwj) - set blc [punk::char::charshort boxd_dvhz] ;# (fwj) - set trc [punk::char::charshort boxd_dvhz] ;# (fwj) - set brc [punk::char::charshort boxd_dvhz] ;# (fwj) - set hltj \u2569 ;# (btj) - set hlbj \u2566 ;# (ttj) - } - } - - } - "arc" { - #unicode box drawing set - - - set hl [punk::char::charshort boxd_lhz] ;# light horizontal - set hlt $hl - set hlb $hl - set vl [punk::char::charshort boxd_lv] ;#light vertical - set vll $vl - set vlr $vl - set tlc [punk::char::charshort boxd_ladr] ;#light arc down and right \U256D - set trc [punk::char::charshort boxd_ladl] ;#light arc down and left \U256E - set blc [punk::char::charshort boxd_laur] ;#light arc up and right \U2570 - set brc [punk::char::charshort boxd_laul] ;#light arc up and left \U256F - - #horizontal and vertical bar joins - set hltj $hlt - set hlbj $hlb - set vllj $vll - set vlrj $vlr - - #set targetdown,targetleft,targetright,targetup vars - #default empty targets to current box type 'arc' - foreach dir {down left right up} { - set target [tcl::dict::get $join_targets $dir] - switch -- $target { - "" - arc { - set target$dir self - } - default { - set target$dir other - } - } - } - - switch -- $do_joins { - down { - #1 - switch -- $targetdown { - self { - set blc \u251c ;# *light (ltj) - #set blc \u29FD ;# misc math right-pointing curved angle bracket (ltj) - positioned too far left - #set blc \u227b ;# math succeeds char. joins on right ok - gaps top and bottom - almost passable - #set blc \u22b1 ;#math succeeds under relation - looks 'ornate', sits too low to join horizontal - - #set brc \u2524 ;# *light(rtj) - #set brc \u29FC ;# misc math left-pointing curved angle bracket (rtj) - } - } - } - left { - #2 - switch -- $targetleft { - self { - set tlc \u252c ;# *light(ttj) - need a low positioned curved y shape - nothing apparent - #set blc \u2144 ;# (btj) - upside down y - positioning too low for arc - set blc \u2534 ;# *light (btj) - } - } - } - right { - #3 - switch -- $targetright { - self { - set trc \u252c ;# *light (ttj) - #set brc \u2144 ;# (btj) - set brc \u2534 ;# *light (btj) - } - } - } - up { - #4 - switch -- $targetup { - self { - set tlc \u251c ;# *light (ltj) - set trc \u2524 ;# *light(rtj) - } - } - } - down_left { - #5 - switch -- $targetdown-$targetleft { - self-self { - #set blc \u27e1 ;# white concave-sided diamond - positioned too far right - #set blc \u27e3 ;# concave sided diamond with rightwards tick - positioned too low, too right - big gaps - #set blc \u2bce ;# from "Miscellaneous Symbols and Arrows" - positioned too far right - set brc \u2524 ;# *light (rtj) - set tlc \u252c ;# *light (ttj) - } - self-other { - #set blc \u2560 ;# (ltj) - #set brc \u2563 ;# (rtj) - #leave tlc as ordinary double corner - } - other-self { - #set blc \u2569 ;# (btj) - #leave brc as ordinary double corner - #set tlc \u2566 ;# (ttj) - } - } - } - down_right { - switch -- $targetdown-$targetright { - self-self { - #set brc \u2bce ;# from "Miscellaneous Symbols and Arrows" - positioned too far right - set trc \u252c ;# (ttj) - set blc \u2524 ;# (rtj) - } - } - } - } - } - arc_b { - set hl " " - set hlt " " - set hlb " " - set vl " " - set vll " " - set vlr " " - set tlc " " - set trc " " - set blc " " - set brc " " - #horizontal and vertical bar joins - set hltj " " - set hlbj " " - set vllj " " - set vlrj " " - - set arcframe [textblock::framedef -boxonly $boxonly -joins $joins arc corner vll vlr vllj vlrj] - tcl::dict::with arcframe {} ;#extract keys as vars - } - arc_c { - set hl " " - set hlt " " - set hlb " " - set vl " " - set vll " " - set vlr " " - set tlc " " - set trc " " - set blc " " - set brc " " - #horizontal and vertical bar joins - set hltj " " - set hlbj " " - set vllj " " - set vlrj " " - - set arcframe [textblock::framedef -boxonly $boxonly -joins $joins arc corner] - tcl::dict::with arcframe {} ;#extract keys as vars - } - block1 { - #box drawing as far as we can go without extra blocks from legacy computing unicode block - which is unfortunately not commonly supported - set hlt \u2581 ;# lower one eighth block - set hlb \u2594 ;# upper one eighth block - set vll \u258f ;# left one eighth block - set vlr \u2595 ;# right one eighth block - set tlc \u2581 ;# lower one eighth block - set trc \u2581 ;# lower one eighth block - set blc \u2594 ;# upper one eighth block - set brc \u2594 ;# upper one eight block - - #horizontal and vertical bar joins - set hltj $hlt - set hlbj $hlb - set vllj $vll - set vlrj $vlr - - } - block2 { - #the resultant table will have text appear towards top of each box - #with 'legacy' computing unicode block - hopefully these become more widely supported - as they are useful and fill in some gaps - set hlt \u2594 ;# upper one eighth block - set hlb \u2581 ;# lower one eighth block - set vlr \u2595 ;# right one eighth block - set vll \u258f ;# left one eighth block - - #some terminals (on windows as at 2024) miscount width of these single-width blocks internally - #resulting in extra spacing that is sometimes well removed from the character itself (e.g at next ansi reset) - #This was fixed in windows-terminal based systems (2021) but persists in others. - #https://github.com/microsoft/terminal/issues/11694 - set tlc \U1fb7d ;#legacy block - set trc \U1fb7e ;#legacy block - set blc \U1fb7c ;#legacy block - set brc \U1fb7f ;#legacy block - - if {[punk::console::check::has_bug_legacysymbolwidth]} { - #rather than totally fail on some mixed layout that happens to use block2 - just degrade it - but prevent alignment problems - set sp \u00a0 ;#non breaking space (plain space may act transparent in some use cases) - set tlc $sp - set trc $sp - set blc $sp - set brc $sp - } - - #horizontal and vertical bar joins - set hltj $hlt - set hlbj $hlb - set vllj $vll - set vlrj $vlr - - } - block2hack { - #the resultant table will have text appear towards top of each box - #with 'legacy' computing unicode block - hopefully these become more widely supported - as they are useful and fill in some gaps - set hlt \u2594 ;# upper one eighth block - set hlb \u2581 ;# lower one eighth block - set vlr \u2595 ;# right one eighth block - set vll \u258f ;# left one eighth block - - #see comments in block2 regarding the problems in some terminals that this *may* hack around to some extent. - #the caller probably only needs block2hack if block2 doesn't work - - #1) - #review - this hack looks sort of promising - but overtype::renderline needs fixing ? - #set tlc \U1fb7d\b ;#legacy block - #set trc \U1fb7e\b ;#legacy block - #set blc \U1fb7c\b ;#legacy block - #set brc \U1fb7f\b ;#legacy block - - #2) - works on cmd.exe and some others - # a 'privacy message' is 'probably' also not supported on the old terminal but is on newer ones - #known exception - conemu on windows - displays junk for various ansi codes - (and slow terminal anyway) - #this hack has a reasonable chance of working - #except that the punk overtype library does recognise PMs - #A single backspace however is an unlikely and generally unuseful PM - so there is a corresponding hack in the renderline system to pass this PM through! - #ugly - in that we don't know the application specifics of what the PM data contains and where it's going. - set tlc \U1fb7d\x1b^\b\x1b\\ ;#legacy block - set trc \U1fb7e\x1b^\b\x1b\\ ;#legacy block - set blc \U1fb7c\x1b^\b\x1b\\ ;#legacy block - set brc \U1fb7f\x1b^\b\x1b\\ ;#legacy block - - #horizontal and vertical bar joins - set hltj $hlt - set hlbj $hlb - set vllj $vll - set vlrj $vlr - } - block { - set hlt \u2580 ;#upper half - set hlb \u2584 ;#lower half - set vll \u258c ;#left half - set vlr \u2590 ;#right half - - set tlc \u259b ;#upper left corner half - set trc \u259c - set blc \u2599 - set brc \u259f - - #horizontal and vertical bar joins - set hltj $hlt - set hlbj $hlb - set vllj $vll - set vlrj $vlr - } - default { - #set default_custom [tcl::dict::create hl " " vl " " tlc " " trc " " blc " " brc " "] ;#only default the general types - these form defaults for more specific types if they're missing - set default_custom [tcl::dict::create hl " " vl " " tlc " " trc " " blc " " brc " "] - if {"all" in [dict keys $f]} { - set A [dict get $f all] - set default_custom [tcl::dict::create hl $A vl $A tlc $A trc $A blc $A brc $A] - } - if {[llength $f] % 2} { - #todo - retrieve usage from punk::args - error "textblock::frametype frametype '$f' is not one of the predefined frametypes: $::textblock::frametypes and does not appear to be a dictionary for a custom frametype" - } - #unknown order of keys specified by user - validate before creating vars as we need more general elements to be available as defaults - dict for {k v} $f { - switch -- $k { - all - hl - vl - tlc - trc - blc - brc - hlt - hlb - vll - vlr - hltj - hlbj - vllj - vlrj {} - default { - error "textblock::frametype '$f' has unknown element '$k'" - } - } - } - #verified keys - safe to extract as vars - set custom_frame [tcl::dict::merge $default_custom $f] - tcl::dict::with custom_frame {} ;#extract keys as vars - #longer j vars must be after their more specific counterparts in the list being processed by foreach - foreach t {hlt hlb vll vlr hltj hlbj vllj vlrj} { - if {[tcl::dict::exists $custom_frame $t]} { - set $t [tcl::dict::get $custom_frame $t] - } else { - #set more explicit type to it's more general counterpart if it's missing - #e.g hlt -> hl - #e.g hltj -> hlt - set $t [set [string range $t 0 end-1]] - } - } - #assert vars hl vl tlc trc blc brc hlt hlb vll vlr hltj hlbj vllj vlrj are all set - #horizontal and vertical bar joins - key/variable ends with 'j' - } - } - if {$boxonly} { - set result [tcl::dict::create\ - tlc $tlc hlt $hlt trc $trc\ - vll $vll vlr $vlr\ - blc $blc hlb $hlb brc $brc\ - ] - } else { - set result [tcl::dict::create\ - tlc $tlc hlt $hlt trc $trc\ - vll $vll vlr $vlr\ - blc $blc hlb $hlb brc $brc\ - hltj $hltj\ - hlbj $hlbj\ - vllj $vllj\ - vlrj $vlrj\ - ] - } - set result [dict filter $result key {*}$globs] - tcl::dict::set framedef_cache $cache_key $result - return $result - } - - - variable frame_cache - set frame_cache [tcl::dict::create] - - punk::args::definition { - @id -id ::textblock::frame_cache - @cmd -name textblock::frame_cache -help\ - "Display or clear the frame cache." - -action -default {} -choices {clear} -help\ - "Clear the textblock::frame_cache dictionary" - -pretty -default 1 -help\ - "Use 'pdict textblock::frame_cache */*' for prettier output" - @values -min 0 -max 0 - } - proc frame_cache {args} { - set argd [punk::args::get_by_id ::textblock::frame_cache $args] - set action [dict get $argd opts -action] - - if {$action ni [list clear ""]} { - error "frame_cache action '$action' not understood. Valid actions: clear" - } - variable frame_cache - if {[dict get $argd opts -pretty]} { - set out [pdict -chan none frame_cache */*] - } else { - set out "" - if {[catch { - set termwidth [tcl::dict::get [punk::console::get_size] columns] - }]} { - set termwidth 80 - } - - tcl::dict::for {k v} $frame_cache { - lassign $v _f frame _used used - set fwidth [textblock::widthtopline $frame] - #review - are cached frames uniform width lines? - #set fwidth [textblock::width $frame] - set frameinfo "$k used:$used " - set allinone_width [expr {[tcl::string::length $frameinfo] + $fwidth}] - if {$allinone_width >= $termwidth} { - #split across 2 lines - append out "$frameinfo\n" - append out $frame \n - } else { - append out [textblock::join -- $frameinfo $frame]\n - } - append out \n ;# frames used to build tables often have joins - keep a line in between for clarity - } - } - if {$action eq "clear"} { - set frame_cache [tcl::dict::create] - append out \nCLEARED - } - return $out - } - - - variable FRAMETYPES - set FRAMETYPES [textblock::frametypes] - variable EG - set EG [a+ brightblack] - variable RST - set RST [a] - - proc frame_samples {} { - set FRAMETYPELABELS [dict create] - if {[info commands ::textblock::frame] ne ""} { - foreach ft [frametypes] { - dict set FRAMETYPELABELS $ft [textblock::frame -checkargs 0 -type $ft " "] - } - } - set FRAMETYPELABELS [dict remove $FRAMETYPELABELS block2hack] - return $FRAMETYPELABELS - } - #proc EG {} "return {[a+ brightblack]}" - #make EG fetch from SGR cache so as to abide by colour off/on - proc EG {} { - a+ brightblack - } - #proc RST {} "return {\x1b\[m}" - proc RST {} { - return "\x1b\[m" - } - - #catch 22 for -choicelabels - need some sort of lazy evaluation - # ${[textblock::frame_samples]} - - #todo punk::args alias for centre center etc? - punk::args::definition -dynamic 1 { - @id -id ::textblock::frame - @cmd -name "textblock::frame"\ - -help "Frame a block of text with a border." - -checkargs -default 1 -type boolean\ - -help "If true do extra argument checks and - provide more comprehensive error info. - Set false for slight performance improvement." - -etabs -default 0\ - -help "expanding tabs - experimental/unimplemented." - -type -default light -choices {${[textblock::frametypes]}} -choicerestricted 0 -choicecolumns 8 -type dict\ - -choicelabels { - ${[textblock::frame_samples]} - }\ - -help "Type of border for frame." - -boxlimits -default {hl vl tlc blc trc brc} -type list -help "Limit the border box to listed elements. - passing an empty string will result in no box, but title/subtitle will still appear if supplied. - ${[textblock::EG]}e.g: -frame -boxlimits {} -title things [a+ red White]my\\ncontent${[textblock::RST]}" - -boxmap -default {} -type dict - -joins -default {} -type list - -title -default "" -type string -regexprefail {\n}\ - -help "Frame title placed on topbar - no newlines. - May contain ANSI - no trailing reset required. - ${[textblock::EG]}e.g 1: frame -title My[a+ green]Green[a]Thing - e.g 2: frame -title [a+ red underline]MyThing${[textblock::RST]}" - -subtitle -default "" -type string -regexprefail {\n}\ - -help "Frame subtitle placed on bottombar - no newlines - May contain Ansi - no trailing reset required." - -width -default "" -type int\ - -help "Width of resulting frame including borders. - If omitted or empty-string, the width will be determined automatically based on content." - -height -default "" -type int\ - -help "Height of resulting frame including borders." - -ansiborder -default "" -type ansistring\ - -help "Ansi escape sequence to set border attributes. - ${[textblock::EG]}e.g 1: frame -ansiborder [a+ web-red] contents - e.g 2: frame -ansiborder \"\\x1b\\\[31m\" contents${[textblock::RST]}" - -ansibase -default "" -type ansistring\ - -help "Default ANSI attributes within frame." - -blockalign -default centre -choices {left right centre}\ - -help "Alignment of the content block within the frame." - -pad -default 1 -type boolean -help "Whether to pad within the ANSI so content background - extends within the content block inside the frame. - Has no effect if no ANSI in content." - -textalign -default left -choices {left right centre}\ - -help "Alignment of text within the content block. (centre unimplemented)" - -ellipsis -default 1 -type boolean\ - -help "Whether to show elipsis for truncated content and title/subtitle." - -usecache -default 1 -type boolean - -buildcache -default 1 -type boolean - -crm_mode -default 0 -type boolean\ - -help "Show ANSI control characters within frame contents. - (Control Representation Mode) - Frame width doesn't adapt and content may be truncated - so -width may need to be manually set to display more." - - @values -min 0 -max 1 - contents -default "" -type string\ - -help "Frame contents - may be a block of text containing newlines and ANSI. - Text may be 'ragged' - ie unequal line-lengths. - No trailing ANSI reset required. - ${[textblock::EG]}e.g: frame \"[a+ blue White] \\nMy blue foreground text on\\nwhite background\\n\"${[textblock::RST]}" - } - - #options before content argument - which is allowed to be absent - #frame performance (noticeable with complex tables even of modest size) is improved somewhat by frame_cache - but is still (2024) a fairly expensive operation. - # - #consider if we can use -sticky nsew instead of -blockalign (as per Tk grid -sticky option) - # This would require some sort of expand equivalent e.g for -sticky ew or -sticky ns - for which we have to decide a meaning for text.. e.g ansi padding? - #We are framing 'rendered' text - so we don't have access to for example an inner frame or table to tell it to expand - #we could refactor as an object and provide a -return object option, then use stored -sticky data to influence how another object renders into it - # - but we would need to maintain support for the rendered-string based operations too. - proc frame {args} { - variable frametypes - variable use_hash - - #counterintuitively - in-proc dict create each time is generally slightly faster than linked namespace var - set opts [tcl::dict::create\ - -etabs 0\ - -type light\ - -boxlimits [list hl vl tlc blc trc brc]\ - -boxmap {}\ - -joins [list]\ - -title ""\ - -subtitle ""\ - -width ""\ - -height ""\ - -ansiborder ""\ - -ansibase ""\ - -blockalign "centre"\ - -textalign "left"\ - -ellipsis 1\ - -usecache 1\ - -buildcache 1\ - -pad 1\ - -crm_mode 0\ - -checkargs 1\ - ] - #-pad 1 is default so that simple 'textblock::frame "[a+ Red]a \nbbb[a]" extends the bg colour on the short ragged lines (and empty lines) - # for ansi art - -pad 0 is likely to be preferable - - set has_contents 0 - set optlist $args ;#initial only - content will be removed - #no solo opts for frame - if {[llength $args] %2 == 0} { - if {[lindex $args end-1] eq "--"} { - set contents [lpop optlist end] - set has_contents 1 - lpop optlist end ;#drop the end-of-opts flag - } else { - set optlist $args - set contents "" - } - } else { - set contents [lpop optlist end] - set has_contents 1 - } - - #todo args -justify left|centre|right (center) - #todo -blockalignbias -textalignbias? - #use -buildcache 1 with -usecache 0 for debugging cache issues so we can inspect using textblock::frame_cache - set optnames [tcl::dict::keys $opts] - set opts_ok 1 ;#default assumption - foreach {k v} $optlist { - set k2 [tcl::prefix::match -error "" $optnames $k] - switch -- $k2 { - -etabs - -type - -boxlimits - -boxmap - -joins - - -title - -subtitle - -width - -height - - -ansiborder - -ansibase - - -blockalign - -textalign - -ellipsis - - -crm_mode - - -usecache - -buildcache - -pad - - -checkargs { - tcl::dict::set opts $k2 $v - } - default { - #error "frame option '$k' not understood. Valid options are $optnames" - set opts_ok 0 - break - } - } - } - set check_args [dict get $opts -checkargs] - - #only use punk::args if check_args is true or our basic checks failed - #never need to checkargs if only one argument supplied even if it looks like an option - as it will be treated as data to frame - if {[llength $args] != 1 && (!$opts_ok || $check_args)} { - set argd [punk::args::get_by_id ::textblock::frame $args] - set opts [dict get $argd opts] - set contents [dict get $argd values contents] - } - - # -- --- --- --- --- --- - # cache relevant - set opt_usecache [tcl::dict::get $opts -usecache] - set opt_buildcache [tcl::dict::get $opts -buildcache] - set usecache $opt_usecache ;#may need to override - set opt_etabs [tcl::dict::get $opts -etabs] ;#affects contentwidth - needed before cache determination - set opt_crm_mode [tcl::dict::get $opts -crm_mode] - # -- --- --- --- --- --- - set opt_type [tcl::dict::get $opts -type] - set opt_boxlimits [tcl::dict::get $opts -boxlimits] - set opt_joins [tcl::dict::get $opts -joins] - set opt_boxmap [tcl::dict::get $opts -boxmap] - set buildcache $opt_buildcache - set opt_pad [tcl::dict::get $opts -pad] - # -- --- --- --- --- --- - set opt_title [tcl::dict::get $opts -title] - set opt_subtitle [tcl::dict::get $opts -subtitle] - set opt_width [tcl::dict::get $opts -width] - set opt_height [tcl::dict::get $opts -height] - # -- --- --- --- --- --- - set opt_ansiborder [tcl::dict::get $opts -ansiborder] - set opt_ansibase [tcl::dict::get $opts -ansibase] ;#experimental - set opt_ellipsis [tcl::dict::get $opts -ellipsis] - - set opt_blockalign [tcl::dict::get $opts -blockalign] - set opt_textalign [tcl::dict::get $opts -textalign] - - set custom_keys [list hl hlt hlb vl vll vlr tlc trc blc brc] - - set known_frametypes $frametypes ;# light, heavey etc as defined in the ::textblock::frametypes variable - set default_custom [tcl::dict::create hl " " vl " " tlc " " trc " " blc " " brc " "] - - lassign [textblock::frametype $opt_type] _cat category _type ftype - if {$category eq "custom"} { - set custom_frame $ftype - set frameset "custom" - set framedef $custom_frame - } else { - #category = predefined - set frameset $ftype ;# light,heavy etc - set framedef $ftype - } - - #if check_args? - - - #REVIEW - now done in framedef? - #set join_directions [list] - ##targets - light,heavy (double?) - seem to be some required glyphs missing from unicode - ##e.g down-light, up-heavy - #set join_targets [tcl::dict::create left "" down "" right "" up ""] - #foreach jt $opt_joins { - # lassign [split $jt -] direction target - # if {$target ne ""} { - # tcl::dict::set join_targets $direction $target - # } - # lappend join_directions $direction - #} - #set join_directions [lsort -unique $join_directions] - #set do_joins [::join $join_directions _] - - - - - # -- --- --- --- --- --- - - if {$has_contents} { - if {[tcl::string::last \t $contents] >= 0} { - if {[tcl::info::exists punk::console::tabwidth]} { - set tw $::punk::console::tabwidth - } else { - set tw 8 - } - if {$opt_etabs} { - #todo - set contents [textutil::tabify::untabify2 $contents $tw] - } - } - set contents [tcl::string::map {\r\n \n} $contents] - if {$opt_crm_mode} { - if {$opt_height eq ""} { - set h [textblock::height $contents] - } else { - set h [expr {$opt_height -2}] - } - if {$opt_width eq ""} { - set w [textblock::width $contents] - } else { - set w [expr {$opt_width -2}] - } - set contents [overtype::renderspace -crm_mode 1 -wrap 1 -width $w -height $h "" $contents] - set actual_contentwidth $w - set actual_contentheight $h - } else { - #set actual_contentwidth [textblock::width $contents] ;#length of longest line in contents (contents can be ragged) - #set actual_contentheight [textblock::height $contents] - lassign [textblock::size_as_list $contents] actual_contentwidth actual_contentheight - } - } else { - set actual_contentwidth 0 - set actual_contentheight 0 - } - - if {$opt_title ne ""} { - set titlewidth [punk::ansi::printing_length $opt_title] - set content_or_title_width [expr {max($actual_contentwidth,$titlewidth)}] - } else { - set titlewith 0 - set content_or_title_width $actual_contentwidth - } - #opt_subtitle ?? - - if {$opt_width eq ""} { - set frame_inner_width $content_or_title_width - } else { - set frame_inner_width [expr {max(0,$opt_width - 2)}] ;#default - } - - if {$opt_height eq ""} { - set frame_inner_height $actual_contentheight - } else { - set frame_inner_height [expr {max(0,$opt_height -2)}] ;#default - } - if {$frame_inner_height == 0 && $frame_inner_width == 0} { - set has_contents 0 - } - #todo - render it with vertical overflow so we can process ansi moves? - #set linecount [textblock::height $contents] - set linecount $frame_inner_height - - # -- --- --- --- --- --- --- --- --- - variable frame_cache - #review - custom frame affects frame_inner_width - exclude from caching? - #set cache_key [concat $optlist $frame_inner_width $frame_inner_height] - #jmn - #set hashables [concat $optlist $frame_inner_width $frame_inner_height] - set hashables [list {*}$optlist $frame_inner_width $frame_inner_height] - - - switch -- $use_hash { - sha1 { - package require sha1 - set hash [sha1::sha1 [encoding convertto utf-8 $hashables]] - } - md5 { - package require md5 - if {[package vsatisfies [package present md5] 2- ] } { - set hash [md5::md5 -hex [encoding convertto utf-8 $hashables]] ;#need fast and unique to content - not cryptographic - review - } else { - set hash [md5::md5 [encoding convertto utf-8 $hashables]] - } - } - none { - set hash $hashables - } - } - - set cache_key "$hash-$frame_inner_width-$frame_inner_height-actualcontentwidth:$actual_contentwidth" - #should be in a unicode private range different to that used in table construction - #e.g BMP PUA U+E000 -> U+F8FF - although this is commonly used for example by nerdfonts - #also supplementary private use blocks - #however these display double wide on for example cmd terminal despite having wcswidth 1 (makes layout debugging difficult) - #U+F0000 -> U+FFFD - #U+100000 -> U+10FFFD - #FSUB options: \uf0ff \uF1FF \uf2ff (no nerdfont glyphs - should look like standard replacement char) \uF2DD (circular thingy) - #should be something someone is unlikely to use as part of a custom frame character. - #ideally a glyph that doesn't auto-expand into whitespace and is countable when in a string (narrower is better) - #As nerdfont glyphs tend to be mostly equal height & width - circular glyphs tend to be more distinguishable in a string - #terminal settings may need to be adjusted to stop auto glyph resizing - a rather annoying misfeature that some people seem to think they like. - #e.g in wezterm config: allow_square_glyphs_to_overflow_width = "Never" - #review - we could consider wasting a few cycles to check for a conflict and use a different FSUB - set FSUB \uF2DD - - - #this occurs commonly in table building with colspans - review - if {($actual_contentwidth > $frame_inner_width) || ($actual_contentheight != $frame_inner_height)} { - set usecache 0 - #set buildcache 0 ;#comment out for debug/analysis so we can see - #puts "--->> frame_inner_width:$frame_inner_width actual_contentwidth:$actual_contentwidth contents: '$contents'" - set cache_key [a+ Web-red web-white]$cache_key[a] - } - if {$buildcache && ($actual_contentwidth < $frame_inner_width)} { - #colourise cache_key to warn - if {$actual_contentwidth == 0} { - #we can still substitute with right length - set cache_key [a+ Web-steelblue web-black]$cache_key[a] - } else { - #actual_contentwidth is narrower than frame - check template's patternwidth - if {[tcl::dict::exists $frame_cache $cache_key]} { - set cache_patternwidth [tcl::dict::get $frame_cache $cache_key patternwidth] - } else { - set cache_patternwidth $actual_contentwidth - } - if {$actual_contentwidth < $cache_patternwidth} { - set usecache 0 - set cache_key [a+ Web-orange web-black]$cache_key[a] - } elseif {$actual_contentwidth == $cache_patternwidth} { - #set usecache 1 - } else { - #actual_contentwidth > pattern - set usecache 0 - set cache_key [a+ Web-red web-black]$cache_key[a] - } - } - } - - #JMN debug - #set usecache 0 - - set is_cached 0 - if {$usecache && [tcl::dict::exists $frame_cache $cache_key]} { - set cache_patternwidth [tcl::dict::get $frame_cache $cache_key patternwidth] - set template [tcl::dict::get $frame_cache $cache_key frame] - set used [tcl::dict::get $frame_cache $cache_key used] - tcl::dict::set frame_cache $cache_key used [expr {$used+1}] ;#update existing record - set is_cached 1 - } - - - # -- --- --- --- --- --- --- --- --- - if {!$is_cached} { - # -- --- --- --- --- - # -- --- --- --- --- - set is_joins_ok 1 - foreach v $opt_joins { - lassign [split $v -] direction target - switch -- $direction { - left - right - up - down {} - default { - set is_joins_ok 0 - break - } - } - switch -- $target { - "" - light - light_b - light_c - heavy - heavy_b - heavy_c - ascii - altg - arc - arc_b - arc_c - double - custom - block - block1 - block2 {} - default { - set is_joins_ok 0 - break - } - } - } - if {!$is_joins_ok} { - error "frame option -joins '$opt_joins' must contain only values from the set: left,right,up,down with targets heavy,light,ascii,altg,arc,double,block,block1,custom e.g down-light" - } - # -- --- --- --- --- --- - set is_boxmap_ok 1 - tcl::dict::for {boxelement subst} $opt_boxmap { - switch -- $boxelement { - hl - hlt - hlb - vl - vll - vlr - tlc - trc - blc - brc {} - hltj - hlbj - vllj - vlrj {} - default { - set is_boxmap_ok 0 - break - } - } - } - if {!$is_boxmap_ok} { - error "frame option -boxmap '$opt_boxmap' must contain only keys from the set: hl,hlt,hlb,vl,vll,vlr,tlc,trc,blc,brc,hltj,hlbj,vllj,vlrj" - } - # -- --- --- --- --- --- - #these are all valid commands for overtype:: - switch -- $opt_textalign { - left - right - centre - center {} - default { - error "frame option -textalign must be left|right|centre|center - received: $opt_textalign" - } - } - # -- --- --- --- --- --- - switch -- $opt_blockalign { - left - right - centre - center {} - default { - error "frame option -blockalign must be left|right|centre|center - received: $opt_blockalign" - } - } - # -- --- --- --- --- - # -- --- --- --- --- - set is_boxlimits_ok 1 - set exact_boxlimits [list] - foreach v $opt_boxlimits { - switch -- $v { - hl { - lappend exact_boxlimits hlt hlb - } - vl { - lappend exact_boxlimits vll vlr - } - hlt - hlb - vll - vlr - tlc - trc - blc - brc { - lappend exact_boxlimits $v - } - default { - #k not in custom_keys - set is_boxlimits_ok 0 - break - } - } - } - #review vllj etc? - if {!$is_boxlimits_ok} { - error "frame option -boxlimits '$opt_boxlimits' must contain only values from the set: hl,hlt,hlb,vl,vll,vlr,tlc,trc,blc,brc" - } - set exact_boxlimits [lsort -unique $exact_boxlimits] - # -- --- --- --- --- --- - - - set rst [a] - #set column [tcl::string::repeat " " $frame_inner_width] ;#default - may need to override for custom frame - set underlayline [tcl::string::repeat " " $frame_inner_width] - set underlay [::join [lrepeat $linecount $underlayline] \n] - - - set vll_width 1 ;#default for all except custom (printing width) - set vlr_width 1 - - set framedef [textblock::framedef -joins $opt_joins $framedef] - tcl::dict::with framedef {} ;#extract vll,hlt,tlc etc vars - - #puts "---> $opt_boxmap" - #review - we handle double-wide in custom frames - what about for boxmaps? - tcl::dict::for {boxelement sub} $opt_boxmap { - if {$boxelement eq "vl"} { - set vll $sub - set vlr $sub - set hl $sub - } elseif {$boxelement eq "hl"} { - set hlt $sub - set hlb $sub - set hl $sub - } else { - set $boxelement $sub - } - } - - switch -- $frameset { - custom { - #REVIEW - textblock::table assumes that at least the vl elements are 1-wide - #generally supporting wider or taller custom frame elements would make for some interesting graphical possibilities though - #if no ansi, these widths are reasonable to maintain in grapheme_width_cached indefinitely - set vll_width [punk::ansi::printing_length $vll] - set hlb_width [punk::ansi::printing_length $hlb] - set hlt_width [punk::ansi::printing_length $hlt] - - set vlr_width [punk::ansi::printing_length $vlr] - - set tlc_width [punk::ansi::printing_length $tlc] - set trc_width [punk::ansi::printing_length $trc] - set blc_width [punk::ansi::printing_length $blc] - set brc_width [punk::ansi::printing_length $brc] - - - set framewidth [expr {$frame_inner_width + 2}] ;#reverse default assumption - if {$opt_width eq ""} { - #width wasn't specified - so user is expecting frame to adapt to title/contents - #content shouldn't truncate because of extra wide frame - #review - punk::console::get_size ? wrapping? quite hard to support with colspans - set frame_inner_width $content_or_title_width - set tbarwidth [expr {$content_or_title_width + 2 - $tlc_width - $trc_width - 2 + $vll_width + $vlr_width}] ;#+/2's for difference between border element widths and standard element single-width - set bbarwidth [expr {$content_or_title_width + 2 - $blc_width - $brc_width - 2 + $vll_width + $vlr_width}] - } else { - set frame_inner_width [expr $opt_width - $vll_width - $vlr_width] ;#content may be truncated - set tbarwidth [expr {$opt_width - $tlc_width - $trc_width}] - set bbarwidth [expr {$opt_width - $blc_width - $brc_width}] - } - #set column [tcl::string::repeat " " $frame_inner_width] - set underlayline [tcl::string::repeat " " $frame_inner_width] - set underlay [::join [lrepeat $linecount $underlayline] \n] - #cache? - - if {$hlt_width == 1} { - set tbar [tcl::string::repeat $hlt $tbarwidth] - } else { - #possibly mixed width chars that make up hlt - tcl::string::range won't get width right - set blank [tcl::string::repeat " " $tbarwidth] - if {$hlt_width > 0} { - set count [expr {($tbarwidth / $hlt_width) + 1}] - } else { - set count 0 - } - set tbar [tcl::string::repeat $hlt $count] - #set tbar [tcl::string::range $tbar 0 $tbarwidth-1] - set tbar [overtype::left -overflow 0 -exposed1 " " -exposed2 " " $blank $tbar];#spaces for exposed halves of 2w chars instead of default replacement character - } - if {$hlb_width == 1} { - set bbar [tcl::string::repeat $hlb $bbarwidth] - } else { - set blank [tcl::string::repeat " " $bbarwidth] - if {$hlb_width > 0} { - set count [expr {($bbarwidth / $hlb_width) + 1}] - } else { - set count 0 - } - set bbar [tcl::string::repeat $hlb $count] - #set bbar [tcl::string::range $bbar 0 $bbarwidth-1] - set bbar [overtype::left -overflow 0 -exposed1 " " -exposed2 " " $blank $bbar] - } - } - altg { - set tbar [tcl::string::repeat $hlt $frame_inner_width] - set tbar [cd::groptim $tbar] - set bbar [tcl::string::repeat $hlb $frame_inner_width] - set bbar [cd::groptim $bbar] - } - default { - set tbar [tcl::string::repeat $hlt $frame_inner_width] - set bbar [tcl::string::repeat $hlb $frame_inner_width] - - } - } - - set leftborder 0 - set rightborder 0 - set topborder 0 - set bottomborder 0 - # hl - hlt - hlb - vl - vll - vlr - tlc - trc - blc - brc {} - #puts "----->$exact_boxlimits" - foreach lim $exact_boxlimits { - switch -- $lim { - hlt { - set topborder 1 - } - hlb { - set bottomborder 1 - } - vll { - set leftborder 1 - } - vlr { - set rightborder 1 - } - tlc { - set topborder 1 - set leftborder 1 - } - trc { - set topborder 1 - set rightborder 1 - } - blc { - set bottomborder 1 - set leftborder 1 - } - brc { - set bottomborder 1 - set rightborder 1 - } - } - } - if {$opt_width ne "" && $opt_width < 2} { - set rightborder 0 - } - #keep lhs/rhs separate? can we do vertical text on sidebars? - set lhs [tcl::string::repeat $vll\n $linecount] - set lhs [tcl::string::range $lhs 0 end-1] - set rhs [tcl::string::repeat $vlr\n $linecount] - set rhs [tcl::string::range $rhs 0 end-1] - - - if {$opt_ansiborder ne ""} { - set tbar $opt_ansiborder$tbar$rst - set bbar $opt_ansiborder$bbar$rst - set tlc $opt_ansiborder$tlc$rst - set trc $opt_ansiborder$trc$rst - set blc $opt_ansiborder$blc$rst - set brc $opt_ansiborder$brc$rst - - set lhs $opt_ansiborder$lhs$rst ;#wrap the whole block and let textblock::join figure it out - set rhs $opt_ansiborder$rhs$rst - } - - #boxlimits used for partial borders in table generation - set all_exact_boxlimits [list vll vlr hlt hlb tlc blc trc brc] - set unspecified_limits [struct::set difference $all_exact_boxlimits $exact_boxlimits] - foreach lim $unspecified_limits { - switch -- $lim { - vll { - set blank_vll [tcl::string::repeat " " $vll_width] - set lhs [tcl::string::repeat $blank_vll\n $linecount] - set lhs [tcl::string::range $lhs 0 end-1] - } - vlr { - set blank_vlr [tcl::string::repeat " " $vlr_width] - set rhs [tcl::string::repeat $blank_vlr\n $linecount] - set rhs [tcl::string::range $rhs 0 end-1] - } - hlt { - set bar_width [punk::ansi::printing_length $tbar] - set tbar [tcl::string::repeat " " $bar_width] - } - tlc { - set tlc_width [punk::ansi::printing_length $tlc] - set tlc [tcl::string::repeat " " $tlc_width] - } - trc { - set trc_width [punk::ansi::printing_length $trc] - set trc [tcl::string::repeat " " $trc_width] - } - hlb { - set bar_width [punk::ansi::printing_length $bbar] - set bbar [tcl::string::repeat " " $bar_width] - } - blc { - set blc_width [punk::ansi::printing_length $blc] - set blc [tcl::string::repeat " " $blc_width] - } - brc { - set brc_width [punk::ansi::printing_length $brc] - set brc [tcl::string::repeat " " $brc_width] - } - } - } - - if {$opt_title ne ""} { - set topbar [overtype::centre -overflow 0 -exposed1 " " -exposed2 " " -ellipsis 1 -bias left $tbar $opt_title] ;#overtype supports gx0 on/off - } else { - set topbar $tbar - } - if {$opt_subtitle ne ""} { - set bottombar [overtype::centre -overflow 0 -exposed1 " " -exposed2 " " -ellipsis 1 -bias left $bbar $opt_subtitle] ;#overtype supports gx0 on/off - } else { - set bottombar $bbar - } - if {$opt_ansibase eq ""} { - set rstbase [a] - } else { - set rstbase [a]$opt_ansibase - } - - if {$opt_title ne ""} { - #title overrides -boxlimits for topborder - set topborder 1 - } - set fs "" - set fscached "" - set cache_patternwidth 0 - #todo - output nothing except maybe newlines depending on if opt_height 0 and/or opt_width 0? - if {$topborder} { - if {$leftborder && $rightborder} { - append fs $tlc$topbar$trc - } else { - if {$leftborder} { - append fs $tlc$topbar - } elseif {$rightborder} { - append fs $topbar$trc - } else { - append fs $topbar - } - } - } - append fscached $fs - if {$has_contents || $opt_height > 2} { - #if {$topborder && $fs ne "xx"} { - # append fs \n - #} - if {$topborder} { - append fs \n - append fscached \n - } - switch -- $opt_textalign { - right {set pad "left"} - left {set pad "right"} - default {set pad $opt_textalign} - } - #set textaligned_contents [textblock::pad $contents -width $actual_contentwidth -which $pad -within_ansi 1] - #set inner [overtype::block -blockalign $opt_blockalign -ellipsis $opt_ellipsis $opt_ansibase$underlay$rstbase $opt_ansibase$textaligned_contents] - - set cache_contentline [tcl::string::repeat $FSUB $actual_contentwidth] - set cache_patternwidth $actual_contentwidth - set cache_contentpattern [::join [lrepeat $linecount $cache_contentline] \n] - set cache_inner [overtype::block -blockalign $opt_blockalign -ellipsis $opt_ellipsis $opt_ansibase$underlay$rstbase $opt_ansibase$cache_contentpattern] - #after overtype::block - our actual patternwidth may be less - set cache_patternwidth [tcl::string::length [lindex [regexp -inline "\[^$FSUB]*(\[$FSUB]*).*" $cache_inner] 1]] - - if {$leftborder && $rightborder} { - #set bodyparts [list $lhs $inner $rhs] - set cache_bodyparts [list $lhs $cache_inner $rhs] - } else { - if {$leftborder} { - #set bodyparts [list $lhs $inner] - set cache_bodyparts [list $lhs $cache_inner] - } elseif {$rightborder} { - #set bodyparts [list $inner $rhs] - set cache_bodyparts [list $cache_inner $rhs] - } else { - #set bodyparts [list $inner] - set cache_bodyparts [list $cache_inner] - } - } - #set body [textblock::join -- {*}$bodyparts] - - #JMN test - #assert - lhs, cache_inner, rhs non-ragged - so can use join_basic REVIEW - #set cache_body [textblock::join -- {*}$cache_bodyparts] - set cache_body [textblock::join_basic -- {*}$cache_bodyparts] - - append fscached $cache_body - #append fs $body - } - - if {$opt_height eq "" || $opt_height > 1} { - if {$opt_subtitle ne ""} { - #subtitle overrides boxlimits for bottomborder - set bottomborder 1 - } - if {$bottomborder} { - if {($topborder & $fs ne "xx" ) || ($has_contents || $opt_height > 2)} { - #append fs \n - append fscached \n - } - if {$leftborder && $rightborder} { - #append fs $blc$bottombar$brc - append fscached $blc$bottombar$brc - } else { - if {$leftborder} { - #append fs $blc$bottombar - append fscached $blc$bottombar - } elseif {$rightborder} { - #append fs $bottombar$brc - append fscached $bottombar$brc - } else { - #append fs $bottombar - append fscached $bottombar - } - } - } - } - set template $fscached - ;#end !$is_cached - } - - - - - #use the same mechanism to build the final frame - whether from cache or template - if {$actual_contentwidth == 0} { - set fs [tcl::string::map [list $FSUB " "] $template] - } else { - set resultlines [list] - set overwritable [tcl::string::repeat $FSUB $cache_patternwidth] - set contentindex 0 - switch -- $opt_textalign { - left {set pad right} - right {set pad left} - default {set pad $opt_textalign} - } - - #review - if {[tcl::string::is integer -strict $opt_height] && $actual_contentheight < ($opt_height -2)} { - set diff [expr {($opt_height -2) - $actual_contentheight}] - append contents [::join [lrepeat $diff \n] ""] ;# should not affect actual_contentwidth - } - - #set cwidth [textblock::width $contents] - set cwidth $actual_contentwidth - if {$opt_pad} { - set paddedcontents [textblock::pad $contents -known_blockwidth $cwidth -which $pad -within_ansi 1] ;#autowidth to width of content (should match cache_patternwidth) - set paddedwidth [textblock::widthtopline $paddedcontents] - #review - horizontal truncation - if {$paddedwidth > $cache_patternwidth} { - set paddedcontents [overtype::renderspace -width $cache_patternwidth "" $paddedcontents] - } - #important to supply end of opts -- to textblock::join - particularly here with arbitrary data - set contentblock [textblock::join -- $paddedcontents] ;#make sure each line has ansi replays - } else { - if {$cwidth > $cache_patternwidth} { - set contents [overtype::renderspace -width $cache_patternwidth "" $contents] - } - set contentblock [textblock::join -- $contents] ;# adds ansiresets and any required replays on each line - } - - set tlines [split $template \n] - - #we will need to strip off the leading reset on each line when stitching together with template lines so that ansibase can come into play too. - #after textblock::join the reset will be a separate code ie should be exactly ESC[0m - set R [a] - set rlen [tcl::string::length $R] - set clines [split $contentblock \n] - - foreach tline $tlines { - if {[tcl::string::first $FSUB $tline] >= 0} { - set content_line [lindex $clines $contentindex] - if {[tcl::string::first $R [string range $content_line 0 10]] == 0} { - set content_line [tcl::string::range $content_line $rlen end] - } - #make sure to replay opt_ansibase to the right of the replacement - lappend resultlines [tcl::string::map [list $overwritable $content_line$opt_ansibase] $tline] - incr contentindex - } else { - lappend resultlines $tline - } - } - set fs [::join $resultlines \n] - } - - - if {$is_cached} { - return $fs - } else { - if {$buildcache} { - tcl::dict::set frame_cache $cache_key [list frame $template used 0 patternwidth $cache_patternwidth] - } - return $fs - } - } - punk::args::definition { - @id -id ::textblock::gcross - -max_cross_size -default 0 -type integer -help "Largest size cross to use to make up the block - Only cross sizes that divide the size of the overall block will be used. - e.g if the 'size' chosen is 19 (a prime number) - only 1 or the full size of 19 can be used as the crosses to make up the block. - Whereas for a block size of 24, -max_cross_size of 1,2,3,4,6,8,12 or 24 will work. (all divisors) - If a number chosen for -max_cross_size isn't a divisor, the largest divisor below the chosen value will be used. - " - @values -min 0 -max 1 - size -default 1 -type integer - } - proc gcross {args} { - set argd [punk::args::get_by_id ::textblock::gcross $args] - set size [dict get $argd values size] - set opts [dict get $argd opts] - - if {$size == 0} { - return "" - } - - set opt_max_cross_size [tcl::dict::get $opts -max_cross_size] - - #set fit_size [punk::lib::greatestOddFactor $size] - set fit_size $size - if {$opt_max_cross_size == 0} { - set max_cross_size $fit_size - } else { - #todo - only allow divisors - #set testsize [expr {min($fit_size,$opt_max_cross_size)}] - - set factors [punk::lib::factors $size] - #pick odd size in list that is smaller or equal to test_size - set max_cross_size [lindex $factors end] - set last_ok [lindex $factors 0] - for {set i 0} {$i < [llength $factors]} {incr i} { - set s [lindex $factors $i] - if {$s > $opt_max_cross_size} { - break - } - set last_ok $s - } - set max_cross_size $last_ok - } - set crosscount [expr {$size / $max_cross_size}] - - package require punk::char - set x [punk::char::charshort boxd_ldc] - set bs [punk::char::charshort boxd_ldgullr] - set fs [punk::char::charshort boxd_ldgurll] - - set onecross "" - set crossrows [list] - set armsize [expr {int(floor($max_cross_size /2))}] - set row [lrepeat $max_cross_size " "] - #toparm - for {set i 0} {$i < $armsize} {incr i} { - set r $row - lset r $i $bs - lset r end-$i $fs - #append onecross [::join $r ""] \n - lappend crossrows [::join $r ""] - } - - if {$max_cross_size % 2} { - #only put centre cross in for odd sized crosses - set r $row - lset r $armsize $x - #append onecross [::join $r ""] \n - lappend crossrows [::join $r ""] - } - - for {set i [expr {$armsize -1}]} {$i >= 0} {incr i -1} { - set r $row - lset r $i $fs - lset r end-$i $bs - #append onecross [::join $r ""] \n - lappend crossrows [::join $r ""] - } - #set onecross [tcl::string::trimright $onecross \n] - set onecross [::join $crossrows \n] - - #fastest to do row first then columns - because textblock::join must do line by line - - if {$crosscount > 1} { - set row [textblock::join -- {*}[lrepeat $crosscount $onecross]] - set rows [lrepeat $crosscount $row] - set out [::join $rows \n] - } else { - set out $onecross - } - - return $out - } - - #Test we can join two coloured blocks - proc test_colour {} { - set b1 [a red]1\n2\n3[a] - set b2 [a green]a\nb\nc[a] - set result [textblock::join -- $b1 $b2] - puts $result - #return [list $b1 $b2 $result] - return [ansistring VIEW $result] - } - tcl::namespace::import ::punk::ansi::ansistrip -} - - -tcl::namespace::eval ::textblock::piper { - tcl::namespace::export * - proc join {rhs pipelinedata} { - tailcall ::textblock::join -- $pipelinedata $rhs - } -} -interp alias {} piper_blockjoin {} ::textblock::piper::join - - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready -package provide textblock [tcl::namespace::eval textblock { - variable version - set version 0.1.2 -}] -return - -#*** !doctools -#[manpage_end] - diff --git a/src/vfs/_vfscommon.vfs/modules/tomlish-1.1.2.tm b/src/vfs/_vfscommon.vfs/modules/tomlish-1.1.2.tm index 9270ca9c..c7da645b 100644 --- a/src/vfs/_vfscommon.vfs/modules/tomlish-1.1.2.tm +++ b/src/vfs/_vfscommon.vfs/modules/tomlish-1.1.2.tm @@ -185,6 +185,8 @@ namespace eval tomlish { error "tomlish _get_keyval_value invalid to have type TABLE on rhs of =" } ITABLE { + #This one should not be returned as a type value structure! + # set result [::tomlish::to_dict [list $found_sub]] } ARRAY { @@ -249,6 +251,7 @@ namespace eval tomlish { } + #to_dict is a *basic* programmatic datastructure for accessing the data. # produce a dictionary of keys and values from a tomlish tagged list. # to_dict is primarily for reading toml data. @@ -271,8 +274,12 @@ namespace eval tomlish { # so we can raise an error to satisfy the toml rule: 'You cannot define any key or table more than once. Doing so is invalid' #Note that [a] and then [a.b] is ok if there are no subkey conflicts - so we are only tracking complete tablenames here. #we don't error out just because a previous tablename segment has already appeared. - variable tablenames_seen [list] - + ##variable tablenames_seen [list] + if {[uplevel 1 [list info exists tablenames_seen]]} { + upvar tablenames_seen tablenames_seen + } else { + set tablenames_seen [list] + } log::info ">>> processing '$tomlish'<<<" set items $tomlish @@ -311,9 +318,9 @@ namespace eval tomlish { } DOTTEDKEY { log::debug "--> processing $tag: $item" - set dkey_info [_get_dottedkey_info $item] - set dotted_key_hierarchy [dict get $dkey_info keys] - set dotted_key_hierarchy_raw [dict get $dkey_info keys_raw] + set dkey_info [_get_dottedkey_info $item] + set dotted_key_hierarchy [dict get $dkey_info keys] + set dotted_key_hierarchy_raw [dict get $dkey_info keys_raw] #a.b.c = 1 #table_key_hierarchy -> a b @@ -345,6 +352,9 @@ namespace eval tomlish { set keyval_dict [_get_keyval_value $item] dict set datastructure {*}$pathkeys $leafkey $keyval_dict + + #JMN test 2025 + } TABLE { set tablename [lindex $item 1] @@ -386,8 +396,40 @@ namespace eval tomlish { lappend table_key_hierarchy_raw $rawseg if {[dict exists $datastructure {*}$table_key_hierarchy]} { - #It's ok for this key to already exist *if* it was defined by a previous tablename, - # but not if it was defined as a key/qkey/skey ? + #It's ok for this key to already exist *if* it was defined by a previous tablename or equivalent + #and if this key is longer + + #consider the following 2 which are legal: + #[table] + #x.y = 3 + #[table.x.z] + #k= 22 + + #equivalent + + #[table] + #[table.x] + #y = 3 + #[table.x.z] + #k=22 + + #illegal + #[table] + #x.y = 3 + #[table.x.y.z] + #k = 22 + ## - we should bfail on encoungerint table.x.y because only table and table.x are effectively tables + ## - we should also fail if + + #illegal + #[table] + #x.y = {p=3} + #[table.x.y.z] + #k = 22 + ## we should fail because y is an inline table which is closed to further entries + + + #TODO! fix - this code is wrong set testkey [join $table_key_hierarchy_raw .] @@ -422,7 +464,7 @@ namespace eval tomlish { if {$found_testkey == 0} { #the raw table_key_hierarchy is better to display in the error message, although it's not the actual dict keyset set msg "key [join $table_key_hierarchy_raw .] already exists in datastructure, but wasn't defined by a supertable." - append msg "tablenames_seen:" + append msg \n "tablenames_seen:" \n foreach ts $tablenames_seen { append msg " " $ts \n } @@ -453,13 +495,18 @@ namespace eval tomlish { #now add the contained elements foreach element [lrange $item 2 end] { set type [lindex $element 0] + log::debug "--> $type processing contained element $element" switch -exact -- $type { DOTTEDKEY { set dkey_info [_get_dottedkey_info $element] - set dotted_key_hierarchy [dict get $dkey_info keys] - set dotted_key_hierarchy_raw [dict get $dkey_info keys_raw] - set leaf_key [lindex $dotted_key_hierarchy end] - set dkeys [lrange $dotted_key_hierarchy 0 end-1] + #e.g1 keys {x.y y} keys_raw {'x.y' y} + #e.g2 keys {x.y y} keys_raw {{"x.y"} y} + set dotted_key_hierarchy [dict get $dkey_info keys] + set dkeys [lrange $dotted_key_hierarchy 0 end-1] + set leaf_key [lindex $dotted_key_hierarchy end] + set dotted_key_hierarchy_raw [dict get $dkey_info keys_raw] + set dkeys_raw [lrange $dotted_key_hierarchy_raw 0 end-1] + set leaf_key_raw [lindex $dotted_key_hierarchy_raw end] #ensure empty keys are still represented in the datastructure set test_keys $table_keys @@ -476,7 +523,22 @@ namespace eval tomlish { error "Duplicate key '$table_keys $dkeys $leaf_key'. The key already exists at this level in the toml data. The toml data is not valid." } set keyval_dict [_get_keyval_value $element] + #keyval_dict is either a {type value } + #or the result from parsing an arbitrary dict from an inline table - which could theoretically look the same at the topmost level + #punk::dict::is_tomlish_typeval can distinguish + puts stdout ">>> $keyval_dict" dict set datastructure {*}$table_keys {*}$dkeys $leaf_key $keyval_dict + #JMN 2025 + #tomlish::utils::normalize_key ?? + lappend tablenames_seen [join [list {*}$table_key_hierarchy_raw {*}$dkeys_raw] .] ;#???? + #if the keyval_dict is not a simple type x value y - then it's an inline table ? + #if so - we should add the path to the leaf_key as a seen table too - as it's not allowed to have more entries added. + if {![tomlish::dict::is_tomlish_typeval $keyval_dict]} { + #the value is either empty or or a dict structure with arbitrary (from-user-data) toplevel keys + # inner structure will contain {type value } if all leaves are not empty ITABLES + lappend tablenames_seen [join [list {*}$table_key_hierarchy_raw {*}$dkeys_raw $leaf_key_raw] .] + } + } KEY - QKEY - SQKEY { #obsolete ? @@ -777,7 +839,7 @@ namespace eval tomlish { set result [list] set lastparent [lindex $parents end] if {$lastparent in [list "" do_inline]} { - if {[tomlish::dict::is_tomltype $vinfo]} { + if {[tomlish::dict::is_tomlish_typeval $vinfo]} { set type [dict get $vinfo type] #treat ITABLE differently? set sublist [_from_dictval_tomltype $parents $tablestack $keys $vinfo] @@ -811,7 +873,7 @@ namespace eval tomlish { } else { set VK_PART [list KEY $vk] } - if {[tomlish::dict::is_tomltype $vv]} { + if {[tomlish::dict::is_tomlish_typeval $vv]} { #type x value y set sublist [_from_dictval_tomltype $parents $tablestack $keys $vv] set record [list DOTTEDKEY [list $VK_PART {WS { }}] = {WS { }} $sublist] @@ -877,7 +939,7 @@ namespace eval tomlish { } } else { #lastparent is not toplevel "" or "do_inline" - if {[tomlish::dict::is_tomltype $vinfo]} { + if {[tomlish::dict::is_tomlish_typeval $vinfo]} { #type x value y set sublist [_from_dictval_tomltype $parents $tablestack $keys $vinfo] lappend result {*}$sublist @@ -901,7 +963,7 @@ namespace eval tomlish { } else { set VK_PART [list KEY $vk] } - if {[tomlish::dict::is_tomltype $vv]} { + if {[tomlish::dict::is_tomlish_typeval $vv]} { #type x value y set sublist [_from_dictval_tomltype $parents $tablestack $keys $vv] set record [list DOTTEDKEY [list $VK_PART] = $sublist] @@ -2404,7 +2466,8 @@ namespace eval tomlish::utils { } ;#RS #check if str is valid for use as a toml bare key - proc is_barekey {str} { + #Early toml versions? only allowed letters + underscore + dash + proc is_barekey1 {str} { if {[tcl::string::length $str] == 0} { return 0 } else { @@ -2418,6 +2481,52 @@ namespace eval tomlish::utils { } } + #from toml.abnf in github.com/toml-lang/toml + #unquoted-key = 1*unquoted-key-char + #unquoted-key-char = ALPHA / DIGIT / %x2D / %x5F ; a-z A-Z 0-9 - _ + #unquoted-key-char =/ %xB2 / %xB3 / %xB9 / %xBC-BE ; superscript digits, fractions + #unquoted-key-char =/ %xC0-D6 / %xD8-F6 / %xF8-37D ; non-symbol chars in Latin block + #unquoted-key-char =/ %x37F-1FFF ; exclude GREEK QUESTION MARK, which is basically a semi-colon + #unquoted-key-char =/ %x200C-200D / %x203F-2040 ; from General Punctuation Block, include the two tie symbols and ZWNJ, ZWJ + #unquoted-key-char =/ %x2070-218F / %x2460-24FF ; include super-/subscripts, letterlike/numberlike forms, enclosed alphanumerics + #unquoted-key-char =/ %x2C00-2FEF / %x3001-D7FF ; skip arrows, math, box drawing etc, skip 2FF0-3000 ideographic up/down markers and spaces + #unquoted-key-char =/ %x2070-21FF / %x2300-24FF ; skip math operators + #unquoted-key-char =/ %x25A0-268B / %x2690-2757 ; skip box drawing, block elements, and some yin-yang symbols + #unquoted-key-char =/ %x2762-2767 / %x2776-27E5 ; skip some Dingbat punctuation + #unquoted-key-char =/ %x2801-297F ; skip some math brackets and arrows, and braille blank + #unquoted-key-char =/ %x2B00-2FFF / %x3001-D7FF ; skip various math operators and symbols, and ideographic space + #unquoted-key-char =/ %xF900-FDCF / %xFDF0-FFFD ; skip D800-DFFF surrogate block, E000-F8FF Private Use area, FDD0-FDEF intended for process-internal use (unicode) + #unquoted-key-char =/ %x10000-EFFFF ; all chars outside BMP range, excluding Private Use planes (F0000-10FFFF) + variable re_barekey + set ranges [list] + lappend ranges {a-zA-Z0-9\_\-} + lappend ranges {\u00B2} {\u00B3} {\u00B9} {\u00BC-\u00BE} ;# superscript digits, fractions + lappend ranges {\u00C0-\u00D6} {\u00D8-\u00F6} {\u00F8-\u037D} ;# non-symbol chars in Latin block + lappend ranges {\u037f-\u1FFF} ;# exclude GREEK QUESTION MARK, which is basically a semi-colon + lappend ranges {\u200C-\u200D} {\u203F-\u2040} ;# from General Punctuation Block, include the two tie symbols and ZWNJ, ZWJ + lappend ranges {\u2070-\u218f} {\u2460-\u24FF} ;# include super-subscripts, letterlike/numberlike forms, enclosed alphanumerics + lappend ranges {\u2C00-\u2FEF} {\u3001-\uD7FF} ;# skip arrows, math, box drawing etc, skip 2FF0-3000 ideographic up/down markers and spaces + lappend ranges {\u2070-\u21FF} {\u2300-\u24FF} ;# skip math operators + lappend ranges {\u25A0-\u268B} {\u2690-\u2757} ;# skip box drawing, block elements, and some yin-yang symbols + lappend ranges {\u2762-\u2767} {\u2776-\u27E5} ;# skip some Dingbat punctuation + lappend ranges {\u2801-\u297F} ;# skip some math brackets and arrows, and braille blank + lappend ranges {\u2B00-\u2FFF} {\u3001-\uD7FF} ;# skip various math operators and symbols, and ideographic space + lappend ranges {\uF900-\uFDCF} {\uFDF0-\uFFFD} ;# skip D800-DFFF surrogate block, E000-F8FF Private Use area, FDD0-FDEF intended for process-internal use (unicode) + lappend ranges {\U10000-\UEFFFF} ;# all chars outside BMP range, excluding Private Use planes (F0000-10FFFF) + set re_barekey {^[} + foreach r $ranges { + append re_barekey $r + } + append re_barekey {]+$} + + proc is_barekey {str} { + if {[tcl::string::length $str] == 0} { + return 0 + } + variable re_barekey + return [regexp $re_barekey $str] + } + #test only that the characters in str are valid for the toml specified type 'integer'. proc int_validchars1 {str} { set numchars [tcl::string::length $str] @@ -3471,7 +3580,7 @@ namespace eval tomlish::parse { return 1 } barekey { - error "tomlish Unexpected character '$c' during bare key. Only \[a-zA-Z_-\] allowed. [tomlish::parse::report_line]" + error "tomlish Unexpected character '$c' during bare key. Only \[a-zA-Z0-9_-\] and a selection of letter-like chars allowed (see tomlish::utils::is_barekey). [tomlish::parse::report_line]" } whitespace { # hash marks end of whitespace token @@ -5222,7 +5331,7 @@ namespace eval tomlish::parse { if {[tomlish::utils::is_barekey $c]} { append tok $c } else { - error "tomlish Unexpected character '$c' during bare key. Only \[a-zA-Z0-9_-\] allowed. [tomlish::parse::report_line]" + error "tomlish Unexpected character '$c' during bare key. Only \[a-zA-Z0-9_-\] and a selection of letter-like chars allowed. (see tomlish::utils::is_barekey) [tomlish::parse::report_line]" } } starttablename - starttablearrayname { @@ -5354,10 +5463,15 @@ namespace eval tomlish::dict { namespace export {[a-z]*}; # Convention: export all lowercase namespace path [namespace parent] - proc is_tomltype {d} { - expr {[dict size $d] == 2 && [dict exists $d type] && [dict exists $d value]} + proc is_tomlish_typeval {d} { + #designed to detect {type value } e.g {type INT value 3}, {type STRING value "blah etc"} + #as a sanity check we need to avoid mistaking user data that happens to match same form + #consider x.y={type="spud",value="blah"} + #The value of type will itself have already been converted to {type STRING value spud} ie never a single element. + #check the length of the type as a quick way to see it's a tag - not something else masqerading. + expr {[dict size $d] == 2 && [dict exists $d type] && [dict exists $d value] && [llength [dict get $d type]] == 1} } - proc is_tomltype2 {d} { + proc is_tomlish_typeval2 {d} { upvar ::tomlish::tags tags expr {[lindex $d 0] eq "type" && [lindex $d 1] in $tags} } @@ -5366,7 +5480,7 @@ namespace eval tomlish::dict { set dictposn [expr {[dict size $d] -1}] foreach k [lreverse [dict keys $d]] { set dval [dict get $d $k] - if {[is_tomltype $dval]} { + if {[is_tomlish_typeval $dval]} { set last_simple $dictposn break } diff --git a/src/vfs/_vfscommon.vfs/modules/tomlish-1.1.1.tm b/src/vfs/_vfscommon.vfs/modules/tomlish-1.1.3.tm similarity index 75% rename from src/vfs/_vfscommon.vfs/modules/tomlish-1.1.1.tm rename to src/vfs/_vfscommon.vfs/modules/tomlish-1.1.3.tm index 0c8d0b1a..3da39427 100644 --- a/src/vfs/_vfscommon.vfs/modules/tomlish-1.1.1.tm +++ b/src/vfs/_vfscommon.vfs/modules/tomlish-1.1.3.tm @@ -7,7 +7,7 @@ # (C) 2024 # # @@ Meta Begin -# Application tomlish 1.1.1 +# Application tomlish 1.1.3 # Meta platform tcl # Meta license # @@ Meta End @@ -17,19 +17,20 @@ # doctools header # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #*** !doctools -#[manpage_begin tomlish_module_tomlish 0 1.1.1] +#[manpage_begin tomlish_module_tomlish 0 1.1.3] #[copyright "2024"] #[titledesc {tomlish toml parser}] [comment {-- Name section and table of contents description --}] -#[moddesc {tomlish}] [comment {-- Description at end of page heading --}] +#[moddesc {tomlish}] [comment {-- Description at end of page heading --}] #[require tomlish] #[keywords module parsing toml configuration] #[description] #[para] tomlish is an intermediate representation of toml data in a tree structure (tagged lists representing type information) -#[para] The design goals are for tomlish to be whitespace and comment preserving ie byte-for byte preservation during roundtrips from toml to tomlish and back to toml +#[para] The design goals are for tomlish to be whitespace and comment preserving ie byte-for byte preservation during roundtrips from toml to tomlish and back to toml #[para] The tomlish representation can then be converted to a Tcl dict structure or to other formats such as json, #[para] although these other formats are generally unlikely to retain whitespace or comments +#[para] The other formats also won't preserve roundtripability e.g \t and a literal tab coming from a toml file will be indistinguishable. #[para] A further goal is to allow at least a useful subset of in-place editing operations which also preserve whitespace and comments. -#[para] e.g leaf key value editing, and table reordering/sorting, key-renaming at any level, key insertions/deletions +#[para] e.g leaf key value editing, and table reordering/sorting, key-renaming at any level, key insertions/deletions #[para] The API for editing (tomldoc object?) may require explicit setting of type if accessing an existing key #[para] e.g setting a key that already exists and is a different type (especially if nested structure such as a table or array) #[para] will need a -type option (-force ?) to force overriding with another type such as an int. @@ -78,7 +79,7 @@ package require logger # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ namespace eval tomlish { namespace export {[a-z]*}; # Convention: export all lowercase - variable types + variable types #IDEAS: # since get_toml produces tomlish with whitespace/comments intact: @@ -90,7 +91,7 @@ namespace eval tomlish { # - set/add Table? - position in doc based on existing tables/subtables? #The tomlish intermediate representation allows things such as sorting the toml document by table name or other re-ordering of tables - - # because the tables include subkeys, comments and newlines within their structure - those elements all come along with it nicely during reordering. + # because the tables include subkeys, comments and newlines within their structure - those elements all come along with it nicely during reordering. #The same goes for the first newline following a keyval e.g x=1 \ny=2\n\n #The newline is part of the keyval structure so makes reordering easier #example from_toml "a=1\nb=2\n\n\n" @@ -106,14 +107,14 @@ namespace eval tomlish { #TABLE is analogous to a Tcl dict #WS = inline whitespace #KEY = bare key and value - #QKEY = double quoted key and value + #DQKEY = double quoted key and value #SQKEY = single quoted key and value #ITABLE = inline table (*can* be anonymous table) # inline table values immediately create a table with the opening brace # inline tables are fully defined between their braces, as are dotted-key subtables defined within # No additional subtables or arrays of tables may be defined within an inline table after the ending brace - they must be entirely self-contained - set tags [list TOMLISH ARRAY TABLE ITABLE ANONTABLE WS NEWLINE COMMENT DOTTEDKEY KEY QKEY SQKEY STRING STRINGPART MULTISTRING LITERAL LITERALPART MULTILITERAL INT FLOAT BOOL DATETIME] + set tags [list TOMLISH ARRAY TABLE ITABLE ANONTABLE WS NEWLINE COMMENT DOTTEDKEY KEY DQKEY SQKEY STRING STRINGPART MULTISTRING LITERAL LITERALPART MULTILITERAL INT FLOAT BOOL DATETIME] #tomlish v1.0 should accept arbitrary 64-bit signed ints (from -2^63 to 2^63-1) #we will restrict to this range for compatibility for now - although Tcl can handle larger (arbitrarily so?) set min_int -9223372036854775808 ;#-2^63 @@ -127,19 +128,19 @@ namespace eval tomlish { logger::initNamespace ::tomlish foreach lvl [logger::levels] { interp alias {} tomlish_log_$lvl {} ::tomlish::Dolog $lvl - log::logproc $lvl tomlish_log_$lvl + log::logproc $lvl tomlish_log_$lvl } #*** !doctools #[subsection {Namespace tomlish}] - #[para] Core API functions for tomlish + #[para] Core API functions for tomlish #[list_begin definitions] proc tags {} { return $::tomlish::tags } - #helper function for get_dict + #helper function for to_dict proc _get_keyval_value {keyval_element} { log::notice ">>> _get_keyval_value from '$keyval_element'<<<" set found_value 0 @@ -147,10 +148,23 @@ namespace eval tomlish { # 3 is the earliest index at which the value could occur (depending on whitespace) set found_sub [list] if {[lindex $keyval_element 2] ne "="} { - error ">>>_get_keyval_value doesn't seem to be a properly structured { = } list" + error "tomlish _get_keyval_value keyval_element doesn't seem to be a properly structured { = } list" } + + #review + if {[uplevel 1 [list info exists tablenames_seen]]} { + upvar tablenames_seen tablenames_seen + } else { + set tablenames_seen [list] ;#list of lists + } + if {[uplevel 1 [list info exists tablenames_closed]]} { + upvar tablenames_closed tablenames_closed + } else { + set tablenames_closed [list] ;#list of lists + } + foreach sub [lrange $keyval_element 2 end] { - #note that a barekey/quotedkey won't occur directly inside a barekey/quotedkey + #note that a barekey/dquotedkey won't occur directly inside a barekey/dquotedkey switch -exact -- [lindex $sub 0] { STRING - LITERAL - MULTISTRING - MULTILITERAL - INT - FLOAT - BOOL - DATETIME - TABLE - ARRAY - ITABLE { set type [lindex $sub 0] @@ -162,15 +176,15 @@ namespace eval tomlish { } } if {!$found_value} { - error "Failed to find value element in KEY. '$keyval_element'" + error "tomlish Failed to find value element in KEY. '$keyval_element'" } if {$found_value > 1} { - error "Found multiple value elements in KEY, expected exactly one. '$keyval_element'" + error "tomlish Found multiple value elements in KEY, expected exactly one. '$keyval_element'" } switch -exact -- $type { INT - FLOAT - BOOL - DATETIME { - #simple (non-container, no-substitution) datatype + #simple (non-container, no-substitution) datatype set result [list type $type value $value] } STRING - STRINGPART { @@ -182,26 +196,34 @@ namespace eval tomlish { } TABLE { #invalid? - error "_get_keyval_value invalid to have type TABLE on rhs of =" + error "tomlish _get_keyval_value invalid to have type TABLE on rhs of =" } ITABLE { - set result [::tomlish::get_dict [list $found_sub]] + #This one should not be returned as a type value structure! + # + set result [::tomlish::to_dict [list $found_sub]] } ARRAY { #we need to recurse to get the corresponding dict for the contained item(s) #pass in the whole $found_sub - not just the $value! - set result [list type $type value [::tomlish::get_dict [list $found_sub]]] + set prev_tablenames_seen $tablenames_seen + set prev_tablenames_closed $tablenames_closed + set tablenames_seen [list] + set tablenames_closed [list] + set result [list type $type value [::tomlish::to_dict [list $found_sub]]] + set tablenames_seen $prev_tablenames_seen + set tablenames_closed $prev_tablenames_closed } MULTISTRING - MULTILITERAL { #review - mapping these to STRING might make some conversions harder? #if we keep the MULTI - we know we have to look for newlines for example when converting to json #without specific types we'd have to check every STRING - and lose info about how best to map chars within it - set result [list type $type value [::tomlish::get_dict [list $found_sub]]] + set result [list type $type value [::tomlish::to_dict [list $found_sub]]] } default { - error "Unexpected value type '$type' found in keyval '$keyval_element'" + error "tomlish Unexpected value type '$type' found in keyval '$keyval_element'" } - } + } return $result } @@ -209,7 +231,7 @@ namespace eval tomlish { set key_hierarchy [list] set key_hierarchy_raw [list] if {[lindex $dottedkeyrecord 0] ne "DOTTEDKEY"} { - error "_get_dottedkey_info error. Supplied list doesn't appear to be a DOTTEDKEY (tag: [lindex $dottedkeyrecord 0])" + error "tomlish _get_dottedkey_info error. Supplied list doesn't appear to be a DOTTEDKEY (tag: [lindex $dottedkeyrecord 0])" } set compoundkeylist [lindex $dottedkeyrecord 1] set expect_sep 0 @@ -230,7 +252,7 @@ namespace eval tomlish { lappend key_hierarchy $val lappend key_hierarchy_raw $val } - QKEY { + DQKEY { lappend key_hierarchy [::tomlish::utils::unescape_string $val] lappend key_hierarchy_raw \"$val\" } @@ -247,62 +269,87 @@ namespace eval tomlish { } return [dict create keys $key_hierarchy keys_raw $key_hierarchy_raw] } - #get_dict is a *basic* programmatic datastructure for accessing the data. + + + + #to_dict is a *basic* programmatic datastructure for accessing the data. # produce a dictionary of keys and values from a tomlish tagged list. - # get_dict is primarily for reading toml data. + # to_dict is primarily for reading toml data. #Extraneous (not within quoted sections) whitespace and comments are not preserved in this structure, # so a roundtrip from toml to this datastructure and back to toml will lose whitespace formatting and comments. # creating/changing toml values can be done directly on a tomlish list if preserving (or adding) formatting/comments is desired. - #A separate package 'tomlish::object' may be needed to allow easier programmatic creating/updating/deleting of data elements whilst preserving (or adding or selectively deleting/editing) such formatting. - proc get_dict {tomlish} { - + #A separate package 'tomlish::object' may be needed to allow easier programmatic creating/updating/deleting of data elements whilst preserving (or adding or selectively deleting/editing) such formatting. + # + + #within an ARRAY, we store a list of items such as plain dicts (possibly empty) and {type value } for simple types + #(ARRAYS can be mixed type) + #This means our dict structure should have only ARRAY and simple types which need to be in {type value } form + #A dict within an array encodeded as a type ITABLE value should also parse - but is the unpreferred form - REVIEW test? + + #Namespacing? + #ie note the difference: + #[Data] + #temp = { cpu = 79.5, case = 72.0} + # versus + #[Data] + #temps = [{cpu = 79.5, case = 72.0}] + proc to_dict {tomlish} { + #keep track of which tablenames have already been directly defined, # so we can raise an error to satisfy the toml rule: 'You cannot define any key or table more than once. Doing so is invalid' #Note that [a] and then [a.b] is ok if there are no subkey conflicts - so we are only tracking complete tablenames here. #we don't error out just because a previous tablename segment has already appeared. - variable tablenames_seen [list] - - - log::info ">>> processing '$tomlish'<<<" + ##variable tablenames_seen [list] + if {[uplevel 1 [list info exists tablenames_seen]]} { + upvar tablenames_seen tablenames_seen + } else { + set tablenames_seen [list] ;#list of lists + } + if {[uplevel 1 [list info exists tablenames_closed]]} { + upvar tablenames_closed tablenames_closed + } else { + set tablenames_closed [list] ;#list of lists + } + + log::info "---> to_dict processing '$tomlish'<<<" set items $tomlish - + foreach lst $items { if {[lindex $lst 0] ni $::tomlish::tags} { error "supplied string does not appear to be toml parsed into a tomlish tagged list. Run tomlish::decode::toml on the raw toml data to produce a tomlish list" } } - + if {[lindex $tomlish 0] eq "TOMLISH"} { #ignore TOMLISH tag at beginning set items [lrange $tomlish 1 end] } - + set datastructure [dict create] foreach item $items { set tag [lindex $item 0] #puts "...> item:'$item' tag:'$tag'" switch -exact -- $tag { - KEY - QKEY - SQKEY { - log::debug "--> processing $tag: $item" + KEY - DQKEY - SQKEY { + log::debug "---> to_dict item: processing $tag: $item" set key [lindex $item 1] - if {$tag eq "QKEY"} { + if {$tag eq "DQKEY"} { set key [::tomlish::utils::unescape_string $key] } #!todo - normalize key. (may be quoted/doublequoted) - + if {[dict exists $datastructure $key]} { error "Duplicate key '$key'. The key already exists at this level in the toml data. The toml data is not valid." } - + #lassign [_get_keyval_value $item] type val set keyval_dict [_get_keyval_value $item] dict set datastructure $key $keyval_dict } DOTTEDKEY { - log::debug "--> processing $tag: $item" - set dkey_info [_get_dottedkey_info $item] - set dotted_key_hierarchy [dict get $dkey_info keys] - set dotted_key_hierarchy_raw [dict get $dkey_info keys_raw] + log::debug "---> to_dict item processing $tag: $item" + set dkey_info [_get_dottedkey_info $item] + set dotted_key_hierarchy [dict get $dkey_info keys] #a.b.c = 1 #table_key_hierarchy -> a b @@ -317,138 +364,166 @@ namespace eval tomlish { set leafkey [lindex $dotted_key_hierarchy 0] } else { set table_hierarchy [lrange $dotted_key_hierarchy 0 end-1] - set table_hierarchy_raw [lrange $dotted_key_hierarchy_raw 0 end-1] - set leafkey [lindex $dotted_key_hierarchy end] + set leafkey [lindex $dotted_key_hierarchy end] } #ensure empty tables are still represented in the datastructure + #review - this seems unnecessary? set pathkeys [list] foreach k $table_hierarchy { - lappend pathkeys $k + lappend pathkeys $k if {![dict exists $datastructure {*}$pathkeys]} { - dict set datastructure {*}$pathkeys [list] + dict set datastructure {*}$pathkeys [list] } else { - tomlish::log::notice "get_dict datastructure at key path $pathkeys already had data: [dict get $datastructure {*}$pathkeys]" + tomlish::log::notice "to_dict datastructure at key path $pathkeys already had data: [dict get $datastructure {*}$pathkeys]" } } + #review? + if {[dict exists $datastructure {*}$table_hierarchy $leafkey]} { + error "Duplicate key '$table_hierarchy $leafkey'. The key already exists at this level in the toml data. The toml data is not valid." + } + + #JMN test 2025 + if {[llength $table_hierarchy]} { + lappend tablenames_seen $table_hierarchy + } set keyval_dict [_get_keyval_value $item] - dict set datastructure {*}$pathkeys $leafkey $keyval_dict + if {![tomlish::dict::is_tomlish_typeval $keyval_dict]} { + lappend tablenames_seen [list {*}$table_hierarchy $leafkey] + lappend tablenames_closed [list {*}$table_hierarchy $leafkey] + + #review - item is an ITABLE - we recurse here without datastructure context :/ + #overwriting keys? todo ? + dict set datastructure {*}$table_hierarchy $leafkey $keyval_dict + } else { + dict set datastructure {*}$table_hierarchy $leafkey $keyval_dict + } + } TABLE { set tablename [lindex $item 1] - set tablename [::tomlish::utils::tablename_trim $tablename] - - if {$tablename in $tablenames_seen} { + #set tablename [::tomlish::utils::tablename_trim $tablename] + set norm_segments [::tomlish::utils::tablename_split $tablename true] ;#true to normalize + if {$norm_segments in $tablenames_seen} { error "Table name '$tablename' has already been directly defined in the toml data. Invalid." } - - log::debug "--> processing $tag (name: $tablename): $item" - set name_segments [::tomlish::utils::tablename_split $tablename] + + log::debug "---> to_dict processing item $tag (name: $tablename): $item" + set name_segments [::tomlish::utils::tablename_split $tablename] ;#unnormalized set last_seg "" #toml spec rule - all segments mst be non-empty #note that the results of tablename_split are 'raw' - ie some segments may be enclosed in single or double quotes. - - set table_key_hierarchy [list] - set table_key_hierarchy_raw [list] - - foreach rawseg $name_segments { - - set seg [::tomlish::utils::normalize_key $rawseg] ;#strips one level of enclosing quotes, and substitutes only toml-specified escapes - set c1 [tcl::string::index $rawseg 0] - set c2 [tcl::string::index $rawseg end] - if {($c1 eq "'") && ($c2 eq "'")} { - #single quoted segment. No escapes are processed within it. - set seg [tcl::string::range $rawseg 1 end-1] - } elseif {($c1 eq "\"") && ($c2 eq "\"")} { - #double quoted segment. Apply escapes. - set seg [::tomlish::utils::unescape_string [tcl::string::range $rawseg 1 end-1]] - } else { - set seg $rawseg - } - - #no need to check for empty segments here - we've already called tablename_split which would have raised an error for empty segments. - #if {$rawseg eq ""} { - # error "Table name '[lindex $item 1]' is not valid. All segments (parts between dots) must be non-empty" - #} - lappend table_key_hierarchy $seg - lappend table_key_hierarchy_raw $rawseg - - if {[dict exists $datastructure {*}$table_key_hierarchy]} { - #It's ok for this key to already exist *if* it was defined by a previous tablename, - # but not if it was defined as a key/qkey/skey ? - - set testkey [join $table_key_hierarchy_raw .] - - set testkey_length [llength $table_key_hierarchy_raw] + + set table_key_sublist [list] + + foreach normseg $norm_segments { + lappend table_key_sublist $normseg + if {[dict exists $datastructure {*}$table_key_sublist]} { + #It's ok for this key to already exist *if* it was defined by a previous tablename or equivalent + #and if this key is longer + + #consider the following 2 which are legal: + #[table] + #x.y = 3 + #[table.x.z] + #k= 22 + + #equivalent + + #[table] + #[table.x] + #y = 3 + #[table.x.z] + #k=22 + + #illegal + #[table] + #x.y = 3 + #[table.x.y.z] + #k = 22 + ## - we should fail on encountering table.x.y because only table and table.x are effectively tables + + #illegal + #[table] + #x.y = {p=3} + #[table.x.y.z] + #k = 22 + ## we should fail because y is an inline table which is closed to further entries + + + #note: it is not safe to compare normalized tablenames using join! + # e.g a.'b.c'.d is not the same as a.b.c.d + # instead compare {a b.c d} with {a b c d} + # Here is an example where the number of keys is the same, but they must be compared as a list, not a joined string. + #'a.b'.'c.d.e' vs 'a.b.c'.'d.e' + #we need to normalize the tablenames seen so that {"x\ty"} matches {"xy"} + + set sublist_length [llength $table_key_sublist] set found_testkey 0 - if {$testkey in $tablenames_seen} { + if {$table_key_sublist in $tablenames_seen} { set found_testkey 1 } else { #see if it was defined by a longer entry - foreach seen $tablenames_seen { - set seen_segments [::tomlish::utils::tablename_split $seen] - #these are raw unnormalized tablename segments. Need to normalize the double-quoted ones, - # and strip the quotes from both single-quoted and double-quoted entries. - - #note: it is not safe to compare normalized tablenames using join! - # e.g a.'b.c'.d is not the same as a.b.c.d - # instead compare {a b.c d} with {a b c d} - # Here is an example where the number of keys is the same, but they must be compared as a list, not a joined string. - #'a.b'.'c.d.e' vs 'a.b.c'.'d.e' - - #VVV the test below is wrong VVV! - #we need to normalize the tablenames seen so that {"x\ty"} matches {"xy"} - - set seen_match [join [lrange $seen_segments 0 [expr {$testkey_length -1}]] .] - puts stderr "testkey:'$testkey' vs seen_match:'$seen_match'" - if {$testkey eq $seen_match} { + foreach seen_table_segments $tablenames_seen { + if {[llength $seen_table_segments] <= $sublist_length} { + continue + } + #each tablenames_seen entry is already a list of normalized segments + + #we could have [a.b.c.d] early on + # followed by [a.b] - which was still defined by the earlier one. + + set seen_longer [lrange $seen_segments 0 [expr {$sublist_length -1}]] + puts stderr "testkey:'$table_key_sublist' vs seen_match:'$seen_longer'" + if {$table_key_sublist eq $seen_longer} { set found_testkey 1 } } } - + if {$found_testkey == 0} { #the raw table_key_hierarchy is better to display in the error message, although it's not the actual dict keyset - set msg "key [join $table_key_hierarchy_raw .] already exists in datastructure, but wasn't defined by a supertable." - append msg "tablenames_seen:" + set msg "key $table_key_sublist already exists in datastructure, but wasn't defined by a supertable." + append msg \n "tablenames_seen:" \n foreach ts $tablenames_seen { append msg " " $ts \n } error $msg } } - + } - + #ensure empty tables are still represented in the datastructure set table_keys [list] foreach k $table_key_hierarchy { - lappend table_keys $k + lappend table_keys $k if {![dict exists $datastructure {*}$table_keys]} { - dict set datastructure {*}$table_keys [list] + dict set datastructure {*}$table_keys [list] } else { - tomlish::log::notice "get_dict datastructure at (TABLE) subkey $table_keys already had data: [dict get $datastructure {*}$table_keys]" + tomlish::log::notice "to_dict datastructure at (TABLE) subkey $table_keys already had data: [dict get $datastructure {*}$table_keys]" } } - + #We must do this after the key-collision test above! - lappend tablenames_seen $tablename - - - log::debug ">>>>>>>>>>>>>>>>>>>>table_key_hierarchy : $table_key_hierarchy" - log::debug ">>>>>>>>>>>>>>>>>>>>table_key_hierarchy_raw: $table_key_hierarchy_raw" - + lappend tablenames_seen $norm_segments + + + log::debug ">>> to_dict >>>>>>>>>>>>>>>>> table_key_hierarchy : $table_key_hierarchy" + #now add the contained elements foreach element [lrange $item 2 end] { set type [lindex $element 0] + log::debug "----> tododict processing $tag subitem $type processing contained element $element" switch -exact -- $type { DOTTEDKEY { set dkey_info [_get_dottedkey_info $element] - set dotted_key_hierarchy [dict get $dkey_info keys] - set dotted_key_hierarchy_raw [dict get $dkey_info keys_raw] - set leaf_key [lindex $dotted_key_hierarchy end] - set dkeys [lrange $dotted_key_hierarchy 0 end-1] + #e.g1 keys {x.y y} keys_raw {'x.y' "a\tb"} keys {x.y {a b}} (keys_raw has escape, keys has literal tab char) + #e.g2 keys {x.y y} keys_raw {{"x.y"} "a\tb"} keys {x.y {a b}} (keys_raw has escape, keys has literal tab char) + set dotted_key_hierarchy [dict get $dkey_info keys] + set dkeys [lrange $dotted_key_hierarchy 0 end-1] + set leaf_key [lindex $dotted_key_hierarchy end] #ensure empty keys are still represented in the datastructure set test_keys $table_keys @@ -457,7 +532,7 @@ namespace eval tomlish { if {![dict exists $datastructure {*}$test_keys]} { dict set datastructure {*}$test_keys [list] } else { - tomlish::log::notice "get_dict datastructure at (DOTTEDKEY) subkey $test_keys already had data: [dict get $datastructure {*}$test_keys]" + tomlish::log::notice "to_dict datastructure at (DOTTEDKEY) subkey $test_keys already had data: [dict get $datastructure {*}$test_keys]" } } @@ -465,12 +540,27 @@ namespace eval tomlish { error "Duplicate key '$table_keys $dkeys $leaf_key'. The key already exists at this level in the toml data. The toml data is not valid." } set keyval_dict [_get_keyval_value $element] + #keyval_dict is either a {type value } + #or the result from parsing an arbitrary dict from an inline table - which could theoretically look the same at the topmost level + #punk::dict::is_tomlish_typeval can distinguish + puts stdout "to_dict>>> $keyval_dict" dict set datastructure {*}$table_keys {*}$dkeys $leaf_key $keyval_dict + #JMN 2025 + lappend tablenames_seen [list {*}$table_key_hierarchy {*}$dkeys] + + if {![tomlish::dict::is_tomlish_typeval $keyval_dict]} { + #the value is either empty or or a dict structure with arbitrary (from-user-data) toplevel keys + # inner structure will contain {type value } if all leaves are not empty ITABLES + lappend tablenames_seen [list {*}$table_key_hierarchy {*}$dkeys $leaf_key] + #if the keyval_dict is not a simple type x value y - then it's an inline table ? + #if so - we should add the path to the leaf_key as a closed table too - as it's not allowed to have more entries added. + } + } - KEY - QKEY - SQKEY { + KEY - DQKEY - SQKEY { #obsolete ? set keyval_key [lindex $element 1] - if {$type eq "QKEY"} { + if {$type eq "DQKEY"} { set keyval_key [::tomlish::utils::unescape_string $keyval_key] } if {[dict exists $datastructure {*}$dotted_key_hierarchy $keyval_key]} { @@ -483,7 +573,7 @@ namespace eval tomlish { #ignore } default { - error "Sub element of type '$type' not understood in table context. Expected only KEY,QKEY,SQKEY,NEWLINE,COMMENT,WS" + error "Sub element of type '$type' not understood in table context. Expected only KEY,DQKEY,SQKEY,NEWLINE,COMMENT,WS" } } } @@ -495,11 +585,11 @@ namespace eval tomlish { set datastructure [list] foreach element [lrange $item 1 end] { set type [lindex $element 0] + log::debug "----> tododict processing $tag subitem $type processing contained element $element" switch -exact -- $type { DOTTEDKEY { set dkey_info [_get_dottedkey_info $element] set dotted_key_hierarchy [dict get $dkey_info keys] - set dotted_key_hierarchy_raw [dict get $dkey_info keys_raw] set leaf_key [lindex $dotted_key_hierarchy end] set dkeys [lrange $dotted_key_hierarchy 0 end-1] @@ -511,7 +601,7 @@ namespace eval tomlish { if {![dict exists $datastructure {*}$test_keys]} { dict set datastructure {*}$test_keys [list] } else { - tomlish::log::notice "get_dict datastructure at (DOTTEDKEY) subkey $test_keys already had data: [dict get $datastructure {*}$test_keys]" + tomlish::log::notice "to_dict datastructure at (DOTTEDKEY) subkey $test_keys already had data: [dict get $datastructure {*}$test_keys]" } } @@ -525,7 +615,7 @@ namespace eval tomlish { #ignore } default { - error "Sub element of type '$type' not understood in ITABLE context. Expected only KEY,QKEY,SQKEY,NEWLINE,COMMENT,WS" + error "Sub element of type '$type' not understood in ITABLE context. Expected only KEY,DQKEY,SQKEY,NEWLINE,COMMENT,WS" } } } @@ -534,9 +624,10 @@ namespace eval tomlish { #arrays in toml are allowed to contain mixtures of types set datastructure [list] log::debug "--> processing array: $item" - + foreach element [lrange $item 1 end] { set type [lindex $element 0] + log::debug "----> tododict processing $tag subitem $type processing contained element $element" switch -exact -- $type { INT - FLOAT - BOOL - DATETIME { set value [lindex $element 1] @@ -550,9 +641,20 @@ namespace eval tomlish { set value [lindex $element 1] lappend datastructure [list type $type value $value] } - ITABLE - TABLE - ARRAY - MULTISTRING - MULTILITERAL { - set value [lindex $element 1] - lappend datastructure [list type $type value [::tomlish::get_dict [list $element]]] + ITABLE { + #anonymous table + #lappend datastructure [list type $type value [::tomlish::to_dict [list $element]]] + lappend datastructure [::tomlish::to_dict [list $element]] ;#store itables within arrays as raw dicts (possibly empty) + } + TABLE { + #invalid? shouldn't be output from from_dict - but could manually be constructed as such? review + #doesn't make sense as table needs a name? + #take as synonym for ITABLE? + error "to_dict TABLE within array unexpected" + } + ARRAY - MULTISTRING - MULTILITERAL { + #set value [lindex $element 1] + lappend datastructure [list type $type value [::tomlish::to_dict [list $element]]] } WS - SEP - NEWLINE - COMMENT { #ignore whitespace, commas, newlines and comments @@ -576,10 +678,10 @@ namespace eval tomlish { # def # etc # ''' - # - we would like to trimleft each line to the column following the opening delim + # - we would like to trimleft each line to the column following the opening delim # ------------------------------------------------------------------------- - log::debug "--> processing multiliteral: $item" + log::debug "---> todict processing multiliteral: $item" set parts [lrange $item 1 end] if {[lindex $parts 0 0] eq "NEWLINE"} { set parts [lrange $parts 1 end] ;#skip it @@ -608,7 +710,7 @@ namespace eval tomlish { } MULTISTRING { #triple dquoted string - log::debug "--> processing multistring: $item" + log::debug "---> to_dict processing multistring: $item" set stringvalue "" set idx 0 set parts [lrange $item 1 end] @@ -620,7 +722,7 @@ namespace eval tomlish { STRING { #todo - do away with STRING ? #we don't build MULTISTRINGS containing STRING - but should we accept it? - tomlish::log::warn "doulbe quoting a STRING found in MULTISTRING - should be STRINGPART?" + tomlish::log::warn "double quoting a STRING found in MULTISTRING - should be STRINGPART?" append stringvalue "\"[::tomlish::utils::unescape_string [lindex $element 1]]\"" } STRINGPART { @@ -662,7 +764,7 @@ namespace eval tomlish { } set trimming 0 } else { - set non_ws [lsearch -index 0 -start $idx+1 -not [lrange $parts 0 $next_nl-1] WS] + set non_ws [lsearch -index 0 -start $idx+1 -not [lrange $parts 0 $next_nl-1] WS] if {$non_ws >= 0} { set idx [expr {$non_ws -1}] set trimming 0 @@ -673,7 +775,7 @@ namespace eval tomlish { } } } - } + } } NEWLINE { #if newline is first element - it is not part of the data of a multistring @@ -697,7 +799,7 @@ namespace eval tomlish { set datastructure $stringvalue } WS - COMMENT - NEWLINE { - #ignore + #ignore } default { error "Unexpected tag '$tag' in Tomlish list '$tomlish'" @@ -707,6 +809,358 @@ namespace eval tomlish { return $datastructure } + + proc _from_dictval_tomltype {parents tablestack keys typeval} { + set type [dict get $typeval type] + set val [dict get $typeval value] + switch -- $type { + ARRAY { + set subitems [list] + foreach item $val { + lappend subitems [_from_dictval [list {*}$parents ARRAY] $tablestack $keys $item] SEP + } + if {[lindex $subitems end] eq "SEP"} { + set subitems [lrange $subitems 0 end-1] + } + return [list ARRAY {*}$subitems] + } + ITABLE { + if {$val eq ""} { + return ITABLE + } else { + return [_from_dictval [list {*}$parents ITABLE] $tablestack $keys $val] + } + } + MULTISTRING { + #value is a raw string that isn't encoded as tomlish + #create a valid toml snippet with the raw value and decode it to the proper tomlish MULTISTRING format + #We need to convert controls in $val to escape sequences - except for newlines + # + #consider an *option* to reformat for long lines? (perhaps overcomplex - byte equiv - but may fold in ugly places) + #we could use a line-length limit to decide when to put in a "line ending backslash" + #and even format it with a reasonable indent so that proper CONT and WS entries are made (?) REVIEW + # + #TODO + set tomlpart "x=\"\"\"\\\n" + append tomlpart $val "\"\"\"" + set tomlish [tomlish::decode::toml $tomlpart] + #e.g if val = " etc\nblah" + #TOMLISH {DOTTEDKEY {{KEY x}} = {MULTISTRING CONT {NEWLINE LF} {WS { }} {STRINGPART etc} {NEWLINE lf} {STRINGPART blah} } } + #lindex 1 3 is the MULTISTRING tomlish list + return [lindex $tomlish 1 3] + } + MULTILITERAL { + #MLL string can contain newlines - but still no control chars + #todo - validate + set tomlpart "x='''\n" + append tomlpart $val ''' + set tomlish [tomlish::decode::toml $tomlpart] + return [lindex $tomlish 1 3] + } + LITERAL { + #from v1.0 spec - "Control characters other than tab are not permitted in a literal string" + #(This rules out raw ANSI SGR - which is somewhat restrictive - but perhaps justified for a config format + # as copy-pasting ansi to a config value is probably not always wise, and it's not something that can be + # easily input via a text editor. ANSI can go in Basic strings using the \e escape if that's accepted v1.1?) + #we could choose to change the type to another format here when encountering invalid chars - but that seems + #like too much magic. We elect to error out and require the dict to have valid data for the types it specifies. + if {[string first ' $val] >=0} { + error "_from_dictval_tomltype error: single quote found in LITERAL - cannot encode dict to TOML-VALID TOMLISH" + } + #detect control chars other than tab + #for this we can use rawstring_to_Bstring_with_escaped_controls - even though this isn't a Bstring + #we are just using the map to detect a difference. + set testval [tomlish::utils::rawstring_to_Bstring_with_escaped_controls $val] + if {$testval ne $val} { + #some escaping would have to be done if this value was destined for a Bstring... + #therefor this string has controls and isn't suitable for a LITERAL according to the specs. + error "_from_dictval_tomltype error: control chars (other than tab) found in LITERAL value - cannot encode dict to TOML-VALID TOMLISH" + } + return [list LITERAL $val] + } + STRING { + return [list STRING [tomlish::utils::rawstring_to_Bstring_with_escaped_controls $val]] + } + INT { + if {![::tomlish::utils::is_int $val]} { + error "_from_dictval_tomltype error: bad INT value '$val' - cannot encode dict to TOML-VALID TOMLISH" + } + return [list INT $val] + } + FLOAT { + if {![::tomlish::utils::is_float $val]} { + error "_from_dictval_tomltype error: bad FLOAT value '$val' - cannot encode dict to TOML-VALID TOMLISH" + } + return [list FLOAT $val] + } + default { + if {$type ni [::tomlish::tags]} { + error "_from_dictval_tomltype error: Unrecognised typename '$type' in {type value } - cannot encode dict to TOML-VALID TOMLISH" + } + return [list $type $val] + } + } + } + + proc _from_dictval {parents tablestack keys vinfo} { + set k [lindex $keys end] + if {[regexp {\s} $k] || [string first . $k] >= 0} {} + if {![::tomlish::utils::is_barekey $k]} { + #Any dot in the key would have been split by to_dict - so if it's present here it's part of this key - not a level separator! + #requires quoting + #we'll use a basic mechanism for now to determine the type of quoting - whether it has any single quotes or not. + #todo - more? + #For keys - we currently (2025) are only allowed barekeys,basic strings and literal strings. (no multiline forms) + if {[string first ' $k] >=0} { + #basic string + } else { + #literal string + set K_PART [list SQKEY $k] + } + } else { + set K_PART [list KEY $k] + } + puts stderr "---parents:'$parents' keys:'$keys' vinfo: $vinfo---" + puts stderr "---tablestack: $tablestack---" + set result [list] + set lastparent [lindex $parents end] + if {$lastparent in [list "" do_inline]} { + if {[tomlish::dict::is_tomlish_typeval $vinfo]} { + set type [dict get $vinfo type] + #treat ITABLE differently? + set sublist [_from_dictval_tomltype $parents $tablestack $keys $vinfo] + lappend result DOTTEDKEY [list $K_PART {WS { }}] = {WS { }} $sublist {NEWLINE lf} + } else { + #set result [list TABLE $k {NEWLINE lf}] + if {$vinfo ne ""} { + + #set result [list DOTTEDKEY [list [list KEY $k]] = ] + #set records [list ITABLE] + + set last_tomltype_posn [tomlish::dict::last_tomltype_posn $vinfo] + + if {$lastparent eq "do_inline"} { + set result [list DOTTEDKEY [list $K_PART] =] + set records [list ITABLE] + } else { + #review - quoted k ?? + set result [list TABLE $k {NEWLINE lf}] + set tablestack [list {*}$tablestack [list T $k]] + set records [list] + } + + + + set lastidx [expr {[dict size $vinfo] -1}] + set dictidx 0 + dict for {vk vv} $vinfo { + if {[regexp {\s} $vk] || [string first . $vk] >= 0} { + set VK_PART [list SQKEY $vk] + } else { + set VK_PART [list KEY $vk] + } + if {[tomlish::dict::is_tomlish_typeval $vv]} { + #type x value y + set sublist [_from_dictval_tomltype $parents $tablestack $keys $vv] + set record [list DOTTEDKEY [list $VK_PART {WS { }}] = {WS { }} $sublist] + } else { + if {$vv eq ""} { + #experimental + if {[lindex $parents 0] eq "" && $dictidx > $last_tomltype_posn} { + puts stderr "_from_dictval could uninline KEY $vk (tablestack:$tablestack)" + #set tname [tomlish::dict::name_from_tablestack [list {*}$tablestack [list T $vk]]] + set tname [join [list {*}$keys $vk] .] + set record [list TABLE $tname {NEWLINE lf}] + set tablestack [list {*}$tablestack [list T $vk]] + } else { + set record [list DOTTEDKEY [list $VK_PART] = ITABLE] + set tablestack [list {*}$tablestack [list I $vk]] + } + } else { + if { 0 } { + #experiment.. sort of getting there. + if {[lindex $parents 0] eq "" && $dictidx > $last_tomltype_posn} { + puts stderr "_from_dictval could uninline2 KEYS [list {*}$keys $vk] (tablestack:$tablestack)" + set tname [join [list {*}$keys $vk] .] + set record [list TABLE $tname {NEWLINE lf}] + set tablestack [list {*}$tablestack [list T $vk]] + + #review - todo? + set dottedkey_value [_from_dictval [list {*}$parents TABLE] $tablestack [list {*}$keys $vk] $vv] + lappend record {*}$dottedkey_value + + } else { + set dottedkey_value [_from_dictval [list {*}$parents ITABLE] $tablestack [list {*}$keys $vk] $vv] + set record [list DOTTEDKEY [list $VK_PART] = $dottedkey_value] + } + } else { + set dottedkey_value [_from_dictval [list {*}$parents ITABLE] $tablestack [list {*}$keys $vk] $vv] + set record [list DOTTEDKEY [list $VK_PART] = $dottedkey_value] + } + } + } + if {$dictidx != $lastidx} { + #lappend record SEP + if {$lastparent eq "do_inline"} { + lappend record SEP + } else { + lappend record {NEWLINE lf} + } + } + lappend records $record + incr dictidx + } + if {$lastparent eq "do_inline"} { + lappend result $records {NEWLINE lf} + } else { + lappend result {*}$records {NEWLINE lf} + } + } else { + if {$lastparent eq "do_inline"} { + lappend result DOTTEDKEY [list [list KEY $k]] = ITABLE {NEWLINE lf} + } else { + lappend result TABLE $k {NEWLINE lf} + } + } + } + } else { + #lastparent is not toplevel "" or "do_inline" + if {[tomlish::dict::is_tomlish_typeval $vinfo]} { + #type x value y + set sublist [_from_dictval_tomltype $parents $tablestack $keys $vinfo] + lappend result {*}$sublist + } else { + if {$lastparent eq "TABLE"} { + #review + dict for {vk vv} $vinfo { + set dottedkey_value [_from_dictval [list {*}$parents DOTTEDKEY] $tablestack [list {*}$keys $vk] $vv] + lappend result [list DOTTEDKEY [list [list KEY $vk]] = $dottedkey_value {NEWLINE lf}] + } + } else { + if {$vinfo ne ""} { + set lastidx [expr {[dict size $vinfo] -1}] + set dictidx 0 + set sub [list] + #REVIEW + #set result $lastparent ;#e.g sets ITABLE + set result ITABLE + set last_tomltype_posn [tomlish::dict::last_tomltype_posn $vinfo] + dict for {vk vv} $vinfo { + if {[regexp {\s} $vk] || [string first . $vk] >=0} { + set VK_PART [list SQKEY $vk] + } else { + set VK_PART [list KEY $vk] + } + if {[tomlish::dict::is_tomlish_typeval $vv]} { + #type x value y + set sublist [_from_dictval_tomltype $parents $tablestack $keys $vv] + set record [list DOTTEDKEY [list $VK_PART] = $sublist] + } else { + if {$vv eq ""} { + #can't just uninline at this level + #we need a better method to query main dict for uninlinability at each level + # (including what's been inlined already) + #if {[lindex $parents 0] eq "" && $dictidx > $last_tomltype_posn} { + # puts stderr "_from_dictval uninline2 KEY $keys" + # set tname [join [list {*}$keys $vk] .] + # set record [list TABLE $tname {NEWLINE lf}] + # set tablestack [list {*}$tablestack [list T $vk]] + #} else { + set record [list DOTTEDKEY [list $VK_PART] = ITABLE] + #} + } else { + #set sub [_from_dictval ITABLE $vk $vv] + set dottedkey_value [_from_dictval [list {*}$parents ITABLE] $tablestack [list {*}$keys $vk] $vv] + #set record [list DOTTEDKEY [list $VK_PART] = ITABLE $dottedkey_value] + set record [list DOTTEDKEY [list $VK_PART] = $dottedkey_value] + } + } + if {$dictidx != $lastidx} { + lappend record SEP + } + lappend result $record + incr dictidx + } + } else { + puts stderr "table x-1" + lappend result DOTTEDKEY [list $K_PART] = ITABLE + } + } + } + } + return $result + } + + + proc from_dict {d} { + #consider: + # t1={a=1,b=2} + # x = 1 + #If we represent t1 as an expanded table we get + # [t1] + # a=1 + # b=2 + # x=1 + # --- which is incorrect - as x was a toplevel key like t1! + #This issue doesn't occur if x is itself an inline table + # t1={a=1,b=2} + # x= {no="problem"} + # + # (or if we were to reorder x to come before t1) + + #As the dictionary form doesn't distinguish the structure used to create tables {[table1]\nk=v} vs inline {table1={k=v}} + #Without a solution, from_dict would have to always produce the inline form for toplevel tables unless we allowed re-ordering, + #which is unpreferred here. + + #A possible solution: + #scan the top level to see if all (trailing) elements are themselves dicts + # (ie not of form {type XXX value yyy}) + # + # A further point is that if all root level values are at the 'top' - we can treat lower table-like structures as {[table]} elements + #ie we don't need to force do_inline if all the 'simple' keys are before any compound keys + + #set root_has_values 0 + #approach 1) - the naive approach - forces inline when not always necessary + #dict for {k v} $d { + # if {[llength $v] == 4 && [lindex $v 0] eq "type"} { + # set root_has_values 1 + # break + # } + #} + + + #approach 2) - track the position of last {type x value y} in the dictionary built by to_dict + # - still not perfect. Inlines dotted tables unnecessarily + #This means from_dict doesn't produce output optimal for human editing. + set last_simple [tomlish::dict::last_tomltype_posn $d] + + + ## set parent "do_inline" ;#a value used in _from_dictval to distinguish from "" or other context based parent values + #Any keys that are themselves tables - will need to be represented inline + #to avoid reordering, or incorrect assignment of plain values to the wrong table. + + ## set parent "" + #all toplevel keys in the dict structure can represent subtables. + #we are free to use {[tablename]\n} syntax for toplevel elements. + + + set tomlish [list TOMLISH] + set dictposn 0 + set tablestack [list [list T root]] ;#todo + dict for {t tinfo} $d { + if {$last_simple > $dictposn} { + set parents [list do_inline] + } else { + set parents [list ""] + } + set keys [list $t] + set trecord [_from_dictval $parents $tablestack $keys $tinfo] + lappend tomlish $trecord + incr dictposn + } + return $tomlish + } + proc json_to_toml {json} { #*** !doctools #[call [fun json_to_toml] [arg json]] @@ -718,8 +1172,12 @@ namespace eval tomlish { #TODO use huddle? proc from_json {json} { - set jstruct [::tomlish::json_struct $json] - return [::tomlish::from_json_struct $jstruct] + #set jstruct [::tomlish::json_struct $json] + #return [::tomlish::from_json_struct $jstruct] + package require huddle + package require huddle::json + set h [huddle::json::json2huddle parse $json] + } proc from_json_struct {jstruct} { @@ -734,7 +1192,7 @@ namespace eval tomlish { proc get_json {tomlish} { package require fish::json - set d [::tomlish::get_dict $tomlish] + set d [::tomlish::to_dict $tomlish] #return [::tomlish::dict_to_json $d] return [fish::json::from "struct" $d] } @@ -747,20 +1205,17 @@ namespace eval tomlish { } # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - -namespace eval tomlish::encode { - #*** !doctools - #[subsection {Namespace tomlish::encode}] - #[para] - #[list_begin definitions] - - #STRING,INT,FLOAT,BOOL, DATETIME - simple wrappers for completeness +namespace eval tomlish::build { + #STRING,INT,FLOAT,BOOL, DATETIME - simple wrappers for completeness # take a value of the appropriate type and wrap as a tomlish tagged item - proc string {s} { - return [list STRING $s] + proc STRING {s} { + return [list STRING [::tomlish::utils::rawstring_to_Bstring_with_escaped_controls $s]] + } + proc LITERAL {litstring} { + } - proc int {i} { + proc INT {i} { #whole numbers, may be prefixed with a + or - #Leading zeros are not allowed #Hex,octal binary forms are allowed (toml 1.0) @@ -773,16 +1228,16 @@ namespace eval tomlish::encode { if {![::tomlish::utils::int_validchars $i]} { error "Unable to interpret '$i' as an integer. Only 0-9 + 1 _ characters are acceptable. [::tomlish::parse::report_line]" } - + if {[::tomlish::utils::is_int $i]} { return [list INT $i] } else { error "'$i' is not a valid integer as per the Toml spec. [::tomlish::parse::report_line]" } - + } - proc float {f} { + proc FLOAT {f} { #convert any non-lower case variants of special values to lowercase for Toml if {[::tcl::string::tolower $f] in {nan +nan -nan inf +inf -inf}} { return [list FLOAT [tcl::string::tolower $f]] @@ -790,24 +1245,24 @@ namespace eval tomlish::encode { if {[::tomlish::utils::is_float $f]} { return [list FLOAT $f] } else { - error "Unable to interpret '$f' as Toml float. Check your input, or check that tomlish is able to handle all Toml floats properly [::tomlish::parse::report_line]" + error "Unable to interpret '$f' as Toml float. Check your input, or check that tomlish is able to handle all Toml floats properly [::tomlish::parse::report_line]" } } - proc datetime {str} { + proc DATETIME {str} { if {[::tomlish::utils::is_datetime $str]} { return [list DATETIME $str] } else { - error "Unable to interpret '$str' as Toml datetime. Check your input, or check that tomlish is able to handle all Toml datetimes properly [::tomlish::parse::report_line]" + error "Unable to interpret '$str' as Toml datetime. Check your input, or check that tomlish is able to handle all Toml datetimes properly [::tomlish::parse::report_line]" } } - proc boolean {b} { + proc BOOLEAN {b} { #convert any Tcl-acceptable boolean to boolean as accepted by toml - lower case true/false if {![tcl::string::is boolean -strict $b]} { error "Unable to convert '$b' to Toml boolean true|false. [::tomlish::parse::report_line]" } else { - if {[expr {$b && 1}]} { + if {$b && 1} { return [::list BOOL true] } else { return [::list BOOL false] @@ -815,13 +1270,12 @@ namespace eval tomlish::encode { } } - - #TODO - #Take tablename followed by - # a) *tomlish* name-value pairs e.g table mydata [list KEY item11 = [list STRING "test"]] {KEY item2 = [list INT 1]} + #REVIEW + #Take tablename followed by + # a) *tomlish* name-value pairs e.g table mydata [list KEY item11 = [list STRING "test"]] {KEY item2 = [list INT 1]} # (accept also key value {STRING }) # b) simple 2-element tcl lists being name & *simple* value pairs for which basic heuristics will be used to determine types - proc table {name args} { + proc _table {name args} { set pairs [list] foreach t $args { if {[llength $t] == 4} { @@ -832,7 +1286,7 @@ namespace eval tomlish::encode { if {[llength $valuepart] != 2} { error "supplied value must be typed. e.g {INT 1} or {STRING test}" } - lappend pairs [list KEY $keystr = $valuepart] + lappend pairs [list KEY $keystr = $valuepart] } elseif {[llength $t] == 2} { #!todo - type heuristics lassign $t n v @@ -843,39 +1297,59 @@ namespace eval tomlish::encode { } set result [list TABLE $name {NEWLINE lf}] foreach p $pairs { - lappend result $p {NEWLINE lf} + lappend result $p {NEWLINE lf} } return $result #return [list TABLE $name $pairs] } + #REVIEW - root & table are not correct #the tomlish root is basically a nameless table representing the root of the document - proc root {args} { + proc _root {args} { set table [::tomlish::encode::table TOMLISH {*}$args] - set result [lrange $table 2 end] + set result [lrange $table 2 end] } +} + +namespace eval tomlish::encode { + #*** !doctools + #[subsection {Namespace tomlish::encode}] + #[para] + #[list_begin definitions] + + + + #WS = whitepace, US = underscore + #--------------------------------------------------------------------------------------------------------- + #NOTE - this DELIBERATELY does not validate the data, or process escapes etc + #It encodes the tomlish records as they are. + #ie it only produces toml shaped data from a tomlish list. + #It is part of the roundtripability of data from toml to tomlish + #e.g duplicate keys etc can exist in the toml output. + #The to_dict from_dict (or any equivalent processor pair) is responsible for validation and conversion + #back and forth of escape sequences where appropriate. + #--------------------------------------------------------------------------------------------------------- proc tomlish {list {context ""}} { if {![tcl::string::is list $list]} { error "Supplied 'tomlish' is not a valid Tcl list. Expected a tagged list (parsed Toml)" } set toml "" ;#result string - + foreach item $list { set tag [lindex $item 0] #puts "tomlish::encode::tomlish processing item '$item', tag '$tag'" #during recursion, some tags require different error checking in different contexts. set nextcontext $tag ; - - + #Handle invalid tag nestings switch -- $context { - QKEY - + DQKEY - SQKEY - KEY { - if {$tag in {KEY QKEY SQKEY}} { + if {$tag in {KEY DQKEY SQKEY}} { error "Invalid tag '$tag' encountered within '$context'" } } @@ -896,12 +1370,12 @@ namespace eval tomlish::encode { #no context, or no defined nesting error for this context } } - + switch -- $tag { TOMLISH { #optional root tag. Ignore. } - QKEY - + DQKEY - SQKEY - KEY { # @@ -910,7 +1384,7 @@ namespace eval tomlish::encode { } elseif {$tag eq "SQKEY"} { append toml '[lindex $item 1]' ;#SQuoted Key } else { - append toml \"[lindex $item 1]\" ;#Quoted Key + append toml \"[lindex $item 1]\" ;#DQuoted Key } #= could be at various positions depending on WS foreach part [lrange $item 2 end] { @@ -922,7 +1396,7 @@ namespace eval tomlish::encode { } } DOTTEDKEY { - #QKEY, SQKEY, BAREKEY, WS, DOTSEP + #DQKEY, SQKEY, BAREKEY, WS, DOTSEP foreach part [lindex $item 1] { append toml [::tomlish::encode::tomlish [list $part] $nextcontext] } @@ -938,11 +1412,10 @@ namespace eval tomlish::encode { } } TABLE { - append toml "\[[lindex $item 1]\]" ;#table name + append toml "\[[lindex $item 1]\]" ;#table name foreach part [lrange $item 2 end] { append toml [::tomlish::encode::tomlish [list $part] $nextcontext] } - } ITABLE { #inline table - e.g within array or on RHS of keyval/qkeyval @@ -953,7 +1426,6 @@ namespace eval tomlish::encode { append toml "\{$data\}" } ARRAY { - set arraystr "" foreach part [lrange $item 1 end] { append arraystr [::tomlish::encode::tomlish [list $part] $nextcontext] @@ -984,6 +1456,7 @@ namespace eval tomlish::encode { append toml "\\" } STRING { + #Basic string (Bstring) #simple double quoted strings only # append toml \"[lindex $item 1]\" @@ -1007,7 +1480,7 @@ namespace eval tomlish::encode { append toml [lindex $item 1] } MULTILITERAL { - #multiliteral could be handled as a single literal if we allowed literal to contain newlines + #multiliteral could be handled as a single literal if we allowed literal to contain newlines #- except that the first newline must be retained for roundtripping tomlish <-> toml but # the first newline is not part of the data. # we elect instead to maintain a basic LITERALPART that must not contain newlines.. @@ -1039,7 +1512,7 @@ namespace eval tomlish::encode { error "Not a properly formed 'tomlish' taggedlist.\n '$list'\n Unknown tag '[lindex $item 0]'. See output of \[tomlish::tags\] command." } } - + } return $toml } @@ -1054,32 +1527,35 @@ namespace eval tomlish::encode { #(encode tomlish as toml) interp alias {} tomlish::to_toml {} tomlish::encode::tomlish -# +# namespace eval tomlish::decode { #*** !doctools #[subsection {Namespace tomlish::decode}] - #[para] + #[para] #[list_begin definitions] - #return a Tcl list of tomlish tokens + #return a Tcl list of tomlish tokens #i.e get a standard list of all the toml terms in string $s #where each element of the list is a *tomlish* term.. i.e a specially 'tagged' Tcl list. #(simliar to a tcl 'Huddle' - but also supporting whitespace preservation) - #Note that we deliberately don't check certain things such as duplicate table declarations here. + # ---------------------------------------------------------------------------------------------- + # NOTE: the production of tomlish from toml source doesn't indicate the toml source was valid!!! + # e.g we deliberately don't check certain things such as duplicate table declarations here. + # ---------------------------------------------------------------------------------------------- #Part of the justification for this is that as long as the syntax is toml shaped - we can load files which violate certain rules and allow programmatic manipulation. # (e.g perhaps a toml editor to highlight violations for fixing) # A further stage is then necessary to load the tomlish tagged list into a data structure more suitable for efficient query/reading. # e.g dicts or an object oriented structure #Note also - *no* escapes in quoted strings are processed. This is up to the datastructure stage - #e.g to_dict will substitute \r \n \uHHHH \UHHHHHHH etc + #e.g to_dict will substitute \r \n \uHHHH \UHHHHHHH etc #This is important for tomlish to maintain the ability to perform competely lossless round-trips from toml to tomlish and back to toml. # (which is handy for testing as well as editing some part of the structure with absolutely no effect on other parts of the document) - #If we were to unescape a tab character for example + #If we were to unescape a tab character for example # - we have no way of knowing if it was originally specified as \t \u0009 or \U00000009 or directly as a tab character. # For this reason, we also do absolutely no line-ending transformations based on platform. - # All line-endings are maintained as is, and even a file with mixed cr crlf line-endings will be correctly interpreted and can be 'roundtripped' + # All line-endings are maintained as is, and even a file with mixed lf crlf line-endings will be correctly interpreted and can be 'roundtripped' proc toml {args} { #*** !doctools @@ -1088,73 +1564,70 @@ namespace eval tomlish::decode { set s [join $args \n] - namespace upvar ::tomlish::parse is_parsing is_parsing + namespace upvar ::tomlish::parse is_parsing is_parsing set is_parsing 1 - - + if {[info command ::tomlish::parse::spacestack] eq "::tomlish::parse::spacestack"} { tomlish::parse::spacestack destroy } struct::stack ::tomlish::parse::spacestack - + namespace upvar ::tomlish::parse last_space_action last_space_action namespace upvar ::tomlish::parse last_space_type last_space_type - - + namespace upvar ::tomlish::parse tok tok set tok "" - - namespace upvar ::tomlish::parse type type - namespace upvar ::tomlish::parse tokenType tokenType - ::tomlish::parse::set_tokenType "" - namespace upvar ::tomlish::parse tokenType_list tokenType_list + + namespace upvar ::tomlish::parse type type + namespace upvar ::tomlish::parse tokenType tokenType + ::tomlish::parse::set_tokenType "" + namespace upvar ::tomlish::parse tokenType_list tokenType_list set tokenType [list] ;#Flat (un-nested) list of tokentypes found - - namespace upvar ::tomlish::parse lastChar lastChar + + namespace upvar ::tomlish::parse lastChar lastChar set lastChar "" - + set result "" - namespace upvar ::tomlish::parse nest nest + namespace upvar ::tomlish::parse nest nest set nest 0 - + namespace upvar ::tomlish::parse v v ;#array keyed on nest level - - + + set v(0) {TOMLISH} array set s0 [list] ;#whitespace data to go in {SPACE {}} element. set parentlevel 0 - + namespace upvar ::tomlish::parse i i set i 0 - - namespace upvar ::tomlish::parse state state - - namespace upvar ::tomlish::parse braceCount braceCount + + namespace upvar ::tomlish::parse state state + + namespace upvar ::tomlish::parse braceCount braceCount set barceCount 0 namespace upvar ::tomlish::parse bracketCount bracketCount set bracketCount 0 - + set sep 0 set r 1 - namespace upvar ::tomlish::parse token_waiting token_waiting + namespace upvar ::tomlish::parse token_waiting token_waiting set token_waiting [dict create] ;#if ::tok finds a *complete* second token during a run, it will put the 2nd one here to be returned by the next call. - - + + set state "table-space" ::tomlish::parse::spacestack push {type space state table-space} namespace upvar ::tomlish::parse linenum linenum;#'line number' of input data. (incremented for each literal linefeed - but not escaped ones in data) set linenum 1 - set ::tomlish::parse::state_list [list] + set ::tomlish::parse::state_list [list] try { while {$r} { set r [::tomlish::parse::tok $s] #puts stdout "got tok: '$tok' while parsing string '$s' " set next_tokenType_known 0 ;#whether we begin a new token here based on what terminated the token result of 'tok' - - - + + #puts "got token: '$tok' tokenType='$tokenType'. while v($nest) = [set v($nest)]" #puts "-->tok: $tok tokenType='$tokenType'" set prevstate $state @@ -1162,7 +1635,7 @@ namespace eval tomlish::decode { #review goNextState could perform more than one space_action set space_action [dict get $transition_info space_action] set newstate [dict get $transition_info newstate] ;#use of 'newstate' vs 'state' makes code clearer below - + if {[tcl::string::match "err-*" $state]} { ::tomlish::log::warn "---- State error in state $prevstate for tokenType: $tokenType token value: $tok. $state aborting parse. [tomlish::parse::report_line]" lappend v(0) [list ERROR tokentype $tokenType state $prevstate to $state leveldata [set v($nest)]] @@ -1175,23 +1648,23 @@ namespace eval tomlish::decode { # --------------------------------------------------------- if {$space_action eq "pop"} { - #pop_trigger_tokens: newline tablename endarray endinlinetable + #pop_trigger_tokens: newline tablename endarray endinlinetable #note a token is a pop trigger depending on context. e.g first newline during keyval is a pop trigger. set parentlevel [expr {$nest -1}] - set do_append_to_parent 1 ;#most tokens will leave this alone - but some like squote_seq need to do their own append + set do_append_to_parent 1 ;#most tokens will leave this alone - but some like squote_seq need to do their own append switch -exact -- $tokenType { squote_seq { #### set do_append_to_parent 0 ;#mark false to indicate we will do our own appends if needed #Without this - we would get extraneous empty list entries in the parent - # - as the xxx-squote-space isn't a space level from the toml perspective - # - the use of a space is to give us a hook here to (possibly) integrate extra quotes into the parent space when we pop + # - as the xxx-squote-space isn't a space level from the toml perspective + # - the use of a space is to give us a hook here to (possibly) integrate extra quotes into the parent space when we pop switch -- $tok { ' { tomlish::parse::set_token_waiting type startsquote value $tok complete 1 startindex [expr {$i -1}] } '' { - #review - we should perhaps return double_squote instead? + #review - we should perhaps return double_squote instead? #tomlish::parse::set_token_waiting type literal value "" complete 1 tomlish::parse::set_token_waiting type double_squote value "" complete 1 startindex [expr {$i - 2}] } @@ -1213,7 +1686,7 @@ namespace eval tomlish::decode { switch -- [lindex $lastpart 0] { LITERALPART { set newval "[lindex $lastpart 1]'" - set parentdata $v($parentlevel) + set parentdata $v($parentlevel) lset parentdata end [list LITERALPART $newval] set v($parentlevel) $parentdata } @@ -1234,7 +1707,7 @@ namespace eval tomlish::decode { switch -exact -- $prevstate { leading-squote-space { error "---- 5 squotes from leading-squote-space - shouldn't get here" - #we should have emitted the triple and left the following squotes for next loop + #we should have emitted the triple and left the following squotes for next loop } trailing-squote-space { tomlish::parse::set_token_waiting type triple_squote value $tok complete 1 startindex [expr {$i-5}] @@ -1243,7 +1716,7 @@ namespace eval tomlish::decode { switch -- [lindex $lastpart 0] { LITERALPART { set newval "[lindex $lastpart 1]''" - set parentdata $v($parentlevel) + set parentdata $v($parentlevel) lset parentdata end [list LITERALPART $newval] set v($parentlevel) $parentdata } @@ -1261,7 +1734,7 @@ namespace eval tomlish::decode { } } } - puts "---- HERE squote_seq pop <$tok>" + puts stderr "tomlish::decode::toml ---- HERE squote_seq pop <$tok>" } triple_squote { #presumably popping multiliteral-space @@ -1296,10 +1769,19 @@ namespace eval tomlish::decode { set v($nest) $merged } equal { - if {$prevstate eq "dottedkey-space"} { - tomlish::log::debug "---- equal ending dottedkey-space for last_space_action pop" - #re-emit for parent space - tomlish::parse::set_token_waiting type equal value = complete 1 startindex [expr {$i-1}] + #pop caused by = + switch -exact -- $prevstate { + dottedkey-space { + tomlish::log::debug "---- equal ending dottedkey-space for last_space_action pop" + #re-emit for parent space + tomlish::parse::set_token_waiting type equal value = complete 1 startindex [expr {$i-1}] + } + dottedkey-space-tail { + #experiment? + tomlish::log::debug "---- equal ending dottedkey-space-tail for last_space_action pop" + #re-emit for parent space + tomlish::parse::set_token_waiting type equal value = complete 1 startindex [expr {$i-1}] + } } } newline { @@ -1338,12 +1820,12 @@ namespace eval tomlish::decode { } incr nest -1 - + } elseif {$last_space_action eq "push"} { set prevnest $nest incr nest 1 set v($nest) [list] - # push_trigger_tokens: barekey quotedkey startinlinetable startarray tablename tablearrayname + # push_trigger_tokens: barekey dquotedkey startinlinetable startarray tablename tablearrayname switch -exact -- $tokenType { @@ -1365,6 +1847,19 @@ namespace eval tomlish::decode { #todo - check not something already waiting? tomlish::parse::set_token_waiting type $tokenType value $tok complete 1 startindex [expr {$i -[tcl::string::length $tok]}] ;#re-submit token in the newly pushed space } + dquotedkey { + switch -exact -- $prevstate { + table-space - itable-space { + set v($nest) [list DOTTEDKEY] + } + } + #todo - check not something already waiting? + tomlish::parse::set_token_waiting type $tokenType value $tok complete 1 startindex [expr {$i -[tcl::string::length $tok]}] ;#re-submit token in the newly pushed space + } + XXXdquotedkey - XXXitablequotedkey { + #todo + set v($nest) [list DQKEY $tok] ;#$tok is the keyname + } barekey { switch -exact -- $prevstate { table-space - itable-space { @@ -1374,7 +1869,7 @@ namespace eval tomlish::decode { #todo - check not something already waiting? set waiting [tomlish::parse::get_token_waiting] if {[llength $waiting]} { - set i [dict get $waiting startindex] + set i [dict get $waiting startindex] tomlish::parse::clear_token_waiting tomlish::parse::set_token_waiting type $tokenType value $tok complete 1 startindex [expr {$i -[tcl::string::length $tok]}] ;#re-submit token in the newly pushed space } else { @@ -1382,28 +1877,23 @@ namespace eval tomlish::decode { } } startsquote { + #JMN set next_tokenType_known 1 ::tomlish::parse::set_tokenType "squotedkey" set tok "" } - quotedkey - itablequotedkey { - set v($nest) [list QKEY $tok] ;#$tok is the keyname - } - itablesquotedkey { - set v($nest) [list SQKEY $tok] ;#$tok is the keyname - } tablename { #note: we do not use the output of tomlish::tablename_trim to produce a tablename for storage in the tomlish list! #The tomlish list is intended to preserve all whitespace (and comments) - so a roundtrip from toml file to tomlish # back to toml file will be identical. #It is up to the datastructure stage to normalize and interpret tomlish for programmatic access. - # we call tablename_trim here only to to validate that the tablename data is well-formed at the outermost level, + # we call tablename_trim here only to to validate that the tablename data is well-formed at the outermost level, # so we can raise an error at this point rather than create a tomlish list with obviously invalid table names. - + #todo - review! It's arguable that we should not do any validation here, and just store even incorrect raw tablenames, - # so that the tomlish list is more useful for say a toml editor. Consider adding an 'err' tag to the appropriate place in the + # so that the tomlish list is more useful for say a toml editor. Consider adding an 'err' tag to the appropriate place in the # tomlish list? - + set test_only [::tomlish::utils::tablename_trim $tok] ::tomlish::log::debug "---- trimmed (but not normalized) tablename: '$test_only'" set v($nest) [list TABLE $tok] ;#$tok is the *raw* table name @@ -1434,13 +1924,17 @@ namespace eval tomlish::decode { error "---- push trigger tokenType '$tokenType' not yet implemented" } } - + } else { #no space level change switch -exact -- $tokenType { squotedkey { puts "---- squotedkey in state $prevstate (no space level change)" - lappend v($nest) [list SQKEY $tok] + lappend v($nest) [list SQKEY $tok] + } + dquotedkey { + puts "---- dquotedkey in state $prevstate (no space level change)" + lappend v($nest) [list DQKEY $tok] } barekey { lappend v($nest) [list KEY $tok] @@ -1473,10 +1967,10 @@ namespace eval tomlish::decode { } quoted-key { set next_tokenType_known 1 - ::tomlish::parse::set_tokenType "quotedkey" + ::tomlish::parse::set_tokenType "dquotedkey" set tok "" } - itable-quoted-key { + XXXitable-quoted-key { set next_tokenType_known 1 ::tomlish::parse::set_tokenType "itablequotedkey" set tok "" @@ -1498,7 +1992,7 @@ namespace eval tomlish::decode { ::tomlish::parse::set_tokenType "squotedkey" set tok "" } - itable-squoted-key { + XXXitable-squoted-key { set next_tokenType_known 1 ::tomlish::parse::set_tokenType "itablesquotedkey" set tok "" @@ -1542,7 +2036,7 @@ namespace eval tomlish::decode { double_squote { switch -exact -- $prevstate { keyval-value-expected { - lappend v($nest) [list LITERAL ""] + lappend v($nest) [list LITERAL ""] } multiliteral-space { #multiliteral-space to multiliteral-space @@ -1566,9 +2060,6 @@ namespace eval tomlish::decode { literalpart { lappend v($nest) [list LITERALPART $tok] ;#will not get wrapped in squotes directly } - quotedkey { - #lappend v($nest) [list QKEY $tok] ;#TEST - } itablequotedkey { } @@ -1621,20 +2112,20 @@ namespace eval tomlish::decode { } } } - + if {!$next_tokenType_known} { ::tomlish::log::notice "---- tomlish::decode::toml - current tokenType:$tokenType Next token type not known" ::tomlish::parse::set_tokenType "" set tok "" } - + if {$state eq "end-state"} { break } - - + + } - + #while {$nest > 0} { # lappend v([expr {$nest -1}]) [set v($nest)] # incr nest -1 @@ -1643,21 +2134,21 @@ namespace eval tomlish::decode { ::tomlish::parse::spacestack pop lappend v([expr {$nest -1}]) [set v($nest)] incr nest -1 - + #set parent [spacestack peek] ;#the level being appended to #lassign $parent type state #if {$type eq "space"} { - # + # #} elseif {$type eq "buffer"} { # lappend v([expr {$nest -1}]) {*}[set v($nest)] #} else { # error "invalid spacestack item: $parent" #} } - + } finally { set is_parsing 0 - } + } return $v(0) } @@ -1670,7 +2161,7 @@ interp alias {} tomlish::from_toml {} tomlish::decode::toml namespace eval tomlish::utils { #*** !doctools #[subsection {Namespace tomlish::utils}] - #[para] + #[para] #[list_begin definitions] @@ -1690,7 +2181,7 @@ namespace eval tomlish::utils { } #basic generic quote matching for single and double quotes - #note for example that {[o'malley]} will return sq - as the single quote is not closed or wrapped in double quotes + #note for example that {[o'malley]} will return sq - as the single quote is not closed or wrapped in double quotes proc tok_in_quotedpart {tok} { set sLen [tcl::string::length $tok] set quote_type "" @@ -1701,7 +2192,7 @@ namespace eval tomlish::utils { if {$had_slash} { #don't enter quote mode #leave slash_mode because even if current char is slash - it is escaped - set had_slash 0 + set had_slash 0 } else { set ctype [tcl::string::map [list {"} dq {'} sq \\ bsl] $c] switch -- $ctype { @@ -1713,7 +2204,7 @@ namespace eval tomlish::utils { } bsl { set had_slash 1 - } + } } } } else { @@ -1754,15 +2245,15 @@ namespace eval tomlish::utils { #quoted is for double-quotes, litquoted is for single-quotes (string literal) set seg "" for {set i 0} {$i < $sLen} {incr i} { - + if {$i > 0} { set lastChar [tcl::string::index $tablename [expr {$i - 1}]] } else { set lastChar "" } - + set c [tcl::string::index $tablename $i] - + if {$c eq "."} { switch -exact -- $mode { unquoted { @@ -1796,10 +2287,16 @@ namespace eval tomlish::utils { set mode "quoted" set seg "\"" } elseif {$mode eq "unquoted"} { - append seg $c + append seg $c } elseif {$mode eq "quoted"} { append seg $c - lappend segments $seg + + if {$normalize} { + lappend segments [::tomlish::utils::unescape_string [tcl::string::range $seg 1 end-1]] + } else { + lappend segments $seg + } + set seg "" set mode "syntax" ;#make sure we only accept a dot or end-of-data now. } elseif {$mode eq "litquoted"} { @@ -1816,16 +2313,17 @@ namespace eval tomlish::utils { append seg $c } elseif {$mode eq "quoted"} { append seg $c - + } elseif {$mode eq "litquoted"} { append seg $c + #no normalization to do lappend segments $seg set seg "" set mode "syntax" } elseif {$mode eq "syntax"} { error "tablename_split. expected whitespace or dot, got single quote. tablename: '$tablename'" } - + } elseif {$c in [list " " \t]} { if {$mode eq "syntax"} { #ignore @@ -1844,16 +2342,17 @@ namespace eval tomlish::utils { if {$i == $sLen-1} { #end of data ::tomlish::log::debug "End of data: mode='$mode'" + #REVIEW - we can only end up in unquoted or syntax here? are other branches reachable? switch -exact -- $mode { quoted { if {$c ne "\""} { error "tablename_split. missing closing double-quote in a segment. tablename: '$tablename'" } if {$normalize} { - lappend segments $seg - } else { lappend segments [::tomlish::utils::unescape_string [tcl::string::range $seg 1 end-1]] - #lappend segments [subst -nocommands -novariables [::string range $seg 1 end-1]] ;#wrong + #lappend segments [subst -nocommands -novariables [::string range $seg 1 end-1]] ;#wrong + } else { + lappend segments $seg } } litquoted { @@ -1877,7 +2376,7 @@ namespace eval tomlish::utils { } foreach seg $segments { set trimmed [tcl::string::trim $seg " \t"] - #note - we explicitly allow 'empty' quoted strings '' & "" + #note - we explicitly allow 'empty' quoted strings '' & "" # (these are 'discouraged' but valid toml keys) #if {$trimmed in [list "''" "\"\""]} { # puts stderr "tablename_split. warning - Empty quoted string as tablename segment" @@ -1891,8 +2390,8 @@ namespace eval tomlish::utils { proc unicode_escape_info {slashu} { #!todo - # validate that slashu is either a \uxxxx or \Uxxxxxxxx value of the correct length and - # is a valid 'unicode scalar value' + # validate that slashu is either a \uxxxx or \Uxxxxxxxx value of the correct length and + # is a valid 'unicode scalar value' (any Unicode code point except high-surrogate and low-surrogate code points) # ie integers in the range 0 to D7FF16 and E00016 to 10FFFF16 inclusive #expr {(($x >= 0) && ($x <= 0xD7FF16)) || (($x >= 0xE00016) && ($x <= 0x10FFFF16))} if {[tcl::string::match {\\u*} $slashu]} { @@ -1925,30 +2424,73 @@ namespace eval tomlish::utils { } } else { return [list err [list reason "Supplied string did not start with \\u or \\U" ]] - } - + } + } + #Note that unicode characters don't *have* to be escaped. + #So if we provide a function named 'escape_string', the name implies the inverse of unescape_string which unescapes unicode \u \U values. + #- an inverse of unescape_string would encode all unicode chars unnecessarily. + #- as toml accepts a compact escape sequence for common chars such as tab,backspace,linefeed etc but also allows the full form \u009 etc + #- escape_string and unescape_string would not be reliably roundtrippable inverses anyway. + #REVIEW - provide it anyway? When would it be desirable to use? + + variable Bstring_control_map [list\ + \b {\b}\ + \n {\n}\ + \r {\r}\ + \" {\"}\ + \x1b {\e}\ + \\ "\\\\"\ + ] + #\e for \x1b seems like it might be included - v1.1?? hard to find current state of where toml is going :/ + #for a Bstring (Basic string) tab is explicitly mentioned as not being one that must be escaped. + for {set cdec 0} {$cdec <= 8} {incr cdec} { + set hhhh [format %.4X $cdec] + lappend Bstring_control_map [format %c $cdec] \\u$hhhh + } + for {set cdec [expr {0x0A}]} {$cdec <= 0x1F} {incr cdec} { + set hhhh [format %.4X $cdec] + lappend Bstring_control_map [format %c $cdec] \\u$hhhh + } + # \u007F = 127 + lappend Bstring_control_map [format %c 127] \\u007F + + #Note the inclusion of backslash in the list of controls makes this non idempotent - subsequent runs would keep encoding the backslashes! + #escape only those chars that must be escaped in a Bstring (e.g not tab which can be literal or escaped) + #for example - can be used by from_dict to produce valid Bstring data for a tomlish record + proc rawstring_to_Bstring_with_escaped_controls {str} { + #for the well known chars that have compact escape sequences allowed by toml - we choose that form over the full \u form. + #we'll use a string map with an explicit list rather than algorithmic at runtime + # - the string map is probably more performant than splitting a string, especially if it's large + variable Bstring_control_map + return [string map $Bstring_control_map $str] + } + + #review - unescape what string? Bstring vs MLBstring? + #we should be specific in the function naming here + #used by to_dict - so part of validation? - REVIEW proc unescape_string {str} { #note we can't just use Tcl subst because: # it also transforms \a (audible bell) and \v (vertical tab) which are not in the toml spec. # it would strip out backslashes inappropriately: e.g "\j" becomes just j # it recognizes other escapes which aren't approprite e.g \xhh and octal \nnn - # it replaces\ with a single whitespace + # it replaces \ with a single whitespace (trailing backslash) #This means we shouldn't use 'subst' on the whole string, but instead substitute only the toml-specified escapes (\r \n \b \t \f \\ \" \uhhhh & \Uhhhhhhhh - + set buffer "" set buffer4 "" ;#buffer for 4 hex characters following a \u set buffer8 "" ;#buffer for 8 hex characters following a \u - + set sLen [tcl::string::length $str] - + #we need to handle arbitrarily long sequences of backslashes. \\\\\ etc set slash_active 0 set unicode4_active 0 set unicode8_active 0 - - + + ::tomlish::log::debug "unescape_string. got len [string length str] str $str" + #!todo - check for invalid data in the form of a raw carriage return (decimal 13) without following linefeed? set i 0 for {} {$i < $sLen} {} { @@ -1957,15 +2499,21 @@ namespace eval tomlish::utils { } else { set lastChar "" } - + set c [tcl::string::index $str $i] - ::tomlish::log::debug "unescape_string. got char $c" + #::tomlish::log::debug "unescape_string. got char $c" ;#too much? + + #---------------------- + #as we are 'unescaping' - should we really be testing for existing values that should have been escaped? + #this test looks incomplete anyway REVIEW scan $c %c n if {($n <= 31) && ($n != 9) && ($n != 10) && ($n != 13)} { #we don't expect unescaped unicode characters from 0000 to 001F - #*except* for raw tab (which is whitespace) and newlines error "unescape_string. Invalid data for a toml string. Unescaped control character (decimal $n) [::tomlish::utils::string_to_slashu $c]" } + #---------------------- + incr i ;#must incr here because we do'returns'inside the loop if {$c eq "\\"} { if {$slash_active} { @@ -1976,14 +2524,14 @@ namespace eval tomlish::utils { } elseif {$unicode8_active} { error "unescape_string. unexpected case slash during unicode8 not yet handled" } else { - # don't output anything (yet) + # don't output anything (yet) set slash_active 1 } } else { if {$unicode4_active} { if {[tcl::string::length $buffer4] < 4} { append buffer4 $c - } + } if {[tcl::string::length $buffer4] == 4} { #we have a \uHHHH to test set unicode4_active 0 @@ -1997,7 +2545,7 @@ namespace eval tomlish::utils { } elseif {$unicode8_active} { if {[tcl::string::length $buffer8] < 8} { append buffer8 $c - } + } if {[tcl::string::length $buffer8] == 8} { #we have a \UHHHHHHHH to test set unicode8_active 0 @@ -2030,11 +2578,13 @@ namespace eval tomlish::utils { } default { set slash_active 0 - - append buffer "\\" + #review - toml spec says all other escapes are reserved + #and if they are used TOML should produce an error. + #we leave detecting this for caller for now - REVIEW + append buffer "\\" append buffer $c } - } + } } else { append buffer $c } @@ -2042,10 +2592,10 @@ namespace eval tomlish::utils { } #puts stdout "EOF 4:$unicode4_active 8:$unicode8_active slash:$slash_active" if {$unicode4_active} { - error "End of string reached before complete unicode escape sequence \uHHHH" + error "End of string reached before complete unicode escape sequence \uHHHH" } if {$unicode8_active} { - error "End of string reached before complete unicode escape sequence \UHHHHHHHH" + error "End of string reached before complete unicode escape sequence \UHHHHHHHH" } if {$slash_active} { append buffer "\\" @@ -2053,6 +2603,9 @@ namespace eval tomlish::utils { return $buffer } + #This does not have to do with unicode normal forms - which it seems toml has decided against regarding use in keys (review/references?) + #This is meant for internal use regarding ensuring we match equivalent keys which may have just been specified with different string mechanisms, + #e.g squoted vs dquoted vs barekey. proc normalize_key {rawkey} { set c1 [tcl::string::index $rawkey 0] set c2 [tcl::string::index $rawkey end] @@ -2063,41 +2616,57 @@ namespace eval tomlish::utils { #double quoted segment. Apply escapes. # set keydata [tcl::string::range $rawkey 1 end-1] ;#strip outer quotes only + #e.g key could have mix of \UXXXXXXXX escapes and unicode chars + #or mix of \t and literal tabs. + #unescape to convert all to literal versions for comparison set key [::tomlish::utils::unescape_string $keydata] #set key [subst -nocommands -novariables $keydata] ;#wrong. Todo - create a string escape substitution function. } else { set key $rawkey } return $key - } + } proc string_to_slashu {string} { set rv {} foreach c [split $string {}] { - scan $c %c c - append rv {\u} - append rv [format %.4X $c] + scan $c %c cdec + if {$cdec > 65535} { + append rv {\U} [format %.8X $cdec] + } else { + append rv {\u} [format %.4X $cdec] + } } return $rv } - #'nonprintable' is conservative here because some systems (e.g windows console) are very limited in what they can display. + #'nonprintable' is conservative here because some systems (e.g windows console) are very limited in what they can display. + #This is used for display purposes only (error msgs) proc nonprintable_to_slashu {s} { set res "" foreach i [split $s ""] { - scan $i %c c - + scan $i %c cdec + set printable 0 - if {($c>31) && ($c<127)} { + if {($cdec>31) && ($cdec<127)} { set printable 1 } - if {$printable} {append res $i} else {append res \\u[format %.4X $c]} + if {$printable} { + append res $i + } else { + if {$cdec > 65535} { + append res \\U[format %.8X $cdec] + } else { + append res \\u[format %.4X $cdec] + } + } } set res - } ;#RS + } ;# initial version from tcl wiki RS #check if str is valid for use as a toml bare key - proc is_barekey {str} { + #Early toml versions? only allowed letters + underscore + dash + proc is_barekey1 {str} { if {[tcl::string::length $str] == 0} { return 0 } else { @@ -2111,6 +2680,52 @@ namespace eval tomlish::utils { } } + #from toml.abnf in github.com/toml-lang/toml + #unquoted-key = 1*unquoted-key-char + #unquoted-key-char = ALPHA / DIGIT / %x2D / %x5F ; a-z A-Z 0-9 - _ + #unquoted-key-char =/ %xB2 / %xB3 / %xB9 / %xBC-BE ; superscript digits, fractions + #unquoted-key-char =/ %xC0-D6 / %xD8-F6 / %xF8-37D ; non-symbol chars in Latin block + #unquoted-key-char =/ %x37F-1FFF ; exclude GREEK QUESTION MARK, which is basically a semi-colon + #unquoted-key-char =/ %x200C-200D / %x203F-2040 ; from General Punctuation Block, include the two tie symbols and ZWNJ, ZWJ + #unquoted-key-char =/ %x2070-218F / %x2460-24FF ; include super-/subscripts, letterlike/numberlike forms, enclosed alphanumerics + #unquoted-key-char =/ %x2C00-2FEF / %x3001-D7FF ; skip arrows, math, box drawing etc, skip 2FF0-3000 ideographic up/down markers and spaces + #unquoted-key-char =/ %x2070-21FF / %x2300-24FF ; skip math operators + #unquoted-key-char =/ %x25A0-268B / %x2690-2757 ; skip box drawing, block elements, and some yin-yang symbols + #unquoted-key-char =/ %x2762-2767 / %x2776-27E5 ; skip some Dingbat punctuation + #unquoted-key-char =/ %x2801-297F ; skip some math brackets and arrows, and braille blank + #unquoted-key-char =/ %x2B00-2FFF / %x3001-D7FF ; skip various math operators and symbols, and ideographic space + #unquoted-key-char =/ %xF900-FDCF / %xFDF0-FFFD ; skip D800-DFFF surrogate block, E000-F8FF Private Use area, FDD0-FDEF intended for process-internal use (unicode) + #unquoted-key-char =/ %x10000-EFFFF ; all chars outside BMP range, excluding Private Use planes (F0000-10FFFF) + variable re_barekey + set ranges [list] + lappend ranges {a-zA-Z0-9\_\-} + lappend ranges {\u00B2} {\u00B3} {\u00B9} {\u00BC-\u00BE} ;# superscript digits, fractions + lappend ranges {\u00C0-\u00D6} {\u00D8-\u00F6} {\u00F8-\u037D} ;# non-symbol chars in Latin block + lappend ranges {\u037f-\u1FFF} ;# exclude GREEK QUESTION MARK, which is basically a semi-colon + lappend ranges {\u200C-\u200D} {\u203F-\u2040} ;# from General Punctuation Block, include the two tie symbols and ZWNJ, ZWJ + lappend ranges {\u2070-\u218f} {\u2460-\u24FF} ;# include super-subscripts, letterlike/numberlike forms, enclosed alphanumerics + lappend ranges {\u2C00-\u2FEF} {\u3001-\uD7FF} ;# skip arrows, math, box drawing etc, skip 2FF0-3000 ideographic up/down markers and spaces + lappend ranges {\u2070-\u21FF} {\u2300-\u24FF} ;# skip math operators + lappend ranges {\u25A0-\u268B} {\u2690-\u2757} ;# skip box drawing, block elements, and some yin-yang symbols + lappend ranges {\u2762-\u2767} {\u2776-\u27E5} ;# skip some Dingbat punctuation + lappend ranges {\u2801-\u297F} ;# skip some math brackets and arrows, and braille blank + lappend ranges {\u2B00-\u2FFF} {\u3001-\uD7FF} ;# skip various math operators and symbols, and ideographic space + lappend ranges {\uF900-\uFDCF} {\uFDF0-\uFFFD} ;# skip D800-DFFF surrogate block, E000-F8FF Private Use area, FDD0-FDEF intended for process-internal use (unicode) + lappend ranges {\U10000-\UEFFFF} ;# all chars outside BMP range, excluding Private Use planes (F0000-10FFFF) + set re_barekey {^[} + foreach r $ranges { + append re_barekey $r + } + append re_barekey {]+$} + + proc is_barekey {str} { + if {[tcl::string::length $str] == 0} { + return 0 + } + variable re_barekey + return [regexp $re_barekey $str] + } + #test only that the characters in str are valid for the toml specified type 'integer'. proc int_validchars1 {str} { set numchars [tcl::string::length $str] @@ -2132,25 +2747,25 @@ namespace eval tomlish::utils { proc is_int {str} { set matches [regexp -all {[0-9\_xo\-\+A-Fa-f]} $str] - + if {[tcl::string::length $str] == $matches} { #all characters in legal range - # --------------------------------------- - #check for leading zeroes in non 0x 0b 0o + # --------------------------------------- + #check for leading zeroes in non 0x 0b 0o #first strip any +, - or _ (just for this test) set check [tcl::string::map {+ "" - "" _ ""} $str] if {([tcl::string::length $check] > 1) && ([tcl::string::index $check 0] eq "0") && ([tcl::string::index $check 1] ni {o x b})} { return 0 - } - # --------------------------------------- + } + # --------------------------------------- #check +,- only occur in the first position. if {[tcl::string::last - $str] > 0} { - return 0 + return 0 } if {[tcl::string::last + $str] > 0} { - return 0 + return 0 } set numeric_value [tcl::string::map {_ ""} $str] ;#allow some earlier tcl versions which don't support underscores #use Tcl's integer check to ensure we don't let things like 3e4 through - which is a float (would need to be 0x3e4 for hex) @@ -2158,7 +2773,7 @@ namespace eval tomlish::utils { return 0 } #!todo - check bounds only based on some config value - #even though Tcl can handle bignums, we won't accept anything outside of toml 1.0 minimum requirements. + #even though Tcl can handle bignums, we won't accept anything outside of toml 1.0 minimum requirements. #presumably very large numbers would have to be supplied in a toml file as strings. #Review - toml 1.0 only says that it must handle up to 2^63 - not that this is a max if {$numeric_value > $::tomlish::max_int} { @@ -2195,7 +2810,7 @@ namespace eval tomlish::utils { if {$str in {inf +inf -inf nan +nan -nan}} { return 1 } - + if {[tcl::string::length $str] == $matches} { #all characters in legal range #A leading zero is ok, but we should disallow multiple leading zeroes (same rules as toml ints) @@ -2215,14 +2830,14 @@ namespace eval tomlish::utils { #for floats, +,- may occur in multiple places #e.g -2E-22 +3e34 #!todo - check bounds ? - + #strip underscores for tcl double check set check [tcl::string::map {_ ""} $str] #string is double accepts inf nan +NaN etc. if {![tcl::string::is double $check]} { return 0 } - + } else { return 0 } @@ -2240,7 +2855,7 @@ namespace eval tomlish::utils { } } - #review - we + #review - we proc is_datetime {str} { #e.g 1979-05-27 #e.g 1979-05-27T00:32:00Z @@ -2249,14 +2864,14 @@ namespace eval tomlish::utils { #e.g 1979-05-27 00:32:00.999999-07:00 #review - #minimal datetimes? + #minimal datetimes? # 2024 ok - shortest valid 4 digit year? # 02:00 ok # 05-17 ok if {[string length $str] < 4} { return 0 } - + set matches [regexp -all {[zZtT0-9\-\+\.:]} $str] if {[tcl::string::length $str] == $matches} { #all characters in legal range @@ -2264,8 +2879,8 @@ namespace eval tomlish::utils { lassign [split $str T] datepart timepart #!todo - what if the value is 'time only'? - #Tcl's free-form clock scan (no -format option) is deprecated - # + #Tcl's free-form clock scan (no -format option) is deprecated + # #if {[catch {clock scan $datepart} err]} { # puts stderr "tcl clock scan failed err:'$err'" # return 0 @@ -2286,7 +2901,7 @@ namespace eval tomlish::utils { namespace eval tomlish::parse { #*** !doctools #[subsection {Namespace tomlish::parse}] - #[para] + #[para] #[list_begin definitions] #This is a somewhat curly mix of a statemachine and toml-nesting-stack littered with special cases. @@ -2294,16 +2909,16 @@ namespace eval tomlish::parse { # - e.g some kind of backtracking required if using an ABNF parser? #I don't know the precise technical name for this sort of parser; probably something like "Dog's Breakfast" #More seriously, we don't have distinct lex/parse steps - so it is basically a 'fused lexer' or 'scannerless parser' - - #It is also desirable for this system to be useful in 'interactive' use. review - would a separate lexer make this easier or harder? + + #It is also desirable for this system to be useful in 'interactive' use. review - would a separate lexer make this easier or harder? #A possible alternative more structured approach might be to use a PEG (Parsing Expression Grammar) - + variable is_parsing 0 ;#whether we are in the middle of parsing tomlish text - variable state - # states: + variable state + # states: # table-space, itable-space, array-space # value-expected, keyval-syntax, # quoted-key, squoted-key @@ -2318,10 +2933,10 @@ namespace eval tomlish::parse { #stateMatrix defines for each state, actions to take for each possible token. #single-element actions are the name of the next state into which to transition, or a 'POPSPACE' instruction to pop a level off the spacestack and add the data to the parent container. #dual-element actions are a push instruction and the name of the space to push on the stack. - # - PUSHSPACE is a simple push onto the spacestack, zeropoppushspace also pushes, but will first do a pop *if* the current space level is greater than zero (ie if only if not already in root table-space) + # - PUSHSPACE is a simple push onto the spacestack, zeropoppushspace also pushes, but will first do a pop *if* the current space level is greater than zero (ie if only if not already in root table-space) # -- --- --- --- --- --- - #token/state naming guide + #token/state naming guide # -- --- --- --- --- --- #tokens : underscore separated or bare name e.g newline, start_quote, start_squote #private tokens: always have a leading underscore (These are private 'temporary state' tokens that are never returned as actual tokens e.g _start_squote_sequence @@ -2334,24 +2949,24 @@ namespace eval tomlish::parse { # current-state {token-encountered next-state ... } # where next-state can be a 1 or 2 element list. #If 2 element - the first item is an instruction (ucase) - #If 1 element - it is either a lowercase dashed state name or an ucase instruction - #e.g {PUSHSPACE } or POPSPACE or SAMESPACE + #If 1 element - it is either a lowercase dashed state name or an ucase instruction + #e.g {PUSHSPACE } or POPSPACE or SAMESPACE #SAMESPACE - got to same space as parent without popping a level, but has it's own autotransition lookup - strange concept - review usecases - variable stateMatrix + variable stateMatrix set stateMatrix [dict create] #xxx-space vs xxx-syntax inadequately documented - TODO # --------------------------------------------------------------------------------------------------------------# - # incomplete example of some state starting at table-space + # incomplete example of some state starting at table-space # --------------------------------------------------------------------------------------------------------------# # ( = -> value-expected) # keyval-syntax (popped -> keyval-space -> keyval-tail) (autotransition on pop) # keyval-space (autotransition on push ^) - # table-space (barekey^) (startquote -> quoted-key ^) + # table-space (barekey^) (startdquote -> dquoted-key ^) # --------------------------------------------------------------------------------------------------------------# dict set stateMatrix\ @@ -2361,7 +2976,8 @@ namespace eval tomlish::parse { newline "table-space"\ barekey {PUSHSPACE "keyval-space" state "keyval-syntax"}\ squotedkey {PUSHSPACE "keyval-space" state "keyval-syntax" note ""}\ - startquote "quoted-key"\ + dquotedkey {PUSHSPACE "keyval-space" state "keyval-syntax"}\ + XXXstartquote "quoted-key"\ XXXstartsquote "squoted-key"\ comment "table-space"\ starttablename "tablename-state"\ @@ -2371,6 +2987,7 @@ namespace eval tomlish::parse { comma "err-state"\ eof "end-state"\ equal "err-state"\ + cr "err-lonecr"\ } #itable-space/ curly-syntax : itables @@ -2378,16 +2995,17 @@ namespace eval tomlish::parse { itable-space {\ whitespace "itable-space"\ newline "itable-space"\ - squote_seq_begin {PUSHSPACE "leading-squote-space" returnstate itable-space starttok {squote_seq "'"}}\ barekey {PUSHSPACE "itable-keyval-space" state "itable-keyval-syntax"}\ squotedkey {PUSHSPACE "itable-keyval-space" state "itable-keyval-syntax"}\ + dquotedkey {PUSHSPACE "itable-keyval-space" state "itable-keyval-syntax"}\ endinlinetable "POPSPACE"\ - startquote "quoted-key"\ - startsquote {TOSTATE "squoted-key" comment "jn-testing"}\ - comma "itable-space"\ - comment "err-state"\ + XXXstartquote "quoted-key"\ + XXXstartsquote {TOSTATE "squoted-key" comment "jn-testing"}\ + comma "err-state"\ + comment "itable-space"\ eof "err-state"\ } + #squote_seq_begin {PUSHSPACE "leading-squote-space" returnstate itable-space starttok {squote_seq "'"}} dict set stateMatrix\ @@ -2400,8 +3018,9 @@ namespace eval tomlish::parse { dict set stateMatrix\ keyval-syntax {\ whitespace "keyval-syntax"\ - squotedkey {PUSHSPACE "dottedkey-space"}\ barekey {PUSHSPACE "dottedkey-space"}\ + squotedkey {PUSHSPACE "dottedkey-space"}\ + dquotedkey {PUSHSPACE "dottedkey-space"}\ equal "keyval-value-expected"\ comma "err-state"\ newline "err-state"\ @@ -2443,8 +3062,9 @@ namespace eval tomlish::parse { dict set stateMatrix\ itable-keyval-syntax {\ whitespace "itable-keyval-syntax"\ - squotedkey {PUSHSPACE "dottedkey-space"}\ barekey {PUSHSPACE "dottedkey-space"}\ + squotedkey {PUSHSPACE "dottedkey-space"}\ + dquotedkey {PUSHSPACE "dottedkey-space"}\ equal "itable-keyval-value-expected"\ newline "err-state"\ eof "err-state"\ @@ -2473,8 +3093,8 @@ namespace eval tomlish::parse { whitespace "itable-val-tail"\ endinlinetable "POPSPACE"\ comma "POPSPACE"\ - Xnewline {TOSTATE "itable-val-tail" note "itable-space ??"}\ - newline "err-state"\ + XXXnewline {TOSTATE "itable-val-tail" note "itable-space ??"}\ + newline "POPSPACE"\ comment "itable-val-tail"\ eof "err-state"\ } @@ -2512,41 +3132,68 @@ namespace eval tomlish::parse { newline "err-state"\ eof "err-state"\ } - - #dottedkey-space is not used within [tablename] or [[tablearrayname]] + + #dottedkey-space is not (currently) used within [tablename] or [[tablearrayname]] #it is for keyval ie x.y.z = value + + #this is the state after dot + #we are expecting a complete key token or whitespace + #(initial entry to the space is by one of the keys - which will immediately go to dottedkey-space-tail) dict set stateMatrix\ dottedkey-space {\ whitespace "dottedkey-space"\ - dotsep "dottedkey-space"\ - barekey "dottedkey-space"\ - squotedkey "dottedkey-space"\ - quotedkey "dottedkey-space"\ - equal "POPSPACE"\ + dotsep "err-state"\ + barekey "dottedkey-space-tail"\ + squotedkey "dottedkey-space-tail"\ + dquotedkey "dottedkey-space-tail"\ newline "err-state"\ comma "err-state"\ comment "err-state"\ + equal "err-state"\ } #dottedkeyend "POPSPACE" + #equal "POPSPACE"\ + + #jmn 2025 + #we have 1 or more dottedkeys so far - need dotsep to add more, whitespace to maintain, equal to pop + dict set stateMatrix\ + dottedkey-space-tail {\ + whitespace "dottedkey-space-tail" + dotsep "dottedkey-space" + equal "POPSPACE"\ + } + + #-------------------------------------------------------------------------- + #scratch area + #from_toml {x=1} + # barekey tok + # table-space PUSHSPACE keyval-space state keyval-syntax + # + #-------------------------------------------------------------------------- #REVIEW #toml spec looks like heading towards allowing newlines within inline tables #https://github.com/toml-lang/toml/issues/781 - dict set stateMatrix\ - curly-syntax {\ - whitespace "curly-syntax"\ - newline "curly-syntax"\ - barekey {PUSHSPACE "itable-keyval-space"}\ - itablequotedkey "itable-keyval-space"\ - endinlinetable "POPSPACE"\ - startquote "itable-quoted-key"\ - comma "itable-space"\ - comment "itable-space"\ - eof "err-state"\ - } + + #2025 - appears to be valid for 1.1 - which we are targeting. + #https://github.com/toml-lang/toml/blob/main/toml.md#inline-table + + #JMN2025 + #dict set stateMatrix\ + # curly-syntax {\ + # whitespace "curly-syntax"\ + # newline "curly-syntax"\ + # barekey {PUSHSPACE "itable-keyval-space"}\ + # itablequotedkey "itable-keyval-space"\ + # endinlinetable "POPSPACE"\ + # startquote "itable-quoted-key"\ + # comma "itable-space"\ + # comment "itable-space"\ + # eof "err-state"\ + # } #review comment "err-state" vs comment "itable-space" - see if TOML 1.1 comes out and allows comments in multiline ITABLES #We currently allow multiline ITABLES (also with comments) in the tokenizer. #if we want to disallow as per TOML 1.0 - we should do so when attempting to get structure? @@ -2589,10 +3236,19 @@ namespace eval tomlish::parse { dict set stateMatrix\ quoted-key {\ whitespace "NA"\ - quotedkey {PUSHSPACE "keyval-space"}\ + dquotedkey {PUSHSPACE "keyval-space"}\ newline "err-state"\ endquote "keyval-syntax"\ } + + + #review + dict set stateMatrix\ + dquoted-key {\ + whitespace "NA"\ + dquotedkey "dquoted-key"\ + newline "err-state"\ + } dict set stateMatrix\ squoted-key {\ whitespace "NA"\ @@ -2600,7 +3256,7 @@ namespace eval tomlish::parse { newline "err-state"\ } # endsquote {PUSHSPACE "keyval-space"} - + dict set stateMatrix\ string-state {\ whitespace "NA"\ @@ -2654,7 +3310,7 @@ namespace eval tomlish::parse { trailing-squote-space {\ squote_seq "POPSPACE"\ } - + dict set stateMatrix\ tablename-state {\ @@ -2706,9 +3362,9 @@ namespace eval tomlish::parse { } - # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- #purpose - debugging? remove? - # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- #build a list of 'push triggers' from the stateMatrix # ie tokens which can push a new space onto spacestack set push_trigger_tokens [list] @@ -2725,17 +3381,17 @@ namespace eval tomlish::parse { } } ::tomlish::log::debug "push_trigger_tokens: $push_trigger_tokens" - # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- #This seems hacky... (deprecate in favour of explicit arguments to the instructions in stateMatrix?) - #spacePopTransitions, spacePushTransitions, spaceSameTransitions below for auto state redirections on POPSPACE,PUSHSPACE,SAMESPACE + #spacePopTransitions, spacePushTransitions, spaceSameTransitions below for auto state redirections on POPSPACE,PUSHSPACE,SAMESPACE #mainly for the -space states: #redirect to another state $c based on a state transition from $whatever to $b # e.g "string {array-space array-syntax}" means when transitioning from string to array-space, jump to array-syntax instead. - #this is useful as we often don't know state $b. e.g when it is decided by 'POPSPACE' + #this is useful as we often don't know state $b. e.g when it is decided by 'POPSPACE' #Push to, next #default first states when we push to these spaces @@ -2745,7 +3401,7 @@ namespace eval tomlish::parse { array-space array-space table-space tablename-state } - #itable-space itable-space + #itable-space itable-space #Pop to, next variable spacePopTransitions { array-space array-syntax @@ -2777,7 +3433,7 @@ namespace eval tomlish::parse { variable nest variable v - set prevstate $currentstate + set prevstate $currentstate variable spacePopTransitions @@ -2787,10 +3443,10 @@ namespace eval tomlish::parse { variable last_space_action "none" variable last_space_type "none" variable state_list - + set result "" set starttok "" - + if {[dict exists $::tomlish::parse::stateMatrix $currentstate $tokentype]} { set transition_to [dict get $::tomlish::parse::stateMatrix $currentstate $tokentype] ::tomlish::log::debug "--->> goNextState tokentype:$tokentype tok:$tok currentstate:$currentstate : transition_to = $transition_to" @@ -2806,10 +3462,10 @@ namespace eval tomlish::parse { if {[dict exists $parent_info returnstate]} { set next [dict get $parent_info returnstate] - #clear the returnstate on current level + #clear the returnstate on current level set existing [spacestack pop] dict unset existing returnstate - spacestack push $existing ;#re-push modification + spacestack push $existing ;#re-push modification ::tomlish::log::info "--->> POPSPACE transition to parent space $parentspace redirected to stored returnstate $next <<---" } else { ### @@ -2833,10 +3489,10 @@ namespace eval tomlish::parse { if {[dict exists $currentspace_info returnstate]} { set next [dict get $currentspace_info returnstate] - #clear the returnstate on current level + #clear the returnstate on current level set existing [spacestack pop] dict unset existing returnstate - spacestack push $existing ;#re-push modification + spacestack push $existing ;#re-push modification ::tomlish::log::info "--->> SAMESPACE transition to space $currentspace redirected to stored returnstate $next" } else { if {[dict exists $::tomlish::parse::spaceSameTransitions $currentspace]} { @@ -2859,7 +3515,7 @@ namespace eval tomlish::parse { set last_space_action "pop" set last_space_type $type - + #----- #standard pop set parentlevel [expr {$nest -1}] @@ -2867,8 +3523,8 @@ namespace eval tomlish::parse { incr nest -1 #----- } - #re-entrancy - + #re-entrancy + #set next [list PUSHSPACE [lindex $transition_to 1]] set nexttokentype ${tokentype}2 ;#fake token type e.g tablename2 or tablearrayname2 #::tomlish::log::notice "goNextState REENTRANCY. calling goNextState $nexttokentype $tokentype" @@ -2890,7 +3546,7 @@ namespace eval tomlish::parse { if {[dict exists $transition_to starttok]} { set starttok [dict get $transition_to starttok] } - spacestack push [dict create type space state $original_target] + spacestack push [dict create type space state $original_target] set last_space_action "push" set last_space_type "space" @@ -2928,7 +3584,7 @@ namespace eval tomlish::parse { } } } else { - ::tomlish::log::error "--->> No state transition defined from state $currentstate when tokentype $tokentype received" + ::tomlish::log::error "--->> No state transition defined from state $currentstate when tokentype $tokentype received" set result "nostate" } lappend state_list [list tokentype $tokentype from $currentstate to $result] @@ -2943,7 +3599,7 @@ namespace eval tomlish::parse { if {$is_parsing} { if {$line eq ""} { set line $linenum - } + } return "Line Number: $line" } else { #not in the middle of parsing tomlish text - return nothing. @@ -2954,11 +3610,11 @@ namespace eval tomlish::parse { #produce a *slightly* more readable string rep of the nest for puts etc. proc nest_pretty1 {list} { set prettier "{" - + foreach el $list { if { [lindex $el 0] eq "NEWLINE"} { append prettier "[list $el]\n" - } elseif {([llength $el] > 1) && ([lindex $el 0] in {KEY QKEY SQKEY TABLE ARRAY})} { + } elseif {([llength $el] > 1) && ([lindex $el 0] in {KEY DQKEY SQKEY TABLE ARRAY})} { append prettier [nest_pretty1 $el] } else { append prettier "[list $el] " @@ -3002,7 +3658,7 @@ namespace eval tomlish::parse { puts stderr "_shortcircuit_startquotesequence toklen 2" set_tokenType "startquote" set tok "\"" - incr i -2 + incr i -2 return -level 2 1 } } @@ -3023,15 +3679,15 @@ namespace eval tomlish::parse { # - the reason being that the state transition triggered by the previous token may have invalidated the assumptions made when a token was added as waiting. proc set_token_waiting {args} { if {[llength $args] %2 != 0} { - error "set_token_waiting must have args of form: type value complete 0|1" + error "tomlish set_token_waiting must have args of form: type value complete 0|1" } variable token_waiting if {[llength $token_waiting] && [dict get [lindex $token_waiting end] type] ne "eof"} { #tokloop already set a token_waiting - but something (post tokloop processing?) is trying to set another #we may need to remove the existing token_waiting and reset the tokloop index to the previous char so it's reprocessed in the possibly new context - #rather than attempt to make the right decision here - we raise an error and require the caller to check/handle it - set err "set_token_waiting already has token_waiting: [lindex $token_waiting 0]" + #rather than attempt to make the right decision here - we raise an error and require the caller to check/handle it + set err "tomlish set_token_waiting already has token_waiting: [lindex $token_waiting 0]" append err \n " - cannot add token_waiting: $args" error $err #set tomlish::parse::i [expr {[dict get $token_waiting startindex] -1}] @@ -3051,19 +3707,19 @@ namespace eval tomlish::parse { dict set waiting startindex $v } default { - error "set_token_waiting error - unrecognised key $k. known keys: [dict keys $args]" + error "tomlish set_token_waiting error - unrecognised key $k. known keys: [dict keys $args]" } } } if {![tcl::string::is boolean -strict [dict get $waiting complete]]} { - error "set_token_waiting error - 'complete' must be a boolean. got [dict get $waiting complete]" + error "tomlish set_token_waiting error - 'complete' must be a boolean. got [dict get $waiting complete]" } if {![llength $token_waiting]} { set token_waiting [list $waiting] } else { #an extra sanity-check that we don't have more than just the eof.. if {[llength $token_waiting] > 1} { - set err "Unexpected. Existing token_waiting count > 1.\n" + set err "tomlish Unexpected. Existing token_waiting count > 1.\n" foreach tw $token_waiting { append err " $tw" \n } @@ -3076,9 +3732,9 @@ namespace eval tomlish::parse { return } - #returns 0 or 1 + #returns 0 or 1 #tomlish::parse::tok - #we attempt to do this without lookahead (potential use in streaming toml? for what benefit?) todo -final flag + #we attempt to do this without lookahead (potential use in streaming toml? for what benefit?) todo -final flag # - the possible benefit is being able to more easily process in arbitrarily split chunks (although we would still have to watch crlf splitting ?) # - interactive use? @@ -3089,25 +3745,25 @@ namespace eval tomlish::parse { variable tok variable type ;#character type variable state ;#FSM - - + + variable tokenType variable tokenType_list - - + + variable endToken - - variable lastChar - + + variable lastChar + variable braceCount variable bracketCount - + #------------------------------ #Previous run found another (presumably single-char) token #The normal case is for there to be only one dict in the list #multiple is an exception - primarily for eof - variable token_waiting + variable token_waiting if {[llength $token_waiting]} { set waiting [lindex $token_waiting 0] @@ -3118,7 +3774,7 @@ namespace eval tomlish::parse { return 1 } #------------------------------ - + set resultlist [list] set sLen [tcl::string::length $s] @@ -3132,23 +3788,23 @@ namespace eval tomlish::parse { } else { set lastChar "" } - + set c [tcl::string::index $s $i] set cindex $i - tomlish::log::debug "- tokloop char <$c> index $i tokenType:$tokenType tok:<$tok>" + set ctest [tcl::string::map {\{ lc \} rc \[ lb \] rb \" dq ' sq \\ bsl \r cr \n lf \t tab \uFEFF bom} $c] + tomlish::log::debug "- tokloop char <$ctest> index $i tokenType:$tokenType tok:<$tok>" #puts "got char $c during tokenType '$tokenType'" incr i ;#must incr here because we do returns inside the loop - - set ctest [tcl::string::map {\{ lc \} rc \[ lb \] rb \" dq ' sq \\ bsl \r cr \n lf \t tab \uFEFF bom} $c] + switch -exact -- $ctest { # { set dquotes $multi_dquote - set multi_dquote "" + set multi_dquote "" set had_slash $slash_active set slash_active 0 if {$had_slash} {append tok "\\"} ;#if tokentype not appropriate for \, we would already have errored out. - + if {[tcl::string::length $tokenType]} { switch -exact -- $tokenType { squote_seq { @@ -3164,11 +3820,11 @@ namespace eval tomlish::parse { return 1 } barekey { - error "Unexpected character '$c' during bare key. Only \[a-zA-Z_-\] allowed. [tomlish::parse::report_line]" + error "tomlish Unexpected character '$c' during bare key. Only \[a-zA-Z0-9_-\] and a selection of letter-like chars allowed (see tomlish::utils::is_barekey). [tomlish::parse::report_line]" } whitespace { # hash marks end of whitespace token - #do a return for the whitespace, set token_waiting + #do a return for the whitespace, set token_waiting #set_token_waiting type comment value "" complete 1 incr i -1 ;#leave comment for next run return 1 @@ -3181,14 +3837,14 @@ namespace eval tomlish::parse { } starttablename - starttablearrayname { #fix! - error "Character '#' is invalid first character for $tokenType. [tomlish::parse::report_line]" + error "tomlish Character '#' is invalid first character for $tokenType. [tomlish::parse::report_line]" } tablename - tablearrayname { #invalid in bare parts - but allowed in quoted parts - let tablename parser sort it out append tok $c } default { - #quotedkey, itablequotedkey, string,literal, multistring + #dquotedkey, itablequotedkey, string,literal, multistring append tok $c } } @@ -3203,7 +3859,7 @@ namespace eval tomlish::parse { append tok "$dquotes#" } multiliteral-space { - set_tokenType "literalpart" + set_tokenType "literalpart" set tok "#" } default { @@ -3217,7 +3873,7 @@ namespace eval tomlish::parse { lc { #left curly brace set dquotes $multi_dquote - set multi_dquote "" + set multi_dquote "" set had_slash $slash_active set slash_active 0 @@ -3235,20 +3891,20 @@ namespace eval tomlish::parse { set_tokenType "startsquote" return 1 } - literal - literalpart - squotedkey - itablesquotedkey { + literal - literalpart - squotedkey { append tok $c } - string - quotedkey - itablequotedkey { + string - dquotedkey { if {$had_slash} {append tok "\\"} append tok $c } stringpart { - if {$had_slash} {append tok "\\"} + if {$had_slash} {append tok "\\"} append tok $dquotes$c } starttablename - starttablearrayname { #*bare* tablename can only contain letters,digits underscores - error "Invalid tablename first character \{ [tomlish::parse::report_line]" + error "tomlish Invalid tablename first character \{ [tomlish::parse::report_line]" } tablename - tablearrayname { #valid in quoted parts @@ -3273,7 +3929,7 @@ namespace eval tomlish::parse { return 1 } array-space - array-syntax { - #nested anonymous inline table + #nested anonymous inline table set_tokenType "startinlinetable" set tok "\{" return 1 @@ -3281,7 +3937,7 @@ namespace eval tomlish::parse { table-space { #invalid - but allow parser statemachine to report it. ? set_tokenType "startinlinetable" - set tok "\{" + set tok "\{" return 1 } multistring-space { @@ -3293,11 +3949,11 @@ namespace eval tomlish::parse { append tok "$dquotes\{" } multiliteral-space { - set_tokenType "literalpart" + set_tokenType "literalpart" set tok "\{" } default { - error "state: '$state'. left brace case not implemented [tomlish::parse::report_line]" + error "tomlish state: '$state'. left brace case not implemented [tomlish::parse::report_line]" } } } @@ -3306,7 +3962,7 @@ namespace eval tomlish::parse { rc { #right curly brace set dquotes $multi_dquote - set multi_dquote "" + set multi_dquote "" set had_slash $slash_active set slash_active 0 @@ -3324,33 +3980,31 @@ namespace eval tomlish::parse { set_tokenType "startsquote" return 1 } - literal - literalpart - squotedkey - itablesquotedkey { + literal - literalpart - squotedkey { append tok $c } - string - quotedkey - itablequotedkey - comment { - if {$had_slash} {append tok "\\"} + XXXitablesquotedkey { + } + string - dquotedkey - itablequotedkey - comment { + if {$had_slash} {append tok "\\"} append tok $c } stringpart { - if {$had_slash} {append tok "\\"} + if {$had_slash} {append tok "\\"} append tok $dquotes$c } starttablename - tablename { - if {$had_slash} {append tok "\\"} + if {$had_slash} {append tok "\\"} #invalid! - but leave for datastructure loading stage to catch set_token_waiting type endinlinetable value "" complete 1 startindex $cindex return 1 } starttablearrayname - tablearrayname { - if {$had_slash} {append tok "\\"} + if {$had_slash} {append tok "\\"} #invalid! - but leave for datastructure loading stage to catch set_token_waiting type endtablearrayname value "" complete 1 startindex $cindex return 1 } - itable-val-tail { - #review - error "right-curly in itable-val-tail" - } default { #end any other token incr i -1 @@ -3363,13 +4017,13 @@ namespace eval tomlish::parse { value-expected { #invalid - but allow parser statemachine to report it. set_tokenType "endinlinetable" - set tok "\}" + set tok "\}" return 1 } table-space { #invalid - but allow parser statemachine to report it. ? set_tokenType "endinlinetable" - set tok "\}" + set tok "\}" return 1 } itable-space { @@ -3387,7 +4041,7 @@ namespace eval tomlish::parse { return 1 } tablearrayname-state { - error "unexpected tablearrayname-state problem" + error "tomlish unexpected tablearrayname-state problem" set_tokenType "endinlinetable" set tok "" ;#no output into the tomlish list for this token return 1 @@ -3398,7 +4052,7 @@ namespace eval tomlish::parse { set tok "\}" return 1 } - curly-syntax { + XXXcurly-syntax { set_tokenType "endinlinetable" set tok "\}" return 1 @@ -3411,7 +4065,7 @@ namespace eval tomlish::parse { return 1 } itable-keyval-syntax { - error "endinlinetable unexpected at this point. Expecting key=val syntax [tomlish::parse::report_line]" + error "tomlish endinlinetable unexpected at this point. Expecting key=val syntax [tomlish::parse::report_line]" } multistring-space { set_tokenType "stringpart" @@ -3427,7 +4081,7 @@ namespace eval tomlish::parse { } default { #JMN2024b keyval-tail? - error "state '$state'. endinlinetable case not implemented [tomlish::parse::report_line]" + error "tomlish state '$state'. endinlinetable case not implemented [tomlish::parse::report_line]" } } } @@ -3436,7 +4090,7 @@ namespace eval tomlish::parse { lb { #left square bracket set dquotes $multi_dquote - set multi_dquote "" + set multi_dquote "" set had_slash $slash_active set slash_active 0 @@ -3454,10 +4108,12 @@ namespace eval tomlish::parse { set_tokenType "startsquote" return 1 } - literal - literalpart - squotedkey - itablesquotedkey { + literal - literalpart - squotedkey { append tok $c } - string - quotedkey - itablequotedkey { + XXXitablesquotedkey { + } + string - dquotedkey - itablequotedkey { if {$had_slash} {append tok "\\"} append tok $c } @@ -3473,10 +4129,11 @@ namespace eval tomlish::parse { return 1 } tablename { - #e.g a."x[0]".c is valid table name sequence - so we need to track quoting to know if rb is an end token + #e.g a."x[0]".c is valid table name sequence - so we need to track quoting to know if rb is an end token if {$had_slash} { #resultant tablename may be invalid - but leave for datastructure loading stage to catch - append tok "\\[" + #append tok "\\[" + append tok {\[} } else { if {[tomlish::utils::tok_in_quotedpart $tok] eq ""} { #invalid at this point - state machine should disallow table -> starttablearrayname @@ -3510,7 +4167,7 @@ namespace eval tomlish::parse { #table name #assume it's a single bracket - but we need to wait for non-bracket to confirm it's not a tablearray #note that a starttablearrayname token may contain whitespace between the brackets - # e.g \[ \[ + # e.g \[ \[ set_tokenType "starttablename" set tok "" ;#there is no output into the tomlish list for this token } @@ -3519,7 +4176,7 @@ namespace eval tomlish::parse { set_tokenType "startarray" set tok "\[" return 1 - #error "state: array-space. startarray case not implemented [tomlish::parse::report_line]" + #error "state: array-space. startarray case not implemented [tomlish::parse::report_line]" } multistring-space { set_tokenType "stringpart" @@ -3533,8 +4190,12 @@ namespace eval tomlish::parse { set_tokenType "literalpart" set tok "\[" } + itable-space { + #handle state just to give specific error msg + error "tomlish state: '$state'. Left square bracket invalid. Cannot start array in inline table without key. Use key=\[\] syntax. [tomlish::parse::report_line]" + } default { - error "state: '$state'. startarray case not implemented [tomlish::parse::report_line]" + error "tomlish state: '$state'. startarray case not implemented [tomlish::parse::report_line]" } } } @@ -3542,10 +4203,10 @@ namespace eval tomlish::parse { rb { #right square bracket set dquotes $multi_dquote - set multi_dquote "" + set multi_dquote "" set had_slash $slash_active set slash_active 0 - + if {[tcl::string::length $tokenType]} { switch -exact -- $tokenType { squote_seq { @@ -3560,19 +4221,21 @@ namespace eval tomlish::parse { set_tokenType "startsquote" return 1 } - literal - literalpart - squotedkey - itablesquotedkey { + literal - literalpart - squotedkey { append tok $c } - string - quotedkey - itablequotedkey { - if {$had_slash} {append tok "\\"} + XXXitablesquotedkey { + } + string - dquotedkey - itablequotedkey { + if {$had_slash} {append tok "\\"} append tok $c } stringpart { - if {$had_slash} {append tok "\\"} + if {$had_slash} {append tok "\\"} append tok $dquotes$c } comment { - if {$had_slash} {append tok "\\"} + if {$had_slash} {append tok "\\"} append tok $c } whitespace { @@ -3588,7 +4251,7 @@ namespace eval tomlish::parse { } } tablename { - #e.g a."x[0]".c is valid table name sequence - so we need to track quoting to know if rb is an end token + #e.g a."x[0]".c is valid table name sequence - so we need to track quoting to know if rb is an end token if {$had_slash} { #resultant tablename may be invalid - but leave for datastructure loading stage to catch append tok "\\]" @@ -3604,7 +4267,7 @@ namespace eval tomlish::parse { } tablearraynames { #todo? - if {$had_slash} {append tok "\\"} + if {$had_slash} {append tok "\\"} #invalid! - but leave for datastructure loading stage to catch set_token_waiting type endtablearrayname value "" complete 1 startindex $cindex return 1 @@ -3620,13 +4283,13 @@ namespace eval tomlish::parse { value-expected { #invalid - but allow parser statemachine to report it. set_tokenType "endarray" - set tok "\]" + set tok "\]" return 1 } table-space { #invalid - but allow parser statemachine to report it. ? set_tokenType "endarray" - set tok "\]" + set tok "\]" return 1 } tablename-state { @@ -3639,7 +4302,7 @@ namespace eval tomlish::parse { return 1 } tablearrayname-state { - error "unexpected tablearrayname problem" + error "tomlish unexpected tablearrayname problem" set_tokenType "endtablearray" set tok "" ;#no output into the tomlish list for this token return 1 @@ -3662,7 +4325,7 @@ namespace eval tomlish::parse { set tok "\]" } default { - error "state '$state'. endarray case not implemented [tomlish::parse::report_line]" + error "tomlish state '$state'. endarray case not implemented [tomlish::parse::report_line]" } } } @@ -3678,7 +4341,7 @@ namespace eval tomlish::parse { return 1 } startquotesequence { - _shortcircuit_startquotesequence + _shortcircuit_startquotesequence } _start_squote_sequence { incr i -[tcl::string::length $tok] @@ -3691,15 +4354,17 @@ namespace eval tomlish::parse { incr i -1 ;#reprocess bsl in next run return 1 } else { - error "Unexpected backslash during whitespace. [tomlish::parse::report_line]" + error "tomlish Unexpected backslash during whitespace. [tomlish::parse::report_line]" } } - literal - literalpart - squotedkey - itablesquotedkey { - #never need to set slash_active true when in single quoted tokens + literal - literalpart - squotedkey { + #never need to set slash_active true when in single quoted tokens append tok "\\" set slash_active 0 } - string - quotedkey - itablequotedkey - comment { + XXXitablesquotedkey { + } + string - dquotedkey - itablequotedkey - comment { if {$slash_active} { set slash_active 0 append tok "\\\\" @@ -3718,7 +4383,7 @@ namespace eval tomlish::parse { } } starttablename - starttablearrayname { - error "backslash is invalid as first character of $tokenType [tomlish::parse::report_line]" + error "tomlish backslash is invalid as first character of $tokenType [tomlish::parse::report_line]" } tablename - tablearrayname { if {$slash_active} { @@ -3729,10 +4394,10 @@ namespace eval tomlish::parse { } } barekey { - error "Unexpected backslash during barekey. [tomlish::parse::report_line]" + error "tomlish Unexpected backslash during barekey. [tomlish::parse::report_line]" } default { - error "Backslash unexpected during tokentype: '$tokenType'. [tomlish::parse::report_line]" + error "tomlish Backslash unexpected during tokentype: '$tokenType'. [tomlish::parse::report_line]" } } } else { @@ -3756,14 +4421,14 @@ namespace eval tomlish::parse { set tok "\\" } default { - error "tok error: Unexpected backslash when no token is active. [tomlish::parse::report_line]" + error "tomlish tok error: Unexpected backslash when no token is active. [tomlish::parse::report_line]" } } } } sq { #single quote - set had_slash $slash_active + set had_slash $slash_active set slash_active 0 if {[tcl::string::length $tokenType]} { switch -exact -- $tokenType { @@ -3776,9 +4441,9 @@ namespace eval tomlish::parse { leading-squote-space { append tok $c if {$existingtoklen > 2} { - error "tok error: squote_seq unexpected length $existingtoklen when another received" + error "tomlish tok error: squote_seq unexpected length $existingtoklen when another received" } elseif {$existingtoklen == 2} { - return 1 ;#return tok ''' + return 1 ;#return tok ''' } } trailing-squote-space { @@ -3790,7 +4455,7 @@ namespace eval tomlish::parse { } } default { - error "tok error: squote_seq in unexpected state '$state' - expected leading-squote-space or trailing-squote-space" + error "tomlish tok error: squote_seq in unexpected state '$state' - expected leading-squote-space or trailing-squote-space" } } } @@ -3811,17 +4476,17 @@ namespace eval tomlish::parse { 2 { #switch? append tok $c - set_tokenType triple_squote + set_tokenType triple_squote return 1 } default { - error "unexpected token length [tcl::string::length $tok] in '_start_squote_sequence'" + error "tomlish unexpected token length [tcl::string::length $tok] in '_start_squote_sequence'" } } } literal { #slash_active always false - #terminate the literal + #terminate the literal set_token_waiting type endsquote value "'" complete 1 startindex $cindex return 1 } @@ -3834,7 +4499,7 @@ namespace eval tomlish::parse { incr i -1 ;#throw the "'" back to loop - will be added to an squote_seq token for later processing return 1 } - itablesquotedkey { + XXXitablesquotedkey { set_token_waiting type endsquote value "'" complete 1 startindex $cindex return 1 } @@ -3851,6 +4516,10 @@ namespace eval tomlish::parse { tablename - tablearrayname { append tok $c } + barekey { + #not clear why o'shennanigan shouldn't be a legal barekey - but it seems not to be. + error "tomlish Unexpected single quote during barekey. [tomlish::parse::report_line]" + } default { append tok $c } @@ -3858,8 +4527,8 @@ namespace eval tomlish::parse { } else { switch -exact -- $state { value-expected - array-space { - set_tokenType "_start_squote_sequence" - set tok "'" + set_tokenType "_start_squote_sequence" + set tok "'" } itable-keyval-value-expected - keyval-value-expected { set_tokenType "squote_seq_begin" @@ -3867,18 +4536,26 @@ namespace eval tomlish::parse { return 1 } table-space { - ### + #tests: squotedkey.test set_tokenType "squotedkey" - set tok "" + set tok "" } itable-space { + #tests: squotedkey_itable.test + set_tokenType "squotedkey" + set tok "" + } + XXXitable-space { + #future - could there be multiline keys? + #this would allow arbitrary tcl dicts to be stored in toml + #probably unlikely - as it's perhaps not very 'minimal' or ergonomic for config files set_tokenType "squote_seq_begin" - set tok "'" + set tok "'" return 1 } tablename-state { #first char in tablename-state/tablearrayname-state - set_tokenType tablename + set_tokenType tablename append tok "'" } tablearrayname-state { @@ -3887,16 +4564,16 @@ namespace eval tomlish::parse { } literal-state { tomlish::log::debug "- tokloop sq during literal-state with no tokentype - empty literal?" - set_tokenType literal + set_tokenType literal incr -1 return 1 } multistring-space { - error "unimplemented - squote during state '$state'. [tomlish::parse::report_line]" + error "tomlish unimplemented - squote during state '$state'. [tomlish::parse::report_line]" } multiliteral-space { - #each literalpart is not necessarily started/ended with squotes - but may contain up to 2 in a row - #we are building up an squote_seq to determine if + #each literalpart is not necessarily started/ended with squotes - but may contain up to 2 in a row + #we are building up an squote_seq to determine if #a) it is shorter than ''' so belongs in a literalpart (either previous, subsequent or it's own literalpart between newlines #b) it is exactly ''' and we can terminate the whole multiliteral #c) it is 4 or 5 squotes where the first 1 or 2 beling in a literalpart and the trailing 3 terminate the space @@ -3908,7 +4585,7 @@ namespace eval tomlish::parse { set_tokenType squotedkey } default { - error "unhandled squote during state '$state'. [tomlish::parse::report_line]" + error "tomlish unhandled squote during state '$state'. [tomlish::parse::report_line]" } } } @@ -3916,7 +4593,7 @@ namespace eval tomlish::parse { } dq { #double quote - set had_slash $slash_active + set had_slash $slash_active set slash_active 0 if {[tcl::string::length $tokenType]} { @@ -3935,7 +4612,7 @@ namespace eval tomlish::parse { set_tokenType "startmultiquote" return 1 } else { - error "unexpected token length $toklen in 'startquotesequence'" + error "tomlish unexpected token length $toklen in 'startquotesequence'" } } _start_squote_sequence { @@ -3952,7 +4629,7 @@ namespace eval tomlish::parse { return 1 } default { - error "unexpected _start_squote_sequence length $toklen" + error "tomlish unexpected _start_squote_sequence length $toklen" } } } @@ -3963,7 +4640,7 @@ namespace eval tomlish::parse { if {$had_slash} { append tok "\\" $c } else { - #unescaped quote always terminates a string? + #unescaped quote always terminates a string? set_token_waiting type endquote value "\"" complete 1 startindex $cindex return 1 } @@ -3974,9 +4651,9 @@ namespace eval tomlish::parse { append tok "\\" $c } else { #incr i -1 - + if {$multi_dquote eq "\"\""} { - set_token_waiting type endmultiquote value "\"\"\"" complete 1 startindex [expr {$cindex -2}] + set_token_waiting type endmultiquote value "\"\"\"" complete 1 startindex [expr {$cindex -2}] set multi_dquote "" return 1 } else { @@ -4024,9 +4701,13 @@ namespace eval tomlish::parse { # return 1 #} } + table-space - itable-space { + incr i -1 + return 1 + } default { set_token_waiting type startquote value "\"" complete 1 startindex $cindex - return 1 + return 1 } } } @@ -4034,7 +4715,7 @@ namespace eval tomlish::parse { if {$had_slash} {append tok "\\"} append tok $c } - quotedkey - itablequotedkey { + XXXdquotedkey - XXXitablequotedkey { if {$had_slash} { append tok "\\" append tok $c @@ -4043,7 +4724,17 @@ namespace eval tomlish::parse { return 1 } } - squotedkey - itablesquotedkey { + dquotedkey { + ### + if {$had_slash} { + append tok "\\" + append tok $c + } else { + #set_token_waiting type endsquote value "'" complete 1 + return 1 + } + } + squotedkey { append tok $c } tablename - tablearrayname { @@ -4055,7 +4746,7 @@ namespace eval tomlish::parse { return 1 } default { - error "got quote during tokenType '$tokenType' [tomlish::parse::report_line]" + error "tomlish got quote during tokenType '$tokenType' [tomlish::parse::report_line]" } } } else { @@ -4070,12 +4761,17 @@ namespace eval tomlish::parse { set_tokenType "startquotesequence" ;#one or more quotes in a row - either startquote or multistartquote set tok $c } + itable-keyval-value-expected { + #JMN 2025 - review + set_tokenType "startquotesequence" ;#one or more quotes in a row - either startquote or multistartquote + set tok $c + } multistring-space { #TODO - had_slash!!! #REVIEW if {$had_slash} { set_tokenType "stringpart" - set tok "\\\"" + set tok "\\\"" set multi_dquote "" } else { if {$multi_dquote eq "\"\""} { @@ -4095,18 +4791,21 @@ namespace eval tomlish::parse { set_tokenType "literalpart" set tok "\"" } - table-space { + XXXtable-space { set_tokenType "startquote" set tok $c return 1 } - itable-space { + XXXitable-space { set_tokenType "startquote" set tok $c - return 1 + } + table-space - itable-space { + set_tokenType "dquotedkey" + set tok "" } tablename-state { - set_tokenType tablename + set_tokenType tablename set tok $c } tablearrayname-state { @@ -4114,11 +4813,15 @@ namespace eval tomlish::parse { set tok $c } dottedkey-space { - set_tokenType dquote_seq_begin - set tok $c + set_tokenType dquotedkey + set tok "" + + #only if complex keys become a thing + #set_tokenType dquote_seq_begin + #set tok $c } default { - error "Unexpected quote during state '$state' [tomlish::parse::report_line]" + error "tomlish Unexpected quote during state '$state' [tomlish::parse::report_line]" } } } @@ -4128,7 +4831,7 @@ namespace eval tomlish::parse { set multi_dquote "" ;#!! set had_slash $slash_active set slash_active 0 - + if {[tcl::string::length $tokenType]} { switch -exact -- $tokenType { squote_seq { @@ -4147,13 +4850,13 @@ namespace eval tomlish::parse { #assertion had_slash 0, multi_dquote "" append tok $c } - string - comment - quotedkey - itablequotedkey { + string - comment - dquotedkey - itablequotedkey { #for these tokenTypes an = is just data. - if {$had_slash} {append tok "\\"} + if {$had_slash} {append tok "\\"} append tok $c } stringpart { - if {$had_slash} {append tok "\\"} + if {$had_slash} {append tok "\\"} append tok $dquotes$c } whitespace { @@ -4172,14 +4875,14 @@ namespace eval tomlish::parse { return 1 } starttablename - starttablearrayname { - error "Character '=' is invalid first character for $tokenType. [tomlish::parse::report_line]" + error "tomlish Character '=' is invalid first character for $tokenType. [tomlish::parse::report_line]" } tablename - tablearrayname { #invalid in bare name - but valid in quoted parts - leave for tablename parser to sort out append tok $c } default { - error "unexpected = character during tokentype $tokenType. case not implemented. [tomlish::parse::report_line]" + error "tomlish unexpected = character during tokentype $tokenType. case not implemented. [tomlish::parse::report_line]" } } } else { @@ -4197,7 +4900,7 @@ namespace eval tomlish::parse { set tok "=" } dottedkey-space { - set_tokenType "equal" + set_tokenType "equal" set tok "=" return 1 } @@ -4218,6 +4921,13 @@ namespace eval tomlish::parse { set slash_active 0 if {[tcl::string::length $tokenType]} { switch -exact -- $tokenType { + newline { + #we have received a double cr + ::tomlish::log::warn "double cr - will generate cr token. needs testing" + set_tokenType "cr" ;#lone cr token will generally raise an error - but let state machine handle it + incr i -1 + return 1 + } squote_seq { incr i -1 return 1 @@ -4234,23 +4944,37 @@ namespace eval tomlish::parse { append tok $c } literalpart { + #part of MLL string (multi-line literal string) #we need to split out crlf as a separate NEWLINE to be consistent - ::tomlish::log::warning "literalpart ended by cr - needs testing" - #return literalpart temporarily - allow cr to be reprocessed from multiliteral-space + ::tomlish::log::warn "literalpart ended by cr - needs testing" + #return literalpart temporarily - allow cr to be reprocessed from multiliteral-space incr i -1 return 1 } stringpart { - append tok $dquotes$c + #stringpart is a part of MLB string (multi-line basic string) + #throw back the cr - if followed by lf it will become a {NEWLINE crlf} entry within the MULTISTRING list (e.g between STRINGPART entries) + incr i -1 + return 1 } starttablename - starttablearrayname { - error "Character is invalid first character for $tokenType. [tomlish::parse::report_line]" + error "tomlish Character is invalid first character for $tokenType. [tomlish::parse::report_line]" } tablename - tablearrayname { #could in theory be valid in quoted part of name #review - might be better just to disallow here append tok $c } + whitespace { + #it should technically be part of whitespace if not followed by lf + #but outside of values we are also free to map it to be another NEWLINE instead? REVIEW + incr i -1 + return 1 + } + untyped_value { + incr i -1 + return 1 + } default { #!todo - error out if cr inappropriate for tokenType append tok $c @@ -4264,13 +4988,19 @@ namespace eval tomlish::parse { } } lf { - # \n newline + # \n newline set dquotes $multi_dquote set multi_dquote "" ;#!! - set had_slash $slash_active + set had_slash $slash_active set slash_active 0 if {[tcl::string::length $tokenType]} { switch -exact -- $tokenType { + newline { + #review + #this lf is the trailing part of a crlf + append tok lf ;#assert we should now have tok "crlf" - as a previous cr is the only way to have an incomplete newline tok + return 1 + } squote_seq { incr i -1 return 1 @@ -4290,17 +5020,11 @@ namespace eval tomlish::parse { return 1 } literalpart { - #we allow newlines - but store them within the multiliteral as their own element + #we allow newlines - but store them within the multiliteral as their own element #This is a legitimate end to the literalpart - but not the whole multiliteral set_token_waiting type newline value lf complete 1 startindex $cindex return 1 } - newline { - #review - #this lf is the trailing part of a crlf - append tok lf ;#assert we should now have tok "crlf" - as a previous cr is the only way to have an incomplete newline tok - return 1 - } stringpart { if {$dquotes ne ""} { append tok $dquotes @@ -4308,7 +5032,7 @@ namespace eval tomlish::parse { return 1 } else { if {$had_slash} { - #emit the stringpart (return 1), queue the continuation, go back 1 to reprocess the lf (incr i -1) + #emit the stringpart (return 1), queue the continuation, go back 1 to reprocess the lf (incr i -1) set_token_waiting type continuation value \\ complete 1 startindex [expr {$cindex-1}] incr i -1 return 1 @@ -4319,15 +5043,15 @@ namespace eval tomlish::parse { } } starttablename - tablename - tablearrayname - starttablearrayname { - error "Character is invalid in $tokenType. [tomlish::parse::report_line]" + error "tomlish Character is invalid in $tokenType. [tomlish::parse::report_line]" } default { #newline ends all other tokens. #note for string: we don't add (raw unescaped) newline to simple string. (must use multi-string for this) #note for whitespace: # we will use the convention that \n terminates the current whitespace even if whitespace follows - # ie whitespace is split into separate whitespace tokens at each newline - + # ie whitespace is split into separate whitespace tokens at each newline + #puts "-------------- newline lf during tokenType $tokenType" set_token_waiting type newline value lf complete 1 startindex $cindex return 1 @@ -4349,14 +5073,14 @@ namespace eval tomlish::parse { incr i -1 return 1 } - set_tokenType "newline" - set tok lf + set_tokenType "newline" + set tok lf return 1 } } multiliteral-space { #assert had_slash 0, multi_dquote "" - set_tokenType "newline" + set_tokenType "newline" set tok "lf" return 1 } @@ -4382,7 +5106,7 @@ namespace eval tomlish::parse { } , { set dquotes $multi_dquote - set multi_dquote "" + set multi_dquote "" set had_slash $slash_active set slash_active 0 if {[tcl::string::length $tokenType]} { @@ -4390,7 +5114,7 @@ namespace eval tomlish::parse { newline { #incomplete newline set_tokenType "cr" - incr i -1 + incr i -1 return 1 } squote_seq { @@ -4406,19 +5130,19 @@ namespace eval tomlish::parse { return 1 } comment - tablename - tablearrayname { - if {$had_slash} {append tok "\\"} + if {$had_slash} {append tok "\\"} append tok , } - string - quotedkey - itablequotedkey { - if {$had_slash} {append tok "\\"} + string - dquotedkey - itablequotedkey { + if {$had_slash} {append tok "\\"} append tok $c } stringpart { #stringpart can have up to 2 quotes too - if {$had_slash} {append tok "\\"} + if {$had_slash} {append tok "\\"} append tok $dquotes$c } - literal - literalpart - squotedkey - itablesquotedkey { + literal - literalpart - squotedkey { #assert had_slash always 0, multi_dquote "" append tok $c } @@ -4434,7 +5158,7 @@ namespace eval tomlish::parse { } default { set_token_waiting type comma value "," complete 1 startindex $cindex - if {$had_slash} {append tok "\\"} + if {$had_slash} {append tok "\\"} return 1 } } @@ -4443,12 +5167,12 @@ namespace eval tomlish::parse { multistring-space { set_tokenType "stringpart" set tok "" - if {$had_slash} {append tok "\\"} + if {$had_slash} {append tok "\\"} append tok "$dquotes," } multiliteral-space { #assert had_slash 0, multi_dquote "" - set_tokenType "literalpart" + set_tokenType "literalpart" set tok "," } default { @@ -4462,14 +5186,14 @@ namespace eval tomlish::parse { . { set dquotes $multi_dquote set multi_dquote "" ;#!! - set had_slash $slash_active + set had_slash $slash_active set slash_active 0 if {[tcl::string::length $tokenType]} { switch -exact -- $tokenType { newline { #incomplete newline set_tokenType "cr" - incr i -1 + incr i -1 return 1 } squote_seq { @@ -4485,18 +5209,18 @@ namespace eval tomlish::parse { return 1 } comment - untyped_value { - if {$had_slash} {append tok "\\"} + if {$had_slash} {append tok "\\"} append tok $c } - string - quotedkey - itablequotedkey { - if {$had_slash} {append tok "\\"} + string - dquotedkey - itablequotedkey { + if {$had_slash} {append tok "\\"} append tok $c } stringpart { - if {$had_slash} {append tok "\\"} + if {$had_slash} {append tok "\\"} append tok $dquotes$c } - literal - literalpart - squotedkey - itablesquotedkey { + literal - literalpart - squotedkey { #assert had_slash always 0, multi_dquote "" append tok $c } @@ -4510,18 +5234,22 @@ namespace eval tomlish::parse { incr i -$backchars return 1 } - dottedkey-space { + xxxdottedkey-space { + incr i -1 + return 1 + } + dottedkey-space-tail { incr i -1 return 1 } default { - error "Received period during tokenType 'whitespace' [tomlish::parse::report_line]" + error "tomlish Received period during tokenType 'whitespace' [tomlish::parse::report_line]" } } } starttablename - starttablearrayname { #This would correspond to an empty table name - error "Character '.' is not allowed as first character ($tokenType). [tomlish::parse::report_line]" + error "tomlish Character '.' is not allowed as first character ($tokenType). [tomlish::parse::report_line]" } tablename - tablearrayname { #subtable - split later - review @@ -4535,7 +5263,7 @@ namespace eval tomlish::parse { return 1 } default { - error "Received period during tokenType '$tokenType' [tomlish::parse::report_line]" + error "tomlish Received period during tokenType '$tokenType' [tomlish::parse::report_line]" #set_token_waiting type period value . complete 1 #return 1 } @@ -4545,14 +5273,20 @@ namespace eval tomlish::parse { multistring-space { set_tokenType "stringpart" set tok "" - if {$had_slash} {append tok "\\"} + if {$had_slash} {append tok "\\"} append tok "$dquotes." } multiliteral-space { set_tokenType "literalpart" set tok "." } - dottedkey-space { + XXXdottedkey-space { + ### obs? + set_tokenType "dotsep" + set tok "." + return 1 + } + dottedkey-space-tail { ### set_tokenType "dotsep" set tok "." @@ -4576,7 +5310,7 @@ namespace eval tomlish::parse { newline { #incomplete newline set_tokenType "cr" - incr i -1 + incr i -1 return 1 } squote_seq { @@ -4610,7 +5344,7 @@ namespace eval tomlish::parse { } append tok $dquotes$c } - string - quotedkey - itablequotedkey { + string - dquotedkey - itablequotedkey { if {$had_slash} { append tok "\\" } append tok $c } @@ -4622,13 +5356,13 @@ namespace eval tomlish::parse { incr i -2 return 1 } else { - #split into STRINGPART aaa WS " " + #split into STRINGPART aaa WS " " append tok $dquotes incr i -1 return 1 } } - literal - literalpart - squotedkey - itablesquotedkey { + literal - literalpart - squotedkey { append tok $c } whitespace { @@ -4656,11 +5390,11 @@ namespace eval tomlish::parse { append tok $c } default { - error "Received whitespace space during tokenType '$tokenType' [tomlish::parse::report_line]" + error "tomlish Received whitespace space during tokenType '$tokenType' [tomlish::parse::report_line]" } } } else { - set had_slash $slash_active + set had_slash $slash_active set slash_active 0 switch -exact -- $state { tablename-state { @@ -4700,7 +5434,7 @@ namespace eval tomlish::parse { } default { if {$had_slash} { - error "unexpected backslash [tomlish::parse::report_line]" + error "tomlish unexpected backslash [tomlish::parse::report_line]" } set_tokenType "whitespace" append tok $c @@ -4719,7 +5453,7 @@ namespace eval tomlish::parse { newline { #incomplete newline set_tokenType "cr" - incr i -1 + incr i -1 return 1 } startquotesequence { @@ -4742,10 +5476,11 @@ namespace eval tomlish::parse { incr i -1 return 1 } - quotedkey - itablequotedkey - squotedkey - itablesquotedkey { + squotedkey { append tok $c } - string - comment - whitespace { + dquotedkey - string - comment - whitespace { + #REVIEW append tok $c } stringpart { @@ -4756,7 +5491,7 @@ namespace eval tomlish::parse { incr i -2 return 1 } else { - #split into STRINGPART aaa WS " " + #split into STRINGPART aaa WS " " append tok $dquotes incr i -1 return 1 @@ -4775,11 +5510,11 @@ namespace eval tomlish::parse { append tok $c } default { - error "Received whitespace tab during tokenType '$tokenType' [tomlish::parse::report_line]" + error "tomlish Received whitespace tab during tokenType '$tokenType' [tomlish::parse::report_line]" } } } else { - set had_slash $slash_active + set had_slash $slash_active if {$slash_active} { set slash_active 0 } @@ -4787,11 +5522,11 @@ namespace eval tomlish::parse { tablename-state { #tablename can have leading,trailing and interspersed whitespace! #These will not be treated as whitespace tokens, instead forming part of the name. - set_tokenType tablename + set_tokenType tablename set tok $c } tablearrayname-state { - set_tokenType tablearrayname + set_tokenType tablearrayname set tok $c } multistring-space { @@ -4841,7 +5576,7 @@ namespace eval tomlish::parse { return 1 } } - } else { + } else { switch -exact -- $state { multiliteral-space { set_tokenType "literalpart" @@ -4866,7 +5601,7 @@ namespace eval tomlish::parse { newline { #incomplete newline set_tokenType "cr" - incr i -1 + incr i -1 return 1 } squote_seq { @@ -4901,7 +5636,7 @@ namespace eval tomlish::parse { if {[tomlish::utils::is_barekey $c]} { append tok $c } else { - error "Unexpected character '$c' during bare key. Only \[a-zA-Z0-9_-\] allowed. [tomlish::parse::report_line]" + error "tomlish Unexpected character '$c' during bare key. Only \[a-zA-Z0-9_-\] and a selection of letter-like chars allowed. (see tomlish::utils::is_barekey) [tomlish::parse::report_line]" } } starttablename - starttablearrayname { @@ -4927,16 +5662,16 @@ namespace eval tomlish::parse { set_tokenType "barekey" append tok $c } else { - error "Unexpected char $c ([tomlish::utils::nonprintable_to_slashu $c]) whilst no active tokenType. [tomlish::parse::report_line]" + error "tomlish Unexpected char $c ([tomlish::utils::nonprintable_to_slashu $c]) whilst no active tokenType. [tomlish::parse::report_line]" } } - curly-syntax { + XXXcurly-syntax { puts stderr "curly-syntax - review" if {[tomlish::utils::is_barekey $c]} { set_tokenType "barekey" append tok $c } else { - error "Unexpected char $c ([tomlish::utils::nonprintable_to_slashu $c]) whilst no active tokenType. [tomlish::parse::report_line]" + error "tomlish Unexpected char $c ([tomlish::utils::nonprintable_to_slashu $c]) whilst no active tokenType. [tomlish::parse::report_line]" } } multistring-space { @@ -4961,11 +5696,13 @@ namespace eval tomlish::parse { set tok $c } dottedkey-space { - set_tokenType barekey + set_tokenType barekey set tok $c } default { - tomlish::log::debug "- tokloop char '$c' setting to untyped_value while state:$state" + #todo - something like ansistring VIEW to show control chars? + set cshow [string map [list \t tab \v vt] $c] + tomlish::log::debug "- tokloop char '$cshow' setting to untyped_value while state:$state [tomlish::parse::report_line]" set_tokenType "untyped_value" set tok $c } @@ -4973,9 +5710,9 @@ namespace eval tomlish::parse { } } } - + } - + #run out of characters (eof) if {[tcl::string::length $tokenType]} { #check for invalid ending tokens @@ -4988,7 +5725,7 @@ namespace eval tomlish::parse { if {$toklen == 1} { #invalid #eof with open string - error "eof reached without closing quote for string. [tomlish::parse::report_line]" + error "tomlish eof reached without closing quote for string. [tomlish::parse::report_line]" } elseif {$toklen == 2} { #valid #we ended in a double quote, not actually a startquoteseqence - effectively an empty string @@ -5002,18 +5739,33 @@ namespace eval tomlish::parse { set toklen [tcl::string::length $tok] switch -- $toklen { 1 { - #invalid eof with open literal - error "eof reached without closing single quote for string literal. [tomlish::parse::report_line]" + #invalid eof with open literal + error "tomlish eof reached without closing single quote for string literal. [tomlish::parse::report_line]" } 2 { #review - set_token_waiting type endsquote value "'" complete 1 startindex [expr {$cindex -1}] + set_token_waiting type endsquote value "'" complete 1 startindex [expr {$cindex -1}] set_tokenType "literal" set tok "" return 1 } } } + newline { + #The only newline token that has still not been returned should have a tok value of "cr" + puts "tomlish eof reached - with incomplete newline token '$tok'" + if {$tok eq "cr"} { + #we convert lone cr to it's own "cr" token elsewhere in the document to allow statemachine to handle it. + #(which it should generally do by not handling it ie raising an error - or emitting an ERROR list in the tomlish) + #if trailing char is a lone cr - we should encode it the same way as elsewhere that is outside of values + # ie as it's own token. + switch_tokenType "cr" + return 1 + } else { + #should be unreachable + error "tomlish eof reached - with invalid newline token. value: $tok" + } + } } set_token_waiting type eof value eof complete 1 startindex $i ;#review return 1 @@ -5029,19 +5781,81 @@ namespace eval tomlish::parse { #[list_end] [comment {--- end definitions namespace tomlish::parse ---}] } +namespace eval tomlish::dict { + namespace export {[a-z]*}; # Convention: export all lowercase + namespace path [namespace parent] + + proc is_tomlish_typeval {d} { + #designed to detect {type value } e.g {type INT value 3}, {type STRING value "blah etc"} + #as a sanity check we need to avoid mistaking user data that happens to match same form + #consider x.y={type="spud",value="blah"} + #The value of type will itself have already been converted to {type STRING value spud} ie never a single element. + #check the length of the type as a quick way to see it's a tag - not something else masqerading. + expr {[dict size $d] == 2 && [dict exists $d type] && [dict exists $d value] && [llength [dict get $d type]] == 1} + } + proc is_tomlish_typeval2 {d} { + upvar ::tomlish::tags tags + expr {[lindex $d 0] eq "type" && [lindex $d 1] in $tags} + } + proc last_tomltype_posn {d} { + set last_simple -1 + set dictposn [expr {[dict size $d] -1}] + foreach k [lreverse [dict keys $d]] { + set dval [dict get $d $k] + if {[is_tomlish_typeval $dval]} { + set last_simple $dictposn + break + } + incr dictposn -1 + } + return $last_simple + } + + + #review + proc name_from_tablestack {tablestack} { + set name "" + foreach tinfo [lrange $tablestack 1 end] { + lassign $tinfo type namepart + switch -- $type { + T { + if {$name eq ""} { + append name $namepart + } else { + append name .$namepart + } + } + I { + if {$name eq ""} { + append name $namepart + } else { + append name .$namepart + } + } + default { + #end at first break in the leading sequence of T & I tablenames + break + } + } + } + return $name + } + +} + tcl::namespace::eval tomlish::app { variable applist [list encoder decoder test] #*** !doctools #[subsection {Namespace tomlish::app}] - #[para] + #[para] #[list_begin definitions] proc decoder {args} { #*** !doctools #[call app::[fun decoder] [arg args]] #[para] read toml on stdin until EOF - #[para] on error - returns non-zero exit code and writes error on stderr + #[para] on error - returns non-zero exit code and writes error on stderr #[para] on success - returns zero exit code and writes JSON encoding of the data on stdout #[para] This decoder is intended to be compatible with toml-test @@ -5051,7 +5865,7 @@ tcl::namespace::eval tomlish::app { #Just slurp it all - presumably we are not handling massive amounts of data on stdin. # - even if the input is large, we probably don't gain much (aside from possible memory savings?) by attempting to process input as it arrives. if {[catch { - set toml [read stdin] + set toml [read stdin] }]} { exit 2 ;#read error } @@ -5076,7 +5890,7 @@ tcl::namespace::eval tomlish::app { set opts [dict merge [dict create] $args] fconfigure stdin -translation binary if {[catch { - set json [read stdin] + set json [read stdin] }]} { exit 2 ;#read error } @@ -5087,7 +5901,7 @@ tcl::namespace::eval tomlish::app { exit 1 } puts -nonewline stdout $toml - exit 0 + exit 0 } proc test {args} { @@ -5111,7 +5925,7 @@ proc ::tomlish::appnames {} { lappend applist [namespace tail $cmd] } return $applist -} +} # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ @@ -5122,14 +5936,14 @@ namespace eval tomlish::lib { namespace path [namespace parent] #*** !doctools #[subsection {Namespace tomlish::lib}] - #[para] Secondary functions that are part of the API + #[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 + # #[para]Description of utility1 + # return 1 #} @@ -5140,46 +5954,46 @@ namespace eval tomlish::lib { # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ if {$argc > 0} { - puts stderr "argc: $argc args: $argv" - - if {($argc == 1)} { - if {[tcl::string::tolower $argv] in {help -help h -h}} { - puts stdout "Usage: -app where appname one of:[tomlish::appnames]" - exit 0 - } else { - puts stderr "Argument '$argv' not understood. Try -help" - exit 1 - } - } - set opts [dict create] - set opts [dict merge $opts $argv] - - set opts_understood [list -app ] - if {"-app" in [dict keys $opts]} { - #Don't vet the remaining opts - as they are interpreted by each app - } else { - foreach key [dict keys $opts] { - if {$key ni $opts_understood} { - puts stderr "Option '$key' not understood" - exit 1 - } - } - } - if {[dict exists $opts -app]} { - set app [dict get $opts -app] - if {$app ni [tomlish::appnames]} { - puts stderr "app '[dict get $opts -app]' not found" - exit 1 - } - tomlish::app::$app {*}$opts - } + puts stderr "argc: $argc args: $argv" + + if {($argc == 1)} { + if {[tcl::string::tolower $argv] in {help -help h -h}} { + puts stdout "Usage: -app where appname one of:[tomlish::appnames]" + exit 0 + } else { + puts stderr "Argument '$argv' not understood. Try -help" + exit 1 + } + } + set opts [dict create] + set opts [dict merge $opts $argv] + + set opts_understood [list -app ] + if {"-app" in [dict keys $opts]} { + #Don't vet the remaining opts - as they are interpreted by each app + } else { + foreach key [dict keys $opts] { + if {$key ni $opts_understood} { + puts stderr "Option '$key' not understood" + exit 1 + } + } + } + if {[dict exists $opts -app]} { + set app [dict get $opts -app] + if {$app ni [tomlish::appnames]} { + puts stderr "app '[dict get $opts -app]' not found" + exit 1 + } + tomlish::app::$app {*}$opts + } } -## Ready +## Ready package provide tomlish [namespace eval tomlish { variable pkg tomlish variable version - set version 1.1.1 + set version 1.1.3 }] return diff --git a/src/vfs/_vfscommon.vfs/modules/tomlish-1.1.4.tm b/src/vfs/_vfscommon.vfs/modules/tomlish-1.1.4.tm new file mode 100644 index 00000000..7a6d5205 --- /dev/null +++ b/src/vfs/_vfscommon.vfs/modules/tomlish-1.1.4.tm @@ -0,0 +1,6172 @@ +# -*- 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 tomlish 1.1.4 +# Meta platform tcl +# Meta license +# @@ Meta End + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# doctools header +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[manpage_begin tomlish_module_tomlish 0 1.1.4] +#[copyright "2024"] +#[titledesc {tomlish toml parser}] [comment {-- Name section and table of contents description --}] +#[moddesc {tomlish}] [comment {-- Description at end of page heading --}] +#[require tomlish] +#[keywords module parsing toml configuration] +#[description] +#[para] tomlish is an intermediate representation of toml data in a tree structure (tagged lists representing type information) +#[para] The design goals are for tomlish to be whitespace and comment preserving ie byte-for byte preservation during roundtrips from toml to tomlish and back to toml +#[para] The tomlish representation can then be converted to a Tcl dict structure or to other formats such as json, +#[para] although these other formats are generally unlikely to retain whitespace or comments +#[para] The other formats also won't preserve roundtripability e.g \t and a literal tab coming from a toml file will be indistinguishable. +#[para] A further goal is to allow at least a useful subset of in-place editing operations which also preserve whitespace and comments. +#[para] e.g leaf key value editing, and table reordering/sorting, key-renaming at any level, key insertions/deletions +#[para] The API for editing (tomldoc object?) may require explicit setting of type if accessing an existing key +#[para] e.g setting a key that already exists and is a different type (especially if nested structure such as a table or array) +#[para] will need a -type option (-force ?) to force overriding with another type such as an int. + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section Overview] +#[para] overview of tomlish +#[subsection Concepts] +#[para] - + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[subsection dependencies] +#[para] packages used by tomlish +#[list_begin itemized] + +package require Tcl 8.6- +package require struct::stack +package require logger + +#*** !doctools +#[item] [package {Tcl 8.6-}] +#[item] [package {struct::stack}] + +#limit ourselves to clear, destroy, peek, pop, push, rotate, or size (e.g v 1.3 does not implement 'get') + + +#*** !doctools +#[list_end] + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section API] + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# Base namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +namespace eval tomlish { + namespace export {[a-z]*}; # Convention: export all lowercase + variable types + + #IDEAS: + # since get_toml produces tomlish with whitespace/comments intact: + # tomldoc object - allow (at least basic?) editing of toml whilst preserving comments & whitespace + # - setKey (set leaf only to value) how to specify type? -type option? - whole array vs index into arrays and further nested objects? - option for raw toml additions? + # - separate addKey?? + # - deleteKey (delete leaf) + # - deleteTable (delete table - if only has leaves? - option to delete with child tables?) + # - set/add Table? - position in doc based on existing tables/subtables? + + #The tomlish intermediate representation allows things such as sorting the toml document by table name or other re-ordering of tables - + # because the tables include subkeys, comments and newlines within their structure - those elements all come along with it nicely during reordering. + #The same goes for the first newline following a keyval e.g x=1 \ny=2\n\n + #The newline is part of the keyval structure so makes reordering easier + #example from_toml "a=1\nb=2\n\n\n" + # 0 = TOMLISH + # 1 = KEY a = {INT 1} {NEWLINE lf} + # 2 = NEWLINE lf + # 3 = KEY b = {INT 2} {NEWLINE lf} + # 4 = NEWLINE lf + # 5 = NEWLINE lf + + + #ARRAY is analogous to a Tcl list + #TABLE is analogous to a Tcl dict + #WS = inline whitespace + #KEY = bare key and value + #DQKEY = double quoted key and value + #SQKEY = single quoted key and value + #ITABLE = inline table (*can* be anonymous table) + # inline table values immediately create a table with the opening brace + # inline tables are fully defined between their braces, as are dotted-key subtables defined within + # No additional subtables or arrays of tables may be defined within an inline table after the ending brace - they must be entirely self-contained + + set tags [list TOMLISH ARRAY TABLE ITABLE TABLEARRAY WS NEWLINE COMMENT DOTTEDKEY KEY DQKEY SQKEY STRING STRINGPART MULTISTRING LITERAL LITERALPART MULTILITERAL INT FLOAT BOOL DATETIME] + #removed - ANONTABLE + #tomlish v1.0 should accept arbitrary 64-bit signed ints (from -2^63 to 2^63-1) + #we will restrict to this range for compatibility for now - although Tcl can handle larger (arbitrarily so?) + set min_int -9223372036854775808 ;#-2^63 + set max_int +9223372036854775807 ;#2^63-1 + + proc Dolog {lvl txt} { + #return "$lvl -- $txt" + set msg "[clock format [clock seconds] -format "%Y-%m-%dT%H:%M:%S"] tomlish '$txt'" + puts stderr $msg + } + logger::initNamespace ::tomlish + foreach lvl [logger::levels] { + interp alias {} tomlish_log_$lvl {} ::tomlish::Dolog $lvl + log::logproc $lvl tomlish_log_$lvl + } + + #*** !doctools + #[subsection {Namespace tomlish}] + #[para] Core API functions for tomlish + #[list_begin definitions] + + proc tags {} { + return $::tomlish::tags + } + + #helper function for to_dict + proc _get_keyval_value {keyval_element} { + log::notice ">>> _get_keyval_value from '$keyval_element'<<<" + set found_value 0 + #find the value + # 3 is the earliest index at which the value could occur (depending on whitespace) + set found_sub [list] + if {[lindex $keyval_element 2] ne "="} { + error "tomlish _get_keyval_value keyval_element doesn't seem to be a properly structured { = } list" + } + + #review + if {[uplevel 1 [list info exists tablenames_seen]]} { + upvar tablenames_seen tablenames_seen + } else { + set tablenames_seen [list] ;#list of lists + } + if {[uplevel 1 [list info exists tablenames_closed]]} { + upvar tablenames_closed tablenames_closed + } else { + set tablenames_closed [list] ;#list of lists + } + + foreach sub [lrange $keyval_element 2 end] { + #note that a barekey/dquotedkey won't occur directly inside a barekey/dquotedkey + switch -exact -- [lindex $sub 0] { + STRING - LITERAL - MULTISTRING - MULTILITERAL - INT - FLOAT - BOOL - DATETIME - TABLE - ARRAY - ITABLE { + set type [lindex $sub 0] + set value [lindex $sub 1] + set found_sub $sub + incr found_value 1 + } + default {} + } + } + if {!$found_value} { + error "tomlish Failed to find value element in KEY. '$keyval_element'" + } + if {$found_value > 1} { + error "tomlish Found multiple value elements in KEY, expected exactly one. '$keyval_element'" + } + + switch -exact -- $type { + INT - FLOAT - BOOL - DATETIME { + #simple (non-container, no-substitution) datatype + set result [list type $type value $value] + } + STRING - STRINGPART { + set result [list type $type value [::tomlish::utils::unescape_string $value]] + } + LITERAL - LITERALPART { + #REVIEW + set result [list type $type value $value] + } + TABLE { + #invalid? + error "tomlish _get_keyval_value invalid to have type TABLE on rhs of =" + } + ITABLE { + #This one should not be returned as a type value structure! + # + set result [::tomlish::to_dict [list $found_sub]] + } + ARRAY { + #we need to recurse to get the corresponding dict for the contained item(s) + #pass in the whole $found_sub - not just the $value! + set prev_tablenames_seen $tablenames_seen + set prev_tablenames_closed $tablenames_closed + set tablenames_seen [list] + set tablenames_closed [list] + set result [list type $type value [::tomlish::to_dict [list $found_sub]]] + set tablenames_seen $prev_tablenames_seen + set tablenames_closed $prev_tablenames_closed + } + MULTISTRING - MULTILITERAL { + #review - mapping these to STRING might make some conversions harder? + #if we keep the MULTI - we know we have to look for newlines for example when converting to json + #without specific types we'd have to check every STRING - and lose info about how best to map chars within it + set result [list type $type value [::tomlish::to_dict [list $found_sub]]] + } + default { + error "tomlish Unexpected value type '$type' found in keyval '$keyval_element'" + } + } + return $result + } + + proc _get_dottedkey_info {dottedkeyrecord} { + set key_hierarchy [list] + set key_hierarchy_raw [list] + if {[lindex $dottedkeyrecord 0] ne "DOTTEDKEY"} { + error "tomlish _get_dottedkey_info error. Supplied list doesn't appear to be a DOTTEDKEY (tag: [lindex $dottedkeyrecord 0])" + } + set compoundkeylist [lindex $dottedkeyrecord 1] + set expect_sep 0 + foreach part $compoundkeylist { + set parttag [lindex $part 0] + if {$parttag eq "WS"} { + continue + } + if {$expect_sep} { + if {$parttag ne "DOTSEP"} { + error "DOTTEDKEY missing dot separator between parts. '$dottedkeyrecord'" + } + set expect_sep 0 + } else { + set val [lindex $part 1] + switch -exact -- $parttag { + KEY { + lappend key_hierarchy $val + lappend key_hierarchy_raw $val + } + DQKEY { + lappend key_hierarchy [::tomlish::utils::unescape_string $val] + lappend key_hierarchy_raw \"$val\" + } + SQKEY { + lappend key_hierarchy $val + lappend key_hierarchy_raw "'$val'" + } + default { + error "DOTTED key unexpected part '$parttag' - ensure dot separator is between key parts. '$item'" + } + } + set expect_sep 1 + } + } + return [dict create keys $key_hierarchy keys_raw $key_hierarchy_raw] + } + + + + #to_dict is a *basic* programmatic datastructure for accessing the data. + # produce a dictionary of keys and values from a tomlish tagged list. + # to_dict is primarily for reading toml data. + #Extraneous (not within quoted sections) whitespace and comments are not preserved in this structure, + # so a roundtrip from toml to this datastructure and back to toml will lose whitespace formatting and comments. + # creating/changing toml values can be done directly on a tomlish list if preserving (or adding) formatting/comments is desired. + #A separate package 'tomlish::object' may be needed to allow easier programmatic creating/updating/deleting of data elements whilst preserving (or adding or selectively deleting/editing) such formatting. + # + + #within an ARRAY, we store a list of items such as plain dicts (possibly empty) and {type value } for simple types + #(ARRAYS can be mixed type) + #This means our dict structure should have only ARRAY and simple types which need to be in {type value } form + #A dict within an array encodeded as a type ITABLE value should also parse - but is the unpreferred form - REVIEW test? + + #Namespacing? + #ie note the difference: + #[Data] + #temp = { cpu = 79.5, case = 72.0} + # versus + #[Data] + #temps = [{cpu = 79.5, case = 72.0}] + proc to_dict {tomlish} { + + #keep track of which tablenames have already been directly defined, + # so we can raise an error to satisfy the toml rule: 'You cannot define any key or table more than once. Doing so is invalid' + #Note that [a] and then [a.b] is ok if there are no subkey conflicts - so we are only tracking complete tablenames here. + #we don't error out just because a previous tablename segment has already appeared. + ##variable tablenames_seen [list] + if {[uplevel 1 [list info exists tablenames_seen]]} { + upvar tablenames_seen tablenames_seen + } else { + set tablenames_seen [list] ;#list of lists + } + if {[uplevel 1 [list info exists tablenames_closed]]} { + upvar tablenames_closed tablenames_closed + } else { + set tablenames_closed [list] ;#list of lists + } + + log::info "---> to_dict processing '$tomlish'<<<" + set items $tomlish + + foreach lst $items { + if {[lindex $lst 0] ni $::tomlish::tags} { + error "supplied string does not appear to be toml parsed into a tomlish tagged list. Run tomlish::decode::toml on the raw toml data to produce a tomlish list" + } + } + + if {[lindex $tomlish 0] eq "TOMLISH"} { + #ignore TOMLISH tag at beginning + set items [lrange $tomlish 1 end] + } + + set datastructure [dict create] + foreach item $items { + set tag [lindex $item 0] + #puts "...> item:'$item' tag:'$tag'" + switch -exact -- $tag { + KEY - DQKEY - SQKEY { + log::debug "---> to_dict item: processing $tag: $item" + set key [lindex $item 1] + if {$tag eq "DQKEY"} { + set key [::tomlish::utils::unescape_string $key] + } + #!todo - normalize key. (may be quoted/doublequoted) + + if {[dict exists $datastructure $key]} { + error "Duplicate key '$key'. The key already exists at this level in the toml data. The toml data is not valid." + } + + #lassign [_get_keyval_value $item] type val + set keyval_dict [_get_keyval_value $item] + dict set datastructure $key $keyval_dict + } + DOTTEDKEY { + log::debug "---> to_dict item processing $tag: $item" + set dkey_info [_get_dottedkey_info $item] + set dotted_key_hierarchy [dict get $dkey_info keys] + + #a.b.c = 1 + #table_key_hierarchy -> a b + #leafkey -> c + if {[llength $dotted_key_hierarchy] == 0} { + #empty?? probably invalid. review + #This is different to '' = 1 or ''.'' = 1 which have lengths 1 and 2 respectively + error "DOTTED key has no parts - invalid? '$item'" + } elseif {[llength $dotted_key_hierarchy] == 1} { + #dottedkey is only a key - no table component + set table_hierarchy [list] + set leafkey [lindex $dotted_key_hierarchy 0] + } else { + set table_hierarchy [lrange $dotted_key_hierarchy 0 end-1] + set leafkey [lindex $dotted_key_hierarchy end] + } + + #ensure empty tables are still represented in the datastructure + #review - this seems unnecessary? + set pathkeys [list] + foreach k $table_hierarchy { + lappend pathkeys $k + if {![dict exists $datastructure {*}$pathkeys]} { + dict set datastructure {*}$pathkeys [list] + } else { + tomlish::log::notice "to_dict datastructure at key path $pathkeys already had data: [dict get $datastructure {*}$pathkeys]" + } + } + #review? + if {[dict exists $datastructure {*}$table_hierarchy $leafkey]} { + error "Duplicate key '$table_hierarchy $leafkey'. The key already exists at this level in the toml data. The toml data is not valid." + } + + #JMN test 2025 + if {[llength $table_hierarchy]} { + lappend tablenames_seen $table_hierarchy + } + + set keyval_dict [_get_keyval_value $item] + if {![tomlish::dict::is_tomlish_typeval $keyval_dict]} { + lappend tablenames_seen [list {*}$table_hierarchy $leafkey] + lappend tablenames_closed [list {*}$table_hierarchy $leafkey] + + #review - item is an ITABLE - we recurse here without datastructure context :/ + #overwriting keys? todo ? + dict set datastructure {*}$table_hierarchy $leafkey $keyval_dict + } else { + dict set datastructure {*}$table_hierarchy $leafkey $keyval_dict + } + + } + TABLE { + set tablename [lindex $item 1] + #set tablename [::tomlish::utils::tablename_trim $tablename] + set norm_segments [::tomlish::utils::tablename_split $tablename true] ;#true to normalize + if {$norm_segments in $tablenames_seen} { + error "Table name '$tablename' has already been directly defined in the toml data. Invalid." + } + + log::debug "---> to_dict processing item $tag (name: $tablename): $item" + set name_segments [::tomlish::utils::tablename_split $tablename] ;#unnormalized + set last_seg "" + #toml spec rule - all segments mst be non-empty + #note that the results of tablename_split are 'raw' - ie some segments may be enclosed in single or double quotes. + + set table_key_sublist [list] + + foreach normseg $norm_segments { + lappend table_key_sublist $normseg + if {[dict exists $datastructure {*}$table_key_sublist]} { + #It's ok for this key to already exist *if* it was defined by a previous tablename or equivalent + #and if this key is longer + + #consider the following 2 which are legal: + #[table] + #x.y = 3 + #[table.x.z] + #k= 22 + + #equivalent + + #[table] + #[table.x] + #y = 3 + #[table.x.z] + #k=22 + + #illegal + #[table] + #x.y = 3 + #[table.x.y.z] + #k = 22 + ## - we should fail on encountering table.x.y because only table and table.x are effectively tables + + #illegal + #[table] + #x.y = {p=3} + #[table.x.y.z] + #k = 22 + ## we should fail because y is an inline table which is closed to further entries + + + #note: it is not safe to compare normalized tablenames using join! + # e.g a.'b.c'.d is not the same as a.b.c.d + # instead compare {a b.c d} with {a b c d} + # Here is an example where the number of keys is the same, but they must be compared as a list, not a joined string. + #'a.b'.'c.d.e' vs 'a.b.c'.'d.e' + #we need to normalize the tablenames seen so that {"x\ty"} matches {"xy"} + + set sublist_length [llength $table_key_sublist] + set found_testkey 0 + if {$table_key_sublist in $tablenames_seen} { + set found_testkey 1 + } else { + #see if it was defined by a longer entry + foreach seen_table_segments $tablenames_seen { + if {[llength $seen_table_segments] <= $sublist_length} { + continue + } + #each tablenames_seen entry is already a list of normalized segments + + #we could have [a.b.c.d] early on + # followed by [a.b] - which was still defined by the earlier one. + + set seen_longer [lrange $seen_segments 0 [expr {$sublist_length -1}]] + puts stderr "testkey:'$table_key_sublist' vs seen_match:'$seen_longer'" + if {$table_key_sublist eq $seen_longer} { + set found_testkey 1 + } + } + } + + if {$found_testkey == 0} { + #the raw unnormalized tablename might be ok to display in the error message, although it's not the actual dict keyset + set msg "key $table_key_sublist already exists in datastructure, but wasn't defined by a supertable." + append msg \n "tablenames_seen:" \n + foreach ts $tablenames_seen { + append msg " " $ts \n + } + error $msg + } + } + + } + + #ensure empty tables are still represented in the datastructure + set key_sublist [list] + foreach k $norm_segments { + lappend key_sublist $k + if {![dict exists $datastructure {*}$key_sublist]} { + dict set datastructure {*}$key_sublist [list] + } else { + tomlish::log::notice "to_dict datastructure at (TABLE) subkey $key_sublist already had data: [dict get $datastructure {*}$key_sublist]" + } + } + + #We must do this after the key-collision test above! + lappend tablenames_seen $norm_segments + + + log::debug ">>> to_dict >>>>>>>>>>>>>>>>> normalized table key hierarchy : $norm_segments" + + #now add the contained elements + foreach element [lrange $item 2 end] { + set type [lindex $element 0] + log::debug "----> tododict processing $tag subitem $type processing contained element $element" + switch -exact -- $type { + DOTTEDKEY { + set dkey_info [_get_dottedkey_info $element] + #e.g1 keys {x.y y} keys_raw {'x.y' "a\tb"} keys {x.y {a b}} (keys_raw has escape, keys has literal tab char) + #e.g2 keys {x.y y} keys_raw {{"x.y"} "a\tb"} keys {x.y {a b}} (keys_raw has escape, keys has literal tab char) + set dotted_key_hierarchy [dict get $dkey_info keys] + set dkeys [lrange $dotted_key_hierarchy 0 end-1] + set leaf_key [lindex $dotted_key_hierarchy end] + + #ensure empty keys are still represented in the datastructure + set test_keys $norm_segments + foreach k $dkeys { + lappend test_keys $k + if {![dict exists $datastructure {*}$test_keys]} { + dict set datastructure {*}$test_keys [list] + } else { + tomlish::log::notice "to_dict datastructure at (DOTTEDKEY) subkey $test_keys already had data: [dict get $datastructure {*}$test_keys]" + } + } + + if {[dict exists $datastructure {*}$norm_segments {*}$dkeys $leaf_key]} { + error "Duplicate key '$norm_segments $dkeys $leaf_key'. The key already exists at this level in the toml data. The toml data is not valid." + } + set keyval_dict [_get_keyval_value $element] + #keyval_dict is either a {type value } + #or the result from parsing an arbitrary dict from an inline table - which could theoretically look the same at the topmost level + #punk::dict::is_tomlish_typeval can distinguish + puts stdout "to_dict>>> $keyval_dict" + dict set datastructure {*}$norm_segments {*}$dkeys $leaf_key $keyval_dict + #JMN 2025 + lappend tablenames_seen [list {*}$norm_segments {*}$dkeys] + + if {![tomlish::dict::is_tomlish_typeval $keyval_dict]} { + #the value is either empty or or a dict structure with arbitrary (from-user-data) toplevel keys + # inner structure will contain {type value } if all leaves are not empty ITABLES + lappend tablenames_seen [list {*}$norm_segments {*}$dkeys $leaf_key] + #if the keyval_dict is not a simple type x value y - then it's an inline table ? + #if so - we should add the path to the leaf_key as a closed table too - as it's not allowed to have more entries added. + } + + } + NEWLINE - COMMENT - WS { + #ignore + } + default { + error "Sub element of type '$type' not understood in table context. Expected only KEY,DQKEY,SQKEY,NEWLINE,COMMENT,WS" + } + } + } + #now make sure we add an empty value if there were no contained elements! + #!todo. + } + ITABLE { + #SEP??? + set datastructure [list] + foreach element [lrange $item 1 end] { + set type [lindex $element 0] + log::debug "----> tododict processing $tag subitem $type processing contained element $element" + switch -exact -- $type { + DOTTEDKEY { + set dkey_info [_get_dottedkey_info $element] + set dotted_key_hierarchy [dict get $dkey_info keys] + set leaf_key [lindex $dotted_key_hierarchy end] + set dkeys [lrange $dotted_key_hierarchy 0 end-1] + + #ensure empty keys are still represented in the datastructure + set table_keys [list] ;#We don't know the context - next level up will have to check for key collisions? + set test_keys $table_keys + foreach k $dkeys { + lappend test_keys $k + if {![dict exists $datastructure {*}$test_keys]} { + dict set datastructure {*}$test_keys [list] + } else { + tomlish::log::notice "to_dict datastructure at (DOTTEDKEY) subkey $test_keys already had data: [dict get $datastructure {*}$test_keys]" + } + } + + if {[dict exists $datastructure {*}$table_keys {*}$dkeys $leaf_key]} { + error "Duplicate key '$table_keys $dkeys $leaf_key'. The key already exists at this level in the toml data. The toml data is not valid." + } + set keyval_dict [_get_keyval_value $element] + dict set datastructure {*}$table_keys {*}$dkeys $leaf_key $keyval_dict + } + NEWLINE - COMMENT - WS { + #ignore + } + default { + error "Sub element of type '$type' not understood in ITABLE context. Expected only KEY,DQKEY,SQKEY,NEWLINE,COMMENT,WS" + } + } + } + } + ARRAY { + #arrays in toml are allowed to contain mixtures of types + set datastructure [list] + log::debug "--> processing array: $item" + + foreach element [lrange $item 1 end] { + set type [lindex $element 0] + log::debug "----> tododict processing $tag subitem $type processing contained element $element" + switch -exact -- $type { + INT - FLOAT - BOOL - DATETIME { + set value [lindex $element 1] + lappend datastructure [list type $type value $value] + } + STRING { + set value [lindex $element 1] + lappend datastructure [list type $type value [::tomlish::utils::unescape_string $value]] + } + LITERAL { + set value [lindex $element 1] + lappend datastructure [list type $type value $value] + } + ITABLE { + #anonymous table + #lappend datastructure [list type $type value [::tomlish::to_dict [list $element]]] + lappend datastructure [::tomlish::to_dict [list $element]] ;#store itables within arrays as raw dicts (possibly empty) + } + TABLE { + #invalid? shouldn't be output from from_dict - but could manually be constructed as such? review + #doesn't make sense as table needs a name? + #take as synonym for ITABLE? + error "to_dict TABLE within array unexpected" + } + ARRAY - MULTISTRING - MULTILITERAL { + #set value [lindex $element 1] + lappend datastructure [list type $type value [::tomlish::to_dict [list $element]]] + } + WS - SEP - NEWLINE - COMMENT { + #ignore whitespace, commas, newlines and comments + } + default { + error "Unexpected value type '$type' found in array" + } + } + } + } + MULTILITERAL { + #triple squoted string + #first newline stripped only if it is the very first element + #(ie *immediately* following the opening delims) + #All whitespace other than newlines is within LITERALPARTS + # ------------------------------------------------------------------------- + #todo - consider extension to toml to allow indent-aware multiline literals + # how - propose as issue in toml github? Use different delim? e.g ^^^ ? + #e.g + # xxx=?'''abc + # def + # etc + # ''' + # - we would like to trimleft each line to the column following the opening delim + # ------------------------------------------------------------------------- + + log::debug "---> todict processing multiliteral: $item" + set parts [lrange $item 1 end] + if {[lindex $parts 0 0] eq "NEWLINE"} { + set parts [lrange $parts 1 end] ;#skip it + } + for {set idx 0} {$idx < [llength $parts]} {incr idx} { + set element [lindex $parts $idx] + set type [lindex $element 0] + switch -exact -- $type { + LITERALPART { + append stringvalue [lindex $element 1] + } + NEWLINE { + set val [lindex $element 1] + if {$val eq "nl"} { + append stringvalue \n + } else { + append stringvalue \r\n + } + } + default { + error "Unexpected value type '$type' found in multistring" + } + } + } + set datastructure $stringvalue + } + MULTISTRING { + #triple dquoted string + log::debug "---> to_dict processing multistring: $item" + set stringvalue "" + set idx 0 + set parts [lrange $item 1 end] + for {set idx 0} {$idx < [llength $parts]} {incr idx} { + set element [lindex $parts $idx] + set type [lindex $element 0] + #We use STRINGPART in the tomlish representation as a distinct element to STRING - which would imply wrapping quotes to be reinserted + switch -exact -- $type { + STRING { + #todo - do away with STRING ? + #we don't build MULTISTRINGS containing STRING - but should we accept it? + tomlish::log::warn "double quoting a STRING found in MULTISTRING - should be STRINGPART?" + append stringvalue "\"[::tomlish::utils::unescape_string [lindex $element 1]]\"" + } + STRINGPART { + append stringvalue [::tomlish::utils::unescape_string [lindex $element 1]] + } + CONT { + #When the last non-whitespace character on a line is an unescaped backslash, + #it will be trimmed along with all whitespace (including newlines) up to the next non-whitespace character or closing delimiter + # review - we allow some whitespace in stringpart elements - can a stringpart ever be all whitespace? + set next_nl [lsearch -index 0 -start $idx+1 $parts NEWLINE] + if {$next_nl == -1} { + #last line + set non_ws [lsearch -index 0 -start $idx+1 -not $parts WS] + if {$non_ws >= 0} { + append stringvalue "\\" ;#add the sep + } else { + #skip over ws without emitting + set idx [llength $parts] + } + } else { + set parts_til_nl [lrange $parts 0 $next_nl-1] + set non_ws [lsearch -index 0 -start $idx+1 -not $parts_til_nl WS] + if {$non_ws >= 0} { + append stringvalue "\\" + } else { + #skip over ws on this line + set idx $next_nl + #then have to check each subsequent line until we get to first non-whitespace + set trimming 1 + while {$trimming && $idx < [llength $parts]} { + set next_nl [lsearch -index 0 -start $idx+1 $parts NEWLINE] + if {$next_nl == -1} { + #last line + set non_ws [lsearch -index 0 -start $idx+1 -not $parts WS] + if {$non_ws >= 0} { + set idx [expr {$non_ws -1}] + } else { + set idx [llength $parts] + } + set trimming 0 + } else { + set non_ws [lsearch -index 0 -start $idx+1 -not [lrange $parts 0 $next_nl-1] WS] + if {$non_ws >= 0} { + set idx [expr {$non_ws -1}] + set trimming 0 + } else { + set idx $next_nl + #keep trimming + } + } + } + } + } + } + NEWLINE { + #if newline is first element - it is not part of the data of a multistring + if {$idx > 0} { + set val [lindex $element 1] + if {$val eq "nl"} { + append stringvalue \n + } else { + append stringvalue \r\n + } + } + } + WS { + append stringvalue [lindex $element 1] + } + default { + error "Unexpected value type '$type' found in multistring" + } + } + } + set datastructure $stringvalue + } + WS - COMMENT - NEWLINE { + #ignore + } + default { + error "Unexpected tag '$tag' in Tomlish list '$tomlish'" + } + } + } + return $datastructure + } + + + proc _from_dictval_tomltype {parents tablestack keys typeval} { + set type [dict get $typeval type] + set val [dict get $typeval value] + switch -- $type { + ARRAY { + set subitems [list] + foreach item $val { + lappend subitems [_from_dictval [list {*}$parents ARRAY] $tablestack $keys $item] SEP + } + if {[lindex $subitems end] eq "SEP"} { + set subitems [lrange $subitems 0 end-1] + } + return [list ARRAY {*}$subitems] + } + ITABLE { + if {$val eq ""} { + return ITABLE + } else { + return [_from_dictval [list {*}$parents ITABLE] $tablestack $keys $val] + } + } + MULTISTRING { + #value is a raw string that isn't encoded as tomlish + #create a valid toml snippet with the raw value and decode it to the proper tomlish MULTISTRING format + #We need to convert controls in $val to escape sequences - except for newlines + # + #consider an *option* to reformat for long lines? (perhaps overcomplex - byte equiv - but may fold in ugly places) + #we could use a line-length limit to decide when to put in a "line ending backslash" + #and even format it with a reasonable indent so that proper CONT and WS entries are made (?) REVIEW + # + #TODO + set tomlpart "x=\"\"\"\\\n" + append tomlpart $val "\"\"\"" + set tomlish [tomlish::decode::toml $tomlpart] + #e.g if val = " etc\nblah" + #TOMLISH {DOTTEDKEY {{KEY x}} = {MULTISTRING CONT {NEWLINE LF} {WS { }} {STRINGPART etc} {NEWLINE lf} {STRINGPART blah} } } + #lindex 1 3 is the MULTISTRING tomlish list + return [lindex $tomlish 1 3] + } + MULTILITERAL { + #MLL string can contain newlines - but still no control chars + #todo - validate + set tomlpart "x='''\n" + append tomlpart $val ''' + set tomlish [tomlish::decode::toml $tomlpart] + return [lindex $tomlish 1 3] + } + LITERAL { + #from v1.0 spec - "Control characters other than tab are not permitted in a literal string" + #(This rules out raw ANSI SGR - which is somewhat restrictive - but perhaps justified for a config format + # as copy-pasting ansi to a config value is probably not always wise, and it's not something that can be + # easily input via a text editor. ANSI can go in Basic strings using the \e escape if that's accepted v1.1?) + #we could choose to change the type to another format here when encountering invalid chars - but that seems + #like too much magic. We elect to error out and require the dict to have valid data for the types it specifies. + if {[string first ' $val] >=0} { + error "_from_dictval_tomltype error: single quote found in LITERAL - cannot encode dict to TOML-VALID TOMLISH" + } + #detect control chars other than tab + #for this we can use rawstring_to_Bstring_with_escaped_controls - even though this isn't a Bstring + #we are just using the map to detect a difference. + set testval [tomlish::utils::rawstring_to_Bstring_with_escaped_controls $val] + if {$testval ne $val} { + #some escaping would have to be done if this value was destined for a Bstring... + #therefor this string has controls and isn't suitable for a LITERAL according to the specs. + error "_from_dictval_tomltype error: control chars (other than tab) found in LITERAL value - cannot encode dict to TOML-VALID TOMLISH" + } + return [list LITERAL $val] + } + STRING { + return [list STRING [tomlish::utils::rawstring_to_Bstring_with_escaped_controls $val]] + } + INT { + if {![::tomlish::utils::is_int $val]} { + error "_from_dictval_tomltype error: bad INT value '$val' - cannot encode dict to TOML-VALID TOMLISH" + } + return [list INT $val] + } + FLOAT { + if {![::tomlish::utils::is_float $val]} { + error "_from_dictval_tomltype error: bad FLOAT value '$val' - cannot encode dict to TOML-VALID TOMLISH" + } + return [list FLOAT $val] + } + default { + if {$type ni [::tomlish::tags]} { + error "_from_dictval_tomltype error: Unrecognised typename '$type' in {type value } - cannot encode dict to TOML-VALID TOMLISH" + } + return [list $type $val] + } + } + } + + proc _from_dictval {parents tablestack keys vinfo} { + set k [lindex $keys end] + if {[regexp {\s} $k] || [string first . $k] >= 0} {} + if {![::tomlish::utils::is_barekey $k]} { + #Any dot in the key would have been split by to_dict - so if it's present here it's part of this key - not a level separator! + #requires quoting + #we'll use a basic mechanism for now to determine the type of quoting - whether it has any single quotes or not. + #todo - more? + #For keys - we currently (2025) are only allowed barekeys,basic strings and literal strings. (no multiline forms) + if {[string first ' $k] >=0} { + #basic string + } else { + #literal string + set K_PART [list SQKEY $k] + } + } else { + set K_PART [list KEY $k] + } + puts stderr "---parents:'$parents' keys:'$keys' vinfo: $vinfo---" + puts stderr "---tablestack: $tablestack---" + set result [list] + set lastparent [lindex $parents end] + if {$lastparent in [list "" do_inline]} { + if {[tomlish::dict::is_tomlish_typeval $vinfo]} { + set type [dict get $vinfo type] + #treat ITABLE differently? + set sublist [_from_dictval_tomltype $parents $tablestack $keys $vinfo] + lappend result DOTTEDKEY [list $K_PART {WS { }}] = {WS { }} $sublist {NEWLINE lf} + } else { + #set result [list TABLE $k {NEWLINE lf}] + if {$vinfo ne ""} { + + #set result [list DOTTEDKEY [list [list KEY $k]] = ] + #set records [list ITABLE] + + set last_tomltype_posn [tomlish::dict::last_tomltype_posn $vinfo] + + if {$lastparent eq "do_inline"} { + set result [list DOTTEDKEY [list $K_PART] =] + set records [list ITABLE] + } else { + #review - quoted k ?? + set result [list TABLE $k {NEWLINE lf}] + set tablestack [list {*}$tablestack [list T $k]] + set records [list] + } + + + + set lastidx [expr {[dict size $vinfo] -1}] + set dictidx 0 + dict for {vk vv} $vinfo { + if {[regexp {\s} $vk] || [string first . $vk] >= 0} { + set VK_PART [list SQKEY $vk] + } else { + set VK_PART [list KEY $vk] + } + if {[tomlish::dict::is_tomlish_typeval $vv]} { + #type x value y + set sublist [_from_dictval_tomltype $parents $tablestack $keys $vv] + set record [list DOTTEDKEY [list $VK_PART {WS { }}] = {WS { }} $sublist] + } else { + if {$vv eq ""} { + #experimental + if {[lindex $parents 0] eq "" && $dictidx > $last_tomltype_posn} { + puts stderr "_from_dictval could uninline KEY $vk (tablestack:$tablestack)" + #set tname [tomlish::dict::name_from_tablestack [list {*}$tablestack [list T $vk]]] + set tname [join [list {*}$keys $vk] .] + set record [list TABLE $tname {NEWLINE lf}] + set tablestack [list {*}$tablestack [list T $vk]] + } else { + set record [list DOTTEDKEY [list $VK_PART] = ITABLE] + set tablestack [list {*}$tablestack [list I $vk]] + } + } else { + if { 0 } { + #experiment.. sort of getting there. + if {[lindex $parents 0] eq "" && $dictidx > $last_tomltype_posn} { + puts stderr "_from_dictval could uninline2 KEYS [list {*}$keys $vk] (tablestack:$tablestack)" + set tname [join [list {*}$keys $vk] .] + set record [list TABLE $tname {NEWLINE lf}] + set tablestack [list {*}$tablestack [list T $vk]] + + #review - todo? + set dottedkey_value [_from_dictval [list {*}$parents TABLE] $tablestack [list {*}$keys $vk] $vv] + lappend record {*}$dottedkey_value + + } else { + set dottedkey_value [_from_dictval [list {*}$parents ITABLE] $tablestack [list {*}$keys $vk] $vv] + set record [list DOTTEDKEY [list $VK_PART] = $dottedkey_value] + } + } else { + set dottedkey_value [_from_dictval [list {*}$parents ITABLE] $tablestack [list {*}$keys $vk] $vv] + set record [list DOTTEDKEY [list $VK_PART] = $dottedkey_value] + } + } + } + if {$dictidx != $lastidx} { + #lappend record SEP + if {$lastparent eq "do_inline"} { + lappend record SEP + } else { + lappend record {NEWLINE lf} + } + } + lappend records $record + incr dictidx + } + if {$lastparent eq "do_inline"} { + lappend result $records {NEWLINE lf} + } else { + lappend result {*}$records {NEWLINE lf} + } + } else { + if {$lastparent eq "do_inline"} { + lappend result DOTTEDKEY [list [list KEY $k]] = ITABLE {NEWLINE lf} + } else { + lappend result TABLE $k {NEWLINE lf} + } + } + } + } else { + #lastparent is not toplevel "" or "do_inline" + if {[tomlish::dict::is_tomlish_typeval $vinfo]} { + #type x value y + set sublist [_from_dictval_tomltype $parents $tablestack $keys $vinfo] + lappend result {*}$sublist + } else { + if {$lastparent eq "TABLE"} { + #review + dict for {vk vv} $vinfo { + set dottedkey_value [_from_dictval [list {*}$parents DOTTEDKEY] $tablestack [list {*}$keys $vk] $vv] + lappend result [list DOTTEDKEY [list [list KEY $vk]] = $dottedkey_value {NEWLINE lf}] + } + } else { + if {$vinfo ne ""} { + set lastidx [expr {[dict size $vinfo] -1}] + set dictidx 0 + set sub [list] + #REVIEW + #set result $lastparent ;#e.g sets ITABLE + set result ITABLE + set last_tomltype_posn [tomlish::dict::last_tomltype_posn $vinfo] + dict for {vk vv} $vinfo { + if {[regexp {\s} $vk] || [string first . $vk] >=0} { + set VK_PART [list SQKEY $vk] + } else { + set VK_PART [list KEY $vk] + } + if {[tomlish::dict::is_tomlish_typeval $vv]} { + #type x value y + set sublist [_from_dictval_tomltype $parents $tablestack $keys $vv] + set record [list DOTTEDKEY [list $VK_PART] = $sublist] + } else { + if {$vv eq ""} { + #can't just uninline at this level + #we need a better method to query main dict for uninlinability at each level + # (including what's been inlined already) + #if {[lindex $parents 0] eq "" && $dictidx > $last_tomltype_posn} { + # puts stderr "_from_dictval uninline2 KEY $keys" + # set tname [join [list {*}$keys $vk] .] + # set record [list TABLE $tname {NEWLINE lf}] + # set tablestack [list {*}$tablestack [list T $vk]] + #} else { + set record [list DOTTEDKEY [list $VK_PART] = ITABLE] + #} + } else { + #set sub [_from_dictval ITABLE $vk $vv] + set dottedkey_value [_from_dictval [list {*}$parents ITABLE] $tablestack [list {*}$keys $vk] $vv] + #set record [list DOTTEDKEY [list $VK_PART] = ITABLE $dottedkey_value] + set record [list DOTTEDKEY [list $VK_PART] = $dottedkey_value] + } + } + if {$dictidx != $lastidx} { + lappend record SEP + } + lappend result $record + incr dictidx + } + } else { + puts stderr "table x-1" + lappend result DOTTEDKEY [list $K_PART] = ITABLE + } + } + } + } + return $result + } + + + proc from_dict {d} { + #consider: + # t1={a=1,b=2} + # x = 1 + #If we represent t1 as an expanded table we get + # [t1] + # a=1 + # b=2 + # x=1 + # --- which is incorrect - as x was a toplevel key like t1! + #This issue doesn't occur if x is itself an inline table + # t1={a=1,b=2} + # x= {no="problem"} + # + # (or if we were to reorder x to come before t1) + + #As the dictionary form doesn't distinguish the structure used to create tables {[table1]\nk=v} vs inline {table1={k=v}} + #Without a solution, from_dict would have to always produce the inline form for toplevel tables unless we allowed re-ordering, + #which is unpreferred here. + + #A possible solution: + #scan the top level to see if all (trailing) elements are themselves dicts + # (ie not of form {type XXX value yyy}) + # + # A further point is that if all root level values are at the 'top' - we can treat lower table-like structures as {[table]} elements + #ie we don't need to force do_inline if all the 'simple' keys are before any compound keys + + #set root_has_values 0 + #approach 1) - the naive approach - forces inline when not always necessary + #dict for {k v} $d { + # if {[llength $v] == 4 && [lindex $v 0] eq "type"} { + # set root_has_values 1 + # break + # } + #} + + + #approach 2) - track the position of last {type x value y} in the dictionary built by to_dict + # - still not perfect. Inlines dotted tables unnecessarily + #This means from_dict doesn't produce output optimal for human editing. + set last_simple [tomlish::dict::last_tomltype_posn $d] + + + ## set parent "do_inline" ;#a value used in _from_dictval to distinguish from "" or other context based parent values + #Any keys that are themselves tables - will need to be represented inline + #to avoid reordering, or incorrect assignment of plain values to the wrong table. + + ## set parent "" + #all toplevel keys in the dict structure can represent subtables. + #we are free to use {[tablename]\n} syntax for toplevel elements. + + + set tomlish [list TOMLISH] + set dictposn 0 + set tablestack [list [list T root]] ;#todo + dict for {t tinfo} $d { + if {$last_simple > $dictposn} { + set parents [list do_inline] + } else { + set parents [list ""] + } + set keys [list $t] + set trecord [_from_dictval $parents $tablestack $keys $tinfo] + lappend tomlish $trecord + incr dictposn + } + return $tomlish + } + + proc json_to_toml {json} { + #*** !doctools + #[call [fun json_to_toml] [arg json]] + #[para] + + set tomlish [::tomlish::from_json $json] + set toml [::tomlish::to_toml $tomlish] + } + + #TODO use huddle? + proc from_json {json} { + #set jstruct [::tomlish::json_struct $json] + #return [::tomlish::from_json_struct $jstruct] + package require huddle + package require huddle::json + set h [huddle::json::json2huddle parse $json] + + } + + proc from_json_struct {jstruct} { + package require fish::json_toml + return [fish::json_toml::jsonstruct2tomlish $jstruct] + } + + proc toml_to_json {toml} { + set tomlish [::tomlish::from_toml $toml] + return [::tomlish::get_json $tomlish] + } + + proc get_json {tomlish} { + package require fish::json + set d [::tomlish::to_dict $tomlish] + #return [::tomlish::dict_to_json $d] + return [fish::json::from "struct" $d] + } + + + + + #*** !doctools + #[list_end] [comment {--- end definitions namespace tomlish ---}] +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +namespace eval tomlish::build { + #STRING,INT,FLOAT,BOOL, DATETIME - simple wrappers for completeness + # take a value of the appropriate type and wrap as a tomlish tagged item + proc STRING {s} { + return [list STRING [::tomlish::utils::rawstring_to_Bstring_with_escaped_controls $s]] + } + proc LITERAL {litstring} { + error todo + } + + proc INT {i} { + #whole numbers, may be prefixed with a + or - + #Leading zeros are not allowed + #Hex,octal binary forms are allowed (toml 1.0) + #We will error out on encountering commas, as commas are interpreted differently depending on locale (and don't seem to be supported in the toml spec anyway) + #!todo - Tcl can handle bignums - bigger than a 64bit signed long as specified in toml. + # - We should probably raise an error for number larger than this and suggest the user supply it as a string? + if {[tcl::string::last , $i] > -1} { + error "Unable to interpret '$i' as an integer. Use underscores if you need a thousands separator [::tomlish::parse::report_line]" + } + if {![::tomlish::utils::int_validchars $i]} { + error "Unable to interpret '$i' as an integer. Only 0-9 + 1 _ characters are acceptable. [::tomlish::parse::report_line]" + } + + if {[::tomlish::utils::is_int $i]} { + return [list INT $i] + } else { + error "'$i' is not a valid integer as per the Toml spec. [::tomlish::parse::report_line]" + } + + } + + proc FLOAT {f} { + #convert any non-lower case variants of special values to lowercase for Toml + if {[::tcl::string::tolower $f] in {nan +nan -nan inf +inf -inf}} { + return [list FLOAT [tcl::string::tolower $f]] + } + if {[::tomlish::utils::is_float $f]} { + return [list FLOAT $f] + } else { + error "Unable to interpret '$f' as Toml float. Check your input, or check that tomlish is able to handle all Toml floats properly [::tomlish::parse::report_line]" + } + } + + proc DATETIME {str} { + if {[::tomlish::utils::is_datetime $str]} { + return [list DATETIME $str] + } else { + error "Unable to interpret '$str' as Toml datetime. Check your input, or check that tomlish is able to handle all Toml datetimes properly [::tomlish::parse::report_line]" + } + } + + proc BOOLEAN {b} { + #convert any Tcl-acceptable boolean to boolean as accepted by toml - lower case true/false + if {![tcl::string::is boolean -strict $b]} { + error "Unable to convert '$b' to Toml boolean true|false. [::tomlish::parse::report_line]" + } else { + if {$b && 1} { + return [::list BOOL true] + } else { + return [::list BOOL false] + } + } + } + + #REVIEW + #Take tablename followed by + # a) *tomlish* name-value pairs e.g table mydata [list KEY item11 = [list STRING "test"]] {KEY item2 = [list INT 1]} + # (accept also key value {STRING }) + # b) simple 2-element tcl lists being name & *simple* value pairs for which basic heuristics will be used to determine types + proc _table {name args} { + set pairs [list] + foreach t $args { + if {[llength $t] == 4} { + if {[tcl::string::tolower [lindex $t 0]] ne "key" || [tcl::string::tolower [lindex $t 2]] ni "= value"} { + error "Only items tagged as KEY = currently accepted as name-value pairs for table command" + } + lassign $t _k keystr _eq valuepart + if {[llength $valuepart] != 2} { + error "supplied value must be typed. e.g {INT 1} or {STRING test}" + } + lappend pairs [list KEY $keystr = $valuepart] + } elseif {[llength $t] == 2} { + #!todo - type heuristics + lassign $t n v + lappend pairs [list KEY $n = [list STRING $v]] + } else { + error "'KEY = { toml but + # the first newline is not part of the data. + # we elect instead to maintain a basic LITERALPART that must not contain newlines.. + # and to compose MULTILITERAL of multiple NEWLINE LITERALPART parts, + #with the datastructure representation dropping the first newline (if immediately following opening delim) when building the value. + set literal "" + foreach part [lrange $item 1 end] { + append literal [::tomlish::encode::tomlish [list $part] $nextcontext] + } + append toml '''$literal''' + } + INT - + BOOL - + FLOAT - + DATETIME { + append toml [lindex $item 1] + } + INCOMPLETE { + error "cannot process tomlish term tagged as INCOMPLETE" + } + COMMENT { + append toml "#[lindex $item 1]" + } + BOM { + #Byte Order Mark may appear at beginning of a file. Needs to be preserved. + append toml "\uFEFF" + } + default { + error "Not a properly formed 'tomlish' taggedlist.\n '$list'\n Unknown tag '[lindex $item 0]'. See output of \[tomlish::tags\] command." + } + } + + } + return $toml + } + + + + #*** !doctools + #[list_end] [comment {--- end definitions namespace tomlish::encode ---}] +} +#fish toml from tomlish + +#(encode tomlish as toml) +interp alias {} tomlish::to_toml {} tomlish::encode::tomlish + +# + + +namespace eval tomlish::decode { + #*** !doctools + #[subsection {Namespace tomlish::decode}] + #[para] + #[list_begin definitions] + + #return a Tcl list of tomlish tokens + #i.e get a standard list of all the toml terms in string $s + #where each element of the list is a *tomlish* term.. i.e a specially 'tagged' Tcl list. + #(simliar to a tcl 'Huddle' - but also supporting whitespace preservation) + # ---------------------------------------------------------------------------------------------- + # NOTE: the production of tomlish from toml source doesn't indicate the toml source was valid!!! + # e.g we deliberately don't check certain things such as duplicate table declarations here. + # ---------------------------------------------------------------------------------------------- + #Part of the justification for this is that as long as the syntax is toml shaped - we can load files which violate certain rules and allow programmatic manipulation. + # (e.g perhaps a toml editor to highlight violations for fixing) + # A further stage is then necessary to load the tomlish tagged list into a data structure more suitable for efficient query/reading. + # e.g dicts or an object oriented structure + #Note also - *no* escapes in quoted strings are processed. This is up to the datastructure stage + #e.g to_dict will substitute \r \n \uHHHH \UHHHHHHH etc + #This is important for tomlish to maintain the ability to perform competely lossless round-trips from toml to tomlish and back to toml. + # (which is handy for testing as well as editing some part of the structure with absolutely no effect on other parts of the document) + #If we were to unescape a tab character for example + # - we have no way of knowing if it was originally specified as \t \u0009 or \U00000009 or directly as a tab character. + # For this reason, we also do absolutely no line-ending transformations based on platform. + # All line-endings are maintained as is, and even a file with mixed lf crlf line-endings will be correctly interpreted and can be 'roundtripped' + + proc toml {args} { + #*** !doctools + #[call [fun toml] [arg arg...]] + #[para] return a Tcl list of tomlish tokens + + set s [join $args \n] + + namespace upvar ::tomlish::parse is_parsing is_parsing + set is_parsing 1 + + if {[info command ::tomlish::parse::spacestack] eq "::tomlish::parse::spacestack"} { + tomlish::parse::spacestack destroy + } + struct::stack ::tomlish::parse::spacestack + + namespace upvar ::tomlish::parse last_space_action last_space_action + namespace upvar ::tomlish::parse last_space_type last_space_type + + namespace upvar ::tomlish::parse tok tok + set tok "" + + namespace upvar ::tomlish::parse type type + namespace upvar ::tomlish::parse tokenType tokenType + ::tomlish::parse::set_tokenType "" + namespace upvar ::tomlish::parse tokenType_list tokenType_list + set tokenType [list] ;#Flat (un-nested) list of tokentypes found + + namespace upvar ::tomlish::parse lastChar lastChar + set lastChar "" + + + set result "" + namespace upvar ::tomlish::parse nest nest + set nest 0 + + namespace upvar ::tomlish::parse v v ;#array keyed on nest level + + + set v(0) {TOMLISH} + array set s0 [list] ;#whitespace data to go in {SPACE {}} element. + set parentlevel 0 + + namespace upvar ::tomlish::parse i i + set i 0 + + namespace upvar ::tomlish::parse state state + + namespace upvar ::tomlish::parse braceCount braceCount + set barceCount 0 + namespace upvar ::tomlish::parse bracketCount bracketCount + set bracketCount 0 + + set sep 0 + set r 1 + namespace upvar ::tomlish::parse token_waiting token_waiting + set token_waiting [dict create] ;#if ::tok finds a *complete* second token during a run, it will put the 2nd one here to be returned by the next call. + + + set state "table-space" + ::tomlish::parse::spacestack push {type space state table-space} + namespace upvar ::tomlish::parse linenum linenum;#'line number' of input data. (incremented for each literal linefeed - but not escaped ones in data) + set linenum 1 + + set ::tomlish::parse::state_list [list] + try { + while {$r} { + set r [::tomlish::parse::tok $s] + #puts stdout "got tok: '$tok' while parsing string '$s' " + set next_tokenType_known 0 ;#whether we begin a new token here based on what terminated the token result of 'tok' + + + #puts "got token: '$tok' tokenType='$tokenType'. while v($nest) = [set v($nest)]" + #puts "-->tok: $tok tokenType='$tokenType'" + set prevstate $state + set transition_info [::tomlish::parse::goNextState $tokenType $tok $state] + #review goNextState could perform more than one space_action + set space_action [dict get $transition_info space_action] + set newstate [dict get $transition_info newstate] ;#use of 'newstate' vs 'state' makes code clearer below + + if {[tcl::string::match "err-*" $state]} { + ::tomlish::log::warn "---- State error in state $prevstate for tokenType: $tokenType token value: $tok. $state aborting parse. [tomlish::parse::report_line]" + lappend v(0) [list ERROR tokentype $tokenType state $prevstate to $state leveldata [set v($nest)]] + return $v(0) + } + # --------------------------------------------------------- + #NOTE there may already be a token_waiting at this point + #set_token_waiting can raise an error here, + # in which case the space_action branch needs to be rewritten to handle the existing token_waiting + # --------------------------------------------------------- + + if {$space_action eq "pop"} { + #pop_trigger_tokens: newline tablename endarray endinlinetable + #note a token is a pop trigger depending on context. e.g first newline during keyval is a pop trigger. + set parentlevel [expr {$nest -1}] + set do_append_to_parent 1 ;#most tokens will leave this alone - but some like squote_seq need to do their own append + switch -exact -- $tokenType { + squote_seq { + #### + set do_append_to_parent 0 ;#mark false to indicate we will do our own appends if needed + #Without this - we would get extraneous empty list entries in the parent + # - as the xxx-squote-space isn't a space level from the toml perspective + # - the use of a space is to give us a hook here to (possibly) integrate extra quotes into the parent space when we pop + switch -- $tok { + ' { + tomlish::parse::set_token_waiting type startsquote value $tok complete 1 startindex [expr {$i -1}] + } + '' { + #review - we should perhaps return double_squote instead? + #tomlish::parse::set_token_waiting type literal value "" complete 1 + tomlish::parse::set_token_waiting type double_squote value "" complete 1 startindex [expr {$i - 2}] + } + ''' { + #### + #if already an eof in token_waiting - set_token_waiting will insert before it + tomlish::parse::set_token_waiting type triple_squote value $tok complete 1 startindex [expr {$i - 3}] + } + '''' { + switch -exact -- $prevstate { + leading-squote-space { + error "---- 4 squotes from leading-squote-space - shouldn't get here" + #we should have emitted the triple and left the last for next loop + } + trailing-squote-space { + tomlish::parse::set_token_waiting type triple_squote value $tok complete 1 startindex [expr {$i - 4}] + #todo integrate left squote with nest data at this level + set lastpart [lindex $v($parentlevel) end] + switch -- [lindex $lastpart 0] { + LITERALPART { + set newval "[lindex $lastpart 1]'" + set parentdata $v($parentlevel) + lset parentdata end [list LITERALPART $newval] + set v($parentlevel) $parentdata + } + NEWLINE { + lappend v($parentlevel) [list LITERALPART "'"] + } + MULTILITERAL { + #empty + lappend v($parentlevel) [list LITERALPART "'"] + } + default { + error "--- don't know how to integrate extra trailing squote with data $v($parentlevel)" + } + } + } + default { + error "--- unexpected popped due to squote_seq but came from state '$prevstate' should have been leading-squote-space or trailing-squote-space" + } + } + } + ''''' { + switch -exact -- $prevstate { + leading-squote-space { + error "---- 5 squotes from leading-squote-space - shouldn't get here" + #we should have emitted the triple and left the following squotes for next loop + } + trailing-squote-space { + tomlish::parse::set_token_waiting type triple_squote value $tok complete 1 startindex [expr {$i-5}] + #todo integrate left 2 squotes with nest data at this level + set lastpart [lindex $v($parentlevel) end] + switch -- [lindex $lastpart 0] { + LITERALPART { + set newval "[lindex $lastpart 1]''" + set parentdata $v($parentlevel) + lset parentdata end [list LITERALPART $newval] + set v($parentlevel) $parentdata + } + NEWLINE { + lappend v($parentlevel) [list LITERALPART "''"] + } + MULTILITERAL { + lappend v($parentlevel) [list LITERALPART "''"] + } + default { + error "--- don't know how to integrate extra trailing 2 squotes with data $v($parentlevel)" + } + } + } + default { + error "--- unexpected popped due to squote_seq but came from state '$prevstate' should have been leading-squote-space or trailing-squote-space" + } + } + } + } + puts stderr "tomlish::decode::toml ---- HERE squote_seq pop <$tok>" + } + triple_squote { + #presumably popping multiliteral-space + ::tomlish::log::debug "---- triple_squote for last_space_action pop leveldata: $v($nest)" + set merged [list] + set lasttype "" + foreach part $v($nest) { + switch -exact -- [lindex $part 0] { + MULTILITERAL { + lappend merged $part + } + LITERALPART { + if {$lasttype eq "LITERALPART"} { + set prevpart [lindex $merged end] + lset prevpart 1 [lindex $prevpart 1][lindex $part 1] + lset merged end $prevpart + } else { + lappend merged $part + } + } + NEWLINE { + #note that even though first newline ultimately gets stripped from multiliterals - that isn't done here + #we still need the first one for roundtripping. The datastructure stage is where it gets stripped. + lappend merged $part + } + default { + error "---- triple_squote unhandled part type [lindex $part 0] unable to merge leveldata: $v($next)" + } + } + set lasttype [lindex $part 0] + } + set v($nest) $merged + } + equal { + #pop caused by = + switch -exact -- $prevstate { + dottedkey-space { + tomlish::log::debug "---- equal ending dottedkey-space for last_space_action pop" + #re-emit for parent space + tomlish::parse::set_token_waiting type equal value = complete 1 startindex [expr {$i-1}] + } + dottedkey-space-tail { + #experiment? + tomlish::log::debug "---- equal ending dottedkey-space-tail for last_space_action pop" + #re-emit for parent space + tomlish::parse::set_token_waiting type equal value = complete 1 startindex [expr {$i-1}] + } + } + } + newline { + incr linenum + lappend v($nest) [list NEWLINE $tok] + } + tablename { + #note: a tablename only 'pops' if we are greater than zero + error "---- tablename pop should already have been handled as special case zeropoppushspace in goNextState" + } + tablearrayname { + #!review - tablearrayname different to tablename regarding push/pop? + #note: a tablename only 'pops' if we are greater than zero + error "---- tablearrayname pop should already have been handled as special case zeropoppushspace in goNextState" + } + endarray { + #nothing to do here. + } + comma { + #comma for inline table will pop the keyvalue space + lappend v($nest) "SEP" + } + endinlinetable { + ::tomlish::log::debug "---- endinlinetable for last_space_action pop" + } + endmultiquote { + ::tomlish::log::debug "---- endmultiquote for last_space_action 'pop'" + } + default { + error "---- unexpected tokenType '$tokenType' for last_space_action 'pop'" + } + } + if {$do_append_to_parent} { + #e.g squote_seq does it's own appends as necessary - so won't get here + lappend v($parentlevel) [set v($nest)] + } + + incr nest -1 + + } elseif {$last_space_action eq "push"} { + set prevnest $nest + incr nest 1 + set v($nest) [list] + # push_trigger_tokens: barekey dquotedkey startinlinetable startarray tablename tablearrayname + + + switch -exact -- $tokenType { + squote_seq_begin { + #### + if {[dict exists $transition_info starttok] && [dict get $transition_info starttok] ne ""} { + lassign [dict get $transition_info starttok] starttok_type starttok_val + set next_tokenType_known 1 + ::tomlish::parse::set_tokenType $starttok_type + set tok $starttok_val + } + } + squotedkey { + switch -exact -- $prevstate { + table-space - itable-space { + set v($nest) [list DOTTEDKEY] + } + } + #todo - check not something already waiting? + tomlish::parse::set_token_waiting type $tokenType value $tok complete 1 startindex [expr {$i -[tcl::string::length $tok]}] ;#re-submit token in the newly pushed space + } + dquotedkey { + switch -exact -- $prevstate { + table-space - itable-space { + set v($nest) [list DOTTEDKEY] + } + } + #todo - check not something already waiting? + tomlish::parse::set_token_waiting type $tokenType value $tok complete 1 startindex [expr {$i -[tcl::string::length $tok]}] ;#re-submit token in the newly pushed space + } + XXXdquotedkey - XXXitablequotedkey { + #todo + set v($nest) [list DQKEY $tok] ;#$tok is the keyname + } + barekey { + switch -exact -- $prevstate { + table-space - itable-space { + set v($nest) [list DOTTEDKEY] + } + } + #todo - check not something already waiting? + set waiting [tomlish::parse::get_token_waiting] + if {[llength $waiting]} { + set i [dict get $waiting startindex] + tomlish::parse::clear_token_waiting + tomlish::parse::set_token_waiting type $tokenType value $tok complete 1 startindex [expr {$i -[tcl::string::length $tok]}] ;#re-submit token in the newly pushed space + } else { + tomlish::parse::set_token_waiting type $tokenType value $tok complete 1 startindex [expr {$i -[tcl::string::length $tok]}] ;#re-submit token in the newly pushed space + } + } + startsquote { + #JMN + set next_tokenType_known 1 + ::tomlish::parse::set_tokenType "squotedkey" + set tok "" + } + tablename { + #note: we do not use the output of tomlish::tablename_trim to produce a tablename for storage in the tomlish list! + #The tomlish list is intended to preserve all whitespace (and comments) - so a roundtrip from toml file to tomlish + # back to toml file will be identical. + #It is up to the datastructure stage to normalize and interpret tomlish for programmatic access. + # we call tablename_trim here only to to validate that the tablename data is well-formed at the outermost level, + # so we can raise an error at this point rather than create a tomlish list with obviously invalid table names. + + #todo - review! It's arguable that we should not do any validation here, and just store even incorrect raw tablenames, + # so that the tomlish list is more useful for say a toml editor. Consider adding an 'err' tag to the appropriate place in the + # tomlish list? + + set test_only [::tomlish::utils::tablename_trim $tok] + ::tomlish::log::debug "---- trimmed (but not normalized) tablename: '$test_only'" + set v($nest) [list TABLE $tok] ;#$tok is the *raw* table name + #note also that equivalent tablenames may have different toml representations even after being trimmed! + #e.g ["x\t\t"] & ["x "] (tab escapes vs literals) + #These will show as above in the tomlish list, but should normalize to the same tablename when used as keys by the datastructure stage. + } + tablearrayname { + set test_only [::tomlish::utils::tablename_trim $tok] + puts stdout "trimmed (but not normalized) tablearrayname: '$test_only'" + set v($nest) [list TABLEARRAY $tok] ;#$tok is the *raw* tablearray name + } + startarray { + set v($nest) [list ARRAY] ;#$tok is just the opening bracket - don't output. + } + startinlinetable { + set v($nest) [list ITABLE] ;#$tok is just the opening curly brace - don't output. + } + startmultiquote { + ::tomlish::log::debug "---- push trigger tokenType startmultiquote" + set v($nest) [list MULTISTRING] ;#container for STRINGPART, WS, CONT, NEWLINE + } + triple_squote { + ::tomlish::log::debug "---- push trigger tokenType triple_squote" + set v($nest) [list MULTILITERAL] ;#container for NEWLINE,LITERAL + } + default { + error "---- push trigger tokenType '$tokenType' not yet implemented" + } + } + + } else { + #no space level change + switch -exact -- $tokenType { + squotedkey { + puts "---- squotedkey in state $prevstate (no space level change)" + lappend v($nest) [list SQKEY $tok] + } + dquotedkey { + puts "---- dquotedkey in state $prevstate (no space level change)" + lappend v($nest) [list DQKEY $tok] + } + barekey { + lappend v($nest) [list KEY $tok] + } + dotsep { + lappend v($nest) [list DOTSEP] + } + starttablename { + #$tok is triggered by the opening bracket and sends nothing to output + } + starttablearrayname { + #$tok is triggered by the double opening brackets and sends nothing to output + } + tablename - tablenamearray { + error "---- did not expect 'tablename/tablearrayname' without space level change (no space level change)" + #set v($nest) [list TABLE $tok] + } + endtablename - endtablearrayname { + #no output into the tomlish list for this token + } + startinlinetable { + puts stderr "---- decode::toml error. did not expect startinlinetable without space level change (no space level change)" + } + startquote { + switch -exact -- $newstate { + string-state { + set next_tokenType_known 1 + ::tomlish::parse::set_tokenType "string" + set tok "" + } + quoted-key { + set next_tokenType_known 1 + ::tomlish::parse::set_tokenType "dquotedkey" + set tok "" + } + XXXitable-quoted-key { + set next_tokenType_known 1 + ::tomlish::parse::set_tokenType "itablequotedkey" + set tok "" + } + default { + error "---- startquote switch case not implemented for nextstate: $newstate (no space level change)" + } + } + } + startsquote { + switch -exact -- $newstate { + literal-state { + set next_tokenType_known 1 + ::tomlish::parse::set_tokenType "literal" + set tok "" + } + squoted-key { + set next_tokenType_known 1 + ::tomlish::parse::set_tokenType "squotedkey" + set tok "" + } + multiliteral-space { + #false alarm squote returned from squote_seq pop + ::tomlish::log::debug "---- adding lone squote to own LITERALPART nextstate: $newstate (no space level change)" + #(single squote - not terminating space) + lappend v($nest) [list LITERALPART '] + #may need to be joined on pop if there are neighbouring LITERALPARTs + } + default { + error "---- startsquote switch case not implemented for nextstate: $newstate (no space level change)" + } + } + } + startmultiquote { + #review + puts stderr "---- got startmultiquote in state $prevstate (no space level change)" + set next_tokenType_known 1 + ::tomlish::parse::set_tokenType "stringpart" + set tok "" + } + endquote { + #nothing to do? + set tok "" + } + endsquote { + set tok "" + } + endmultiquote { + #JMN!! + set tok "" + } + string { + lappend v($nest) [list STRING $tok] ;#directly wrapped in dquotes + } + literal { + lappend v($nest) [list LITERAL $tok] ;#directly wrapped in squotes + } + double_squote { + switch -exact -- $prevstate { + keyval-value-expected { + lappend v($nest) [list LITERAL ""] + } + multiliteral-space { + #multiliteral-space to multiliteral-space + lappend v($nest) [list LITERALPART ''] + } + default { + error "--- unhandled tokenType '$tokenType' when transitioning from state $prevstate to $newstate [::tomlish::parse::report_line] (no space level change)" + } + } + } + multistring { + #review + lappend v($nest) [list MULTISTRING $tok] + } + stringpart { + lappend v($nest) [list STRINGPART $tok] ;#will not get wrapped in dquotes directly + } + multiliteral { + lappend v($nest) [LIST MULTILITERAL $tok] + } + literalpart { + lappend v($nest) [list LITERALPART $tok] ;#will not get wrapped in squotes directly + } + itablequotedkey { + + } + untyped_value { + #we can't determine the type of unquoted values (int,float,datetime,bool) until the entire token was read. + if {$tok in {true false}} { + set tag BOOL + } elseif {[::tomlish::utils::is_int $tok]} { + set tag INT + } elseif {[::tomlish::utils::is_float $tok]} { + set tag FLOAT + } elseif {[::tomlish::utils::is_datetime $tok]} { + set tag DATETIME + } else { + error "---- Unable to interpret '$tok' as Boolean, Integer, Float or Datetime as per the toml specs. [tomlish::parse::report_line] (no space level change)" + } + lappend v($nest) [list $tag $tok] + + } + comment { + #puts stdout "----- comment token returned '$tok'------" + lappend v($nest) [list COMMENT "$tok"] + } + equal { + #we append '=' to the nest so that any surrounding whitespace is retained. + lappend v($nest) = + } + comma { + lappend v($nest) SEP + } + newline { + incr linenum + lappend v($nest) [list NEWLINE $tok] + } + whitespace { + lappend v($nest) [list WS $tok] + } + continuation { + lappend v($nest) CONT + } + bom { + lappend v($nest) BOM + } + eof { + #ok - nothing more to add to the tomlish list. + #!todo - check previous tokens are complete/valid? + } + default { + error "--- unknown tokenType '$tokenType' during state $prevstate [::tomlish::parse::report_line] (no space level change)" + } + } + } + + if {!$next_tokenType_known} { + ::tomlish::log::notice "---- tomlish::decode::toml - current tokenType:$tokenType Next token type not known" + ::tomlish::parse::set_tokenType "" + set tok "" + } + + if {$state eq "end-state"} { + break + } + + + } + + #while {$nest > 0} { + # lappend v([expr {$nest -1}]) [set v($nest)] + # incr nest -1 + #} + while {[::tomlish::parse::spacestack size] > 1} { + ::tomlish::parse::spacestack pop + lappend v([expr {$nest -1}]) [set v($nest)] + incr nest -1 + + #set parent [spacestack peek] ;#the level being appended to + #lassign $parent type state + #if {$type eq "space"} { + # + #} elseif {$type eq "buffer"} { + # lappend v([expr {$nest -1}]) {*}[set v($nest)] + #} else { + # error "invalid spacestack item: $parent" + #} + } + + } finally { + set is_parsing 0 + } + return $v(0) + } + + #*** !doctools + #[list_end] [comment {--- end definitions namespace tomlish::decode ---}] +} +#decode toml to tomlish +interp alias {} tomlish::from_toml {} tomlish::decode::toml + +namespace eval tomlish::utils { + #*** !doctools + #[subsection {Namespace tomlish::utils}] + #[para] + #[list_begin definitions] + + + #tablenames (& tablearraynames) may contain irrelevant leading, trailing and interspersed whitespace + # tablenames can be made up of segments delimited by dots. .eg [ a.b . c ] + #trimmed, the tablename becomes {a.b.c} + # A segment may contain whitespace if it is quoted e.g [a . b . "c etc " ] + #ie whitespace is only irrelevant if it's outside a quoted segment + #trimmed, the tablename becomes {a.b."c etc "} + proc tablename_trim {tablename} { + set segments [tablename_split $tablename false] + set trimmed_segments [list] + foreach seg $segments { + lappend trimmed_segments [::string trim $seg " \t"] + } + return [join $trimmed_segments .] + } + + #basic generic quote matching for single and double quotes + #note for example that {[o'malley]} will return sq - as the single quote is not closed or wrapped in double quotes + proc tok_in_quotedpart {tok} { + set sLen [tcl::string::length $tok] + set quote_type "" + set had_slash 0 + for {set i 0} {$i < $sLen} {incr i} { + set c [tcl::string::index $tok $i] + if {$quote_type eq ""} { + if {$had_slash} { + #don't enter quote mode + #leave slash_mode because even if current char is slash - it is escaped + set had_slash 0 + } else { + set ctype [tcl::string::map [list {"} dq {'} sq \\ bsl] $c] + switch -- $ctype { + dq { + set quote_type dq + } + sq { + set quote_type sq + } + bsl { + set had_slash 1 + } + } + } + } else { + if {$had_slash} { + #don't leave quoted mode + #leave slash_mode because even if current char is slash - it is escaped + set had_slash 0 + } else { + set ctype [tcl::string::map [list {"} dq {'} sq \\ bsl] $c] + switch -- $ctype { + dq { + if {$quote_type eq "dq"} { + set quote_type "" + } + } + sq { + if {$quote_type eq "sq"} { + set quote_type "" + } + } + bsl { + set had_slash 1 + } + } + } + } + } + return $quote_type ;#dq | sq + } + + #utils::tablename_split + proc tablename_split {tablename {normalize false}} { + #we can't just split on . because we have to handle quoted segments which may contain a dot. + #eg {dog."tater.man"} + set sLen [tcl::string::length $tablename] + set segments [list] + set mode "unknown" ;#5 modes: unknown, quoted,litquoted, unquoted, syntax + #quoted is for double-quotes, litquoted is for single-quotes (string literal) + set seg "" + for {set i 0} {$i < $sLen} {incr i} { + + if {$i > 0} { + set lastChar [tcl::string::index $tablename [expr {$i - 1}]] + } else { + set lastChar "" + } + + set c [tcl::string::index $tablename $i] + + if {$c eq "."} { + switch -exact -- $mode { + unquoted { + #dot marks end of segment. + lappend segments $seg + set seg "" + set mode "unknown" + } + quoted { + append seg $c + } + unknown { + lappend segments $seg + set seg "" + } + litquoted { + append seg $c + } + default { + #mode: syntax + #we got our dot. - the syntax mode is now satisfied. + set mode "unknown" + } + } + } elseif {($c eq "\"") && ($lastChar ne "\\")} { + if {$mode eq "unknown"} { + if {[tcl::string::trim $seg] ne ""} { + #we don't allow a quote in the middle of a bare key + error "tablename_split. character '\"' invalid at this point in tablename. tablename: '$tablename'" + } + set mode "quoted" + set seg "\"" + } elseif {$mode eq "unquoted"} { + append seg $c + } elseif {$mode eq "quoted"} { + append seg $c + + if {$normalize} { + lappend segments [::tomlish::utils::unescape_string [tcl::string::range $seg 1 end-1]] + } else { + lappend segments $seg + } + + set seg "" + set mode "syntax" ;#make sure we only accept a dot or end-of-data now. + } elseif {$mode eq "litquoted"} { + append seg $c + } elseif {$mode eq "syntax"} { + error "tablename_split. expected whitespace or dot, got double quote. tablename: '$tablename'" + } + } elseif {($c eq "\'")} { + if {$mode eq "unknown"} { + append seg $c + set mode "litquoted" + } elseif {$mode eq "unquoted"} { + #single quote inside e.g o'neill + append seg $c + } elseif {$mode eq "quoted"} { + append seg $c + + } elseif {$mode eq "litquoted"} { + append seg $c + #no normalization to do + lappend segments $seg + set seg "" + set mode "syntax" + } elseif {$mode eq "syntax"} { + error "tablename_split. expected whitespace or dot, got single quote. tablename: '$tablename'" + } + + } elseif {$c in [list " " \t]} { + if {$mode eq "syntax"} { + #ignore + } else { + append seg $c + } + } else { + if {$mode eq "syntax"} { + error "tablename_split. Expected a dot separator. got '$c'. tablename: '$tablename'" + } + if {$mode eq "unknown"} { + set mode "unquoted" + } + append seg $c + } + if {$i == $sLen-1} { + #end of data + ::tomlish::log::debug "End of data: mode='$mode'" + #REVIEW - we can only end up in unquoted or syntax here? are other branches reachable? + switch -exact -- $mode { + quoted { + if {$c ne "\""} { + error "tablename_split. missing closing double-quote in a segment. tablename: '$tablename'" + } + if {$normalize} { + lappend segments [::tomlish::utils::unescape_string [tcl::string::range $seg 1 end-1]] + #lappend segments [subst -nocommands -novariables [::string range $seg 1 end-1]] ;#wrong + } else { + lappend segments $seg + } + } + litquoted { + set trimmed_seg [tcl::string::trim $seg] + if {[tcl::string::index $trimmed_seg end] ne "\'"} { + error "tablename_split. missing closing single-quote in a segment. tablename: '$tablename'" + } + lappend segments $seg + } + unquoted - unknown { + lappend segments $seg + } + syntax { + #ok - segment already lappended + } + default { + lappend segments $seg + } + } + } + } + foreach seg $segments { + set trimmed [tcl::string::trim $seg " \t"] + #note - we explicitly allow 'empty' quoted strings '' & "" + # (these are 'discouraged' but valid toml keys) + #if {$trimmed in [list "''" "\"\""]} { + # puts stderr "tablename_split. warning - Empty quoted string as tablename segment" + #} + if {$trimmed eq "" } { + error "tablename_split. Empty segment found. tablename: '$tablename' segments [llength $segments] ($segments)" + } + } + return $segments + } + + proc unicode_escape_info {slashu} { + #!todo + # validate that slashu is either a \uxxxx or \Uxxxxxxxx value of the correct length and + # is a valid 'unicode scalar value' (any Unicode code point except high-surrogate and low-surrogate code points) + # ie integers in the range 0 to D7FF16 and E00016 to 10FFFF16 inclusive + #expr {(($x >= 0) && ($x <= 0xD7FF16)) || (($x >= 0xE00016) && ($x <= 0x10FFFF16))} + if {[tcl::string::match {\\u*} $slashu]} { + set exp {^\\u([0-9a-fA-F]{4}$)} + if {[regexp $exp $slashu match hex]} { + if {[scan $hex %4x dec] != 1} { + #why would a scan ever fail after matching the regexp? !todo - review. unreachable branch? + return [list err [list reason "Failed to convert '$hex' to decimal"]] + } else { + return [list ok [list char [subst -nocommand -novariable $slashu]]] + } + } else { + return [list err [list reason "Supplied string not of the form \\uHHHH where H in \[0-9a-fA-F\]"]] + } + } elseif {[tcl::string::match {\\U*} $slashu]} { + set exp {^\\U([0-9a-fA-F]{8}$)} + if {[regexp $exp $slashu match hex]} { + if {[scan $hex %8x dec] != 1} { + #why would a scan ever fail after matching the regexp? !todo - review. unreachable branch? + return [list err [list reason "Failed to convert '$hex' to decimal"]] + } else { + if {(($dec >= 0) && ($dec <= 0xD7FF16)) || (($dec >= 0xE00016) && ($dec <= 0x10FFFF16))} { + return [list ok [list char [subst -nocommand -novariable $slashu]]] + } else { + return [list err [list reason "$slashu is not within the 'unicode scalar value' ranges 0 to 0xD7FF16 or 0xE00016 to 0x10FFFF16"]] + } + } + } else { + return [list err [list reason "Supplied string not of the form \\UHHHHHHHH where H in \[0-9a-fA-F\]"]] + } + } else { + return [list err [list reason "Supplied string did not start with \\u or \\U" ]] + } + + } + + #Note that unicode characters don't *have* to be escaped. + #So if we provide a function named 'escape_string', the name implies the inverse of unescape_string which unescapes unicode \u \U values. + #- an inverse of unescape_string would encode all unicode chars unnecessarily. + #- as toml accepts a compact escape sequence for common chars such as tab,backspace,linefeed etc but also allows the full form \u009 etc + #- escape_string and unescape_string would not be reliably roundtrippable inverses anyway. + #REVIEW - provide it anyway? When would it be desirable to use? + + variable Bstring_control_map [list\ + \b {\b}\ + \n {\n}\ + \r {\r}\ + \" {\"}\ + \x1b {\e}\ + \\ "\\\\"\ + ] + #\e for \x1b seems like it might be included - v1.1?? hard to find current state of where toml is going :/ + #for a Bstring (Basic string) tab is explicitly mentioned as not being one that must be escaped. + for {set cdec 0} {$cdec <= 8} {incr cdec} { + set hhhh [format %.4X $cdec] + lappend Bstring_control_map [format %c $cdec] \\u$hhhh + } + for {set cdec [expr {0x0A}]} {$cdec <= 0x1F} {incr cdec} { + set hhhh [format %.4X $cdec] + lappend Bstring_control_map [format %c $cdec] \\u$hhhh + } + # \u007F = 127 + lappend Bstring_control_map [format %c 127] \\u007F + + #Note the inclusion of backslash in the list of controls makes this non idempotent - subsequent runs would keep encoding the backslashes! + #escape only those chars that must be escaped in a Bstring (e.g not tab which can be literal or escaped) + #for example - can be used by from_dict to produce valid Bstring data for a tomlish record + proc rawstring_to_Bstring_with_escaped_controls {str} { + #for the well known chars that have compact escape sequences allowed by toml - we choose that form over the full \u form. + #we'll use a string map with an explicit list rather than algorithmic at runtime + # - the string map is probably more performant than splitting a string, especially if it's large + variable Bstring_control_map + return [string map $Bstring_control_map $str] + } + + #review - unescape what string? Bstring vs MLBstring? + #we should be specific in the function naming here + #used by to_dict - so part of validation? - REVIEW + proc unescape_string {str} { + #note we can't just use Tcl subst because: + # it also transforms \a (audible bell) and \v (vertical tab) which are not in the toml spec. + # it would strip out backslashes inappropriately: e.g "\j" becomes just j + # it recognizes other escapes which aren't approprite e.g \xhh and octal \nnn + # it replaces \ with a single whitespace (trailing backslash) + #This means we shouldn't use 'subst' on the whole string, but instead substitute only the toml-specified escapes (\r \n \b \t \f \\ \" \uhhhh & \Uhhhhhhhh + + set buffer "" + set buffer4 "" ;#buffer for 4 hex characters following a \u + set buffer8 "" ;#buffer for 8 hex characters following a \u + + set sLen [tcl::string::length $str] + + #we need to handle arbitrarily long sequences of backslashes. \\\\\ etc + set slash_active 0 + set unicode4_active 0 + set unicode8_active 0 + + ::tomlish::log::debug "unescape_string. got len [string length str] str $str" + + #!todo - check for invalid data in the form of a raw carriage return (decimal 13) without following linefeed? + set i 0 + for {} {$i < $sLen} {} { + if {$i > 0} { + set lastChar [tcl::string::index $str [expr {$i - 1}]] + } else { + set lastChar "" + } + + set c [tcl::string::index $str $i] + #::tomlish::log::debug "unescape_string. got char $c" ;#too much? + + #---------------------- + #as we are 'unescaping' - should we really be testing for existing values that should have been escaped? + #this test looks incomplete anyway REVIEW + scan $c %c n + if {($n <= 31) && ($n != 9) && ($n != 10) && ($n != 13)} { + #we don't expect unescaped unicode characters from 0000 to 001F - + #*except* for raw tab (which is whitespace) and newlines + error "unescape_string. Invalid data for a toml string. Unescaped control character (decimal $n) [::tomlish::utils::string_to_slashu $c]" + } + #---------------------- + + incr i ;#must incr here because we do'returns'inside the loop + if {$c eq "\\"} { + if {$slash_active} { + append buffer "\\" + set slash_active 0 + } elseif {$unicode4_active} { + error "unescape_string. unexpected case slash during unicode4 not yet handled" + } elseif {$unicode8_active} { + error "unescape_string. unexpected case slash during unicode8 not yet handled" + } else { + # don't output anything (yet) + set slash_active 1 + } + } else { + if {$unicode4_active} { + if {[tcl::string::length $buffer4] < 4} { + append buffer4 $c + } + if {[tcl::string::length $buffer4] == 4} { + #we have a \uHHHH to test + set unicode4_active 0 + set result [tomlish::utils::unicode_escape_info "\\u$buffer4"] + if {[lindex $result 0] eq "ok"} { + append buffer [dict get $result ok char] + } else { + error "unescape_string error: [lindex $result 1]" + } + } + } elseif {$unicode8_active} { + if {[tcl::string::length $buffer8] < 8} { + append buffer8 $c + } + if {[tcl::string::length $buffer8] == 8} { + #we have a \UHHHHHHHH to test + set unicode8_active 0 + set result [tomlish::utils::unicode_escape_info "\\U$buffer8"] + if {[lindex $result 0] eq "ok"} { + append buffer [dict get $result ok char] + } else { + error "unescape_string error: [lindex $result 1]" + } + } + } elseif {$slash_active} { + set slash_active 0 + set ctest [tcl::string::map {{"} dq} $c] + switch -exact -- $ctest { + dq { + set e "\\\"" + append buffer [subst -nocommand -novariable $e] + } + b - t - n - f - r { + set e "\\$c" + append buffer [subst -nocommand -novariable $e] + } + u { + set unicode4_active 1 + set buffer4 "" + } + U { + set unicode8_active 1 + set buffer8 "" + } + default { + set slash_active 0 + #review - toml spec says all other escapes are reserved + #and if they are used TOML should produce an error. + #we leave detecting this for caller for now - REVIEW + append buffer "\\" + append buffer $c + } + } + } else { + append buffer $c + } + } + } + #puts stdout "EOF 4:$unicode4_active 8:$unicode8_active slash:$slash_active" + if {$unicode4_active} { + error "End of string reached before complete unicode escape sequence \uHHHH" + } + if {$unicode8_active} { + error "End of string reached before complete unicode escape sequence \UHHHHHHHH" + } + if {$slash_active} { + append buffer "\\" + } + return $buffer + } + + #This does not have to do with unicode normal forms - which it seems toml has decided against regarding use in keys (review/references?) + #This is meant for internal use regarding ensuring we match equivalent keys which may have just been specified with different string mechanisms, + #e.g squoted vs dquoted vs barekey. + proc normalize_key {rawkey} { + set c1 [tcl::string::index $rawkey 0] + set c2 [tcl::string::index $rawkey end] + if {($c1 eq "'") && ($c2 eq "'")} { + #single quoted segment. No escapes allowed within it. + set key [tcl::string::range $rawkey 1 end-1] + } elseif {($c1 eq "\"") && ($c2 eq "\"")} { + #double quoted segment. Apply escapes. + # + set keydata [tcl::string::range $rawkey 1 end-1] ;#strip outer quotes only + #e.g key could have mix of \UXXXXXXXX escapes and unicode chars + #or mix of \t and literal tabs. + #unescape to convert all to literal versions for comparison + set key [::tomlish::utils::unescape_string $keydata] + #set key [subst -nocommands -novariables $keydata] ;#wrong. Todo - create a string escape substitution function. + } else { + set key $rawkey + } + return $key + } + + proc string_to_slashu {string} { + set rv {} + foreach c [split $string {}] { + scan $c %c cdec + if {$cdec > 65535} { + append rv {\U} [format %.8X $cdec] + } else { + append rv {\u} [format %.4X $cdec] + } + } + return $rv + } + + #'nonprintable' is conservative here because some systems (e.g windows console) are very limited in what they can display. + #This is used for display purposes only (error msgs) + proc nonprintable_to_slashu {s} { + set res "" + foreach i [split $s ""] { + scan $i %c cdec + + set printable 0 + if {($cdec>31) && ($cdec<127)} { + set printable 1 + } + if {$printable} { + append res $i + } else { + if {$cdec > 65535} { + append res \\U[format %.8X $cdec] + } else { + append res \\u[format %.4X $cdec] + } + } + } + set res + } ;# initial version from tcl wiki RS + + #check if str is valid for use as a toml bare key + #Early toml versions? only allowed letters + underscore + dash + proc is_barekey1 {str} { + if {[tcl::string::length $str] == 0} { + return 0 + } else { + set matches [regexp -all {[a-zA-Z0-9\_\-]} $str] + if {[tcl::string::length $str] == $matches} { + #all characters match the regexp + return 1 + } else { + return 0 + } + } + } + + #from toml.abnf in github.com/toml-lang/toml + #unquoted-key = 1*unquoted-key-char + #unquoted-key-char = ALPHA / DIGIT / %x2D / %x5F ; a-z A-Z 0-9 - _ + #unquoted-key-char =/ %xB2 / %xB3 / %xB9 / %xBC-BE ; superscript digits, fractions + #unquoted-key-char =/ %xC0-D6 / %xD8-F6 / %xF8-37D ; non-symbol chars in Latin block + #unquoted-key-char =/ %x37F-1FFF ; exclude GREEK QUESTION MARK, which is basically a semi-colon + #unquoted-key-char =/ %x200C-200D / %x203F-2040 ; from General Punctuation Block, include the two tie symbols and ZWNJ, ZWJ + #unquoted-key-char =/ %x2070-218F / %x2460-24FF ; include super-/subscripts, letterlike/numberlike forms, enclosed alphanumerics + #unquoted-key-char =/ %x2C00-2FEF / %x3001-D7FF ; skip arrows, math, box drawing etc, skip 2FF0-3000 ideographic up/down markers and spaces + #unquoted-key-char =/ %x2070-21FF / %x2300-24FF ; skip math operators + #unquoted-key-char =/ %x25A0-268B / %x2690-2757 ; skip box drawing, block elements, and some yin-yang symbols + #unquoted-key-char =/ %x2762-2767 / %x2776-27E5 ; skip some Dingbat punctuation + #unquoted-key-char =/ %x2801-297F ; skip some math brackets and arrows, and braille blank + #unquoted-key-char =/ %x2B00-2FFF / %x3001-D7FF ; skip various math operators and symbols, and ideographic space + #unquoted-key-char =/ %xF900-FDCF / %xFDF0-FFFD ; skip D800-DFFF surrogate block, E000-F8FF Private Use area, FDD0-FDEF intended for process-internal use (unicode) + #unquoted-key-char =/ %x10000-EFFFF ; all chars outside BMP range, excluding Private Use planes (F0000-10FFFF) + variable re_barekey + set ranges [list] + lappend ranges {a-zA-Z0-9\_\-} + lappend ranges {\u00B2} {\u00B3} {\u00B9} {\u00BC-\u00BE} ;# superscript digits, fractions + lappend ranges {\u00C0-\u00D6} {\u00D8-\u00F6} {\u00F8-\u037D} ;# non-symbol chars in Latin block + lappend ranges {\u037f-\u1FFF} ;# exclude GREEK QUESTION MARK, which is basically a semi-colon + lappend ranges {\u200C-\u200D} {\u203F-\u2040} ;# from General Punctuation Block, include the two tie symbols and ZWNJ, ZWJ + lappend ranges {\u2070-\u218f} {\u2460-\u24FF} ;# include super-subscripts, letterlike/numberlike forms, enclosed alphanumerics + lappend ranges {\u2C00-\u2FEF} {\u3001-\uD7FF} ;# skip arrows, math, box drawing etc, skip 2FF0-3000 ideographic up/down markers and spaces + lappend ranges {\u2070-\u21FF} {\u2300-\u24FF} ;# skip math operators + lappend ranges {\u25A0-\u268B} {\u2690-\u2757} ;# skip box drawing, block elements, and some yin-yang symbols + lappend ranges {\u2762-\u2767} {\u2776-\u27E5} ;# skip some Dingbat punctuation + lappend ranges {\u2801-\u297F} ;# skip some math brackets and arrows, and braille blank + lappend ranges {\u2B00-\u2FFF} {\u3001-\uD7FF} ;# skip various math operators and symbols, and ideographic space + lappend ranges {\uF900-\uFDCF} {\uFDF0-\uFFFD} ;# skip D800-DFFF surrogate block, E000-F8FF Private Use area, FDD0-FDEF intended for process-internal use (unicode) + lappend ranges {\U10000-\UEFFFF} ;# all chars outside BMP range, excluding Private Use planes (F0000-10FFFF) + set re_barekey {^[} + foreach r $ranges { + append re_barekey $r + } + append re_barekey {]+$} + + proc is_barekey {str} { + if {[tcl::string::length $str] == 0} { + return 0 + } + variable re_barekey + return [regexp $re_barekey $str] + } + + #test only that the characters in str are valid for the toml specified type 'integer'. + proc int_validchars1 {str} { + set numchars [tcl::string::length $str] + if {[regexp -all {[0-9\_\-\+]} $str] == $numchars} { + return 1 + } else { + return 0 + } + } + #add support for hex,octal,binary 0x.. 0o.. 0b... + proc int_validchars {str} { + set numchars [tcl::string::length $str] + if {[regexp -all {[0-9\_xo\-\+A-Fa-f]} $str] == $numchars} { + return 1 + } else { + return 0 + } + } + + proc is_int {str} { + set matches [regexp -all {[0-9\_xo\-\+A-Fa-f]} $str] ;#0b101 etc covered by a-f + + if {[tcl::string::length $str] == $matches} { + #all characters in legal range + + # --------------------------------------- + #check for leading zeroes in non 0x 0b 0o + #first strip any +, - or _ (just for this test) + #(but still allowing 0 -0 +0) + set check [tcl::string::map {+ "" - "" _ ""} $str] + if {([tcl::string::length $check] > 1) && ([tcl::string::index $check 0] eq "0") && ([tcl::string::index $check 1] ni {o x b})} { + return 0 + } + # --------------------------------------- + + #check +,- only occur in the first position. (excludes also +++1 etc) + if {[tcl::string::last - $str] > 0} { + return 0 + } + if {[tcl::string::last + $str] > 0} { + return 0 + } + + #------------------------------------------- + #unclear if a 'digit' includes the type specifiers x b o + #we assume the 0x 0b 0o are NOT counted as digits - as underscores here would seem + #to be likely to cause interop issues with other systems + #(e.g tcl allows 0b1_1 but not 0b_11) + #Most of this structure would be unnecessary if we could rely on string::is::integer understanding underscores (9+?) + #we still need to support earlier Tcl for now though. + + #first rule out any case with more than one underscore in a row + if {[regexp {__} $str]} { + return 0 + } + if {[string index $str 0] eq "_"} { + return 0 + } + set utest [string trimleft $str +-] + #test again for further trick like _+_0xFF + if {[string index $utest 0] eq "_"} { + return 0 + } + if {[string range $utest 0 1] in {0x 0b 0o}} { + set testnum [string range $utest 2 end] + } else { + set testnum $utest + #exclude also things like 0_x 0___b that snuck past our prefix test + if {![string is digit -strict [string map {_ ""} $testnum]]} { + return 0 + } + #assert - only digits and underscores in testnum + #still may have underscores at each end + } + #assert testnum is now the 'digits' portion of a , 0x 0b 0o number + #(+ and - already stripped) + #It may still have chars unsuitable for its type - which will be caught by the string::is::integer test below + if {[string length $testnum] != [string length [string trim $testnum _]]} { + #had non-inner underscores in 'digit' part + return 0 + } + #assert str only has solo inner underscores (if any) between 'digits' + #------------------------------------------- + + set numeric_value [tcl::string::map {_ ""} $str] ;#allow some earlier tcl versions which don't support underscores + #use Tcl's integer check to ensure we don't let things like 3e4 through - which is a float (would need to be 0x3e4 for hex) + if {![tcl::string::is integer -strict $numeric_value]} { + return 0 + } + #!todo - check bounds only based on some config value + #even though Tcl can handle bignums, we won't accept anything outside of toml 1.0 minimum requirements. + #presumably very large numbers would have to be supplied in a toml file as strings. + #Review - toml 1.0 only says that it must handle up to 2^63 - not that this is a max + if {$numeric_value > $::tomlish::max_int} { + return 0 + } + if {$numeric_value < $::tomlish::min_int} { + return 0 + } + } else { + return 0 + } + #Got this far - didn't find anything wrong with it. + return 1 + } + + #test only that the characters in str are valid for the toml specified type 'float'. + proc float_validchars {str} { + set numchars [tcl::string::length $str] + if {[regexp -all {[eE0-9\_\-\+\.]} $str] == $numchars} { + return 1 + } else { + #only allow lower case for these special values - as per Toml 1.0 spec + if {$str ni {inf +inf -inf nan +nan -nan}} { + return 0 + } else { + return 1 + } + } + } + + #note - Tcl's string is double will return true also for the subset of float values which are integers + #This function is to determine whether it matches the Toml float concept - so requires a . or e or E + proc is_float {str} { + #vip greenlight known literals, don't test for case variations - as Toml doesn't allow (whereas Tcl allows Inf NaN etc) + if {$str in {inf +inf -inf nan +nan -nan}} { + return 1 + } + #doorcheck the basics for floatiness vs members of that rival gang - ints + if {![regexp {[.eE]} $str]} { + #could be an integer - which isn't specifically a float for Toml purposes. + return 0 + } + + + #patdown for any contraband chars + set matches [regexp -all {[eE0-9\_\-\+\.]} $str] + if {[tcl::string::length $str] != $matches} { + return 0 + } + + #all characters in legal range + + #A leading zero is ok, but we should disallow multiple leading zeroes (same rules as toml ints) + + #Early Toml spec also disallowed leading zeros in the exponent part(?) + #... this seems less interoperable anyway (some libraries generate leading zeroes in exponents) + #we allow leading zeros in exponents here. + + #Check for leading zeros in main part + #first strip any +, - or _ (just for this test) + set check [tcl::string::map {+ "" - "" _ ""} $str] + set r {([0-9])*} + regexp $r $check intpart ;#intpart holds all numerals before the first .,e or E + set z {([0])*} + regexp $z $intpart leadingzeros + if {[tcl::string::length $leadingzeros] > 1} { + return 0 + } + + #for floats, +,- may occur in multiple places + #e.g -2E-22 +3e34 + #!todo - check bounds ? + + #----------------------------------------- + if {[regexp {__} $str]} { + return 0 + } + if {[string index $str 0] eq "_" || [string index $str end] eq "_"} { + return 0 + } + set utest [string trimleft $str +-] + #test again for further trick like _+_ + if {[string index $utest 0] eq "_"} { + return 0 + } + #----------------------------------------- + + #decimal point, if used must be surrounded by at least one digit on each side + #e.g 3.e+20 also illegal + set dposn [string first . $str] + if {$dposn > -1 } { + set d3 [string range $str $dposn-1 $dposn+1] + if {![string is integer -strict [string index $d3 0]] || ![string is integer -strict [string index $d3 2]]} { + return 0 + } + } + #we've already eliminated leading/trailing underscores + #now ensure each inner underscore is surrounded by digits + if {[regexp {_[^0-9]|[^0-9]_} $str]} { + return 0 + } + + #strip underscores for tcl double check so we can support < tcl 9 versions which didn't allow underscores + set check [tcl::string::map {_ ""} $str] + #string is double accepts inf nan +NaN etc. + if {![tcl::string::is double $check]} { + return 0 + } + + #All good - seems to be a toml-approved float and not an int. + return 1 + } + + #test only that the characters in str are valid for the toml specified type 'datetime'. + proc datetime_validchars {str} { + set numchars [tcl::string::length $str] + if {[regexp -all {[zZtT0-9\-\+\.:]} $str] == $numchars} { + return 1 + } else { + return 0 + } + } + + #review - we + proc is_datetime {str} { + #e.g 1979-05-27 + #e.g 1979-05-27T00:32:00Z + #e.g 1979-05-27 00:32:00-07:00 + #e.g 1979-05-27 00:32:00+10:00 + #e.g 1979-05-27 00:32:00.999999-07:00 + + #review + #minimal datetimes? + # 2024 ok - shortest valid 4 digit year? + # 02:00 ok + # 05-17 ok + if {[string length $str] < 4} { + return 0 + } + + set matches [regexp -all {[zZtT0-9\-\+\.:]} $str] + if {[tcl::string::length $str] == $matches} { + #all characters in legal range + #!todo - use full RFC 3339 parser? + lassign [split $str T] datepart timepart + #!todo - what if the value is 'time only'? + + #Tcl's free-form clock scan (no -format option) is deprecated + # + #if {[catch {clock scan $datepart} err]} { + # puts stderr "tcl clock scan failed err:'$err'" + # return 0 + #} + + #!todo - verify time part is reasonable + } else { + return 0 + } + return 1 + } + + + #*** !doctools + #[list_end] [comment {--- end definitions namespace tomlish::utils ---}] +} + +namespace eval tomlish::parse { + #*** !doctools + #[subsection {Namespace tomlish::parse}] + #[para] + #[list_begin definitions] + + #This is a somewhat curly mix of a statemachine and toml-nesting-stack littered with special cases. + #The code is a pig's-nest - but it should be noted that for example trailing single double quotes in multiline strings are perhaps not so trivial to parse using more standard methods either: + # - e.g some kind of backtracking required if using an ABNF parser? + #I don't know the precise technical name for this sort of parser; probably something like "Dog's Breakfast" + #More seriously, we don't have distinct lex/parse steps - so it is basically a 'fused lexer' or 'scannerless parser' + + #It is also desirable for this system to be useful in 'interactive' use. review - would a separate lexer make this easier or harder? + + #A possible alternative more structured approach might be to use a PEG (Parsing Expression Grammar) + + + variable is_parsing 0 ;#whether we are in the middle of parsing tomlish text + + variable state + # states: + # table-space, itable-space, array-space + # array-value-expected,keyval-value-expected,itable-keyval-value-expected, keyval-syntax, + # quoted-key, squoted-key + # string-state, literal-state, multistring... + # + # notes: + # only the -space states are also 'spaces' ie a container which is pushed/popped on the spacestack + + # + # xxx_value-expected - we also allow for leading whitespace in this state, but once a value is returned we jump to a state based on the containing space. e.g keyval-tail or array-syntax + # + #stateMatrix defines for each state, actions to take for each possible token. + #single-element actions are the name of the next state into which to transition, or a 'POPSPACE' instruction to pop a level off the spacestack and add the data to the parent container. + #dual-element actions are a push instruction and the name of the space to push on the stack. + # - PUSHSPACE is a simple push onto the spacestack, zeropoppushspace also pushes, but will first do a pop *if* the current space level is greater than zero (ie if only if not already in root table-space) + + # -- --- --- --- --- --- + #token/state naming guide + # -- --- --- --- --- --- + #tokens : underscore separated or bare name e.g newline, start_quote, start_squote + #private tokens: always have a leading underscore (These are private 'temporary state' tokens that are never returned as actual tokens e.g _start_squote_sequence + #states : always contain at least one dash e.g err-state, table-space + #instructions + # -- --- --- --- --- --- + + + #stateMatrix dict of elements mapping current state to next state based on returned tokens + # current-state {token-encountered next-state ... } + # where next-state can be a 1 or 2 element list. + #If 2 element - the first item is an instruction (ucase) + #If 1 element - it is either a lowercase dashed state name or an ucase instruction + #e.g {PUSHSPACE } or POPSPACE or SAMESPACE + + + #SAMESPACE - got to same space as parent without popping a level, but has it's own autotransition lookup - strange concept - review usecases + + variable stateMatrix + set stateMatrix [dict create] + + #xxx-space vs xxx-syntax inadequately documented - TODO + + #review - out of date? + # --------------------------------------------------------------------------------------------------------------# + # incomplete example of some state starting at table-space + # --------------------------------------------------------------------------------------------------------------# + # ( = -> keyval-value-expected) + # keyval-syntax (popped -> keyval-space -> keyval-tail) (autotransition on pop) + # keyval-space (autotransition on push ^) + # table-space (barekey^) (startdquote -> dquoted-key ^) + # --------------------------------------------------------------------------------------------------------------# + + dict set stateMatrix\ + table-space { + bom "table-space"\ + whitespace "table-space"\ + newline "table-space"\ + barekey {PUSHSPACE "keyval-space" state "keyval-syntax"}\ + squotedkey {PUSHSPACE "keyval-space" state "keyval-syntax" note ""}\ + dquotedkey {PUSHSPACE "keyval-space" state "keyval-syntax"}\ + XXXstartquote "quoted-key"\ + XXXstartsquote "squoted-key"\ + comment "table-space"\ + starttablename "tablename-state"\ + starttablearrayname "tablearrayname-state"\ + startmultiquote "err-state"\ + endquote "err-state"\ + comma "err-state"\ + eof "end-state"\ + equal "err-state"\ + cr "err-lonecr"\ + } + + #itable-space/ curly-syntax : itables + dict set stateMatrix\ + itable-space {\ + whitespace "itable-space"\ + newline "itable-space"\ + barekey {PUSHSPACE "itable-keyval-space" state "itable-keyval-syntax"}\ + squotedkey {PUSHSPACE "itable-keyval-space" state "itable-keyval-syntax"}\ + dquotedkey {PUSHSPACE "itable-keyval-space" state "itable-keyval-syntax"}\ + endinlinetable "POPSPACE"\ + XXXstartquote "quoted-key"\ + XXXstartsquote {TOSTATE "squoted-key" comment "jn-testing"}\ + comma "err-state"\ + comment "itable-space"\ + eof "err-state"\ + } + #squote_seq_begin {PUSHSPACE "leading-squote-space" returnstate itable-space starttok {squote_seq "'"}} + + + dict set stateMatrix\ + keyval-space {\ + whitespace "keyval-syntax"\ + equal "keyval-value-expected"\ + } + + # ' = ' portion of keyval + dict set stateMatrix\ + keyval-syntax {\ + whitespace "keyval-syntax"\ + barekey {PUSHSPACE "dottedkey-space"}\ + squotedkey {PUSHSPACE "dottedkey-space"}\ + dquotedkey {PUSHSPACE "dottedkey-space"}\ + equal "keyval-value-expected"\ + comma "err-state"\ + newline "err-state"\ + eof "err-state"\ + } + #### + dict set stateMatrix\ + keyval-value-expected {\ + whitespace "keyval-value-expected"\ + untyped_value {TOSTATE "keyval-tail" note ""}\ + startquote {TOSTATE "string-state" returnstate keyval-tail}\ + startmultiquote {PUSHSPACE "multistring-space" returnstate keyval-tail}\ + squote_seq_begin {PUSHSPACE "leading-squote-space" returnstate keyval-value-expected starttok {squote_seq "'"}}\ + startsquote {TOSTATE "literal-state" returnstate keyval-tail note "usual way a literal is triggered"}\ + double_squote {TOSTATE "keyval-tail" note "empty literal received when double squote occurs"}\ + triple_squote {PUSHSPACE "multiliteral-space" returnstate keyval-tail}\ + startinlinetable {PUSHSPACE itable-space returnstate keyval-tail}\ + startarray {PUSHSPACE array-space returnstate keyval-tail}\ + } + #squote_seq_begin {PUSHSPACE "leading-squote-space" returnstate keyval-process-leading-squotes starttok {squote_seq "'"}} + dict set stateMatrix\ + leading-squote-space {\ + squote_seq "POPSPACE"\ + } + #dict set stateMatrix\ + # keyval-process-leading-squotes {\ + # startsquote "literal-state"\ + # triple_squote {PUSHSPACE "multiliteral-space" returnstate keyval-tail}\ + # } + + dict set stateMatrix\ + keyval-tail {\ + whitespace "keyval-tail"\ + newline "POPSPACE"\ + comment "keyval-tail"\ + eof "end-state"\ + } + + dict set stateMatrix\ + itable-keyval-syntax {\ + whitespace "itable-keyval-syntax"\ + barekey {PUSHSPACE "dottedkey-space"}\ + squotedkey {PUSHSPACE "dottedkey-space"}\ + dquotedkey {PUSHSPACE "dottedkey-space"}\ + equal "itable-keyval-value-expected"\ + newline "err-state"\ + eof "err-state"\ + } + dict set stateMatrix\ + itable-keyval-value-expected {\ + whitespace "itable-keyval-value-expected"\ + untyped_value {TOSTATE "itable-val-tail" note ""}\ + startquote {TOSTATE "string-state" returnstate itable-val-tail}\ + startmultiquote {PUSHSPACE "multistring-space" returnstate itable-val-tail}\ + squote_seq_begin {PUSHSPACE "leading-squote-space" returnstate itable-keyval-value-expected starttok {squote_seq "'"}}\ + startsquote {TOSTATE "literal-state" returnstate itable-val-tail note "usual way a literal is triggered"}\ + double_squote {TOSTATE "itable-val-tail" note "empty literal received when double squote occurs"}\ + triple_squote {PUSHSPACE "multiliteral-space" returnstate itable-val-tail}\ + startinlinetable {PUSHSPACE "itable-space" returnstate itable-val-tail}\ + startarray {PUSHSPACE "array-space" returnstate itable-val-tail}\ + } + dict set stateMatrix\ + itable-keyval-space {\ + whitespace "itable-keyval-syntax"\ + equal {TOSTATE "itable-keyval-value-expected" note "required"}\ + } + + dict set stateMatrix\ + itable-val-tail {\ + whitespace "itable-val-tail"\ + endinlinetable "POPSPACE"\ + comma "POPSPACE"\ + XXXnewline {TOSTATE "itable-val-tail" note "itable-space ??"}\ + newline "POPSPACE"\ + comment "itable-val-tail"\ + eof "err-state"\ + } + #dict set stateMatrix\ + # itable-quoted-key {\ + # whitespace "NA"\ + # itablequotedkey {PUSHSPACE "itable-keyval-space"}\ + # newline "err-state"\ + # endquote "itable-keyval-syntax"\ + # } + #dict set stateMatrix\ + # itable-squoted-key {\ + # whitespace "NA"\ + # itablesquotedkey {PUSHSPACE "itable-keyval-space"}\ + # newline "err-state"\ + # endsquote "itable-keyval-syntax"\ + # } + + + + + #array-value-expected ? + dict set stateMatrix\ + XXXvalue-expected {\ + whitespace "value-expected"\ + untyped_value {"SAMESPACE" "" replay untyped_value}\ + startquote "string-state"\ + startsquote "literal-state"\ + triple_squote {PUSHSPACE "multiliteral-space"}\ + startmultiquote {PUSHSPACE "multistring-space"}\ + startinlinetable {PUSHSPACE itable-space}\ + startarray {PUSHSPACE array-space}\ + comment "err-state-value-expected-got-comment"\ + comma "err-state"\ + newline "err-state"\ + eof "err-state"\ + } + #note comment token should never be delivered to array-value-expected state? + + #dottedkey-space is not (currently) used within [tablename] or [[tablearrayname]] + #it is for keyval ie x.y.z = value + + #this is the state after dot + #we are expecting a complete key token or whitespace + #(initial entry to the space is by one of the keys - which will immediately go to dottedkey-space-tail) + dict set stateMatrix\ + dottedkey-space {\ + whitespace "dottedkey-space"\ + dotsep "err-state"\ + barekey "dottedkey-space-tail"\ + squotedkey "dottedkey-space-tail"\ + dquotedkey "dottedkey-space-tail"\ + newline "err-state"\ + comma "err-state"\ + comment "err-state"\ + equal "err-state"\ + } + #dottedkeyend "POPSPACE" + #equal "POPSPACE"\ + + #jmn 2025 + #we have 1 or more dottedkeys so far - need dotsep to add more, whitespace to maintain, equal to pop + dict set stateMatrix\ + dottedkey-space-tail {\ + whitespace "dottedkey-space-tail" + dotsep "dottedkey-space" + equal "POPSPACE"\ + } + + #-------------------------------------------------------------------------- + #scratch area + #from_toml {x=1} + # barekey tok + # table-space PUSHSPACE keyval-space state keyval-syntax + # + + + #-------------------------------------------------------------------------- + + + #REVIEW + #toml spec looks like heading towards allowing newlines within inline tables + #https://github.com/toml-lang/toml/issues/781 + + #2025 - appears to be valid for 1.1 - which we are targeting. + #https://github.com/toml-lang/toml/blob/main/toml.md#inline-table + + #JMN2025 + #dict set stateMatrix\ + # curly-syntax {\ + # whitespace "curly-syntax"\ + # newline "curly-syntax"\ + # barekey {PUSHSPACE "itable-keyval-space"}\ + # itablequotedkey "itable-keyval-space"\ + # endinlinetable "POPSPACE"\ + # startquote "itable-quoted-key"\ + # comma "itable-space"\ + # comment "itable-space"\ + # eof "err-state"\ + # } + #review comment "err-state" vs comment "itable-space" - see if TOML 1.1 comes out and allows comments in multiline ITABLES + #We currently allow multiline ITABLES (also with comments) in the tokenizer. + #if we want to disallow as per TOML 1.0 - we should do so when attempting to get structure? + + + #JMN REVIEW + #dict set stateMatrix\ + # array-space {\ + # whitespace "array-space"\ + # newline "array-space"\ + # untyped_value "SAMESPACE"\ + # startarray {PUSHSPACE "array-space"}\ + # endarray "POPSPACE"\ + # startmultiquote {PUSHSPACE multistring-space}\ + # startinlinetable {PUSHSPACE itable-space}\ + # startquote "string-state"\ + # startsquote "literal-state"\ + # triple_squote {PUSHSPACE "multiliteral-space" returnstate array-syntax note "seems ok 2024"}\ + # comma "array-space"\ + # comment "array-space"\ + # eof "err-state-array-space-got-eof"\ + # } + + ## array-space ## + set aspace [dict create] + dict set aspace whitespace "array-space" + dict set aspace newline "array-space" + dict set aspace untyped_value "SAMESPACE" + dict set aspace startarray {PUSHSPACE "array-space"} + dict set aspace endarray "POPSPACE" + dict set aspace startmultiquote {PUSHSPACE multistring-space} + dict set aspace startinlinetable {PUSHSPACE itable-space} + dict set aspace startquote "string-state" + dict set aspace startsquote "literal-state" + dict set aspace triple_squote {PUSHSPACE "multiliteral-space" returnstate array-syntax note "seems ok 2024"} + dict set aspace comma "array-space" + dict set aspace comment "array-space" + dict set aspace eof "err-state-array-space-got-eof" + dict set stateMatrix array-space $aspace + + #when we pop from an inner array we get to array-syntax + #e.g {x=[[]] ??? + set tarntail [dict create] + dict set tarntail whitespace "tablearrayname-tail" + dict set tarntail newline "err-state" + dict set tarntail comment "err-state" + dict set tarntail eof "err-state" + dict set tarntail endtablename "tablearray-tail" + dict set stateMatrix tablearrayname-tail $tarntail + + #review - somewhat counterintuitive...? + # [(starttablearrayname) (endtablearrayname] + # [(starttablename) (endtablename)] + + # [[xxx]] ??? + set tartail [dict create] + dict set tartail whitespace "tablearray-tail" + dict set tartail newline "table-space" + dict set tartail comment "tablearray-tail" + dict set tartail eof "end-state" + dict set stateMatrix tablearray-tail $tartail + + + + + + + dict set stateMatrix\ + end-state {} + + set knowntokens [list] + set knownstates [list] + dict for {state transitions} $stateMatrix { + if {$state ni $knownstates} {lappend knownstates $state} + dict for {tok instructions} $transitions { + if {$tok ni $knowntokens} {lappend knowntokens $tok} + } + } + dict set stateMatrix nostate {} + foreach tok $knowntokens { + dict set stateMatrix nostate $tok "err-nostate-received-token-$tok" + } + + + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + #purpose - debugging? remove? + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + #build a list of 'push triggers' from the stateMatrix + # ie tokens which can push a new space onto spacestack + set push_trigger_tokens [list] + tcl::dict::for {s transitions} $stateMatrix { + tcl::dict::for {token transition_to} $transitions { + set instruction [lindex $transition_to 0] + switch -exact -- $instruction { + PUSHSPACE - zeropoppushspace { + if {$token ni $push_trigger_tokens} { + lappend push_trigger_tokens $token + } + } + } + } + } + ::tomlish::log::debug "push_trigger_tokens: $push_trigger_tokens" + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + + + + #This seems hacky... (deprecate in favour of explicit arguments to the instructions in stateMatrix?) + #spacePopTransitions, spacePushTransitions, spaceSameTransitions below for auto state redirections on POPSPACE,PUSHSPACE,SAMESPACE + + #mainly for the -space states: + #redirect to another state $c based on a state transition from $whatever to $b + # e.g "string {array-space array-syntax}" means when transitioning from string to array-space, jump to array-syntax instead. + #this is useful as we often don't know state $b. e.g when it is decided by 'POPSPACE' + + #use dict set to add values so we can easily add/remove/comment lines + + #Push to, next + #default first states when we push to these spaces + variable spacePushTransitions [dict create] + dict set spacePushTransitions keyval-space keyval-syntax + dict set spacePushTransitions itable-keyval-space itable-keyval-syntax + dict set spacePushTransitions array-space array-space + dict set spacePushTransitions table-space tablename-state + dict set spacePushTransitions #itable-space itable-space + + #Pop to, next + variable spacePopTransitions [dict create] + dict set spacePopTransitions array-space array-syntax + + + #itable-space curly-syntax + #itable-keyval-space itable-val-tail + #review + #we pop to keyval-space from dottedkey-space or from keyval-value-expected? we don't always want to go to keyval-tail + #leave it out and make the POPSPACE caller explicitly specify it + #keyval-space keyval-tail + + variable spaceSameTransitions [dict create] + #JMN test + #dict set spaceSameTransitions array-space array-syntax + + #itable-space curly-syntax + #itable-keyval-space itable-val-tail + + + variable state_list ;#reset every tomlish::decode::toml + + namespace export tomlish toml + namespace ensemble create + + #goNextState has various side-effects e.g pushes and pops spacestack + #REVIEW - setting nest and v elements here is ugly + #todo - make neater, more single-purpose? + proc goNextState {tokentype tok currentstate} { + variable state + variable nest + variable v + + set prevstate $currentstate + + + variable spacePopTransitions + variable spacePushTransitions + variable spaceSameTransitions + + variable last_space_action "none" + variable last_space_type "none" + variable state_list + + set result "" + set starttok "" + + if {[dict exists $::tomlish::parse::stateMatrix $currentstate $tokentype]} { + set transition_to [dict get $::tomlish::parse::stateMatrix $currentstate $tokentype] + ::tomlish::log::debug "--->> goNextState tokentype:$tokentype tok:$tok currentstate:$currentstate : transition_to = $transition_to" + switch -exact -- [lindex $transition_to 0] { + POPSPACE { + spacestack pop + set parent_info [spacestack peek] + set type [dict get $parent_info type] + set parentspace [dict get $parent_info state] + + set last_space_action "pop" + set last_space_type $type + + if {[dict exists $parent_info returnstate]} { + set next [dict get $parent_info returnstate] + #clear the returnstate on current level + set existing [spacestack pop] + dict unset existing returnstate + spacestack push $existing ;#re-push modification + ::tomlish::log::info "--->> POPSPACE transition to parent space $parentspace redirected to stored returnstate $next <<---" + } else { + ### + #review - do away with spacePopTransitions - which although useful to provide a default.. + # - involve error-prone configurations distant to the main state transition configuration in stateMatrix + if {[dict exists $::tomlish::parse::spacePopTransitions $parentspace]} { + set next [dict get $::tomlish::parse::spacePopTransitions $parentspace] + ::tomlish::log::info "--->> POPSPACE transition to parent space $parentspace redirected state to $next (spacePopTransitions)<<---" + } else { + set next $parentspace + ::tomlish::log::info "--->> POPSPACE transition to parent space $parentspace<<---" + } + } + set result $next + } + SAMESPACE { + set currentspace_info [spacestack peek] + ::tomlish::log::debug "--->> SAMESPACE got current space entry: $currentspace_info <<<<<" + set type [dict get $currentspace_info type] + set currentspace [dict get $currentspace_info state] + + if {[dict exists $currentspace_info returnstate]} { + set next [dict get $currentspace_info returnstate] + #clear the returnstate on current level + set existing [spacestack pop] + dict unset existing returnstate + spacestack push $existing ;#re-push modification + ::tomlish::log::info "--->> SAMESPACE transition to space $currentspace redirected to stored returnstate $next" + } else { + if {[dict exists $::tomlish::parse::spaceSameTransitions $currentspace]} { + set next [dict get $::tomlish::parse::spaceSameTransitions $currentspace] + ::tomlish::log::info "--->> SAMESPACE transition to space $currentspace redirected state to $next (spaceSameTransitions)" + } else { + set next $currentspace + ::tomlish::log::info "--->> SAMESPACE transition to space $currentspace" + } + } + set result $next + } + zeropoppushspace { + if {$nest > 0} { + #pop back down to the root level (table-space) + spacestack pop + set parentinfo [spacestack peek] + set type [dict get $parentinfo type] + set target [dict get $parentinfo state] + + set last_space_action "pop" + set last_space_type $type + + #----- + #standard pop + set parentlevel [expr {$nest -1}] + lappend v($parentlevel) [set v($nest)] + incr nest -1 + #----- + } + #re-entrancy + + #set next [list PUSHSPACE [lindex $transition_to 1]] + set nexttokentype ${tokentype}2 ;#fake token type e.g tablename2 or tablearrayname2 + #::tomlish::log::notice "goNextState REENTRANCY. calling goNextState $nexttokentype $tokentype" + #set result [::tomlish::parse::goNextState $nexttokentype $tokentype] + ::tomlish::log::debug "--->> zeropoppushspace goNextState REENTRANCY. calling goNextState $nexttokentype $currentstate" + set transition_info [::tomlish::parse::goNextState $nexttokentype $tok $currentstate] + set result [dict get $transition_info newstate] + } + PUSHSPACE { + set original_target [dict get $transition_to PUSHSPACE] + if {[dict exists $transition_to returnstate]} { + #adjust the existing space record on the stack. + #struct::stack doesn't really support that - so we have to pop and re-push + #todo - investigate a custom stack implementation where we can efficiently lset the top of the stack + set currentspace [spacestack pop] + dict set currentspace returnstate [dict get $transition_to returnstate] + spacestack push $currentspace ;#return modified info to stack so when we POPSPACE the returnstate is available. + } + if {[dict exists $transition_to starttok]} { + set starttok [dict get $transition_to starttok] + } + spacestack push [dict create type space state $original_target] + + set last_space_action "push" + set last_space_type "space" + + if {[dict exists $transition_to state]} { + #an explicit state in the pushed space was requested in the stateMatrix - override the spacePushTransition (spacePushTransitions can be deprecated if we require explicitness?) + set next [dict get $transition_to state] + ::tomlish::log::info "--->> PUSHSPACE transition to space $original_target redirected state to $next by explicit 'state' entry" + } else { + #puts $::tomlish::parse::spacePushTransitions + if {[dict exists $::tomlish::parse::spacePushTransitions $original_target]} { + set next [dict get $::tomlish::parse::spacePushTransitions $original_target] + ::tomlish::log::info "--->> PUSHSPACE transition to space $original_target redirected state to $next (spacePushTransitions) " + } else { + set next $original_target + ::tomlish::log::info "--->> PUSHSPACE transition to space $original_target" + } + } + set result $next + } + TOSTATE { + if {[dict exists $transition_to returnstate]} { + #adjust the existing space record on the stack. + #struct::stack doesn't really support that - so we have to pop and re-push + #todo - investigate a custom stack implementation where we can efficiently lset the top of the stack + set currentspace [spacestack pop] + dict set currentspace returnstate [dict get $transition_to returnstate] + spacestack push $currentspace ;#return modified info to stack so when we POPSPACE the returnstate is available. + } + set result [dict get $transition_to TOSTATE] + } + default { + #simplified version of TOSTATE + set result [lindex $transition_to 0] ;#ignore everything but first word + } + } + } else { + ::tomlish::log::error "--->> No state transition defined from state $currentstate when tokentype $tokentype received" + set result "nostate" + } + lappend state_list [list tokentype $tokentype from $currentstate to $result] + set state $result + ::tomlish::log::notice "--->> STATE TRANSITION tokenType: '$tokentype' tok:$tok triggering '$currentstate' -> '$result' last_space_action:$last_space_action " + return [dict create prevstate $prevstate newstate $result space_action $last_space_action starttok $starttok] + } + + proc report_line {{line ""}} { + variable linenum + variable is_parsing + if {$is_parsing} { + if {$line eq ""} { + set line $linenum + } + return "Line Number: $line" + } else { + #not in the middle of parsing tomlish text - return nothing. + return "" + } + } + + #produce a *slightly* more readable string rep of the nest for puts etc. + proc nest_pretty1 {list} { + set prettier "{" + + foreach el $list { + if { [lindex $el 0] eq "NEWLINE"} { + append prettier "[list $el]\n" + } elseif {([llength $el] > 1) && ([lindex $el 0] in {KEY DQKEY SQKEY TABLE ARRAY})} { + append prettier [nest_pretty1 $el] + } else { + append prettier "[list $el] " + } + } + append prettier "}" + return $prettier + } + + proc set_tokenType {t} { + variable tokenType + variable tokenType_list + if {![info exists tokenType]} { + set tokenType "" + } + lappend tokenType_list $t + set tokenType $t + } + + proc switch_tokenType {t} { + variable tokenType + variable tokenType_list + lset tokenType_list end $t + set tokenType $t + } + + proc get_tokenType {} { + variable tokenType + return $tokenType + } + + proc _shortcircuit_startquotesequence {} { + variable tok + variable i + set toklen [tcl::string::length $tok] + if {$toklen == 1} { + set_tokenType "startquote" + incr i -1 + return -level 2 1 + } elseif {$toklen == 2} { + puts stderr "_shortcircuit_startquotesequence toklen 2" + set_tokenType "startquote" + set tok "\"" + incr i -2 + return -level 2 1 + } + } + + proc get_token_waiting {} { + variable token_waiting + return [lindex $token_waiting 0] + } + proc clear_token_waiting {} { + variable token_waiting + set token_waiting [list] + } + + #token_waiting is a list - but our standard case is to have only one + #in certain circumstances such as near eof we may have 2 + #the set_token_waiting function only allows setting when there is not already one waiting. + #we want to catch cases of inadvertently trying to set multiple + # - the reason being that the state transition triggered by the previous token may have invalidated the assumptions made when a token was added as waiting. + proc set_token_waiting {args} { + if {[llength $args] %2 != 0} { + error "tomlish set_token_waiting must have args of form: type value complete 0|1" + } + variable token_waiting + + if {[llength $token_waiting] && [dict get [lindex $token_waiting end] type] ne "eof"} { + #tokloop already set a token_waiting - but something (post tokloop processing?) is trying to set another + #we may need to remove the existing token_waiting and reset the tokloop index to the previous char so it's reprocessed in the possibly new context + #rather than attempt to make the right decision here - we raise an error and require the caller to check/handle it + set err "tomlish set_token_waiting already has token_waiting: [lindex $token_waiting 0]" + append err \n " - cannot add token_waiting: $args" + error $err + #set tomlish::parse::i [expr {[dict get $token_waiting startindex] -1}] + #set token_waiting [list] + } + + set waiting [dict create] + dict for {k v} $args { + switch -exact $k { + type - complete { + dict set waiting $k $v + } + value { + dict set waiting tok $v + } + startindex { + dict set waiting startindex $v + } + default { + error "tomlish set_token_waiting error - unrecognised key $k. known keys: [dict keys $args]" + } + } + } + if {![tcl::string::is boolean -strict [dict get $waiting complete]]} { + error "tomlish set_token_waiting error - 'complete' must be a boolean. got [dict get $waiting complete]" + } + if {![llength $token_waiting]} { + set token_waiting [list $waiting] + } else { + #an extra sanity-check that we don't have more than just the eof.. + if {[llength $token_waiting] > 1} { + set err "tomlish Unexpected. Existing token_waiting count > 1.\n" + foreach tw $token_waiting { + append err " $tw" \n + } + append err " - cannot add token_waiting: $waiting" + error $err + } + #last entry must be a waiting eof + set token_waiting [list $waiting [lindex $token_waiting end]] + } + return + } + + #returns 0 or 1 + #tomlish::parse::tok + #we attempt to do this without lookahead (potential use in streaming toml? for what benefit?) todo -final flag + # - the possible benefit is being able to more easily process in arbitrarily split chunks (although we would still have to watch crlf splitting ?) + # - interactive use? + + proc tok {s} { + variable nest + variable v + variable i + variable tok + variable type ;#character type + variable state ;#FSM + + + variable tokenType + variable tokenType_list + + + variable endToken + + variable lastChar + + variable braceCount + variable bracketCount + + + #------------------------------ + #Previous run found another (presumably single-char) token + #The normal case is for there to be only one dict in the list + #multiple is an exception - primarily for eof + variable token_waiting + if {[llength $token_waiting]} { + set waiting [lindex $token_waiting 0] + + set tokenType [dict get $waiting type] + set tok [dict get $waiting tok] + #todo: dict get $token_waiting complete + set token_waiting [lrange $token_waiting 1 end] + return 1 + } + #------------------------------ + + set resultlist [list] + set sLen [tcl::string::length $s] + + set slash_active 0 + set quote 0 + set c "" + set multi_dquote "" + for {} {$i < $sLen} {} { + if {$i > 0} { + set lastChar [tcl::string::index $s [expr {$i - 1}]] + } else { + set lastChar "" + } + + set c [tcl::string::index $s $i] + set cindex $i + set ctest [tcl::string::map {\{ lc \} rc \[ lb \] rb \" dq ' sq \\ bsl \r cr \n lf \t tab \uFEFF bom} $c] + tomlish::log::debug "- tokloop char <$ctest> index $i tokenType:$tokenType tok:<$tok>" + #puts "got char $c during tokenType '$tokenType'" + incr i ;#must incr here because we do returns inside the loop + + switch -exact -- $ctest { + # { + set dquotes $multi_dquote + set multi_dquote "" + set had_slash $slash_active + set slash_active 0 + + if {$had_slash} {append tok "\\"} ;#if tokentype not appropriate for \, we would already have errored out. + + if {[tcl::string::length $tokenType]} { + switch -exact -- $tokenType { + squote_seq { + incr i -1 + return 1 + } + startquotesequence { + _shortcircuit_startquotesequence + } + _start_squote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "startsquote" + return 1 + } + barekey { + error "tomlish Unexpected character '$c' during bare key. Only \[a-zA-Z0-9_-\] and a selection of letter-like chars allowed (see tomlish::utils::is_barekey). [tomlish::parse::report_line]" + } + whitespace { + # hash marks end of whitespace token + #do a return for the whitespace, set token_waiting + #set_token_waiting type comment value "" complete 1 + incr i -1 ;#leave comment for next run + return 1 + } + untyped_value { + #REVIEW! the spec isn't clear.. is whitespace after an int,bool etc required before comment? + #we will accept a comment marker as an immediate terminator of the untyped_value. + incr i -1 + return 1 + } + starttablename - starttablearrayname { + #fix! + error "tomlish Character '#' is invalid first character for $tokenType. [tomlish::parse::report_line]" + } + tablename - tablearrayname { + #invalid in bare parts - but allowed in quoted parts - let tablename parser sort it out + append tok $c + } + default { + #dquotedkey, itablequotedkey, string,literal, multistring + append tok $c + } + } + } else { + switch -- $state { + multistring-space { + set_tokenType stringpart + set tok "" + if {$had_slash} { + append tok "\\" + } + append tok "$dquotes#" + } + multiliteral-space { + set_tokenType "literalpart" + set tok "#" + } + default { + #start of token if we're not in a token + set_tokenType comment + set tok "" ;#The hash is not part of the comment data + } + } + } + } + lc { + #left curly brace + set dquotes $multi_dquote + set multi_dquote "" + set had_slash $slash_active + set slash_active 0 + + if {[tcl::string::length $tokenType]} { + switch -exact -- $tokenType { + squote_seq { + incr i -1 + return 1 + } + startquotesequence { + _shortcircuit_startquotesequence + } + _start_squote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "startsquote" + return 1 + } + literal - literalpart - squotedkey { + append tok $c + } + string - dquotedkey { + if {$had_slash} {append tok "\\"} + append tok $c + } + stringpart { + if {$had_slash} {append tok "\\"} + append tok $dquotes$c + } + starttablename - starttablearrayname { + #*bare* tablename can only contain letters,digits underscores + error "tomlish Invalid tablename first character \{ [tomlish::parse::report_line]" + } + tablename - tablearrayname { + #valid in quoted parts + append tok $c + } + comment { + if {$had_slash} {append tok "\\"} + append tok "\{" + } + default { + #end any other token. + incr i -1 + return 1 + } + } + } else { + switch -exact -- $state { + itable-keyval-value-expected - keyval-value-expected { + #switch last key to tablename?? + set_tokenType "startinlinetable" + set tok "\{" + return 1 + } + array-space - array-syntax { + #nested anonymous inline table + set_tokenType "startinlinetable" + set tok "\{" + return 1 + } + table-space { + #invalid - but allow parser statemachine to report it. ? + set_tokenType "startinlinetable" + set tok "\{" + return 1 + } + multistring-space { + set_tokenType "stringpart" + set tok "" + if {$had_slash} { + append tok "\\" + } + append tok "$dquotes\{" + } + multiliteral-space { + set_tokenType "literalpart" + set tok "\{" + } + default { + error "tomlish state: '$state'. left brace case not implemented [tomlish::parse::report_line]" + } + } + } + + } + rc { + #right curly brace + set dquotes $multi_dquote + set multi_dquote "" + set had_slash $slash_active + set slash_active 0 + + if {[tcl::string::length $tokenType]} { + switch -exact -- $tokenType { + squote_seq { + incr i -1 + return 1 + } + startquotesequence { + _shortcircuit_startquotesequence + } + _start_squote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "startsquote" + return 1 + } + literal - literalpart - squotedkey { + append tok $c + } + XXXitablesquotedkey { + } + string - dquotedkey - itablequotedkey - comment { + if {$had_slash} {append tok "\\"} + append tok $c + } + stringpart { + if {$had_slash} {append tok "\\"} + append tok $dquotes$c + } + starttablename - tablename { + if {$had_slash} {append tok "\\"} + #invalid! - but leave for datastructure loading stage to catch + set_token_waiting type endinlinetable value "" complete 1 startindex $cindex + return 1 + } + starttablearrayname - tablearrayname { + if {$had_slash} {append tok "\\"} + #invalid! - but leave for datastructure loading stage to catch + set_token_waiting type endtablearrayname value "" complete 1 startindex $cindex + return 1 + } + default { + #end any other token + incr i -1 + return 1 + } + } + } else { + #$slash_active not relevant when no tokenType + switch -exact -- $state { + table-space { + #invalid - but allow parser statemachine to report it. ? + set_tokenType "endinlinetable" + set tok "\}" + return 1 + } + itable-space { + set_tokenType "endinlinetable" + set tok "\}" + return 1 + } + tablename-state { + #e.g [] - empty tablename - allowed or not? + #empty tablename/tablearrayname ? + #error "unexpected tablename problem" + + set_tokenType "endinlinetable" + set tok "" ;#no output into the tomlish list for this token + return 1 + } + tablearrayname-state { + error "tomlish unexpected tablearrayname-state problem" + set_tokenType "endinlinetable" + set tok "" ;#no output into the tomlish list for this token + return 1 + } + array-syntax - array-space { + #invalid + set_tokenType "endinlinetable" + set tok "\}" + return 1 + } + itable-val-tail { + set_tokenType "endinlinetable" + set tok "" + #we need to pop the keyval - and then reprocess to pop the inlinetable - so we incr -1 + incr i -1 + return 1 + } + itable-keyval-syntax { + error "tomlish endinlinetable unexpected at this point. Expecting key=val syntax [tomlish::parse::report_line]" + } + multistring-space { + set_tokenType "stringpart" + set tok "" + if {$had_slash} { + append tok "\\" + } + append tok "$dquotes\}" + } + multiliteral-space { + set_tokenType "literalpart" ; #review + set tok "\}" + } + default { + #JMN2024b keyval-tail? + error "tomlish state '$state'. endinlinetable case not implemented [tomlish::parse::report_line]" + } + } + } + + } + lb { + #left square bracket + set dquotes $multi_dquote + set multi_dquote "" + set had_slash $slash_active + set slash_active 0 + + if {[tcl::string::length $tokenType]} { + switch -exact -- $tokenType { + squote_seq { + incr i -1 + return 1 + } + startquotesequence { + _shortcircuit_startquotesequence + } + _start_squote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "startsquote" + return 1 + } + literal - literalpart - squotedkey { + append tok $c + } + string - dquotedkey - itablequotedkey { + if {$had_slash} {append tok "\\"} + append tok $c + } + stringpart { + if {$had_slash} {append tok "\\"} + append tok $dquotes$c + } + starttablename { + #change the tokenType + switch_tokenType "starttablearrayname" + set tok "" ;#no output into the tomlish list for this token + #any following whitespace is part of the tablearrayname, so return now + return 1 + } + tablename - tablearrayname { + #e.g a."x[0]".c is valid table name sequence - so we need to track quoting to know if rb is an end token + if {$had_slash} { + #resultant tablename may be invalid - but leave for datastructure loading stage to catch + #append tok "\\[" + append tok {\[} + } else { + if {[tomlish::utils::tok_in_quotedpart $tok] eq ""} { + #invalid at this point - state machine should disallow: + # table -> starttablearrayname + # tablearray -> starttablearrayname + set_token_waiting type starttablearrayname value "" complete 1 startindex $cindex + return 1 + } else { + #we appear to still be in single or double quoted section + append tok "\[" + } + } + } + comment { + if {$had_slash} {append tok "\\"} + append tok "\[" + } + default { + #end any other token. + incr i -1 + return 1 + } + } + } else { + #$slash_active not relevant when no tokenType + switch -exact -- $state { + keyval-value-expected - itable-keyval-value-expected { + set_tokenType "startarray" + set tok "\[" + return 1 + } + array-space - array-syntax { + #nested array? + set_tokenType "startarray" + set tok "\[" + return 1 + #error "state: array-space. startarray case not implemented [tomlish::parse::report_line]" + } + table-space { + #table name + #assume it's a single bracket - but we need to wait for non-bracket to confirm it's not a tablearray + #note that a starttablearrayname token may contain whitespace between the brackets + # e.g \[ \[ + set_tokenType "starttablename" + set tok "" ;#there is no output into the tomlish list for this token + } + multistring-space { + set_tokenType "stringpart" + set tok "" + if {$had_slash} { + append tok "\\" + } + append tok "$dquotes\[" + } + multiliteral-space { + set_tokenType "literalpart" + set tok "\[" + } + itable-space { + #handle state just to give specific error msg + error "tomlish state: '$state'. Left square bracket invalid. Cannot start array in inline table without key. Use key=\[\] syntax. [tomlish::parse::report_line]" + } + default { + error "tomlish state: '$state'. startarray case not implemented [tomlish::parse::report_line]" + } + } + } + } + rb { + #right square bracket + set dquotes $multi_dquote + set multi_dquote "" + set had_slash $slash_active + set slash_active 0 + + if {[tcl::string::length $tokenType]} { + switch -exact -- $tokenType { + squote_seq { + incr i -1 + return 1 + } + startquotesequence { + _shortcircuit_startquotesequence + } + _start_squote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "startsquote" + return 1 + } + literal - literalpart - squotedkey { + append tok $c + } + XXXitablesquotedkey { + } + string - dquotedkey - itablequotedkey { + if {$had_slash} {append tok "\\"} + append tok $c + } + stringpart { + if {$had_slash} {append tok "\\"} + append tok $dquotes$c + } + comment { + if {$had_slash} {append tok "\\"} + append tok $c + } + whitespace { + if {$state eq "multistring-space"} { + #???? + incr i -1 + if {$had_slash} {incr i -1} ;#reprocess + return 1 + } else { + incr i -1 + if {$had_slash} {incr i -1} ;#reprocess + return 1 + } + } + tablename { + #e.g a."x[0]".c is valid table name sequence - so we need to track quoting to know if rb is an end token + if {$had_slash} { + #resultant tablename may be invalid - but leave for datastructure loading stage to catch + append tok "\\]" + } else { + if {[tomlish::utils::tok_in_quotedpart $tok] eq ""} { + set_token_waiting type endtablename value "" complete 1 startindex $cindex + return 1 + } else { + #we appear to still be in single or double quoted section + append tok "]" + } + } + } + tablearrayname { + #e.g a."x[0]".c is valid table name sequence - so we need to track quoting to know if rb is an end token + if {$had_slash} { + #resultant tablename may be invalid - but leave for datastructure loading stage to catch + append tok "\\]" + } else { + if {[tomlish::utils::tok_in_quotedpart $tok] eq ""} { + set_token_waiting type endtablearrayname value "" complete 1 startindex $cindex + return 1 + } else { + #we appear to still be in single or double quoted section + append tok "]" + } + } + } + XXXtablearraynames { + puts "rb @ tablearraynames ??" + #switch? + + #todo? + if {$had_slash} {append tok "\\"} + #invalid! - but leave for datastructure loading stage to catch + set_token_waiting type endtablearrayname value "" complete 1 startindex $cindex + return 1 + } + default { + incr i -1 + return 1 + } + } + } else { + #$slash_active not relevant when no tokenType + switch -exact -- $state { + array-syntax - array-space { + #invalid - but allow parser statemachine to report it. + set_tokenType "endarray" + set tok "\]" + return 1 + } + table-space { + #invalid - but allow parser statemachine to report it. ? + set_tokenType "endarray" + set tok "\]" + return 1 + } + tablename-state { + #e.g [] - empty tablename - allowed or not? + #empty tablename/tablearrayname ? + #error "unexpected tablename problem" + + set_tokenType "endtablename" + set tok "" ;#no output into the tomlish list for this token + return 1 + } + tablearrayname-state { + error "tomlish unexpected tablearrayname problem" + set_tokenType "endtablearray" + set tok "" ;#no output into the tomlish list for this token + return 1 + } + tablearrayname-tail { + #[[xxx] + set_tokenType "endtablename" + #sequence: starttablename -> starttablearrayname -> endtablearrayname -> endtablename + return 1 + } + multistring-space { + set_tokenType "stringpart" + set tok "" + if {$had_slash} { + append tok "\\" + } + append tok "$dquotes\]" + } + multiliteral-space { + set_tokenType "literalpart" + set tok "\]" + } + default { + error "tomlish state '$state'. endarray case not implemented [tomlish::parse::report_line]" + } + } + } + } + bsl { + set dquotes $multi_dquote + set multi_dquote "" ;#!! + #backslash + if {[tcl::string::length $tokenType]} { + switch -exact -- $tokenType { + squote_seq { + incr i -1 + return 1 + } + startquotesequence { + _shortcircuit_startquotesequence + } + _start_squote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "startsquote" + return 1 + } + whitespace { + if {$state eq "multistring-space"} { + #end whitespace token + incr i -1 ;#reprocess bsl in next run + return 1 + } else { + error "tomlish Unexpected backslash during whitespace. [tomlish::parse::report_line]" + } + } + literal - literalpart - squotedkey { + #never need to set slash_active true when in single quoted tokens + append tok "\\" + set slash_active 0 + } + XXXitablesquotedkey { + } + string - dquotedkey - itablequotedkey - comment { + if {$slash_active} { + set slash_active 0 + append tok "\\\\" + } else { + set slash_active 1 + } + } + stringpart { + if {$slash_active} { + #assert - quotes empty - or we wouldn't have slash_active + set slash_active 0 + append tok "\\\\" + } else { + append tok $dquotes + set slash_active 1 + } + } + starttablename - starttablearrayname { + error "tomlish backslash is invalid as first character of $tokenType [tomlish::parse::report_line]" + } + tablename - tablearrayname { + if {$slash_active} { + set slash_active 0 + append tok "\\\\" + } else { + set slash_active 1 + } + } + barekey { + error "tomlish Unexpected backslash during barekey. [tomlish::parse::report_line]" + } + default { + error "tomlish Backslash unexpected during tokentype: '$tokenType'. [tomlish::parse::report_line]" + } + } + } else { + switch -exact -- $state { + multistring-space { + if {$slash_active} { + set_tokenType "stringpart" + set tok "\\\\" + set slash_active 0 + } else { + if {$dquotes ne ""} { + set_tokenType "stringpart" + set tok $dquotes + } + set slash_active 1 + } + } + multiliteral-space { + #nothing can be escaped in multiliteral-space - not even squotes (?) review + set_tokenType "literalpart" + set tok "\\" + } + default { + error "tomlish tok error: Unexpected backslash when no token is active. [tomlish::parse::report_line]" + } + } + } + } + sq { + #single quote + set had_slash $slash_active + set slash_active 0 + if {[tcl::string::length $tokenType]} { + switch -exact -- $tokenType { + squote_seq { + #short squote_seq tokens are returned if active during any other character + #longest allowable for leading/trailing are returned here + #### + set existingtoklen [tcl::string::length $tok] ;#toklen prior to this squote + switch -- $state { + leading-squote-space { + append tok $c + if {$existingtoklen > 2} { + error "tomlish tok error: squote_seq unexpected length $existingtoklen when another received" + } elseif {$existingtoklen == 2} { + return 1 ;#return tok ''' + } + } + trailing-squote-space { + append tok $c + if {$existingtoklen == 4} { + #maxlen to be an squote_seq is multisquote + 2 = 5 + #return tok ''''' + return 1 + } + } + default { + error "tomlish tok error: squote_seq in unexpected state '$state' - expected leading-squote-space or trailing-squote-space" + } + } + } + whitespace { + #end whitespace + incr i -1 ;#reprocess sq + return 1 + } + startquotesequence { + _shortcircuit_startquotesequence + } + _start_squote_sequence { + #temp token creatable only during value-expected or array-space + switch -- [tcl::string::length $tok] { + 1 { + append tok $c + } + 2 { + #switch? + append tok $c + set_tokenType triple_squote + return 1 + } + default { + error "tomlish unexpected token length [tcl::string::length $tok] in '_start_squote_sequence'" + } + } + } + literal { + #slash_active always false + #terminate the literal + set_token_waiting type endsquote value "'" complete 1 startindex $cindex + return 1 + } + literalpart { + #ended by ''' - but final could be '''' or ''''' (up to 2 squotes allowed directly before ending triple squote sequence) + #todo + # idea: end this literalpart (possibly 'temporarily') + # let the sq be reprocessed in the multiliteral-space to push an end-multiliteral-sequence to state stack + # upon popping end-multiliteral-sequence - stitch quotes back into this literalpart's token (if either too short - or a long ending sequence as shown above) + incr i -1 ;#throw the "'" back to loop - will be added to an squote_seq token for later processing + return 1 + } + XXXitablesquotedkey { + set_token_waiting type endsquote value "'" complete 1 startindex $cindex + return 1 + } + squotedkey { + ### + #set_token_waiting type endsquote value "'" complete 1 + return 1 + } + starttablename - starttablearrayname { + #!!! + incr i -1 + return 1 + } + tablename - tablearrayname { + append tok $c + } + barekey { + #not clear why o'shennanigan shouldn't be a legal barekey - but it seems not to be. + error "tomlish Unexpected single quote during barekey. [tomlish::parse::report_line]" + } + default { + append tok $c + } + } + } else { + switch -exact -- $state { + array-space { + set_tokenType "_start_squote_sequence" + set tok "'" + } + itable-keyval-value-expected - keyval-value-expected { + set_tokenType "squote_seq_begin" + set tok "'" + return 1 + } + table-space { + #tests: squotedkey.test + set_tokenType "squotedkey" + set tok "" + } + itable-space { + #tests: squotedkey_itable.test + set_tokenType "squotedkey" + set tok "" + } + XXXitable-space { + #future - could there be multiline keys? + #this would allow arbitrary tcl dicts to be stored in toml + #probably unlikely - as it's perhaps not very 'minimal' or ergonomic for config files + set_tokenType "squote_seq_begin" + set tok "'" + return 1 + } + tablename-state { + #first char in tablename-state/tablearrayname-state + set_tokenType tablename + append tok "'" + } + tablearrayname-state { + set_tokenType tablearrayname + append tok "'" + } + literal-state { + tomlish::log::debug "- tokloop sq during literal-state with no tokentype - empty literal?" + set_tokenType literal + incr -1 + return 1 + } + multistring-space { + error "tomlish unimplemented - squote during state '$state'. [tomlish::parse::report_line]" + } + multiliteral-space { + #each literalpart is not necessarily started/ended with squotes - but may contain up to 2 in a row + #we are building up an squote_seq to determine if + #a) it is shorter than ''' so belongs in a literalpart (either previous, subsequent or it's own literalpart between newlines + #b) it is exactly ''' and we can terminate the whole multiliteral + #c) it is 4 or 5 squotes where the first 1 or 2 beling in a literalpart and the trailing 3 terminate the space + set_tokenType "squote_seq_begin" + set tok "'" + return 1 + } + dottedkey-space { + set_tokenType squotedkey + } + default { + error "tomlish unhandled squote during state '$state'. [tomlish::parse::report_line]" + } + } + } + + } + dq { + #double quote + set had_slash $slash_active + set slash_active 0 + + if {[tcl::string::length $tokenType]} { + switch -exact -- $tokenType { + squote_seq { + incr i -1 + return 1 + } + startquotesequence { + set toklen [tcl::string::length $tok] + if {$toklen == 1} { + append tok $c + } elseif {$toklen == 2} { + append tok $c + #switch vs set? + set_tokenType "startmultiquote" + return 1 + } else { + error "tomlish unexpected token length $toklen in 'startquotesequence'" + } + } + _start_squote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "startsquote" + return 1 + + #set toklen [tcl::string::length $tok] + #switch -- $toklen { + # 1 { + # set_tokenType "startsquote" + # incr i -1 + # return 1 + # } + # 2 { + # set_tokenType "startsquote" + # incr i -2 + # return 1 + # } + # default { + # error "tomlish unexpected _start_squote_sequence length $toklen" + # } + #} + } + literal - literalpart { + append tok $c + } + string { + if {$had_slash} { + append tok "\\" $c + } else { + #unescaped quote always terminates a string? + set_token_waiting type endquote value "\"" complete 1 startindex $cindex + return 1 + } + } + stringpart { + #sub element of multistring + if {$had_slash} { + append tok "\\" $c + } else { + #incr i -1 + + if {$multi_dquote eq "\"\""} { + set_token_waiting type endmultiquote value "\"\"\"" complete 1 startindex [expr {$cindex -2}] + set multi_dquote "" + return 1 + } else { + append multi_dquote "\"" + } + } + } + whitespace { + switch -exact -- $state { + multistring-space { + #REVIEW + if {$had_slash} { + incr i -2 + return 1 + } else { + switch -- [tcl::string::length $multi_dquote] { + 2 { + set_token_waiting type endmultiquote value "\"\"\"" complete 1 startindex [expr {$cindex-2}] + set multi_dquote "" + return 1 + } + 1 { + incr i -2 + return 1 + } + 0 { + incr i -1 + return 1 + } + } + } + } + keyval-value-expected { + #end whitespace token and reprocess + incr i -1 + return 1 + + #if {$multi_dquote eq "\"\""} { + # set_token_waiting type startmultiquote value "\"\"\"" complete 1 + # set multi_dquote "" + # return 1 + #} else { + # #end whitespace token and reprocess + # incr i -1 + # return 1 + #} + } + table-space - itable-space { + incr i -1 + return 1 + } + default { + set_token_waiting type startquote value "\"" complete 1 startindex $cindex + return 1 + } + } + } + comment { + if {$had_slash} {append tok "\\"} + append tok $c + } + XXXdquotedkey - XXXitablequotedkey { + if {$had_slash} { + append tok "\\" + append tok $c + } else { + set_token_waiting type endquote value "\"" complete 1 startindex $cindex + return 1 + } + } + dquotedkey { + ### + if {$had_slash} { + append tok "\\" + append tok $c + } else { + #set_token_waiting type endsquote value "'" complete 1 + return 1 + } + } + squotedkey { + append tok $c + } + tablename - tablearrayname { + if {$had_slash} {append tok "\\"} + append tok $c + } + starttablename - starttablearrayname { + incr i -1 ;## + return 1 + } + default { + error "tomlish got quote during tokenType '$tokenType' [tomlish::parse::report_line]" + } + } + } else { + #$slash_active not relevant when no tokenType + #token is string only if we're expecting a value at this point + switch -exact -- $state { + array-space { + #!? start looking for possible multistartquote + #set_tokenType startquote + #set tok $c + #return 1 + set_tokenType "startquotesequence" ;#one or more quotes in a row - either startquote or multistartquote + set tok $c + } + keyval-value-expected - itable-keyval-value-expected { + set_tokenType "startquotesequence" ;#one or more quotes in a row - either startquote or multistartquote + set tok $c + } + multistring-space { + #TODO - had_slash!!! + #REVIEW + if {$had_slash} { + set_tokenType "stringpart" + set tok "\\\"" + set multi_dquote "" + } else { + if {$multi_dquote eq "\"\""} { + tomlish::log::debug "- tokloop char dq ---> endmultiquote" + set_tokenType "endmultiquote" + set tok "\"\"\"" + return 1 + #set_token_waiting type endmultiquote value "\"\"\"" complete 1 + #set multi_dquote "" + #return 1 + } else { + append multi_dquote "\"" + } + } + } + multiliteral-space { + set_tokenType "literalpart" + set tok "\"" + } + XXXtable-space { + set_tokenType "startquote" + set tok $c + return 1 + } + XXXitable-space { + set_tokenType "startquote" + set tok $c + } + table-space - itable-space { + set_tokenType "dquotedkey" + set tok "" + } + tablename-state { + set_tokenType tablename + set tok $c + } + tablearrayname-state { + set_tokenType tablearrayname + set tok $c + } + dottedkey-space { + set_tokenType dquotedkey + set tok "" + + #only if complex keys become a thing + #set_tokenType dquote_seq_begin + #set tok $c + } + default { + error "tomlish Unexpected quote during state '$state' [tomlish::parse::report_line]" + } + } + } + } + = { + set dquotes $multi_dquote + set multi_dquote "" ;#!! + set had_slash $slash_active + set slash_active 0 + + if {[tcl::string::length $tokenType]} { + switch -exact -- $tokenType { + squote_seq { + incr i -1 + return 1 + } + startquotesequence { + _shortcircuit_startquotesequence + } + _start_squote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "startsquote" + return 1 + } + literal - literalpart - squotedkey { + #assertion had_slash 0, multi_dquote "" + append tok $c + } + string - comment - dquotedkey - itablequotedkey { + #for these tokenTypes an = is just data. + if {$had_slash} {append tok "\\"} + append tok $c + } + stringpart { + if {$had_slash} {append tok "\\"} + append tok $dquotes$c + } + whitespace { + if {$state eq "multistring-space"} { + set backlen [expr {[tcl::string::length $dquotes] + 1}] + incr i -$backlen + return 1 + } else { + set_token_waiting type equal value = complete 1 startindex $cindex + return 1 + } + } + barekey { + #set_token_waiting type equal value = complete 1 + incr i -1 + return 1 + } + starttablename - starttablearrayname { + error "tomlish Character '=' is invalid first character for $tokenType. [tomlish::parse::report_line]" + } + tablename - tablearrayname { + #invalid in bare name - but valid in quoted parts - leave for tablename parser to sort out + append tok $c + } + default { + error "tomlish unexpected = character during tokentype $tokenType. case not implemented. [tomlish::parse::report_line]" + } + } + } else { + switch -exact -- $state { + multistring-space { + set_tokenType "stringpart" + set tok "" + if {$had_slash} { + append tok "\\" + } + append tok ${dquotes}= + } + multiliteral-space { + set_tokenType "literalpart" + set tok "=" + } + dottedkey-space { + set_tokenType "equal" + set tok "=" + return 1 + } + default { + set_tokenType "equal" + set tok = + return 1 + } + } + } + } + cr { + #REVIEW! + set dquotes $multi_dquote + set multi_dquote "" ;#!! + # \r carriage return + if {$slash_active} {append tok "\\"} ;#if tokentype not appropriate for \, we would already have errored out. + set slash_active 0 + if {[tcl::string::length $tokenType]} { + switch -exact -- $tokenType { + newline { + #we have received a double cr + ::tomlish::log::warn "double cr - will generate cr token. needs testing" + set_tokenType "cr" ;#lone cr token will generally raise an error - but let state machine handle it + incr i -1 + return 1 + } + squote_seq { + incr i -1 + return 1 + } + startquotesequence { + _shortcircuit_startquotesequence + } + _start_squote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "startsquote" + return 1 + } + literal { + append tok $c + } + literalpart { + #part of MLL string (multi-line literal string) + #we need to split out crlf as a separate NEWLINE to be consistent + ::tomlish::log::warn "literalpart ended by cr - needs testing" + #return literalpart temporarily - allow cr to be reprocessed from multiliteral-space + incr i -1 + return 1 + } + stringpart { + #stringpart is a part of MLB string (multi-line basic string) + #throw back the cr - if followed by lf it will become a {NEWLINE crlf} entry within the MULTISTRING list (e.g between STRINGPART entries) + incr i -1 + return 1 + } + starttablename - starttablearrayname { + error "tomlish Character is invalid first character for $tokenType. [tomlish::parse::report_line]" + } + tablename - tablearrayname { + #could in theory be valid in quoted part of name + #review - might be better just to disallow here + append tok $c + } + whitespace { + #it should technically be part of whitespace if not followed by lf + #but outside of values we are also free to map it to be another NEWLINE instead? REVIEW + incr i -1 + return 1 + } + untyped_value { + incr i -1 + return 1 + } + default { + #!todo - error out if cr inappropriate for tokenType + append tok $c + } + } + } else { + #lf may be appended if next + #review - lone cr as newline? - this is uncommon - but so is lone cr in a string(?) + set_tokenType "newline" + set tok cr + } + } + lf { + # \n newline + set dquotes $multi_dquote + set multi_dquote "" ;#!! + set had_slash $slash_active + set slash_active 0 + if {[tcl::string::length $tokenType]} { + switch -exact -- $tokenType { + newline { + #review + #this lf is the trailing part of a crlf + append tok lf ;#assert we should now have tok "crlf" - as a previous cr is the only way to have an incomplete newline tok + return 1 + } + squote_seq { + incr i -1 + return 1 + } + startquotesequence { + _shortcircuit_startquotesequence + } + _start_squote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "startsquote" + return 1 + } + literal { + #nl is not allowed *within* a literal - require multiliteral syntax for any literal containing a newline ''' ''' + #even though we terminate the literal without the closing quote here - the token_waiting newline should trigger a state error + set_token_waiting type newline value lf complete 1 startindex $cindex + return 1 + } + literalpart { + #we allow newlines - but store them within the multiliteral as their own element + #This is a legitimate end to the literalpart - but not the whole multiliteral + set_token_waiting type newline value lf complete 1 startindex $cindex + return 1 + } + stringpart { + if {$dquotes ne ""} { + append tok $dquotes + incr i -1 + return 1 + } else { + if {$had_slash} { + #emit the stringpart (return 1), queue the continuation, go back 1 to reprocess the lf (incr i -1) + set_token_waiting type continuation value \\ complete 1 startindex [expr {$cindex-1}] + incr i -1 + return 1 + } else { + set_token_waiting type newline value lf complete 1 startindex $cindex + return 1 + } + } + } + starttablename - tablename - tablearrayname - starttablearrayname { + error "tomlish Character is invalid in $tokenType. [tomlish::parse::report_line]" + } + default { + #newline ends all other tokens. + #note for string: we don't add (raw unescaped) newline to simple string. (must use multi-string for this) + #note for whitespace: + # we will use the convention that \n terminates the current whitespace even if whitespace follows + # ie whitespace is split into separate whitespace tokens at each newline + + #puts "-------------- newline lf during tokenType $tokenType" + set_token_waiting type newline value lf complete 1 startindex $cindex + return 1 + } + } + } else { + switch -exact -- $state { + multistring-space { + if {$had_slash} { + set_tokenType "continuation" + set tok "\\" + incr i -1 + return 1 + } else { + if {$dquotes ne ""} { + #e.g one or 2 quotes just before nl + set_tokenType "stringpart" + set tok $dquotes + incr i -1 + return 1 + } + set_tokenType "newline" + set tok lf + return 1 + } + } + multiliteral-space { + #assert had_slash 0, multi_dquote "" + set_tokenType "newline" + set tok "lf" + return 1 + } + default { + #ignore slash? error? + set_tokenType "newline" + set tok lf + return 1 + } + } + #if {$had_slash} { + # #CONT directly before newline - allows strings_5_byteequivalent test to pass + # set_tokenType "continuation" + # set tok "\\" + # incr i -1 + # return 1 + #} else { + # set_tokenType newline + # set tok lf + # return 1 + #} + } + } + , { + set dquotes $multi_dquote + set multi_dquote "" + set had_slash $slash_active + set slash_active 0 + if {[tcl::string::length $tokenType]} { + switch -exact -- $tokenType { + newline { + #incomplete newline + set_tokenType "cr" + incr i -1 + return 1 + } + squote_seq { + incr i -1 + return 1 + } + startquotesequence { + _shortcircuit_startquotesequence + } + _start_squote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "startsquote" + return 1 + } + comment - tablename - tablearrayname { + if {$had_slash} {append tok "\\"} + append tok , + } + string - dquotedkey - itablequotedkey { + if {$had_slash} {append tok "\\"} + append tok $c + } + stringpart { + #stringpart can have up to 2 quotes too + if {$had_slash} {append tok "\\"} + append tok $dquotes$c + } + literal - literalpart - squotedkey { + #assert had_slash always 0, multi_dquote "" + append tok $c + } + whitespace { + if {$state eq "multistring-space"} { + set backlen [expr {[tcl::string::length $dquotes] + 1}] + incr i -$backlen + return 1 + } else { + set_token_waiting type comma value "," complete 1 startindex $cindex + return 1 + } + } + default { + set_token_waiting type comma value "," complete 1 startindex $cindex + if {$had_slash} {append tok "\\"} + return 1 + } + } + } else { + switch -exact -- $state { + multistring-space { + set_tokenType "stringpart" + set tok "" + if {$had_slash} {append tok "\\"} + append tok "$dquotes," + } + multiliteral-space { + #assert had_slash 0, multi_dquote "" + set_tokenType "literalpart" + set tok "," + } + default { + set_tokenType "comma" + set tok "," + return 1 + } + } + } + } + . { + set dquotes $multi_dquote + set multi_dquote "" ;#!! + set had_slash $slash_active + set slash_active 0 + if {[tcl::string::length $tokenType]} { + switch -exact -- $tokenType { + newline { + #incomplete newline + set_tokenType "cr" + incr i -1 + return 1 + } + squote_seq { + incr i -1 + return 1 + } + startquotesequence { + _shortcircuit_startquotesequence + } + _start_squote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "startsquote" + return 1 + } + comment - untyped_value { + if {$had_slash} {append tok "\\"} + append tok $c + } + string - dquotedkey - itablequotedkey { + if {$had_slash} {append tok "\\"} + append tok $c + } + stringpart { + if {$had_slash} {append tok "\\"} + append tok $dquotes$c + } + literal - literalpart - squotedkey { + #assert had_slash always 0, multi_dquote "" + append tok $c + } + whitespace { + switch -exact -- $state { + multistring-space { + set backchars [expr {[tcl::string::length $dquotes] + 1}] + if {$had_slash} { + incr backchars 1 + } + incr i -$backchars + return 1 + } + xxxdottedkey-space { + incr i -1 + return 1 + } + dottedkey-space-tail { + incr i -1 + return 1 + } + default { + error "tomlish Received period during tokenType 'whitespace' [tomlish::parse::report_line]" + } + } + } + starttablename - starttablearrayname { + #This would correspond to an empty table name + error "tomlish Character '.' is not allowed as first character ($tokenType). [tomlish::parse::report_line]" + } + tablename - tablearrayname { + #subtable - split later - review + append tok $c + } + barekey { + #e.g x.y = 1 + #we need to transition the barekey to become a structured table name ??? review + #x is the tablename y is the key + set_token_waiting type dotsep value "." complete 1 startindex $cindex + return 1 + } + default { + error "tomlish Received period during tokenType '$tokenType' [tomlish::parse::report_line]" + #set_token_waiting type period value . complete 1 + #return 1 + } + } + } else { + switch -exact -- $state { + multistring-space { + set_tokenType "stringpart" + set tok "" + if {$had_slash} {append tok "\\"} + append tok "$dquotes." + } + multiliteral-space { + set_tokenType "literalpart" + set tok "." + } + XXXdottedkey-space { + ### obs? + set_tokenType "dotsep" + set tok "." + return 1 + } + dottedkey-space-tail { + ### + set_tokenType "dotsep" + set tok "." + return 1 + } + default { + set_tokenType "untyped_value" + set tok "." + } + } + } + + } + " " { + set dquotes $multi_dquote + set multi_dquote "" ;#!! + if {[tcl::string::length $tokenType]} { + set had_slash $slash_active + set slash_active 0 + switch -exact -- $tokenType { + newline { + #incomplete newline + set_tokenType "cr" + incr i -1 + return 1 + } + squote_seq { + incr i -1 + return 1 + } + startquotesequence { + _shortcircuit_startquotesequence + } + _start_squote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "startsquote" + return 1 + } + barekey { + #todo had_slash - emit token or error + #whitespace is a terminator for bare keys + #set_token_waiting type whitespace value $c complete 1 + incr i -1 + return 1 + } + untyped_value { + #unquoted values (int,date,float etc) are terminated by whitespace + #set_token_waiting type whitespace value $c complete 1 + incr i -1 + return 1 + } + comment { + if {$had_slash} { + append tok "\\" + } + append tok $dquotes$c + } + string - dquotedkey - itablequotedkey { + if {$had_slash} { append tok "\\" } + append tok $c + } + stringpart { + #for stringpart we store WS separately for ease of processing continuations (CONT stripping) + if {$had_slash} { + #REVIEW + #emit the stringpart - go back to the slash + incr i -2 + return 1 + } else { + #split into STRINGPART aaa WS " " + append tok $dquotes + incr i -1 + return 1 + } + } + literal - literalpart - squotedkey { + append tok $c + } + whitespace { + if {$state eq "multistring-space"} { + if {$dquotes ne ""} { + #end whitespace token + #go back by the number of quotes plus this space char + set backchars [expr {[tcl::string::length $dquotes] + 1}] + incr i -$backchars + return 1 + } else { + append tok $c + } + } else { + append tok $c + } + } + starttablename - starttablearrayname { + incr i -1 + return 1 + } + tablename - tablearrayname { + #include whitespace in the tablename/tablearrayname + #Will need to be normalized upon interpreting the tomlish as a datastructure + append tok $c + } + default { + error "tomlish Received whitespace space during tokenType '$tokenType' [tomlish::parse::report_line]" + } + } + } else { + set had_slash $slash_active + set slash_active 0 + switch -exact -- $state { + tablename-state { + #tablename can have leading,trailing and interspersed whitespace! + #These will not be treated as whitespace tokens, instead forming part of the name. + set_tokenType tablename + set tok "" + if {$had_slash} {append tok "\\"} + append tok $c + } + tablearrayname-state { + set_tokenType tablearrayname + set tok "" + if {$had_slash} {append tok "\\"} + append tok $c + } + multistring-space { + if {$had_slash} { + set_tokenType "continuation" + set tok "\\" + incr i -1 + return 1 + } else { + if {$dquotes ne ""} { + set_tokenType "stringpart" + set tok $dquotes + incr i -1 + return 1 + } + set_tokenType "whitespace" + append tok $c + } + } + multiliteral-space { + set_tokenType "literalpart" + set tok $c + } + default { + if {$had_slash} { + error "tomlish unexpected backslash [tomlish::parse::report_line]" + } + set_tokenType "whitespace" + append tok $c + } + } + } + } + tab { + set dquotes $multi_dquote + set multi_dquote "" ;#!! + + if {[tcl::string::length $tokenType]} { + if {$slash_active} {append tok "\\"} ;#if tokentype not appropriate for \, we would already have errored out (?review) + set slash_active 0 + switch -exact -- $tokenType { + newline { + #incomplete newline + set_tokenType "cr" + incr i -1 + return 1 + } + startquotesequence { + _shortcircuit_startquotesequence + } + _start_squote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "startsquote" + return 1 + } + barekey { + #whitespace is a terminator for bare keys + incr i -1 + #set_token_waiting type whitespace value $c complete 1 + return 1 + } + untyped_value { + #unquoted values (int,date,float etc) are terminated by whitespace + #set_token_waiting type whitespace value $c complete 1 + incr i -1 + return 1 + } + squotedkey { + append tok $c + } + dquotedkey - string - comment - whitespace { + #REVIEW + append tok $c + } + stringpart { + #for stringpart we store WS separately for ease of processing continuations (CONT stripping) + if {$had_slash} { + #REVIEW + #emit the stringpart - go back to the slash + incr i -2 + return 1 + } else { + #split into STRINGPART aaa WS " " + append tok $dquotes + incr i -1 + return 1 + } + } + literal - literalpart { + append tok $c + } + starttablename - starttablearrayname { + incr i -1 + return 1 + } + tablename - tablearrayname { + #include whitespace in the tablename/tablearrayname + #Will need to be normalized upon interpreting the tomlish as a datastructure + append tok $c + } + default { + error "tomlish Received whitespace tab during tokenType '$tokenType' [tomlish::parse::report_line]" + } + } + } else { + set had_slash $slash_active + if {$slash_active} { + set slash_active 0 + } + switch -exact -- $state { + tablename-state { + #tablename can have leading,trailing and interspersed whitespace! + #These will not be treated as whitespace tokens, instead forming part of the name. + set_tokenType tablename + set tok $c + } + tablearrayname-state { + set_tokenType tablearrayname + set tok $c + } + multistring-space { + if {$had_slash} { + set_tokenType "continuation" + set tok "\\" + incr i -1 + return 1 + } else { + if {$dquotes ne ""} { + set_tokenType stringpart + set tok $dquotes + incr i -1 + return 1 + } else { + set_tokenType whitespace + append tok $c + } + } + } + multiliteral-space { + set_tokenType "literalpart" + set tok $c + } + default { + set_tokenType "whitespace" + append tok $c + } + } + } + } + bom { + #BOM (Byte Order Mark) - ignored by token consumer + if {[tcl::string::length $tokenType]} { + switch -exact -- $tokenType { + _start_squote_sequence { + #assert - tok will be one or two squotes only + incr i -[tcl::string::length $tok] + set_tokenType "startsquote" + return 1 + } + literal - literalpart { + append tok $c + } + default { + set_token_waiting type bom value "\uFEFF" complete 1 startindex $cindex + return 1 + } + } + } else { + switch -exact -- $state { + multiliteral-space { + set_tokenType "literalpart" + set tok $c + } + default { + set_tokenType "bom" + set tok "\uFEFF" + return 1 + } + } + } + } + default { + set dquotes $multi_dquote + set multi_dquote "" ;#!! + + if {[tcl::string::length $tokenType]} { + if {$slash_active} {append tok "\\"} ;#if tokentype not appropriate for \, we would already have errored out. + set slash_active 0 + switch -exact -- $tokenType { + newline { + #incomplete newline + set_tokenType "cr" + incr i -1 + return 1 + } + squote_seq { + incr i -1 + return 1 + } + startquotesequence { + _shortcircuit_startquotesequence + } + _start_squote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "startsquote" + return 1 + } + whitespace { + if {$state eq "multistring-space"} { + if {$dquotes ne ""} { + set backlen [expr {[tcl::string::length $dquotes] + 1}] + incr i -$backlen + return 1 + } else { + incr i -1 + return 1 + } + } else { + #review + incr i -1 ;#We don't have a full token to add to the token_waiting dict - so leave this char for next run. + return 1 + } + } + barekey { + if {[tomlish::utils::is_barekey $c]} { + append tok $c + } else { + error "tomlish Unexpected character '$c' during bare key. Only \[a-zA-Z0-9_-\] and a selection of letter-like chars allowed. (see tomlish::utils::is_barekey) [tomlish::parse::report_line]" + } + } + starttablename - starttablearrayname { + incr i -1 + #allow statemachine to set context for subsequent chars + return 1 + } + stringpart { + append tok $dquotes$c + } + default { + #e.g comment/string/literal/literalpart/untyped_value/starttablename/starttablearrayname/tablename/tablearrayname + append tok $c + } + } + } else { + set had_slash $slash_active + set slash_active 0 + switch -exact -- $state { + table-space - itable-space { + #if no currently active token - assume another key value pair + if {[tomlish::utils::is_barekey $c]} { + set_tokenType "barekey" + append tok $c + } else { + error "tomlish Unexpected char $c ([tomlish::utils::nonprintable_to_slashu $c]) whilst no active tokenType. [tomlish::parse::report_line]" + } + } + XXXcurly-syntax { + puts stderr "curly-syntax - review" + if {[tomlish::utils::is_barekey $c]} { + set_tokenType "barekey" + append tok $c + } else { + error "tomlish Unexpected char $c ([tomlish::utils::nonprintable_to_slashu $c]) whilst no active tokenType. [tomlish::parse::report_line]" + } + } + multistring-space { + set_tokenType "stringpart" + if {$had_slash} { + #assert - we don't get had_slash and dquotes at same time + set tok \\$c + } else { + set tok $dquotes$c + } + } + multiliteral-space { + set_tokenType "literalpart" + set tok $c + } + tablename-state { + set_tokenType "tablename" + set tok $c + } + tablearrayname-state { + set_tokenType "tablearrayname" + set tok $c + } + dottedkey-space { + set_tokenType barekey + set tok $c + } + default { + #todo - something like ansistring VIEW to show control chars? + set cshow [string map [list \t tab \v vt] $c] + tomlish::log::debug "- tokloop char '$cshow' setting to untyped_value while state:$state [tomlish::parse::report_line]" + set_tokenType "untyped_value" + set tok $c + } + } + } + } + } + + } + + #run out of characters (eof) + if {[tcl::string::length $tokenType]} { + #check for invalid ending tokens + #if {$state eq "err-state"} { + # error "Reached end of data whilst tokenType = '$tokenType'. INVALID" + #} + switch -exact -- $tokenType { + startquotesequence { + set toklen [tcl::string::length $tok] + if {$toklen == 1} { + #invalid + #eof with open string + error "tomlish eof reached without closing quote for string. [tomlish::parse::report_line]" + } elseif {$toklen == 2} { + #valid + #we ended in a double quote, not actually a startquoteseqence - effectively an empty string + switch_tokenType "startquote" + incr i -1 + #set_token_waiting type string value "" complete 1 + return 1 + } + } + _start_squote_sequence { + set toklen [tcl::string::length $tok] + switch -- $toklen { + 1 { + #invalid eof with open literal + error "tomlish eof reached without closing single quote for string literal. [tomlish::parse::report_line]" + } + 2 { + #review + set_token_waiting type endsquote value "'" complete 1 startindex [expr {$cindex -1}] + set_tokenType "literal" + set tok "" + return 1 + } + } + } + newline { + #The only newline token that has still not been returned should have a tok value of "cr" + puts "tomlish eof reached - with incomplete newline token '$tok'" + if {$tok eq "cr"} { + #we convert lone cr to it's own "cr" token elsewhere in the document to allow statemachine to handle it. + #(which it should generally do by not handling it ie raising an error - or emitting an ERROR list in the tomlish) + #if trailing char is a lone cr - we should encode it the same way as elsewhere that is outside of values + # ie as it's own token. + switch_tokenType "cr" + return 1 + } else { + #should be unreachable + error "tomlish eof reached - with invalid newline token. value: $tok" + } + } + } + set_token_waiting type eof value eof complete 1 startindex $i ;#review + return 1 + } else { + ::tomlish::log::debug "- No current tokenType, ran out of characters, setting tokenType to 'eof' [tomlish::parse::report_line]" + set tokenType "eof" + set tok "eof" + } + return 0 + } + + #*** !doctools + #[list_end] [comment {--- end definitions namespace tomlish::parse ---}] +} + +namespace eval tomlish::dict { + namespace export {[a-z]*}; # Convention: export all lowercase + namespace path [namespace parent] + + proc is_tomlish_typeval {d} { + #designed to detect {type value } e.g {type INT value 3}, {type STRING value "blah etc"} + #as a sanity check we need to avoid mistaking user data that happens to match same form + #consider x.y={type="spud",value="blah"} + #The value of type will itself have already been converted to {type STRING value spud} ie never a single element. + #check the length of the type as a quick way to see it's a tag - not something else masqerading. + expr {[dict size $d] == 2 && [dict exists $d type] && [dict exists $d value] && [llength [dict get $d type]] == 1} + } + proc is_tomlish_typeval2 {d} { + upvar ::tomlish::tags tags + expr {[lindex $d 0] eq "type" && [lindex $d 1] in $tags} + } + proc last_tomltype_posn {d} { + set last_simple -1 + set dictposn [expr {[dict size $d] -1}] + foreach k [lreverse [dict keys $d]] { + set dval [dict get $d $k] + if {[is_tomlish_typeval $dval]} { + set last_simple $dictposn + break + } + incr dictposn -1 + } + return $last_simple + } + + + #review + proc name_from_tablestack {tablestack} { + set name "" + foreach tinfo [lrange $tablestack 1 end] { + lassign $tinfo type namepart + switch -- $type { + T { + if {$name eq ""} { + append name $namepart + } else { + append name .$namepart + } + } + I { + if {$name eq ""} { + append name $namepart + } else { + append name .$namepart + } + } + default { + #end at first break in the leading sequence of T & I tablenames + break + } + } + } + return $name + } + +} + +tcl::namespace::eval tomlish::app { + variable applist [list encoder decoder test] + + #*** !doctools + #[subsection {Namespace tomlish::app}] + #[para] + #[list_begin definitions] + + proc decoder {args} { + #*** !doctools + #[call app::[fun decoder] [arg args]] + #[para] read toml on stdin until EOF + #[para] on error - returns non-zero exit code and writes error on stderr + #[para] on success - returns zero exit code and writes JSON encoding of the data on stdout + #[para] This decoder is intended to be compatible with toml-test + + set opts [dict merge [dict create] $args] + #fconfigure stdin -encoding utf-8 + fconfigure stdin -translation binary + #Just slurp it all - presumably we are not handling massive amounts of data on stdin. + # - even if the input is large, we probably don't gain much (aside from possible memory savings?) by attempting to process input as it arrives. + if {[catch { + set toml [read stdin] + }]} { + exit 2 ;#read error + } + try { + set j [::tomlish::toml_to_json $toml] + } on error {em} { + puts stderr "decoding failed: '$em'" + exit 1 + } + puts -nonewline stdout $j + exit 0 + } + + proc encoder {args} { + #*** !doctools + #[call app::[fun encoder] [arg args]] + #[para] read JSON on stdin until EOF + #[para] return non-zero exitcode if JSON data cannot be converted to a valid TOML representation + #[para] return zero exitcode and TOML data on stdout if JSON data can be converted. + #[para] This encoder is intended to be compatible with toml-test + + set opts [dict merge [dict create] $args] + fconfigure stdin -translation binary + if {[catch { + set json [read stdin] + }]} { + exit 2 ;#read error + } + try { + set toml [::tomlish::json_to_toml $json] + } on error {em} { + puts stderr "encoding failed: '$em'" + exit 1 + } + puts -nonewline stdout $toml + exit 0 + } + + proc test {args} { + set opts [dict merge [dict create] $args] + + package require test::tomlish + if {[dict exists $opts -suite]} { + test::tomlish::suite [dict get $opts -suite] + } + test::tomlish::run + } + + + #*** !doctools + #[list_end] [comment {--- end definitions namespace tomlish::app ---}] +} + +proc ::tomlish::appnames {} { + set applist [list] + foreach cmd [info commands ::tomlish::app::*] { + lappend applist [namespace tail $cmd] + } + return $applist +} + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# Secondary API namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +namespace eval tomlish::lib { + namespace export {[a-z]*}; # Convention: export all lowercase + namespace path [namespace parent] + #*** !doctools + #[subsection {Namespace tomlish::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 tomlish::lib ---}] +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +if {$argc > 0} { + puts stderr "argc: $argc args: $argv" + + if {($argc == 1)} { + if {[tcl::string::tolower $argv] in {help -help h -h}} { + puts stdout "Usage: -app where appname one of:[tomlish::appnames]" + exit 0 + } else { + puts stderr "Argument '$argv' not understood. Try -help" + exit 1 + } + } + set opts [dict create] + set opts [dict merge $opts $argv] + + set opts_understood [list -app ] + if {"-app" in [dict keys $opts]} { + #Don't vet the remaining opts - as they are interpreted by each app + } else { + foreach key [dict keys $opts] { + if {$key ni $opts_understood} { + puts stderr "Option '$key' not understood" + exit 1 + } + } + } + if {[dict exists $opts -app]} { + set app [dict get $opts -app] + if {$app ni [tomlish::appnames]} { + puts stderr "app '[dict get $opts -app]' not found" + exit 1 + } + tomlish::app::$app {*}$opts + } +} + +## Ready +package provide tomlish [namespace eval tomlish { + variable pkg tomlish + variable version + set version 1.1.4 +}] +return + +#*** !doctools +#[manpage_end] + diff --git a/src/vfs/_vfscommon.vfs/modules/zipper-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/zipper-0.1.0.tm deleted file mode 100644 index d096c65be518463b7705889d4e5694fa275388a6..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 3894 zcmb_d3p`Y58y|Pcszl`y#|%Yl2Dxl8rQG&&DRQe_#4&T`!raW9aT!D!bpaqIIB#h`3Ali=v!Xz3HJ?D(Y<}yJBT>t@obQXmT@JL)b2M&lu(a;0P zU9*<1iC#s^U1JeVIW-X;J(EHD@e17-tc2!^;!ItxP4_{bgyglPo8ki+Kj z=;#?9NPz%43pvFBxDXHK(n&C#&EnY_VI`c#O03Wz^ym2jP#A#40x>awp5I(RP$ZoP z^MHlt|9}2iK!S`UH68?`v6AUrKuia@V}VR)k&lG&{P94LMGg!{N-ehGvf1#Qk$4G% zbjG56fCK;oL^4Tb0e(CVgAUJ~dJBdRm{0p000PfLQY&FSr-r{~4Pk786PFf`W^n;; z$xQOtd@e~G-QU@nybD5rnGy_Q0f@namXH`q?fr_*``{yrA>%)kBdXYUbcq0%rzGtfN5{LiUhKd2Bb3>Krkd88e||i z3SfdPKFDB1A%;kF9CSpWMsxLEXb+_M01g8rL4*%x<&9v75s}G524N5xScq%H6Y8GC zW+8H8A&(Gb5TLLb=md{|;R=_3(-NE}Osfo5ucbT8_c zLPr$0RAv6k6s^=kE|(U|`*nGL=ly~4x6S-P`I87#(jEFnVla&57z_@BeCLPD90V6{N-!gsnk+8NkU5s;JHUQuweo=Q zkK?(xOU`CgQSKW0&|vwB^@$j{iBm?JJ6uoQay(~oQj|gaeISB(^7LS(oCvsZOE+Tj zQODB`n%{c(D!*Mu8OHhX%6#fqYb34R)8~J6BzU`Ss{Y3f*Vk)L z3Dv*~H}k%8OVu#c^NsVOK# zEu%5W$y?PoTZLlz^X96}dVL3iF~_s6?I@PX5rkT}K?c(;D^+6!G(pfQp9e=(?{pJK zpPjHjyT<2t#i$Y&N_Wb6)87tLxGOSLH)y!ETp3i^&{}UAkR?Av_@up0&~(VCEkP?g zZyWg;ekh?;cL+a7c<2&#npN14WHY6#Ww`TBsrvV}IvjE*z>n;XoS;%~zkz3mL&979 z4_GI)J~3|eBiQx_-hL)3&Qw*hx=m>~+x6(*JukN>kB^SdG=D_9B8G2gUp|l%8M5kX(4JvCt(~4Bft{scuJq;iCT0j)3(vUfRZ=rCN}4t6URId)iT072V?+WaLLWtD&y90W2_>oV%(Vg%=4sNc89V>ERLglX{D^_4 zQd5qWlcsic*Bi0!W9>fOdpzs(i#BQ7l*%zz(}^t;Du< zWuHb0Jzhj({q_p7zkhx~AAdh=mGD+=fwIF-MsB3x#%}l7=ZWm^z~hA4jP{-0*>(vY z&Du(5HrZLF&fNJeAbhPbpkq{Fs=wzm$Ap2n2bZnlOR8!v6Ns-942M+|&+MJ5ELIII z)9p(P%}75xb&!;nFRHD)vK#!3x=-r)lZ#qy$JgG|x$7I!&o*tj4>-)2^!t`-smYgy z3GHusn7|bd%>B5akgs$1%y3d&PAc`KxDD)d+m#ARH^8~Wp4e{+jfy(<%+yrv$i%KM zG!NTdT@(Gaga5rX6@r#4j{U3s#)B10-uwp!SI}E)!Q5)%Na8mx?AFH3p;+_T!Cw2@ z6WYOtYljZ-RU*Gjl1tpSqlkG}y(T#XieC0{QY`WFO|)n>a>hCSR*NB&UKG-#!`y)8%g z_xhH?B<=LPbh|5>7AKA-|BAamKKVFGC{tL7fy=7no%gVa8#Jei-LHcy_U|2O67}@9 z!4dl|ZNIVUsoWFS=TCZdswPV6#H%@N)HY_91wr6)ErGF@w`OBL~x0>Y- zT*4I6a&?1}LxroKvl53I+2YxS8EO{ z|4#0VQTsp#E9=5B@0;=(%V-*@W@)F)*8uX%?>Bz^sK{k&>ajjOg^DUS%PknMESW?7 zu$5qc$d>p!W%d3&gLWGe(o%H;VD^7oY*M$^y zAc1DX7y7U?eD`y!3HlpMG>)ik%zLWcI9RT?vENH}y+T^*sQr3#Vng~5I_n&J#>VRD z_FARl@8%M{V(^nIOK;!lJ^?+d8bUzhGh0@+?9i`X5}m8kIuHg zGJ;Zqqx}two=m^oN6d5&X)3Exr<|2N3D>V4^5$6SWPD|OJZ>W6L9Www@p!wguj0;CHF5V_ZDTui6=h!8dUMuD?|yn%r+lA6dx2|Do}XZ$t^eB?Ptz7^eJ>fb(+maFvrsZKRP;5%M3Wg0B7qeSWMd