From c2e6ba71e59ab68010c236767a6f82b4f04ed258 Mon Sep 17 00:00:00 2001 From: Julian Noble Date: Wed, 2 Apr 2025 05:11:11 +1100 Subject: [PATCH] update src/make.tcl and src/bootsupport --- src/bootsupport/modules/commandstack-0.3.tm | 1028 +- src/bootsupport/modules/fauxlink-0.1.0.tm | 567 - src/bootsupport/modules/fauxlink-0.1.1.tm | 21 +- src/bootsupport/modules/metaface-1.2.5.tm | 12822 ++++++++-------- src/bootsupport/modules/modpod-0.1.0.tm | 705 - src/bootsupport/modules/modpod-0.1.1.tm | 697 - src/bootsupport/modules/natsort-0.1.1.5.tm | 1894 --- src/bootsupport/modules/patterncmd-1.2.4.tm | 1288 +- .../modules/patternpredator2-1.2.4.tm | 1508 +- src/bootsupport/modules/punk/ansi-0.1.1.tm | 3 +- .../punk/cap/handlers/templates-0.1.0.tm | 65 +- src/bootsupport/modules/punk/config-0.1.tm | 972 +- src/bootsupport/modules/punk/mix/base-0.1.tm | 5 +- src/bootsupport/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 +- src/bootsupport/modules/punk/mod-0.1.tm | 327 +- src/bootsupport/modules/punk/path-0.1.0.tm | 21 +- src/bootsupport/modules/punk/repo-0.1.1.tm | 240 +- src/bootsupport/modules/punkapp-0.1.tm | 478 +- src/bootsupport/modules/punkcheck-0.1.0.tm | 114 +- src/bootsupport/modules/test/tomlish-1.1.1.tm | Bin 46279 -> 35259 bytes src/bootsupport/modules/test/tomlish-1.1.3.tm | Bin 0 -> 41457 bytes src/bootsupport/modules/textblock-0.1.1.tm | 7408 --------- src/bootsupport/modules/textblock-0.1.2.tm | 8520 ---------- src/bootsupport/modules/tomlish-1.1.2.tm | 160 +- .../{tomlish-1.1.1.tm => tomlish-1.1.3.tm} | 2110 ++- src/bootsupport/modules/zipper-0.11.tm | Bin 9248 -> 0 bytes src/make.tcl | 418 +- 32 files changed, 11484 insertions(+), 30131 deletions(-) delete mode 100644 src/bootsupport/modules/fauxlink-0.1.0.tm delete mode 100644 src/bootsupport/modules/modpod-0.1.0.tm delete mode 100644 src/bootsupport/modules/modpod-0.1.1.tm delete mode 100644 src/bootsupport/modules/natsort-0.1.1.5.tm create mode 100644 src/bootsupport/modules/test/tomlish-1.1.3.tm delete mode 100644 src/bootsupport/modules/textblock-0.1.1.tm delete mode 100644 src/bootsupport/modules/textblock-0.1.2.tm rename src/bootsupport/modules/{tomlish-1.1.1.tm => tomlish-1.1.3.tm} (75%) delete mode 100644 src/bootsupport/modules/zipper-0.11.tm diff --git a/src/bootsupport/modules/commandstack-0.3.tm b/src/bootsupport/modules/commandstack-0.3.tm index a45eaeaf..7884214c 100644 --- a/src/bootsupport/modules/commandstack-0.3.tm +++ b/src/bootsupport/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/bootsupport/modules/fauxlink-0.1.0.tm b/src/bootsupport/modules/fauxlink-0.1.0.tm deleted file mode 100644 index fe16b71a..00000000 --- a/src/bootsupport/modules/fauxlink-0.1.0.tm +++ /dev/null @@ -1,567 +0,0 @@ -# -*- tcl -*- -# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from -buildversion.txt -# -# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. -# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# (C) 2024 -# -# @@ Meta Begin -# Application fauxlink 0.1.0 -# Meta platform tcl -# Meta license MIT -# @@ Meta End - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# doctools header -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -#*** !doctools -#[manpage_begin fauxlink_module_fauxlink 0 0.1.0] -#[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 --}] -#[require fauxlink] -#[keywords symlink faux fake shortcut toml] -#[description] -#[para] A cross platform shortcut/symlink alternative. -#[para] Unapologetically ugly - but practical in certain circumstances. -#[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] where can be empty - then the effective nominal name is the tail of the -#[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] The can be unrelated to the actual target -#[para] e.g datafile.dat#..+file%23A.txt.fxlnk -#[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 -#[para] Extensions to behaviour should be added in the file as text data in Toml format, -#[para] with custom data being under a single application-chosen table name -#[para] The toplevel Toml table [fauxlink] is reserved for core extensions to this system. -#[para] Aside from the 2 used for delimiting (+ #) -#[para] certain characters which might normally be allowed in filesystems are required to be encoded -#[para] e.g space and tab are required to be %20 %09 -#[para] Others that require encoding are: * ? \ / | : ; " < > -#[para] The nul character in raw form, when detected, is always mapped away to the empty string - as very few filesystems support it. -#[para] Control characters and other punctuation is optional to encode. -#[para] Generally utf-8 should be used where possible and unicode characters can often be left unencoded on modern systems. -#[para] Where encoding of unicode is desired in the nominalname,encodedtarget,tag or comment portions it can be specified as %UXXXXXXXX -#[para] There must be between 1 and 8 X digits following the %U. Interpretation of chars following %U stops at the first non-hex character. -#[para] This means %Utest would not get any translation as there were no hex digits so it would come out as %Utest -# -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - -#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" -#If we needed the old-style literal %20 it would become -# "my-program-files#++server+c+Program%2520Files.fxlnk" -# -# The file:// scheme on windows supposedly *does* decode %xx (for use in a browser) -# e.g -# pfiles#file%3a++++localhost+c+Program%2520files -# The browser will work with literal spaces too though - so it could just as well be: -# pfiles#file%3a++++localhost+c+Program%20files -#windows may default to using explorer.exe instead of a browser for file:// urls though -#and explorer doesn't want the literal %20. It probably depends what API the file:// url is to be passed to? -#in a .url shortcut either literal space or %20 will work ie %xx values are decoded - - - -#*** !doctools -#[section Overview] -#[para] overview of fauxlink -#[subsection Concepts] -#[para] - - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Requirements -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - -#*** !doctools -#[subsection dependencies] -#[para] packages used by fauxlink -#[list_begin itemized] - -package require Tcl 8.6- -#*** !doctools -#[item] [package {Tcl 8.6-}] - -# #package require frobz -# #*** !doctools -# #[item] [package {frobz}] - -#*** !doctools -#[list_end] - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - -#*** !doctools -#[section API] - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# oo::class namespace -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -namespace eval fauxlink::class { - #*** !doctools - #[subsection {Namespace fauxlink::class}] - #[para] class definitions - if {[info commands [namespace current]::interface_sample1] eq ""} { - #*** !doctools - #[list_begin enumerated] - - # oo::class create interface_sample1 { - # #*** !doctools - # #[enum] CLASS [class interface_sample1] - # #[list_begin definitions] - - # method test {arg1} { - # #*** !doctools - # #[call class::interface_sample1 [method test] [arg arg1]] - # #[para] test method - # puts "test: $arg1" - # } - - # #*** !doctools - # #[list_end] [comment {-- end definitions interface_sample1}] - # } - - #*** !doctools - #[list_end] [comment {--- end class enumeration ---}] - } -} -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# Base namespace -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -namespace eval fauxlink { - namespace export {[a-z]*}; # Convention: export all lowercase - - #todo - enforce utf-8 - - #literal unicode chars supported by modern filesystems - leave as is - REVIEW - - - variable encode_map - variable decode_map - #most filesystems don't allow NULL - map to empty string - - #Make sure % is not in encode_map - set encode_map [dict create\ - \x00 ""\ - { } %20\ - \t %09\ - + %2B\ - # %23\ - * %2A\ - ? %3F\ - \\ %5C\ - / %2F\ - | %7C\ - : %3A\ - {;} %3B\ - {"} %22\ - < %3C\ - > %3E\ - ] - #above have some overlap with ctrl codes below. - #no big deal as it's a dict - - #must_encode - # + # * ? \ / | : ; " < > \t - # also NUL to empty string - - # also ctrl chars 01 to 1F (1..31) - for {set i 1} {$i < 32} {incr i} { - set ch [format %c $i] - set enc "%[format %02X $i]" - set enc_lower [string tolower $enc] - dict set encode_map $ch $enc - dict set decode_map $enc $ch - dict set decode_map $enc_lower $ch - } - - variable must_encode - set must_encode [dict keys $encode_map] - - - #if they are in - - #decode map doesn't include - # %00 (nul) - # %2F "/" - # %2f "/" - # %7f (del) - #we exlude the forward slash because we already have + for that - and multiple ways to specify it obscure intention. - # - set decode_map [dict merge $decode_map [dict create\ - %09 \t\ - %20 { }\ - %21 "!"\ - %22 {"}\ - %23 "#"\ - %24 "$"\ - %25 "%"\ - %26 "&"\ - %27 "'"\ - %28 "("\ - %29 ")"\ - %2A "*"\ - %2a "*"\ - %2B "+"\ - %2b "+"\ - %2C ","\ - %2c ","\ - %2D "-"\ - %2d "-"\ - %2E "."\ - %2e "."\ - %3A ":"\ - %3a ":"\ - %3B {;}\ - %3b {;}\ - %3D "="\ - %3C "<"\ - %3c "<"\ - %3d "="\ - %3E ">"\ - %3e ">"\ - %3F "?"\ - %3f "?"\ - %40 "@"\ - %5B "\["\ - %5b "\["\ - %5C "\\"\ - %5c "\\"\ - %5D "\]"\ - %5d "\]"\ - %5E "^"\ - %5e "^"\ - %60 "`"\ - %7B "{"\ - %7b "{"\ - %7C "|"\ - %7c "|"\ - %7D "}"\ - %7d "}"\ - %7E "~"\ - %7e "~"\ - ]] - #Don't go above 7f - #if we want to specify p - - - #*** !doctools - #[subsection {Namespace fauxlink}] - #[para] Core API functions for fauxlink - #[list_begin definitions] - proc Segment_mustencode_check {str} { - variable decode_map - variable encode_map ;#must_encode - set idx 0 - set err "" - foreach ch [split $str ""] { - if {[dict exists $encode_map $ch]} { - set enc [dict get $encode_map $ch] - if {[dict exists $decode_map $enc]} { - append err " char $idx should be encoded as $enc" \n - } else { - append err " no %xx encoding available. Use %UXX if really required" \n - } - } - incr idx - } - return $err ;#empty string if ok - } - - proc resolve {link} { - variable decode_map - variable encode_map - variable must_encode - set ftail [file tail $link] - set extension_name [string range [file extension $ftail] 1 end] - if {$extension_name ni [list fxlnk 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 - # 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" - } else { - set is_fauxlink 1 - set err_extra "" - } - set linkspec [file rootname $ftail] - # - any # or + within the target path or name should have been uri encoded as %23 and %2b - if {[tcl::string::first # $linkspec] < 0} { - set err "fauxlink::resolve '$link'. Link must contain a # (usually at start if name matches target)" - append err $err_extra - error $err - } - #The 1st 2 parts of split on # are name and target file/dir - #If there are only 3 parts the 3rd part is a comment and there are no 'tags' - #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 - #has a name, a target, 2 tags and one comment - - #check namespec already has required chars encoded - set segments [split $linkspec #] - lassign $segments namespec targetspec - #puts stderr "-->namespec $namespec" - set nametest [tcl::string::map $encode_map $namespec] - #puts stderr "-->nametest $nametest" - #nothing should be changed - if there are unencoded chars that must be encoded it is an error - if {[tcl::string::length $nametest] ne [tcl::string::length $namespec]} { - set err "fauxlink::resolve '$link' invalid chars in name part (section prior to first #)" - append err [Segment_mustencode_check $namespec] - append err $err_extra - error $err - } - #see comments below regarding 2 rounds and ordering. - set name [decode_unicode_escapes $namespec] - set name [tcl::string::map $decode_map $name] - #puts stderr "-->name: $name" - - set targetsegment [split $targetspec +] - #check each + delimited part of targetspec already has required chars encoded - set pp 0 ;#pathpart index - set targetpath_parts [list] - foreach pathpart $targetsegment { - set targettest [tcl::string::map $encode_map $pathpart] - if {[tcl::string::length $targettest] ne [tcl::string::length $pathpart]} { - set err "fauxlink::resolve '$link' invalid chars in targetpath (section following first #)" - append err [Segment_mustencode_check $pathpart] - append err $err_extra - error $err - } - #2 rounds of substitution is possibly asking for trouble.. - #We allow anything in the resultant segments anyway (as %UXXXX... allows all) - #so it's not so much about what can be encoded, - # - but it makes it harder to reason about for users - # In particular - if we map %XX first it makes %25 -> % substitution tricky - # if the user requires a literal %UXXX - they can't do %25UXXX - # the double sub would make it %UXXX -> somechar anyway. - #we do unicode first - as a 2nd round of %XX substitutions is unlikely to interfere. - #There is still the opportunity to use things like %U00000025 followed by hex-chars - # and get some minor surprises, but using %U on ascii is unlikely to be done accidentally - REVIEW - set pathpart [decode_unicode_escapes $pathpart] - set pathpart [tcl::string::map $decode_map $pathpart] - lappend targetpath_parts $pathpart - - incr pp - } - set targetpath [join $targetpath_parts /] - if {$name eq ""} { - set name [lindex $targetpath_parts end] - } - #we do the same encoding checks on tags and comments to increase chances of portability - set tags [list] - set comments [list] - switch -- [llength $segments] { - 2 { - #no tags or comments - } - 3 { - #only 3 sections - last is comment - even if looks like tags - #to make the 3rd part a tagset, an extra # would be needed - set comments [list [lindex $segments 2]] - } - default { - set tagset [lindex $segments 2] - if {$tagset eq ""} { - #ok - no tags - } else { - if {[string first @ $tagset] != 0} { - set err "fauxlink::resolve '$link' invalid tagset in 3rd #-delimited segment" - append err \n " - must begin with @" - append err $err_extra - error $err - } else { - set tagset [string range $tagset 1 end] - set rawtags [split $tagset @] - set tags [list] - foreach t $rawtags { - if {$t eq ""} { - lappend tags "" - } else { - set tagtest [tcl::string::map $encode_map $t] - if {[tcl::string::length $tagtest] ne [tcl::string::length $t]} { - set err "fauxlink::resolve '$link' invalid chars in tag [llength $tags]" - append err [Segment_mustencode_check $t] - append err $err_extra - error $err - } - lappend tags [tcl::string::map $decode_map [decode_unicode_escapes $t]] - } - } - } - } - set rawcomments [lrange $segments 3 end] - #set comments [lsearch -all -inline -not $comments ""] - set comments [list] - foreach c $rawcomments { - if {$c eq ""} {continue} - set commenttest [tcl::string::map $encode_map $c] - if {[tcl::string::length $commenttest] ne [tcl::string::length $c]} { - set err "fauxlink::resolve '$link' invalid chars in comment [llength $comments]" - append err [Segment_mustencode_check $c] - append err $err_extra - error $err - } - lappend comments [tcl::string::map $decode_map [decode_unicode_escapes $c]] - } - } - } - - set data [dict create name $name targetpath $targetpath tags $tags comments $comments fauxlinkextension $extension_name] - if {$is_fauxlink} { - #standard .fxlnk or .fauxlink - return $data - } else { - #custom extension - or called in error on wrong type of file but happened to parse. - #see comments at top regarding is_fauxlink - #make sure no keys in common at top level. - return [dict create\ - linktype $extension_name\ - note "nonstandard extension returning nonstandard dict with result in data key"\ - data $data\ - ] - } - } - variable map - - #default exclusion of / (%U2f and equivs) - #this would allow obfuscation of intention - when we have + for that anyway - proc decode_unicode_escapes {str {exclusions {/ \n \r \x00}}} { - variable map - set ucstart [string first %U $str 0] - if {$ucstart < 0} { - return $str - } - set max 8 - set map [list] - set strend [expr {[string length $str]-1}] - while {$ucstart >= 0} { - set s $ucstart - set i [expr {$s +2}] ;#skip the %U - set hex "" - while {[tcl::string::length $hex] < 8 && $i <= $strend} { - set in [string index $str $i] - if {[tcl::string::is xdigit -strict $in]} { - append hex $in - } else { - break - } - incr i - } - if {$hex ne ""} { - incr i -1 - lappend map $s $i $hex - } - set ucstart [tcl::string::first %U $str $i] - } - set out "" - set lastidx -1 - set e 0 - foreach {s e hex} $map { - append out [string range $str $lastidx+1 $s-1] - set sub [format %c 0x$hex] - if {$sub in $exclusions} { - append out %U$hex ;#put it back - } else { - append out $sub - } - set lastidx $e - } - if {$e < [tcl::string::length $str]-1} { - append out [string range $str $e+1 end] - } - return $out - } - proc link_as {name target} { - - } - - #proc sample1 {p1 args} { - # #*** !doctools - # #[call [fun sample1] [arg p1] [opt {?option value...?}]] - # #[para]Description of sample1 - # return "ok" - #} - - - - - #*** !doctools - #[list_end] [comment {--- end definitions namespace fauxlink ---}] -} -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# Secondary API namespace -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -namespace eval fauxlink::lib { - namespace export {[a-z]*}; # Convention: export all lowercase - namespace path [namespace parent] - #*** !doctools - #[subsection {Namespace fauxlink::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 fauxlink::lib ---}] -} -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -#*** !doctools -#[section Internal] -namespace eval fauxlink::system { - #*** !doctools - #[subsection {Namespace fauxlink::system}] - #[para] Internal functions that are not part of the API - - - -} -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready -package provide fauxlink [namespace eval fauxlink { - variable pkg fauxlink - variable version - set version 0.1.0 -}] -return - -#*** !doctools -#[manpage_end] - diff --git a/src/bootsupport/modules/fauxlink-0.1.1.tm b/src/bootsupport/modules/fauxlink-0.1.1.tm index 5d63ffef..970e47da 100644 --- a/src/bootsupport/modules/fauxlink-0.1.1.tm +++ b/src/bootsupport/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/bootsupport/modules/metaface-1.2.5.tm b/src/bootsupport/modules/metaface-1.2.5.tm index 4c88cb16..ebcf579e 100644 --- a/src/bootsupport/modules/metaface-1.2.5.tm +++ b/src/bootsupport/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/bootsupport/modules/modpod-0.1.0.tm b/src/bootsupport/modules/modpod-0.1.0.tm deleted file mode 100644 index fd6b00ec..00000000 --- a/src/bootsupport/modules/modpod-0.1.0.tm +++ /dev/null @@ -1,705 +0,0 @@ -# -*- tcl -*- -# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from -buildversion.txt -# -# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. -# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# (C) 2024 -# -# @@ Meta Begin -# Application modpod 0.1.0 -# Meta platform tcl -# Meta license -# @@ Meta End - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# doctools header -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -#*** !doctools -#[manpage_begin modpod_module_modpod 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 modpod] -#[keywords module] -#[description] -#[para] - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - -#*** !doctools -#[section Overview] -#[para] overview of modpod -#[subsection Concepts] -#[para] - - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Requirements -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - -#*** !doctools -#[subsection dependencies] -#[para] packages used by modpod -#[list_begin itemized] - -package require Tcl 8.6- -package require struct::set ;#review -package require punk::lib -package require punk::args -#*** !doctools -#[item] [package {Tcl 8.6-}] - -# #package require frobz -# #*** !doctools -# #[item] [package {frobz}] - -#*** !doctools -#[list_end] - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - -#*** !doctools -#[section API] - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# oo::class namespace -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -namespace eval modpod::class { - #*** !doctools - #[subsection {Namespace modpod::class}] - #[para] class definitions - if {[info commands [namespace current]::interface_sample1] eq ""} { - #*** !doctools - #[list_begin enumerated] - - # oo::class create interface_sample1 { - # #*** !doctools - # #[enum] CLASS [class interface_sample1] - # #[list_begin definitions] - - # method test {arg1} { - # #*** !doctools - # #[call class::interface_sample1 [method test] [arg arg1]] - # #[para] test method - # puts "test: $arg1" - # } - - # #*** !doctools - # #[list_end] [comment {-- end definitions interface_sample1}] - # } - - #*** !doctools - #[list_end] [comment {--- end class enumeration ---}] - } -} -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# Base namespace -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -namespace eval modpod { - namespace export {[a-z]*}; # Convention: export all lowercase - - variable connected - if {![info exists connected(to)]} { - set connected(to) list - } - variable modpodscript - set modpodscript [info script] - if {[string tolower [file extension $modpodscript]] eq ".tcl"} { - set connected(self) [file dirname $modpodscript] - } else { - #expecting a .tm - set connected(self) $modpodscript - } - variable loadables [info sharedlibextension] - variable sourceables {.tcl .tk} ;# .tm ? - - #*** !doctools - #[subsection {Namespace modpod}] - #[para] Core API functions for modpod - #[list_begin definitions] - - - - #proc sample1 {p1 args} { - # #*** !doctools - # #[call [fun sample1] [arg p1] [opt {?option value...?}]] - # #[para]Description of sample1 - # return "ok" - #} - - proc connect {args} { - puts stderr "modpod::connect--->>$args" - set argd [punk::args::get_dict { - -type -default "" - *values -min 1 -max 1 - path -type string -minlen 1 -help "path to .tm file or toplevel .tcl script within #modpod-- folder (unwrapped modpod)" - } $args] - catch { - punk::lib::showdict $argd ;#heavy dependencies - } - set opt_path [dict get $argd values path] - variable connected - set original_connectpath $opt_path - set modpodpath [modpod::system::normalize $opt_path] ;# - - if {$modpodpath in $connected(to)} { - return [dict create ok ALREADY_CONNECTED] - } - lappend connected(to) $modpodpath - - set connected(connectpath,$opt_path) $original_connectpath - set is_sourced [expr {[file normalize $modpodpath] eq [file normalize [info_script]]}] - - set connected(location,$modpodpath) [file dirname $modpodpath] - set connected(startdata,$modpodpath) -1 - set connected(type,$modpodpath) [dict get $argd-opts -type] - set connected(fh,$modpodpath) "" - - if {[string range [file tail $modpodpath] 0 7] eq "#modpod-"} { - set connected(type,$modpodpath) "unwrapped" - lassign [::split [file tail [file dirname $modpodpath]] -] connected(package,$modpodpath) connected(version,$modpodpath) - set this_pkg_tm_folder [file dirname [file dirname $modpodpath]] - - } else { - #connect to .tm but may still be unwrapped version available - lassign [::split [file rootname [file tail $modpodath]] -] connected(package,$modpodpath) connected(version,$modpodpath) - set this_pkg_tm_folder [file dirname $modpodpath] - if {$connected(type,$modpodpath) ne "unwrapped"} { - #Not directly connected to unwrapped version - but may still be redirected there - set unwrappedFolder [file join $connected(location,$modpodpath) #modpod-$connected(package,$modpodpath)-$connected(version,$modpodpath)] - if {[file exists $unwrappedFolder]} { - #folder with exact version-match must exist for redirect to 'unwrapped' - set con(type,$modpodpath) "modpod-redirecting" - } - } - - } - set unwrapped_tm_file [file join $this_pkg_tm_folder] "[set connected(package,$modpodpath)]-[set connected(version,$modpodpath)].tm" - set connected(tmfile,$modpodpath) - set tail_segments [list] - set lcase_tmfile_segments [string tolower [file split $this_pkg_tm_folder]] - set lcase_modulepaths [string tolower [tcl::tm::list]] - foreach lc_mpath $lcase_modulepaths { - set mpath_segments [file split $lc_mpath] - if {[llength [struct::set intersect $lcase_tmfile_segments $mpath_segments]] == [llength $mpath_segments]} { - set tail_segments [lrange [file split $this_pkg_tm_folder] [llength $mpath_segments] end] - break - } - } - if {[llength $tail_segments]} { - set connected(fullpackage,$modpodpath) [join [concat $tail_segments [set connected(package,$modpodpath)]] ::] ;#full name of package as used in package require - } else { - set connected(fullpackage,$modpodpath) [set connected(package,$modpodpath)] - } - - switch -exact -- $connected(type,$modpodpath) { - "modpod-redirecting" { - #redirect to the unwrapped version - set loadscript_name [file join $unwrappedFolder #modpod-loadscript-$con(package,$modpod).tcl] - - } - "unwrapped" { - if {[info commands ::thread::id] ne ""} { - set from [pid],[thread::id] - } else { - set from [pid] - } - #::modpod::Puts stderr "$from-> Package $connected(package,$modpodpath)-$connected(version,$modpodpath) is using unwrapped version: $modpodpath" - return [list ok ""] - } - default { - #autodetect .tm - zip/tar ? - #todo - use vfs ? - - #connect to tarball - start at 1st header - set connected(startdata,$modpodpath) 0 - set fh [open $modpodpath r] - set connected(fh,$modpodpath) $fh - fconfigure $fh -encoding iso8859-1 -translation binary -eofchar {} - - if {$connected(startdata,$modpodpath) >= 0} { - #verify we have a valid tar header - if {![catch {::modpod::system::tar::readHeader [red $fh 512]}]} { - seek $fh $connected(startdata,$modpodpath) start - return [list ok $fh] - } else { - #error "cannot verify tar header" - } - } - lpop connected(to) end - set connected(startdata,$modpodpath) -1 - unset connected(fh,$modpodpath) - catch {close $fh} - return [dict create err {Does not appear to be a valid modpod}] - } - } - } - proc disconnect {{modpod ""}} { - variable connected - if {![llength $connected(to)]} { - return 0 - } - if {$modpod eq ""} { - puts stderr "modpod::disconnect WARNING: modpod not explicitly specified. Disconnecting last connected: [lindex $connected(to) end]" - set modpod [lindex $connected(to) end] - } - - if {[set posn [lsearch $connected(to) $modpod]] == -1} { - puts stderr "modpod::disconnect WARNING: disconnect called when not connected: $modpod" - return 0 - } - if {[string length $connected(fh,$modpod)]} { - close $connected(fh,$modpod) - } - array unset connected *,$modpod - set connected(to) [lreplace $connected(to) $posn $posn] - return 1 - } - proc get {args} { - set argd [punk::args::get_dict { - -from -default "" -help "path to pod" - *values -min 1 -max 1 - filename - } $args] - set frompod [dict get $argd opts -from] - set filename [dict get $argd values filename] - - variable connected - set modpod [::tarjar::system::connect_if_not $frompod] - set fh $connected(fh,$modpod) - if {$connected(type,$modpod) eq "unwrapped"} { - #for unwrapped connection - $connected(location) already points to the #modpod-pkg-ver folder - if {[string range $filename 0 0 eq "/"]} { - #absolute path (?) - set path [file join $connected(location,$modpod) .. [string trim $filename /]] - } else { - #relative path - use #modpod-xxx as base - set path [file join $connected(location,$modpod) $filename] - } - set fd [open $path r] - #utf-8? - #fconfigure $fd -encoding iso8859-1 -translation binary - return [list ok [lindex [list [read $fd] [close $fd]] 0]] - } else { - #read from vfs - puts stderr "get $filename from wrapped pod '$frompod' not implemented" - } - } - - - #*** !doctools - #[list_end] [comment {--- end definitions namespace modpod ---}] -} -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# Secondary API namespace -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -namespace eval modpod::lib { - namespace export {[a-z]*}; # Convention: export all lowercase - namespace path [namespace parent] - #*** !doctools - #[subsection {Namespace modpod::lib}] - #[para] Secondary functions that are part of the API - #[list_begin definitions] - - #proc utility1 {p1 args} { - # #*** !doctools - # #[call lib::[fun utility1] [arg p1] [opt {?option value...?}]] - # #[para]Description of utility1 - # return 1 - #} - - proc is_valid_tm_version {versionpart} { - #Needs to be suitable for use with Tcl's 'package vcompare' - if {![catch [list package vcompare $versionparts $versionparts]]} { - return 1 - } else { - return 0 - } - } - proc make_zip_modpod {zipfile outfile} { - set mount_stub { - #zip file with Tcl loader prepended. - #generated using modpod::make_zip_modpod - if {[catch {file normalize [info script]} modfile]} { - error "modpod zip stub error. Unable to determine module path. (possible safe interp restrictions?)" - } - if {$modfile eq "" || ![file exists $modfile]} { - error "modpod zip stub error. Unable to determine module path" - } - set moddir [file dirname $modfile] - set mod_and_ver [file rootname [file tail $modfile]] - lassign [split $mod_and_ver -] moduletail version - if {[file exists $moddir/#modpod-$mod_and_ver]} { - source $moddir/#modpod-$mod_and_ver/$mod_and_ver.tm - } else { - #determine module namespace so we can mount appropriately - proc intersect {A B} { - if {[llength $A] == 0} {return {}} - if {[llength $B] == 0} {return {}} - if {[llength $B] > [llength $A]} { - set res $A - set A $B - set B $res - } - set res {} - foreach x $A {set ($x) {}} - foreach x $B { - if {[info exists ($x)]} { - lappend res $x - } - } - return $res - } - set lcase_tmfile_segments [string tolower [file split $moddir]] - set lcase_modulepaths [string tolower [tcl::tm::list]] - foreach lc_mpath $lcase_modulepaths { - set mpath_segments [file split $lc_mpath] - if {[llength [intersect $lcase_tmfile_segments $mpath_segments]] == [llength $mpath_segments]} { - set tail_segments [lrange [file split $moddir] [llength $mpath_segments] end] ;#use propertly cased tail - break - } - } - if {[llength $tail_segments]} { - set fullpackage [join [concat $tail_segments $moduletail] ::] ;#full name of package as used in package require - set mount_at #modpod/[file join {*}$tail_segments]/#mounted-modpod-$mod_and_ver - } else { - set fullpackage $moduletail - set mount_at #modpod/#mounted-modpod-$mod_and_ver - } - - if {[info commands tcl::zipfs::mount] ne ""} { - #argument order changed to be consistent with vfs::zip::Mount etc - #early versions: zipfs::Mount mountpoint zipname - #since 2023-09: zipfs::Mount zipname mountpoint - #don't use 'file exists' when testing mountpoints. (some versions at least give massive delays on windows platform for non-existance) - #This is presumably related to // being interpreted as a network path - set mountpoints [dict keys [tcl::zipfs::mount]] - if {"//zipfs:/$mount_at" ni $mountpoints} { - #despite API change tcl::zipfs package version was unfortunately not updated - so we don't know argument order without trying it - if {[catch { - #tcl::zipfs::mount $modfile //zipfs:/#mounted-modpod-$mod_and_ver ;#extremely slow if this is a wrong guess (artifact of aforementioned file exists issue ?) - #puts "tcl::zipfs::mount $modfile $mount_at" - tcl::zipfs::mount $modfile $mount_at - } errM]} { - #try old api - if {![catch {tcl::zipfs::mount //zipfs:/$mount_at $modfile}]} { - puts stderr "modpod stub>>> tcl::zipfs::mount failed.\nbut old api: tcl::zipfs::mount succeeded\n tcl::zipfs::mount //zipfs://$mount_at $modfile" - puts stderr "Consider upgrading tcl runtime to one with fixed zipfs API" - } - } - if {![file exists //zipfs:/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm]} { - puts stderr "modpod stub>>> mount at //zipfs:/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm failed\n zipfs mounts: [zipfs mount]" - #tcl::zipfs::unmount //zipfs:/$mount_at - error "Unable to find $mod_and_ver.tm in $modfile for module $fullpackage" - } - } - # #modpod-$mod_and_ver subdirectory always present in the archive so it can be conveniently extracted and run in that form - source //zipfs:/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm - } else { - #fallback to slower vfs::zip - #NB. We don't create the intermediate dirs - but the mount still works - if {![file exists $moddir/$mount_at]} { - if {[catch {package require vfs::zip} errM]} { - set msg "Unable to load vfs::zip package to mount module $mod_and_ver" - append msg \n "If vfs::zip is unavailable - the module can still be loaded by manually unzipping the file $modfile in place." - append msg \n "The unzipped data will all be contained in a folder named #modpod-$mod_and_ver in the same parent folder as $modfile" - error $msg - } else { - set fd [vfs::zip::Mount $modfile $moddir/$mount_at] - if {![file exists $moddir/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm]} { - vfs::zip::Unmount $fd $moddir/$mount_at - error "Unable to find $mod_and_ver.tm in $modfile for module $fullpackage" - } - } - } - source $moddir/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm - } - } - #zipped data follows - } - #todo - test if zipfile has #modpod-loadcript.tcl before even creating - append mount_stub \x1A - modpod::system::make_mountable_zip $zipfile $outfile $mount_stub - - } - proc make_zip_modpod1 {zipfile outfile} { - set mount_stub { - #zip file with Tcl loader prepended. - #generated using modpod::make_zip_modpod - if {[catch {file normalize [info script]} modfile]} { - error "modpod zip stub error. Unable to determine module path. (possible safe interp restrictions?)" - } - if {$modfile eq "" || ![file exists $modfile]} { - error "modpod zip stub error. Unable to determine module path" - } - set moddir [file dirname $modfile] - set mod_and_ver [file rootname [file tail $modfile]] - lassign [split $mod_and_ver -] moduletail version - if {[file exists $moddir/#modpod-$mod_and_ver]} { - source $moddir/#modpod-$mod_and_ver/$mod_and_ver.tm - } else { - if {![file exists $moddir/#mounted-modpod-$mod_and_ver]} { - if {[catch {package require vfs::zip} errM]} { - set msg "Unable to load vfs::zip package to mount module $mod_and_ver" - append msg \n "If vfs::zip is unavailable - the module can still be loaded by manually unzipping the file $modfile in place." - append msg \n "The unzipped data will all be contained in a folder named #modpod-$mod_and_ver in the same parent folder as $ - } - set fd [vfs::zip::Mount $modfile $moddir/#mounted-modpod-$mod_and_ver] - if {![file exists $moddir/#mounted-modpod-$mod_and_ver/#modpod-$mod_and_ver/$mod_and_ver.tm]} { - vfs::zip::Unmount $fd $moddir/#mounted-modpod-$mod_and_ver - error "Unable to find #modpod-$mod_and_ver/$mod_and_ver.tm in $modfile" - } - } - source $moddir/#mounted-modpod-$mod_and_ver/#modpod-$mod_and_ver/$mod_and_ver.tm - } - #zipped data follows - } - #todo - test if zipfile has #modpod-loadcript.tcl before even creating - append mount_stub \x1A - modpod::system::make_mountable_zip $zipfile $outfile $mount_stub - - } - proc make_zip_source_mountable {zipfile outfile} { - set mount_stub { - package require vfs::zip - vfs::zip::Mount [info script] [info script] - } - append mount_stub \x1A - modpod::system::make_mountable_zip $zipfile $outfile $mount_stub - } - - #*** !doctools - #[list_end] [comment {--- end definitions namespace modpod::lib ---}] -} -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -#*** !doctools -#[section Internal] -namespace eval modpod::system { - #*** !doctools - #[subsection {Namespace modpod::system}] - #[para] Internal functions that are not part of the API - - #deflate,store only supported - proc make_mountable_zip {zipfile outfile mount_stub} { - set in [open $zipfile r] - fconfigure $in -encoding iso8859-1 -translation binary - set out [open $outfile w+] - fconfigure $out -encoding iso8859-1 -translation binary - puts -nonewline $out $mount_stub - set offset [tell $out] - lappend report "sfx stub size: $offset" - fcopy $in $out - - close $in - set size [tell $out] - #Now seek in $out to find the end of directory signature: - #The structure itself is 24 bytes Long, followed by a maximum of 64Kbytes text - if {$size < 65559} { - set seek 0 - } else { - set seek [expr {$size - 65559}] - } - seek $out $seek - set data [read $out] - set start_of_end [string last "\x50\x4b\x05\x06" $data] - #set start_of_end [expr {$start_of_end + $seek}] - incr start_of_end $seek - - lappend report "START-OF-END: $start_of_end ([expr {$start_of_end - $size}]) [string length $data]" - - seek $out $start_of_end - set end_of_ctrl_dir [read $out] - binary scan $end_of_ctrl_dir issssiis eocd(signature) eocd(disknbr) eocd(ctrldirdisk) \ - eocd(numondisk) eocd(totalnum) eocd(dirsize) eocd(diroffset) eocd(comment_len) - - lappend report "End of central directory: [array get eocd]" - seek $out [expr {$start_of_end+16}] - - #adjust offset of start of central directory by the length of our sfx stub - puts -nonewline $out [binary format i [expr {$eocd(diroffset) + $offset}]] - flush $out - - seek $out $start_of_end - set end_of_ctrl_dir [read $out] - binary scan $end_of_ctrl_dir issssiis eocd(signature) eocd(disknbr) eocd(ctrldirdisk) \ - eocd(numondisk) eocd(totalnum) eocd(dirsize) eocd(diroffset) eocd(comment_len) - - # 0x06054b50 - end of central dir signature - puts stderr "$end_of_ctrl_dir" - puts stderr "comment_len: $eocd(comment_len)" - puts stderr "eocd sig: $eocd(signature) [punk::lib::dec2hex $eocd(signature)]" - lappend report "New dir offset: $eocd(diroffset)" - lappend report "Adjusting $eocd(totalnum) zip file items." - catch { - punk::lib::showdict -roottype list -chan stderr $report ;#heavy dependencies - } - - seek $out $eocd(diroffset) - for {set i 0} {$i <$eocd(totalnum)} {incr i} { - set current_file [tell $out] - set fileheader [read $out 46] - puts -------------- - puts [ansistring VIEW -lf 1 $fileheader] - puts -------------- - #binary scan $fileheader is2sss2ii2s3ssii x(sig) x(version) x(flags) x(method) \ - # x(date) x(crc32) x(sizes) x(lengths) x(diskno) x(iattr) x(eattr) x(offset) - - binary scan $fileheader ic4sss2ii2s3ssii x(sig) x(version) x(flags) x(method) \ - x(date) x(crc32) x(sizes) x(lengths) x(diskno) x(iattr) x(eattr) x(offset) - set ::last_header $fileheader - - puts "sig: $x(sig) (hex: [punk::lib::dec2hex $x(sig)])" - puts "ver: $x(version)" - puts "method: $x(method)" - - #33639248 dec = 0x02014b50 - central file header signature - if { $x(sig) != 33639248 } { - error "modpod::system::make_mountable_zip Bad file header signature at item $i: dec:$x(sig) hex:[punk::lib::dec2hex $x(sig)]" - } - - foreach size $x(lengths) var {filename extrafield comment} { - if { $size > 0 } { - set x($var) [read $out $size] - } else { - set x($var) "" - } - } - set next_file [tell $out] - lappend report "file $i: $x(offset) $x(sizes) $x(filename)" - - seek $out [expr {$current_file+42}] - puts -nonewline $out [binary format i [expr {$x(offset)+$offset}]] - - #verify: - flush $out - seek $out $current_file - set fileheader [read $out 46] - lappend report "old $x(offset) + $offset" - binary scan $fileheader is2sss2ii2s3ssii x(sig) x(version) x(flags) x(method) \ - x(date) x(crc32) x(sizes) x(lengths) x(diskno) x(iattr) x(eattr) x(offset) - lappend report "new $x(offset)" - - seek $out $next_file - } - close $out - #pdict/showdict reuire punk & textlib - ie lots of dependencies - #don't fall over just because of that - catch { - punk::lib::showdict -roottype list -chan stderr $report - } - #puts [join $report \n] - return - } - - proc connect_if_not {{podpath ""}} { - upvar ::modpod::connected connected - set podpath [::modpod::system::normalize $podpath] - set docon 0 - if {![llength $connected(to)]} { - if {![string length $podpath]} { - error "modpod::system::connect_if_not - Not connected to a modpod file, and no podpath specified" - } else { - set docon 1 - } - } else { - if {![string length $podpath]} { - set podpath [lindex $connected(to) end] - puts stderr "modpod::system::connect_if_not WARNING: using last connected modpod:$podpath for operation\n -podpath not explicitly specified during operation: [info level -1]" - } else { - if {$podpath ni $connected(to)} { - set docon 1 - } - } - } - if {$docon} { - if {[lindex [modpod::connect $podpath]] 0] ne "ok"} { - error "modpod::system::connect_if_not error. file $podpath does not seem to be a valid modpod" - } else { - return $podpath - } - } - #we were already connected - return $podpath - } - - proc myversion {} { - upvar ::modpod::connected connected - set script [info script] - if {![string length $script]} { - error "No result from \[info script\] - modpod::system::myversion should only be called from within a loading modpod" - } - set fname [file tail [file rootname [file normalize $script]]] - set scriptdir [file dirname $script] - - if {![string match "#modpod-*" $fname]} { - lassign [lrange [split $fname -] end-1 end] _pkgname version - } else { - lassign [scan [file tail [file rootname $script]] {#modpod-loadscript-%[a-z]-%s}] _pkgname version - if {![string length $version]} { - #try again on the name of the containing folder - lassign [scan [file tail $scriptdir] {#modpod-%[a-z]-%s}] _pkgname version - #todo - proper walk up the directory tree - if {![string length $version]} { - #try again on the grandparent folder (this is a standard depth for sourced .tcl files in a modpod) - lassign [scan [file tail [file dirname $scriptdir]] {#modpod-%[a-z]-%s}] _pkgname version - } - } - } - - #tarjar::Log debug "'myversion' determined version for [info script]: $version" - return $version - } - - proc myname {} { - upvar ::modpod::connected connected - set script [info script] - if {![string length $script]} { - error "No result from \[info script\] - modpod::system::myname should only be called from within a loading modpod" - } - return $connected(fullpackage,$script) - } - proc myfullname {} { - upvar ::modpod::connected connected - set script [info script] - #set script [::tarjar::normalize $script] - set script [file normalize $script] - if {![string length $script]} { - error "No result from \[info script\] - modpod::system::myfullname should only be called from within a loading tarjar" - } - return $::tarjar::connected(fullpackage,$script) - } - proc normalize {path} { - #newer versions of Tcl don't do tilde sub - - #Tcl's 'file normalize' seems to do some unfortunate tilde substitution on windows.. (at least for relative paths) - # we take the assumption here that if Tcl's tilde substitution is required - it should be done before the path is provided to this function. - set matilda "<_tarjar_tilde_placeholder_>" ;#token that is *unlikely* to occur in the wild, and is somewhat self describing in case it somehow ..escapes.. - set path [string map [list ~ $matilda] $path] ;#give our tildes to matilda to look after - set path [file normalize $path] - #set path [string tolower $path] ;#must do this after file normalize - return [string map [list $matilda ~] $path] ;#get our tildes back. -} -} -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready -package provide modpod [namespace eval modpod { - variable pkg modpod - variable version - set version 0.1.0 -}] -return - -#*** !doctools -#[manpage_end] - diff --git a/src/bootsupport/modules/modpod-0.1.1.tm b/src/bootsupport/modules/modpod-0.1.1.tm deleted file mode 100644 index afa3be2a..00000000 --- a/src/bootsupport/modules/modpod-0.1.1.tm +++ /dev/null @@ -1,697 +0,0 @@ -# -*- tcl -*- -# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from -buildversion.txt -# -# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. -# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# (C) 2024 -# -# @@ Meta Begin -# Application modpod 0.1.1 -# Meta platform tcl -# Meta license -# @@ Meta End - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# doctools header -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -#*** !doctools -#[manpage_begin modpod_module_modpod 0 0.1.1] -#[copyright "2024"] -#[titledesc {Module API}] [comment {-- Name section and table of contents description --}] -#[moddesc {-}] [comment {-- Description at end of page heading --}] -#[require modpod] -#[keywords module] -#[description] -#[para] - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - -#*** !doctools -#[section Overview] -#[para] overview of modpod -#[subsection Concepts] -#[para] - - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Requirements -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - -#*** !doctools -#[subsection dependencies] -#[para] packages used by modpod -#[list_begin itemized] - -package require Tcl 8.6- -package require struct::set ;#review -package require punk::lib -package require punk::args -#*** !doctools -#[item] [package {Tcl 8.6-}] - -# #package require frobz -# #*** !doctools -# #[item] [package {frobz}] - -#*** !doctools -#[list_end] - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - -#*** !doctools -#[section API] - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# oo::class namespace -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -namespace eval modpod::class { - #*** !doctools - #[subsection {Namespace modpod::class}] - #[para] class definitions - if {[info commands [namespace current]::interface_sample1] eq ""} { - #*** !doctools - #[list_begin enumerated] - - # oo::class create interface_sample1 { - # #*** !doctools - # #[enum] CLASS [class interface_sample1] - # #[list_begin definitions] - - # method test {arg1} { - # #*** !doctools - # #[call class::interface_sample1 [method test] [arg arg1]] - # #[para] test method - # puts "test: $arg1" - # } - - # #*** !doctools - # #[list_end] [comment {-- end definitions interface_sample1}] - # } - - #*** !doctools - #[list_end] [comment {--- end class enumeration ---}] - } -} -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# Base namespace -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -namespace eval modpod { - namespace export {[a-z]*}; # Convention: export all lowercase - - variable connected - if {![info exists connected(to)]} { - set connected(to) list - } - variable modpodscript - set modpodscript [info script] - if {[string tolower [file extension $modpodscript]] eq ".tcl"} { - set connected(self) [file dirname $modpodscript] - } else { - #expecting a .tm - set connected(self) $modpodscript - } - variable loadables [info sharedlibextension] - variable sourceables {.tcl .tk} ;# .tm ? - - #*** !doctools - #[subsection {Namespace modpod}] - #[para] Core API functions for modpod - #[list_begin definitions] - - - - #proc sample1 {p1 args} { - # #*** !doctools - # #[call [fun sample1] [arg p1] [opt {?option value...?}]] - # #[para]Description of sample1 - # return "ok" - #} - - #old tar connect mechanism - review - not needed? - proc connect {args} { - puts stderr "modpod::connect--->>$args" - set argd [punk::args::get_dict { - -type -default "" - *values -min 1 -max 1 - path -type string -minlen 1 -help "path to .tm file or toplevel .tcl script within #modpod-- folder (unwrapped modpod)" - } $args] - catch { - punk::lib::showdict $argd ;#heavy dependencies - } - set opt_path [dict get $argd values path] - variable connected - set original_connectpath $opt_path - set modpodpath [modpod::system::normalize $opt_path] ;# - - if {$modpodpath in $connected(to)} { - return [dict create ok ALREADY_CONNECTED] - } - lappend connected(to) $modpodpath - - set connected(connectpath,$opt_path) $original_connectpath - set is_sourced [expr {[file normalize $modpodpath] eq [file normalize [info script]]}] - - set connected(location,$modpodpath) [file dirname $modpodpath] - set connected(startdata,$modpodpath) -1 - set connected(type,$modpodpath) [dict get $argd opts -type] - set connected(fh,$modpodpath) "" - - if {[string range [file tail $modpodpath] 0 7] eq "#modpod-"} { - set connected(type,$modpodpath) "unwrapped" - lassign [::split [file tail [file dirname $modpodpath]] -] connected(package,$modpodpath) connected(version,$modpodpath) - set this_pkg_tm_folder [file dirname [file dirname $modpodpath]] - - } else { - #connect to .tm but may still be unwrapped version available - lassign [::split [file rootname [file tail $modpodath]] -] connected(package,$modpodpath) connected(version,$modpodpath) - set this_pkg_tm_folder [file dirname $modpodpath] - if {$connected(type,$modpodpath) ne "unwrapped"} { - #Not directly connected to unwrapped version - but may still be redirected there - set unwrappedFolder [file join $connected(location,$modpodpath) #modpod-$connected(package,$modpodpath)-$connected(version,$modpodpath)] - if {[file exists $unwrappedFolder]} { - #folder with exact version-match must exist for redirect to 'unwrapped' - set con(type,$modpodpath) "modpod-redirecting" - } - } - - } - set unwrapped_tm_file [file join $this_pkg_tm_folder] "[set connected(package,$modpodpath)]-[set connected(version,$modpodpath)].tm" - set connected(tmfile,$modpodpath) - set tail_segments [list] - set lcase_tmfile_segments [string tolower [file split $this_pkg_tm_folder]] - set lcase_modulepaths [string tolower [tcl::tm::list]] - foreach lc_mpath $lcase_modulepaths { - set mpath_segments [file split $lc_mpath] - if {[llength [struct::set intersect $lcase_tmfile_segments $mpath_segments]] == [llength $mpath_segments]} { - set tail_segments [lrange [file split $this_pkg_tm_folder] [llength $mpath_segments] end] - break - } - } - if {[llength $tail_segments]} { - set connected(fullpackage,$modpodpath) [join [concat $tail_segments [set connected(package,$modpodpath)]] ::] ;#full name of package as used in package require - } else { - set connected(fullpackage,$modpodpath) [set connected(package,$modpodpath)] - } - - switch -exact -- $connected(type,$modpodpath) { - "modpod-redirecting" { - #redirect to the unwrapped version - set loadscript_name [file join $unwrappedFolder #modpod-loadscript-$con(package,$modpod).tcl] - - } - "unwrapped" { - if {[info commands ::thread::id] ne ""} { - set from [pid],[thread::id] - } else { - set from [pid] - } - #::modpod::Puts stderr "$from-> Package $connected(package,$modpodpath)-$connected(version,$modpodpath) is using unwrapped version: $modpodpath" - return [list ok ""] - } - default { - #autodetect .tm - zip/tar ? - #todo - use vfs ? - - #connect to tarball - start at 1st header - set connected(startdata,$modpodpath) 0 - set fh [open $modpodpath r] - set connected(fh,$modpodpath) $fh - fconfigure $fh -encoding iso8859-1 -translation binary -eofchar {} - - if {$connected(startdata,$modpodpath) >= 0} { - #verify we have a valid tar header - if {![catch {::modpod::system::tar::readHeader [red $fh 512]}]} { - seek $fh $connected(startdata,$modpodpath) start - return [list ok $fh] - } else { - #error "cannot verify tar header" - } - } - lpop connected(to) end - set connected(startdata,$modpodpath) -1 - unset connected(fh,$modpodpath) - catch {close $fh} - return [dict create err {Does not appear to be a valid modpod}] - } - } - } - proc disconnect {{modpod ""}} { - variable connected - if {![llength $connected(to)]} { - return 0 - } - if {$modpod eq ""} { - puts stderr "modpod::disconnect WARNING: modpod not explicitly specified. Disconnecting last connected: [lindex $connected(to) end]" - set modpod [lindex $connected(to) end] - } - - if {[set posn [lsearch $connected(to) $modpod]] == -1} { - puts stderr "modpod::disconnect WARNING: disconnect called when not connected: $modpod" - return 0 - } - if {[string length $connected(fh,$modpod)]} { - close $connected(fh,$modpod) - } - array unset connected *,$modpod - set connected(to) [lreplace $connected(to) $posn $posn] - return 1 - } - proc get {args} { - set argd [punk::args::get_dict { - -from -default "" -help "path to pod" - *values -min 1 -max 1 - filename - } $args] - set frompod [dict get $argd opts -from] - set filename [dict get $argd values filename] - - variable connected - #//review - set modpod [::modpod::system::connect_if_not $frompod] - set fh $connected(fh,$modpod) - if {$connected(type,$modpod) eq "unwrapped"} { - #for unwrapped connection - $connected(location) already points to the #modpod-pkg-ver folder - if {[string range $filename 0 0 eq "/"]} { - #absolute path (?) - set path [file join $connected(location,$modpod) .. [string trim $filename /]] - } else { - #relative path - use #modpod-xxx as base - set path [file join $connected(location,$modpod) $filename] - } - set fd [open $path r] - #utf-8? - #fconfigure $fd -encoding iso8859-1 -translation binary - return [list ok [lindex [list [read $fd] [close $fd]] 0]] - } else { - #read from vfs - puts stderr "get $filename from wrapped pod '$frompod' not implemented" - } - } - - - #*** !doctools - #[list_end] [comment {--- end definitions namespace modpod ---}] -} -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# Secondary API namespace -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -namespace eval modpod::lib { - namespace export {[a-z]*}; # Convention: export all lowercase - namespace path [namespace parent] - #*** !doctools - #[subsection {Namespace modpod::lib}] - #[para] Secondary functions that are part of the API - #[list_begin definitions] - - #proc utility1 {p1 args} { - # #*** !doctools - # #[call lib::[fun utility1] [arg p1] [opt {?option value...?}]] - # #[para]Description of utility1 - # return 1 - #} - - proc is_valid_tm_version {versionpart} { - #Needs to be suitable for use with Tcl's 'package vcompare' - if {![catch [list package vcompare $versionparts $versionparts]]} { - return 1 - } else { - return 0 - } - } - - #zipfile is a pure zip at this point - ie no script/exe header - proc make_zip_modpod {args} { - set argd [punk::args::get_dict { - -offsettype -default "file" -choices {archive file} -help "Whether zip offsets are relative to start of file or start of zip-data within the file. - 'archive' relative offsets are easier to work with (for writing/updating) in tools such as 7zip,peazip, - but other tools may be easier with 'file' relative offsets. (e.g info-zip,pkzip) - info-zip's 'zip -A' can sometimes convert archive-relative to file-relative. - -offsettype archive is equivalent to plain 'cat prefixfile zipfile > modulefile'" - *values -min 2 -max 2 - zipfile -type path -minlen 1 -help "path to plain zip file with subfolder #modpod-packagename-version containing .tm, data files and/or binaries" - outfile -type path -minlen 1 -help "path to output file. Name should be of the form packagename-version.tm" - } $args] - set zipfile [dict get $argd values zipfile] - set outfile [dict get $argd values outfile] - set opt_offsettype [dict get $argd opts -offsettype] - - - set mount_stub [string map [list %offsettype% $opt_offsettype] { - #zip file with Tcl loader prepended. Requires either builtin zipfs, or vfs::zip to mount while zipped. - #Alternatively unzip so that extracted #modpod-package-version folder is in same folder as .tm file. - #generated using: modpod::lib::make_zip_modpod -offsettype %offsettype% - if {[catch {file normalize [info script]} modfile]} { - error "modpod zip stub error. Unable to determine module path. (possible safe interp restrictions?)" - } - if {$modfile eq "" || ![file exists $modfile]} { - error "modpod zip stub error. Unable to determine module path" - } - set moddir [file dirname $modfile] - set mod_and_ver [file rootname [file tail $modfile]] - lassign [split $mod_and_ver -] moduletail version - if {[file exists $moddir/#modpod-$mod_and_ver]} { - source $moddir/#modpod-$mod_and_ver/$mod_and_ver.tm - } else { - #determine module namespace so we can mount appropriately - proc intersect {A B} { - if {[llength $A] == 0} {return {}} - if {[llength $B] == 0} {return {}} - if {[llength $B] > [llength $A]} { - set res $A - set A $B - set B $res - } - set res {} - foreach x $A {set ($x) {}} - foreach x $B { - if {[info exists ($x)]} { - lappend res $x - } - } - return $res - } - set lcase_tmfile_segments [string tolower [file split $moddir]] - set lcase_modulepaths [string tolower [tcl::tm::list]] - foreach lc_mpath $lcase_modulepaths { - set mpath_segments [file split $lc_mpath] - if {[llength [intersect $lcase_tmfile_segments $mpath_segments]] == [llength $mpath_segments]} { - set tail_segments [lrange [file split $moddir] [llength $mpath_segments] end] ;#use properly cased tail - break - } - } - if {[llength $tail_segments]} { - set fullpackage [join [concat $tail_segments $moduletail] ::] ;#full name of package as used in package require - set mount_at #modpod/[file join {*}$tail_segments]/#mounted-modpod-$mod_and_ver - } else { - set fullpackage $moduletail - set mount_at #modpod/#mounted-modpod-$mod_and_ver - } - - if {[info commands tcl::zipfs::mount] ne ""} { - #argument order changed to be consistent with vfs::zip::Mount etc - #early versions: zipfs::Mount mountpoint zipname - #since 2023-09: zipfs::Mount zipname mountpoint - #don't use 'file exists' when testing mountpoints. (some versions at least give massive delays on windows platform for non-existance) - #This is presumably related to // being interpreted as a network path - set mountpoints [dict keys [tcl::zipfs::mount]] - if {"//zipfs:/$mount_at" ni $mountpoints} { - #despite API change tcl::zipfs package version was unfortunately not updated - so we don't know argument order without trying it - if {[catch { - #tcl::zipfs::mount $modfile //zipfs:/#mounted-modpod-$mod_and_ver ;#extremely slow if this is a wrong guess (artifact of aforementioned file exists issue ?) - #puts "tcl::zipfs::mount $modfile $mount_at" - tcl::zipfs::mount $modfile $mount_at - } errM]} { - #try old api - if {![catch {tcl::zipfs::mount //zipfs:/$mount_at $modfile}]} { - puts stderr "modpod stub>>> tcl::zipfs::mount failed.\nbut old api: tcl::zipfs::mount succeeded\n tcl::zipfs::mount //zipfs://$mount_at $modfile" - puts stderr "Consider upgrading tcl runtime to one with fixed zipfs API" - } - } - if {![file exists //zipfs:/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm]} { - puts stderr "modpod stub>>> mount at //zipfs:/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm failed\n zipfs mounts: [zipfs mount]" - #tcl::zipfs::unmount //zipfs:/$mount_at - error "Unable to find $mod_and_ver.tm in $modfile for module $fullpackage" - } - } - # #modpod-$mod_and_ver subdirectory always present in the archive so it can be conveniently extracted and run in that form - source //zipfs:/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm - } else { - #fallback to slower vfs::zip - #NB. We don't create the intermediate dirs - but the mount still works - if {![file exists $moddir/$mount_at]} { - if {[catch {package require vfs::zip} errM]} { - set msg "Unable to load vfs::zip package to mount module $mod_and_ver (and zipfs not available either)" - append msg \n "If neither zipfs or vfs::zip are available - the module can still be loaded by manually unzipping the file $modfile in place." - append msg \n "The unzipped data will all be contained in a folder named #modpod-$mod_and_ver in the same parent folder as $modfile" - error $msg - } else { - set fd [vfs::zip::Mount $modfile $moddir/$mount_at] - if {![file exists $moddir/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm]} { - vfs::zip::Unmount $fd $moddir/$mount_at - error "Unable to find $mod_and_ver.tm in $modfile for module $fullpackage" - } - } - } - source $moddir/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm - } - } - #zipped data follows - }] - #todo - test if supplied zipfile has #modpod-loadcript.tcl or some other script/executable before even creating? - append mount_stub \x1A - modpod::system::make_mountable_zip $zipfile $outfile $mount_stub $opt_offsettype - - } - - #*** !doctools - #[list_end] [comment {--- end definitions namespace modpod::lib ---}] -} -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -#*** !doctools -#[section Internal] -namespace eval modpod::system { - #*** !doctools - #[subsection {Namespace modpod::system}] - #[para] Internal functions that are not part of the API - - #deflate,store only supported - - #zipfile here is plain zip - no script/exe prefix part. - proc make_mountable_zip {zipfile outfile mount_stub {offsettype "file"}} { - set inzip [open $zipfile r] - fconfigure $inzip -encoding iso8859-1 -translation binary - set out [open $outfile w+] - fconfigure $out -encoding iso8859-1 -translation binary - puts -nonewline $out $mount_stub - set stuboffset [tell $out] - lappend report "sfx stub size: $stuboffset" - fcopy $inzip $out - close $inzip - - set size [tell $out] - lappend report "tmfile : [file tail $outfile]" - lappend report "output size : $size" - lappend report "offsettype : $offsettype" - - if {$offsettype eq "file"} { - #make zip offsets relative to start of whole file including prepended script. - #(same offset structure as Tcl's 'zipfs mkimg' as at 2024-10) - #we aren't adding any new files/folders so we can edit the offsets in place - - #Now seek in $out to find the end of directory signature: - #The structure itself is 24 bytes Long, followed by a maximum of 64Kbytes text - if {$size < 65559} { - set tailsearch_start 0 - } else { - set tailsearch_start [expr {$size - 65559}] - } - seek $out $tailsearch_start - set data [read $out] - #EOCD - End of Central Directory record - #PK\5\6 - set start_of_end [string last "\x50\x4b\x05\x06" $data] - #set start_of_end [expr {$start_of_end + $seek}] - #incr start_of_end $seek - set filerelative_eocd_posn [expr {$start_of_end + $tailsearch_start}] - - lappend report "kitfile-relative START-OF-EOCD: $filerelative_eocd_posn" - - seek $out $filerelative_eocd_posn - set end_of_ctrl_dir [read $out] - binary scan $end_of_ctrl_dir issssiis eocd(signature) eocd(disknbr) eocd(ctrldirdisk) \ - eocd(numondisk) eocd(totalnum) eocd(dirsize) eocd(diroffset) eocd(comment_len) - - lappend report "End of central directory: [array get eocd]" - seek $out [expr {$filerelative_eocd_posn+16}] - - #adjust offset of start of central directory by the length of our sfx stub - puts -nonewline $out [binary format i [expr {$eocd(diroffset) + $stuboffset}]] - flush $out - - seek $out $filerelative_eocd_posn - set end_of_ctrl_dir [read $out] - binary scan $end_of_ctrl_dir issssiis eocd(signature) eocd(disknbr) eocd(ctrldirdisk) \ - eocd(numondisk) eocd(totalnum) eocd(dirsize) eocd(diroffset) eocd(comment_len) - - # 0x06054b50 - end of central dir signature - puts stderr "$end_of_ctrl_dir" - puts stderr "comment_len: $eocd(comment_len)" - puts stderr "eocd sig: $eocd(signature) [punk::lib::dec2hex $eocd(signature)]" - lappend report "New dir offset: $eocd(diroffset)" - lappend report "Adjusting $eocd(totalnum) zip file items." - catch { - punk::lib::showdict -roottype list -chan stderr $report ;#heavy dependencies - } - - seek $out $eocd(diroffset) - for {set i 0} {$i <$eocd(totalnum)} {incr i} { - set current_file [tell $out] - set fileheader [read $out 46] - puts -------------- - puts [ansistring VIEW -lf 1 $fileheader] - puts -------------- - #binary scan $fileheader is2sss2ii2s3ssii x(sig) x(version) x(flags) x(method) \ - # x(date) x(crc32) x(sizes) x(lengths) x(diskno) x(iattr) x(eattr) x(offset) - - binary scan $fileheader ic4sss2ii2s3ssii x(sig) x(version) x(flags) x(method) \ - x(date) x(crc32) x(sizes) x(lengths) x(diskno) x(iattr) x(eattr) x(offset) - set ::last_header $fileheader - - puts "sig: $x(sig) (hex: [punk::lib::dec2hex $x(sig)])" - puts "ver: $x(version)" - puts "method: $x(method)" - - #PK\1\2 - #33639248 dec = 0x02014b50 - central directory file header signature - if { $x(sig) != 33639248 } { - error "modpod::system::make_mountable_zip Bad file header signature at item $i: dec:$x(sig) hex:[punk::lib::dec2hex $x(sig)]" - } - - foreach size $x(lengths) var {filename extrafield comment} { - if { $size > 0 } { - set x($var) [read $out $size] - } else { - set x($var) "" - } - } - set next_file [tell $out] - lappend report "file $i: $x(offset) $x(sizes) $x(filename)" - - seek $out [expr {$current_file+42}] - puts -nonewline $out [binary format i [expr {$x(offset)+$stuboffset}]] - - #verify: - flush $out - seek $out $current_file - set fileheader [read $out 46] - lappend report "old $x(offset) + $stuboffset" - binary scan $fileheader is2sss2ii2s3ssii x(sig) x(version) x(flags) x(method) \ - x(date) x(crc32) x(sizes) x(lengths) x(diskno) x(iattr) x(eattr) x(offset) - lappend report "new $x(offset)" - - seek $out $next_file - } - } - - close $out - #pdict/showdict reuire punk & textlib - ie lots of dependencies - #don't fall over just because of that - catch { - punk::lib::showdict -roottype list -chan stderr $report - } - #puts [join $report \n] - return - } - - proc connect_if_not {{podpath ""}} { - upvar ::modpod::connected connected - set podpath [::modpod::system::normalize $podpath] - set docon 0 - if {![llength $connected(to)]} { - if {![string length $podpath]} { - error "modpod::system::connect_if_not - Not connected to a modpod file, and no podpath specified" - } else { - set docon 1 - } - } else { - if {![string length $podpath]} { - set podpath [lindex $connected(to) end] - puts stderr "modpod::system::connect_if_not WARNING: using last connected modpod:$podpath for operation\n -podpath not explicitly specified during operation: [info level -1]" - } else { - if {$podpath ni $connected(to)} { - set docon 1 - } - } - } - if {$docon} { - if {[lindex [modpod::connect $podpath]] 0] ne "ok"} { - error "modpod::system::connect_if_not error. file $podpath does not seem to be a valid modpod" - } else { - return $podpath - } - } - #we were already connected - return $podpath - } - - proc myversion {} { - upvar ::modpod::connected connected - set script [info script] - if {![string length $script]} { - error "No result from \[info script\] - modpod::system::myversion should only be called from within a loading modpod" - } - set fname [file tail [file rootname [file normalize $script]]] - set scriptdir [file dirname $script] - - if {![string match "#modpod-*" $fname]} { - lassign [lrange [split $fname -] end-1 end] _pkgname version - } else { - lassign [scan [file tail [file rootname $script]] {#modpod-loadscript-%[a-z]-%s}] _pkgname version - if {![string length $version]} { - #try again on the name of the containing folder - lassign [scan [file tail $scriptdir] {#modpod-%[a-z]-%s}] _pkgname version - #todo - proper walk up the directory tree - if {![string length $version]} { - #try again on the grandparent folder (this is a standard depth for sourced .tcl files in a modpod) - lassign [scan [file tail [file dirname $scriptdir]] {#modpod-%[a-z]-%s}] _pkgname version - } - } - } - - #tarjar::Log debug "'myversion' determined version for [info script]: $version" - return $version - } - - proc myname {} { - upvar ::modpod::connected connected - set script [info script] - if {![string length $script]} { - error "No result from \[info script\] - modpod::system::myname should only be called from within a loading modpod" - } - return $connected(fullpackage,$script) - } - proc myfullname {} { - upvar ::modpod::connected connected - set script [info script] - #set script [::tarjar::normalize $script] - set script [file normalize $script] - if {![string length $script]} { - error "No result from \[info script\] - modpod::system::myfullname should only be called from within a loading tarjar" - } - return $::tarjar::connected(fullpackage,$script) - } - proc normalize {path} { - #newer versions of Tcl don't do tilde sub - - #Tcl's 'file normalize' seems to do some unfortunate tilde substitution on windows.. (at least for relative paths) - # we take the assumption here that if Tcl's tilde substitution is required - it should be done before the path is provided to this function. - set matilda "<_tarjar_tilde_placeholder_>" ;#token that is *unlikely* to occur in the wild, and is somewhat self describing in case it somehow ..escapes.. - set path [string map [list ~ $matilda] $path] ;#give our tildes to matilda to look after - set path [file normalize $path] - #set path [string tolower $path] ;#must do this after file normalize - return [string map [list $matilda ~] $path] ;#get our tildes back. -} -} -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready -package provide modpod [namespace eval modpod { - variable pkg modpod - variable version - set version 0.1.1 -}] -return - -#*** !doctools -#[manpage_end] - diff --git a/src/bootsupport/modules/natsort-0.1.1.5.tm b/src/bootsupport/modules/natsort-0.1.1.5.tm deleted file mode 100644 index 0e4260b8..00000000 --- a/src/bootsupport/modules/natsort-0.1.1.5.tm +++ /dev/null @@ -1,1894 +0,0 @@ -#! /usr/bin/env tclsh - - -package require flagfilter -namespace import ::flagfilter::check_flags - -namespace eval natsort { - proc scriptdir {} { - set possibly_linked_script [file dirname [file normalize [file join [info script] ...]]] - if {[file isdirectory $possibly_linked_script]} { - return $possibly_linked_script - } else { - return [file dirname $possibly_linked_script] - } - } - tcl::tm::add [scriptdir] -} - - -namespace eval natsort { - variable stacktrace_on 0 - - proc do_error {msg {then error}} { - #note we exit or error out even if debug selected - as every do_error call is meant to interrupt code processing at the site of call - #this is not just a 'logging' call even though it has log-like descriptors - lassign $then type code - if {$code eq ""} { - set code 1 - } - set type [string tolower $type] - set levels [list debug info notice warn error critical] - if {$type in [concat $levels exit]} { - puts stderr "|$type> $msg" - } else { - puts stderr "|>natsort_call_err> unable to interpret 2nd argument to do_error: '$then' should be one of '$levels' or 'exit '" - } - if {$::tcl_interactive} { - #may not always be desirable - but assumed to be more useful not to exit despite request, to aid in debugging - if {[string tolower $type] eq "exit"} { - puts stderr " (exit suppressed due to tcl_interactive - raising error instead)" - if {![string is digit -strict $code]} { - puts stderr "|>natsort_call_err> unable to interpret 2nd argument to do_error: '$then' should be: 'exit '" - } - } - return -code error $msg - } else { - if {$type ne "exit"} { - return -code error $msg - } else { - if {[string is digit -strict $code]} { - exit $code - } else { - puts stderr "|>natsort_call_err> unable to interpret 2nd argument to do_error: '$then' should be 'error' or 'exit '" - return -code error $msg - } - } - } - } - - - - - - - variable debug 0 - variable testlist - set testlist { - 00.test-firstposition.txt - 0001.blah.txt - 1.test-sorts-after-all-leadingzero-number-one-equivs.txt - 1010.thousand-and-ten.second.txt - 01010.thousand-and-ten.first.txt - 0001.aaa.txt - 001.zzz.txt - 08.octal.txt-last-octal - 008.another-octal-first-octal.txt - 08.again-second-octal.txt - 001.a.txt - 0010.reconfig.txt - 010.etc.txt - 005.etc.01.txt - 005.Etc.02.txt - 005.123.abc.txt - 200.somewhere.txt - 2zzzz.before-somewhere.txt - 00222-after-somewhere.txt - 005.00010.abc.txt - 005.a3423bc.00010.abc.txt - 005.001.abc.txt - 005.etc.1010.txt - 005.etc.010.txt - 005.etc.10.txt - " 005.etc.10.txt" - 005.etc.001.txt - 20.somewhere.txt - 4611686018427387904999999999-bignum.txt - 4611686018427387903-bigishnum.txt - 9223372036854775807-bigint.txt - etca-a - etc-a - etc2-a - a0001blah.txt - a010.txt - winlike-sort-difference-0.1.txt - winlike-sort-difference-0.1.1.txt - a1.txt - b1-a0001blah.txt - b1-a010.txt - b1-a1.txt - -a1.txt - --a1.txt - --a10.txt - 2.high-two.yml - 02.higher-two.yml - reconfig.txt - _common.stuff.txt - CASETEST.txt - casetest.txt - something.txt - some~thing.txt - someathing.txt - someThing.txt - thing.txt - thing_revised.txt - thing-revised.txt - "thing revised.txt" - "spacetest.txt" - " spacetest.txt" - " spacetest.txt" - "spacetest2.txt" - "spacetest 2.txt" - "spacetest02.txt" - name.txt - name2.txt - "name .txt" - "name2 .txt" - blah.txt - combined.txt - a001.txt - .test - .ssh - "Feb 10.txt" - "Feb 8.txt" - 1ab23v23v3r89ad8a8a8a9d.txt - "Folder (10)/file.tar.gz" - "Folder/file.tar.gz" - "Folder (1)/file (1).tar.gz" - "Folder (1)/file.tar.gz" - "Folder (01)/file.tar.gz" - "Folder1/file.tar.gz" - "Folder(1)/file.tar.gz" - - } - lappend testlist "Some file.txt" - lappend testlist " Some extra file1.txt" - lappend testlist " Some extra file01.txt" - lappend testlist " some extra file1.txt" - lappend testlist " Some extra file003.txt" - lappend testlist " Some file.txt" - lappend testlist "Some extra file02.txt" - lappend testlist "Program Files (x86)" - lappend testlist "01999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999991-bigger-pathologically-bignum.txt" - lappend testlist "199999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999-pathologically-bignum.txt" - lappend testlist "29999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999-smaller-pathologically-bignum.txt" - lappend testlist "199999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999-pathologically-bignum.txt with (more 1.txt" - lappend testlist "199999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999-pathologically-bignum.txt with (more 01.txt" - lappend testlist "a1a1a1a1a1a1a1a1a1a1a1a1a1a1a1a1a1a1a1a1a1a1a1a1.pathological-num-nonnum-swapping-leadzero-should-be-first.txt" - lappend testlist "a1a1a1a1a1a1a1a1a1a1a1a01a1a1a1a1a1a1a1a1a1a1a1a1.pathological-num-nonnum-swapping-leadzero-should-be-first.txt" - lappend testlist "b1b1b1b1.txt" - lappend testlist "b1b01z1z1.txt" - lappend testlist "c1c111c1.txt" - lappend testlist "c1c1c1c1.txt" - - namespace eval overtype { - proc right {args} { - # @d !todo - implement overflow, length checks etc - - if {[llength $args] < 2} { - error {usage: ?-overflow [1|0]? undertext overtext} - } - foreach {undertext overtext} [lrange $args end-1 end] break - - set opt(-overflow) 0 - array set opt [lrange $args 0 end-2] - - - set olen [string length $overtext] - set ulen [string length $undertext] - - if {$opt(-overflow)} { - return [string range $undertext 0 end-$olen]$overtext - } else { - if {$olen > $ulen} { - set diff [expr {$olen - $ulen}] - return [string range $undertext 0 end-$olen][string range $overtext 0 end-$diff] - } else { - return [string range $undertext 0 end-$olen]$overtext - } - } - } - proc left {args} { - # @c overtype starting at left (overstrike) - # @c can/should we use something like this?: 'format "%-*s" $len $overtext - - if {[llength $args] < 2} { - error {usage: ?-overflow [1|0]? ?-ellipsis [1|0]? ?-ellipsistext ...? undertext overtext} - } - foreach {undertext overtext} [lrange $args end-1 end] break - - set opt(-ellipsis) 0 - set opt(-ellipsistext) {...} - set opt(-overflow) 0 - array set opt [lrange $args 0 end-2] - - - set len [string length $undertext] - set overlen [string length $overtext] - set diff [expr {$overlen - $len}] - - #puts stdout "====================>overtype: datalen:$len overlen:$overlen diff:$diff" - #puts stdout "====================>overtype: data: $overtext" - if {$diff > 0} { - if {$opt(-overflow)} { - return $overtext - } else { - if {$opt(-ellipsis)} { - return [overtype::left [string range $overtext 0 [expr {$len -1}]] $opt(-ellipsistext)] - } else { - return [string range $overtext 0 [expr {$len -1}]] - } - } - } else { - return "$overtext[string range $undertext $overlen end]" - } - } - - } - - #considered using hex to make large numbers more compact for viewing in debug output - but it's not that much shorter and probably obscures more than it helps. - proc hex2dec {largeHex} { - #todo - use punk::lib::hex2dec - (scan supports ll so can do larger hex values directly) - set res 0 - set largeHex [string map [list _ ""] $largeHex] - if {[string length $largeHex] <=7} { - #scan can process up to FFFFFFF and does so quickly - return [scan $largeHex %x] - } - foreach hexDigit [split $largeHex {}] { - set new 0x$hexDigit - set res [expr {16*$res + $new}] - } - return $res - } - proc dec2hex {decimalNumber} { - format %4.4llX $decimalNumber - } - - #punk::lib::trimzero - proc trimzero {number} { - set trimmed [string trimleft $number 0] - if {[string length $trimmed] == 0} { - set trimmed 0 - } - return $trimmed - } - #todo - consider human numeric split - #e.g consider SI suffixes k|KMGTPEZY in that order - - #in this context, for natural sorting - numeric segments don't contain underscores or other punctuation such as . - + etc. - #review - what about unicode equivalents such as wide numerals \UFF10 to \UFF19? unicode normalization? - proc split_numeric_segments {name} { - set segments [list] - while {[string length $name]} { - if {[scan $name {%[0-9]%n} chunk len] == 2} { - lappend segments $chunk - set name [string range $name $len end] - } - if {[scan $name {%[^0-9]%n} chunk len] == 2} { - lappend segments $chunk - set name [string range $name $len end] - } - } - return $segments - } - - proc padleft {str count {ch " "}} { - set val [string repeat $ch $count] - append val $str - set diff [expr {max(0,$count - [string length $str])}] - set offset [expr {max(0,$count - $diff)}] - set val [string range $val $offset end] - } - - - # Sqlite may have limited collation sequences available in default builds. - # with custom builds - there may be others such as 'natsort' - see https://sqlite.org/forum/forumpost/e4dc6f3331 - # This is of limited use with the few builtin collations available in 2023 ie binary,nocase & rtrim - # but may provide a quicker,flexible sort option, especially if/when more collation sequences are added to sqlite - # There are also prebuilt packages such as sqlite3-icu which allows things like "SELECT icu_load_collation('en_AU', 'australian');" - proc sort_sqlite {stringlist args} { - package require sqlite3 - - - set args [check_flags -caller natsort_sqlite -defaults [list -db :memory: -collate nocase -winlike 0 -topchars "\uFFFF" -debug 0 -splitchars [list / . - _] -extras {all}] -values $args] - set db [string trim [dict get $args -db]] - set collate [string trim [dict get $args -collate]] - set debug [string trim [dict get $args -debug]] - set topchars [string trim [dict get $args -topchars]] - - set topdot [expr {"." in $topchars}] - set topunderscore [expr {"_" in $topchars}] - - - sqlite3 db_sort_basic $db - set orderedlist [list] - db_sort_basic eval [string map [list %collate% $collate] {create table sqlitesort(index0 text COLLATE %collate%, name text COLLATE %collate%)}] - foreach nm $stringlist { - set segments [split_numeric_segments $nm] - set index "" - set s 0 - foreach seg $segments { - if {($s == 0) && ![string length [string trim $seg]]} { - #don't index leading space - } elseif {($s == 0) && ($topunderscore) && [string match _* [string trim $seg]]} { - append index "[padleft "0" 5]-d -100 topunderscore " - append index [string trim $seg] - } elseif {($s == 0) && ($topdot) && [string match .* [string trim $seg]]} { - append index "[padleft "0" 5]-d -50 topdot " - append index [string trim $seg] - } else { - if {[string is digit [string trim $seg]]} { - set basenum [trimzero [string trim $seg]] - set lengthindex "[padleft [string length $basenum] 5]-d" - append index "$lengthindex " - #append index [padleft $basenum 40] - append index $basenum - } else { - append index [string trim $seg] - } - } - incr s - } - puts stdout ">>$index" - db_sort_basic eval {insert into sqlitesort values($index,$nm)} - } - db_sort_basic eval [string map [list %collate% $collate] {select name from sqlitesort order by index0 COLLATE %collate% ASC, name COLLATE %collate% ASC }] { - lappend orderedlist $name - } - db_sort_basic close - return $orderedlist - } - - proc get_leading_char_count {str char} { - #todo - something more elegant? regex? - set count 0 - foreach c [split $str "" ] { - if {$c eq $char} { - incr count - } else { - break - } - } - return $count - } - proc stacktrace {} { - set stack "Stack trace:\n" - for {set i 1} {$i < [info level]} {incr i} { - set lvl [info level -$i] - set pname [lindex $lvl 0] - append stack [string repeat " " $i]$pname - - if {![catch {info args $pname} pargs]} { - foreach value [lrange $lvl 1 end] arg $pargs { - - if {$value eq ""} { - if {$arg != 0} { - info default $pname $arg value - } - } - append stack " $arg='$value'" - } - } else { - append stack " !unknown vars for $pname" - } - - append stack \n - } - return $stack - } - - proc get_char_count {str char} { - #faster than lsearch on split for str of a few K - expr {[string length $str]-[string length [string map [list $char {}] $str]]} - } - - proc build_key {chunk splitchars topdict tagconfig debug} { - variable stacktrace_on - if {$stacktrace_on} { - puts stderr "+++>[stacktrace]" - } - - set index_map [list - "" _ ""] - #e.g - need to maintain the order - #a b.txt - #a book.txt - #ab.txt - #abacus.txt - - - set original_splitchars [dict get $tagconfig original_splitchars] - - # tag_dashes test moved from loop - review - set tag_dashes 0 - if {![string length [dict get $tagconfig last_part_text_tag]]} { - #winlike - set tag_dashes 1 - } - if {("-" ni $original_splitchars)} { - set tag_dashes 1 - } - if {$debug >= 3} { - puts stdout "START build_key chunk : $chunk" - puts stdout "START build_key splitchars : $splitchars $topdict $tagconfig NO tag dashes" - } - - - ## index_map will have no effect if we've already split on the char anyway(?) - #foreach m [dict keys $index_map] { - # if {$m in $original_splitchars} { - # dict unset index_map $m - # } - #} - - #if {![string length $chunk]} return - - set result "" - if {![llength $splitchars]} { - #no more structural splits - but we need to examine numeric/non-numeric segments at the lowest level. - # we are at a leaf in the recursive split hierarchy - - set s "" ;#we never actually split on "" (unless that was put in splitchars.. but it probably shouldn't be) - set parts [list $chunk] ;#important to treat as list or leading/trailing whitespace lost - - - } else { - set s [lindex $splitchars 0] - if {"spudbucket$s" in "[split $chunk {}]"} { - error "dead-branch spudbucket" - set partindex [build_key $chunk [lrange $splitchars 1 end] $topdict $tagconfig $debug] - if {[dict get $tagconfig showsplits]} { - set pfx "(1${s}=)" ;# = sorts before _ - set partindex ${pfx}$partindex - } - - return $partindex - } else { - set parts_below_index "" - - if {$s ni [split $chunk ""]} { - #$s can be an empty string - set parts [list $chunk] - } else { - set parts [split $chunk $s] ;#whitespace preserved - even if splitting on s that is not in string. - } - #assert - we have a splitchar $s that is in the chunk - so at least one part - if {(![string length $s] || [llength $parts] == 0)} { - error "buld_key assertion false empty split char and/or no parts" - } - - set pnum 1 ;# 1 based for clarity of reading index in debug output - set subpart_count [llength $parts] - - set sub_splits [lrange $splitchars 1 end] ;#pass same splitchars to each subpart - foreach p $parts { - set partindex [build_key $p $sub_splits $topdict $tagconfig $debug] - set lastpart [expr {$pnum == $subpart_count}] - - - ####################### - set showsplits [dict get $tagconfig showsplits] - #split prefixing experiment - maybe not suitable for general use - as it affects sort order - #note that pfx must be consistent until last one, no matter how many partnumbers there are in total. - # we don't want to influence sort order before reaching end. - #e.g for: - #(1.=)... - #(1._)...(2._)...(3.=) - #(1._)...(2.=) - #Note that this is probably more suitable for highly structure dependant sorts where the results are maybe less.. natural. - if {$showsplits} { - if {$lastpart} { - set pfx "(${pnum}${s}_" - #set pfx "(${pnum}${s}=)" ;# = sorts before _ - } else { - set pfx "(${pnum}${s}_" - } - append parts_below_index $pfx - } - ####################### - - if {$lastpart} { - if {[string length $p] && [string is digit $p]} { - set last_part_tag "<22${s}>" - } else { - set last_part_tag "<33${s}>" - } - - set last_part_text_tag [dict get $tagconfig last_part_text_tag] - #for -winlike 1 there is no tag configured. Windows explorer likes to put things in the order: - # module-0.1.1.tm - # module-0.1.1.2.tm - # module-0.1.tm - # arguably -winlike 0 is more natural/human - # module-0.1.tm - # module-0.1.1.tm - # module-0.1.1.2.tm - - if {[string length $last_part_text_tag]} { - #replace only the first text-tag (<30>) from the subpart_index - if {[string match "<30?>*" $partindex]} { - #give textual string index a specific tag for last part in split only. e.g <130> for lower than integers - set partindex "<130>[string range $partindex 5 end]" - } - #append parts_below_index $last_part_tag - } - #set partindex $last_part_tag$partindex - - - } - append parts_below_index $partindex - - - - if {$showsplits} { - if {$lastpart} { - set suffix "${pnum}${s}=)" ;# = sorts before _ - } else { - set suffix "${pnum}${s}_)" - } - append parts_below_index $suffix - } - - - incr pnum - } - append parts_below_index "" ;# don't add anything at the tail that may perturb sort order - - if {$debug >= 3} { - set pad [string repeat " " 20] - puts stdout "END build_key chunk : $chunk " - puts stdout "END build_key splitchars : $splitchars $topdict $tagconfig NO tag dashes" - puts stdout "END build_key ret below_index: $parts_below_index" - } - return $parts_below_index - - - } - } - - - - #puts stdout ">>>chunk:'$chunk'<<< split-on:$s parts: '$parts' splitchars: $splitchars -topdict:$topdict" - - - - - - #if {$chunk eq ""} { - # puts "___________________________________________!!!____" - #} - #puts stdout "-->chunk:$chunk $s parts:$parts" - - #puts stdout "---chunk:'$chunk' part:'$part' parts:'$parts' s:'$s'" - - - - - set segments [split_numeric_segments $chunk] ;#! - set stringindex "" - set segnum 0 - foreach seg $segments { - #puts stdout "=================---->seg:$seg segments:$segments" - #-strict ? - if {[string length $seg] && [string is digit $seg]} { - set basenum [trimzero [string trim $seg]] - set lengthindex "[padleft [string length $basenum] 4]d" - #append stringindex "<20>$lengthindex $basenum $seg" - } else { - set c1 [string range $seg 0 0] - #puts stdout "==============> c1'$c1' topdict: $topdict stringindex:$stringindex" - - if {$c1 in [dict keys $topdict]} { - set tag [dict get $topdict $c1] - #append stringindex "${tag}$c1" - #set seg [string range $seg 1 end] - } - #textindex - set leader "<30>" - set idx $seg - set idx [string trim $idx] - set idx [string tolower $idx] - set idx [string map $index_map $idx] - - - - - - #set the X-c count to match the length of the index - not the raw data - set lengthindex "[padleft [string length $idx] 4]c" - - #append stringindex "${leader}$idx $lengthindex $texttail" - } - } - - if {[llength $parts] != 1} { - error "build_key assertion fail llength parts != 1 parts:$parts" - } - - set segtail_clearance_buffer " " ;#space to clear other split indicators if using showsplits - set segtail $segtail_clearance_buffer - append segtail "\[" - set grouping "" - set pnum 0 - foreach p $parts { - set sublen_list [list] - set subsegments [split_numeric_segments $p] - set i 0 - - set partsorter "" - foreach sub $subsegments { - ##don't trim spaces here - it would be inconsistent. Some subs are pure whitespace - others have internal whitespace. e.g "a4 400b a b2" becomes "a 4 { } 400 {b a b} 2" - #mapping away all whitespace would be consistent, but not necessarily desirable. If it's in the index_map it'll happen anyway - so we don't do it manually here except for evaluating conditions. - set test_trim [string trim $sub] - set str $sub - set str [string tolower $str] - set str [string map $index_map $str] - if {[string length $test_trim] && [string is digit $test_trim]} { - append partsorter [trimzero $str] - } else { - append partsorter "$str" - } - append partsorter - } - - - foreach sub $subsegments { - - if {[string length $sub] && [string is digit $sub]} { - set basenum [trimzero [string trim $sub]] - set subequivs $basenum - set lengthindex "[padleft [string length $subequivs] 4]d " - set idx "$lengthindex [padleft $basenum 10]" ;#todo - cycle through data and determine longest - set tail [overtype::left [string repeat " " 10] $sub] - #set tail "" - } else { - set idx "" - - - set lookahead [lindex $subsegments $i+1] - if {![string length $lookahead]} { - set zeronum "[padleft 0 4]d0" - } else { - set zeronum "" - } - set subequivs $sub - #set subequivs [string trim $subequivs] - set subequivs [string tolower $subequivs] - set subequivs [string map $index_map $subequivs] - - append idx $subequivs - append idx $zeronum - - set idx $subequivs - - - # - - set ch "-" - if {$tag_dashes} { - #puts stdout "____TAG DASHES" - #winlike - set numleading [get_leading_char_count $seg $ch] - if {$numleading > 0} { - set texttail "<31-leading[padleft $numleading 4]$ch>" - } else { - set texttail "<30>" - } - set numothers [expr {[get_char_count $seg $ch] - $numleading}] - if {$debug >= 2} { - puts stdout "____dashcount: [get_char_count $seg $ch] numothers: $numothers" - } - if {$numothers > 0} { - append texttail "<31-others[padleft $numothers 4]$ch>" - } else { - append textail "<30>" - } - } else { - set texttail "<30>" - } - - - - - #set idx $partsorter - set tail "" - #set tail [string tolower $sub] ;#raw - #set tail $partsorter - #append tail ":[string tolower $p]" ;#we need the whole part - even though it makes the index much larger. !todo - tagconfig switch to toggle case sensitive sorting - } - - append grouping "$idx $tail|$s" - incr i - } - - - - - - if {$p eq ""} { - # no subsegments.. - set zeronum "[padleft 0 4]d0" - #append grouping "\u000$zerotail" - append grouping ".$zeronum" - } - - #append grouping | - #append grouping $s - #foreach len $sublen_list { - # append segtail "<[padleft $len 3]>" - #} - incr pnum - } - set grouping [string trimright $grouping $s] - append grouping "[padleft [llength $parts] 4]" - append segtail $grouping - - - #append segtail " <[padleft [llength $parts] 4]>" - - append segtail "\]" - - - #if {[string length $seg] && [string is digit $seg]} { - # append segtail "<20>" - #} else { - # append segtail "<30>" - #} - append stringindex $segtail - - incr segnum - - - - - lappend indices $stringindex - - if {[llength $indices] > 1} { - puts stderr "INDICES [llength $indices]: $stringindex" - error "build_key assertion error deadconcept indices" - } - - #topchar handling on splitter characters - #set c1 [string range $chunk 0 0] - if {$s in [dict keys $topdict]} { - set tag [dict get $topdict $s] - set joiner [string map [list ">" "$s>"] ${tag}] - #we have split on this character $s so if the first part is empty string then $s was a leading character - # we need to bring a tag out front for this, or it will be dominated by the leading sections-remaing tag - # (since the empty string produces no tag of it's own - ?) - if {[string length [lindex $parts 0]] == 0} { - set prefix ${joiner} - } else { - set prefix "" - } - } else { - #use standard character-data positioning tag if no override from topdict - set joiner "<30J>$s" - set prefix "" - } - - - set contentindex $prefix[join $indices $joiner] - if {[string length $s]} { - set split_indicator "" - } else { - set split_indicator "" - - } - if {![string length $s]} { - set s ~ - } - - #return "[overtype::left [string repeat { } 80] $contentindex][overtype::left [string repeat { } 10] [list $s $chunk]]" - #return $contentindex$split_indicator - #return [overtype::left [string repeat - 40] $contentindex] - - if {$debug >= 3} { - puts stdout "END build_key chunk : $chunk" - puts stdout "END build_key splitchars : $splitchars $topdict $tagconfig NO tag dashes" - puts stdout "END build_key ret contentidx : $contentindex" - } - return $contentindex - } - - #---------------------------------------- - #line-processors - data always last argument - opts can be empty string - #all processor should accept empty opts and ignore opts if they don't use them - proc _lineinput_as_tcl1 {opts line} { - set out "" - foreach i $line { - append out "$i " - } - set out [string range $out 0 end-1] - return $out - } - #should be equivalent to above - proc _lineinput_as_tcl {opts line} { - return [concat {*}$line] - } - #will put extra tcl quoting if it was already tcl-shaped e.g text "a" -> {"a"} - proc _lineoutput_as_tcl {opts line} { - return [regexp -inline -all {\S+} $line] - } - - proc _lineinput_as_raw {opts line} { - return $line - } - proc _lineoutput_as_raw {opts line} { - return $line - } - - #words is opposite of tcl - proc _lineinput_as_words {opts line} { - #wordlike_parts - return [regexp -inline -all {\S+} $line] - } - proc _lineoutput_as_words {opts line} { - return [concat {*}$line] - } - - #opts same as tcllib csv::split - except without the 'line' element - #?-alternate? ?sepChar? ?delChar? - proc _lineinput_as_csv {opts line} { - package require csv - if {[lindex $opts 0] eq "-alternate"} { - return [csv::split -alternate $line {*}[lrange $opts 1 end]] - } else { - return [csv::split $line {*}$opts] - } - } - #opts same as tcllib csv::join - #?sepChar? ?delChar? ?delMode? - proc _lineoutput_as_csv {opts line} { - package require csv - return [csv::join $line {*}$opts] - } - #---------------------------------------- - proc sort {stringlist args} { - #puts stdout "natsort::sort args: $args" - variable debug - if {![llength $stringlist]} return - - #allow pass through of the check_flags flag -debugargs so it can be set by the caller - set debugargs 0 - if {[set posn [lsearch $args -debugargs]] >=0} { - if {$posn == [llength $args]-1} { - #-debugargs at tail of list - set debugargs 1 - } else { - set debugargs [lindex $args $posn+1] - } - } - - #-return flagged|defaults doesn't work Review. - #flagfilter global processor/allocator not working 2023-08 - set args [check_flags \ - -caller natsort::sort \ - -return supplied|defaults \ - -debugargs $debugargs \ - -defaults [list -collate nocase \ - -winlike 0 \ - -splits "\uFFFF" \ - -topchars {. _} \ - -showsplits 1 \ - -sortmethod ascii \ - -collate "\uFFFF" \ - -inputformat raw \ - -inputformatapply {index data} \ - -inputformatoptions "" \ - -outputformat raw \ - -outputformatoptions "" \ - -cols "\uFFFF" \ - -debug 0 -db "" -stacktrace 0 -splits "\uFFFF" -showsplits 0] \ - -required {all} \ - -extras {none} \ - -commandprocessors {} \ - -values $args] - - #csv unimplemented - - set winlike [dict get $args -winlike] - set topchars [dict get $args -topchars] - set cols [dict get $args -cols] - set debug [dict get $args -debug] - set stacktrace [dict get $args -stacktrace] - set showsplits [dict get $args -showsplits] - set splits [dict get $args -splits] - set sortmethod [dict get $args -sortmethod] - set opt_collate [dict get $args -collate] - set opt_inputformat [dict get $args -inputformat] - set opt_inputformatapply [dict get $args -inputformatapply] - set opt_inputformatoptions [dict get $args -inputformatoptions] - set opt_outputformat [dict get $args -outputformat] - set opt_outputformatoptions [dict get $args -outputformatoptions] - dict unset args -showsplits - dict unset args -splits - if {$debug} { - puts stdout "natsort::sort processed_args: $args" - if {$debug == 1} { - puts stdout "natsort::sort - try also -debug 2, -debug 3" - } - } - - #set sortmethod "-dictionary" ;# sorts a2b before a001b - possibly other strangenesses that are hard to reason about - - if {$sortmethod in [list dictionary ascii]} { - set sortmethod "-$sortmethod" - # -ascii is default for tcl lsort. - } else { - set sortmethod "-ascii" - } - - set allowed_collations [list nocase] - if {$opt_collate ne "\uFFFF"} { - if {$opt_collate ni $allowed_collations} { - error "natsort::sort unknown value for -collate option. Only acceptable value(s): $allowed_collations" - } - set nocaseopt "-$opt_collate" - } else { - set nocaseopt "" - } - set allowed_inputformats [list tcl raw csv words] - if {$opt_inputformat ni $allowed_inputformats} { - error "natsort::sort unknown value for -inputformat option. Only acceptable value(s): $allowed_inputformats" - } - set allowed_outputformats [list tcl raw csv words] - if {$opt_inputformat ni $allowed_outputformats} { - error "natsort::sort unknown value for -outputformat option. Only acceptable value(s): $allowed_outputformats" - } - - # - set winsplits [list / . _] - set commonsplits [list / . _ -] - #set commonsplits [list] - - set tagconfig [dict create] - dict set tagconfig last_part_text_tag "<19>" - if {$winlike} { - set splitchars $winsplits - #windows explorer sorts leading spaces at the top - which doesn't seem very helpful for keeping things together - but the explorer doesn't seem able to create leading spaces anyway. - set wintop [list "(" ")" { } {.} {_}] ;#windows specific order - foreach t $topchars { - if {$t ni $wintop} { - lappend wintop $t - } - } - set topchars $wintop - dict set tagconfig last_part_text_tag "" - } else { - set splitchars $commonsplits - } - if {$splits ne "\uFFFF"} { - set splitchars $splits - } - dict set tagconfig original_splitchars $splitchars - dict set tagconfig showsplits $showsplits - - #create topdict - set i 0 - set topdict [dict create] - foreach c $topchars { - incr i ;#start at 01 so that 00 reserved for final-split tag (allows x-0.1.txt to sort above x-0.1.1.txt by default. Use tagconfig to change, or choose -winlike 1 for explorer-like sorting) - dict set topdict $c "<0$i>" - } - set keylist [list] - - - if {$opt_inputformat eq "tcl"} { - set lineinput_transform [list _lineinput_as_tcl $opt_inputformatoptions] - } elseif {$opt_inputformat eq "csv"} { - set lineinput_transform [list _lineinput_as_csv $opt_inputformatoptions] - } elseif {$opt_inputformat eq "raw"} { - set lineinput_transform [list _lineinput_as_raw $opt_inputformatoptions] - } elseif {$opt_inputformat eq "words"} { - set lineinput_transform [list _lineinput_as_words $opt_inputformatoptions] - } - if {$opt_outputformat eq "tcl"} { - set lineoutput_transform [list _lineoutput_as_tcl $opt_outputformatoptions] - } elseif {$opt_outputformat eq "csv"} { - set lineoutput_transform [list _lineoutput_as_csv $opt_outputformatoptions] - } elseif {$opt_outputformat eq "raw"} { - set lineoutput_transform [list _lineoutput_as_raw $opt_outputformatoptions] - } elseif {$opt_outputformat eq "words"} { - set lineoutput_transform [list _lineoutput_as_words $opt_outputformatoptions] - } - - - if {("data" in $opt_inputformatapply) || ("index" in $opt_inputformatapply)} { - if {$opt_inputformat eq "raw"} { - set tf_stringlist $stringlist - } else { - set tf_stringlist [list] - foreach v $stringlist { - lappend tf_stringlist [{*}$lineinput_transform $v] - } - } - if {"data" in $opt_inputformatapply} { - set tf_data_stringlist $tf_stringlist - } else { - set tf_data_stringlist $stringlist - } - if {"index" in $opt_inputformatapply} { - set tf_index_stringlist $tf_stringlist - } else { - set tf_index_stringlist $stringlist - } - } else { - set tf_data_stringlist $stringlist - set tf_index_stringlist $stringlist - } - - - - if {$stacktrace} { - puts stdout [natsort::stacktrace] - set natsort::stacktrace_on 1 - } - if {$cols eq "\uFFFF"} { - set colkeys [lmap v $stringlist {}] - } else { - set colkeys [list] - foreach v $tf_index_stringlist { - set lineparts $v - set k [list] - foreach c $cols { - lappend k [lindex $lineparts $c] - } - lappend colkeys [join $k "_"] ;#use a common-split char - Review - } - } - #puts stdout "colkeys: $colkeys" - - if {$opt_inputformat eq "raw"} { - #no inputformat was applied - can just use stringlist - foreach value $stringlist ck $colkeys { - set contentindex [build_key $value $splitchars $topdict $tagconfig $debug] - set colindex [build_key $ck $splitchars $topdict $tagconfig $debug] - lappend keylist ${colindex}-${contentindex}-$value ;#note: entire raw value used for final sort disambiguation (can be whitespace that was ignored in indexing) - } - } else { - foreach keyinput $tf_index_stringlist datavalue $tf_data_stringlist ck $colkeys { - #data may or may not have been transformed - #column index may or may not have been built with transformed data - - set contentindex [build_key $keyinput $splitchars $topdict $tagconfig $debug] - set colindex [build_key $ck $splitchars $topdict $tagconfig $debug] - lappend keylist ${colindex}-${contentindex}-$datavalue ;#note: entire value used for final sort disambiguation (can be whitespace that was ignored in indexing) - } - } - #puts stderr "keylist: $keylist" - - ################################################################################################### - # Use the generated keylist to do the actual sorting - # select either the transformed or raw data as the corresponding output - ################################################################################################### - if {[string length $nocaseopt]} { - set sortcommand [list lsort $sortmethod $nocaseopt -indices $keylist] - } else { - set sortcommand [list lsort $sortmethod -indices $keylist] - } - if {$opt_outputformat eq "raw"} { - #raw output means no further transformations - it doesn't mean there wasn't a transform applied on the input side - #use the tf_data_stringlist in the output - which will be the same as the input stringlist if no input transform applied for data. - #(Also - it may or may not have been *sorted* on transformed data depending on whether 'index' was in $opt_inputformatapply) - foreach idx [{*}$sortcommand] { - lappend result [lindex $tf_data_stringlist $idx] - } - } else { - #we need to apply an output format - #The data may or may not have been transformed at input - foreach idx [{*}$sortcommand] { - lappend result [{*}$lineoutput_transform [lindex $tf_data_stringlist $idx]] - } - } - ################################################################################################### - - - - - - if {$debug >= 2} { - set screen_width 250 - set max_val 0 - set max_idx 0 - ##### calculate colum widths - foreach i [{*}$sortcommand] { - set len_val [string length [lindex $stringlist $i]] - if {$len_val > $max_val} { - set max_val $len_val - } - set len_idx [string length [lindex $keylist $i]] - if {$len_idx > $max_idx} { - set max_idx $len_idx - } - } - #### - set l_width [expr {$max_val + 1}] - set leftcol [string repeat " " $l_width] - set r_width [expr {$screen_width - $l_width - 1}] - set rightcol [string repeat " " $r_width] - set str [overtype::left $leftcol RAW] - puts stdout " $str Index with possibly transformed data at tail" - foreach i [{*}$sortcommand] { - #puts stdout "|d> [overtype::left $leftcol [lindex $stringlist $i] ] [lindex $keylist $i]" - set index [lindex $keylist $i] - set len_idx [string length $index] - set rowcount [expr {$len_idx / $r_width}] - if {($len_idx % $r_width) > 0} { - incr rowcount - } - set rows [list] - for {set r 0} {$r < $rowcount} {incr r} { - lappend rows [string range $index 0 $r_width-$r] - set index [string range $index $r_width end] - } - - set r 0 - foreach idxpart $rows { - if {$r == 0} { - #use the untransformed stringlist - set str [overtype::left $leftcol [lindex $stringlist $i]] - } else { - set str [overtype::left $leftcol ...]] - } - puts stdout " $str $idxpart" - incr r - } - #puts stdout "|> '[lindex $stringlist $i]'" - #puts stdout "|> [lindex $keylist $i]" - } - - puts stdout "|debug> topdict: $topdict" - puts stdout "|debug> splitchars: $splitchars" - } - return $result - } - - - - #Note that although leading whitespace isn't a commonly used feature of filesystem names - it's possible at least on FreeBSD,windows and linux so we should try to handle it sensibly. - proc sort_experiment {stringlist args} { - package require sqlite3 - - variable debug - set args [check_flags -caller natsort::sort \ - -defaults [dict create -db :memory: -collate nocase -nullvalue "->NULL<" -winlike 0 -topchars [list] -debug 0] \ - -extras {all} \ - -values $args] - set db [string trim [dict get $args -db]] - set collate [string trim [dict get $args -collate]] - set winlike [string trim [dict get $args -winlike]] - set debug [string trim [dict get $args -debug]] - set nullvalue [string trim [dict get $args -nullvalue]] - - - set topchars [string trim [dict get $args -topchars]] - - set topdot [expr {"." in $topchars}] - set topunderscore [expr {"_" in $topchars}] - - - sqlite3 db_natsort2 $db - #-- - #our table must handle the name with the greatest number of numeric/non-numeric splits. - #This means a single list member with pathological naming e.g a1a1a1a1a1a1a1a1a1a1a1.txt could greatly extend the number of columns and indices and affect performance. - #review: could be optimised to aggregate the tail into a single index, as the the extra columns won't assist in ordering, but make the table and query bigger. - # we should probably determine the longest common sequence of splits in the input list and add only one more index for the segment after that. - set maxsegments 0 - #-- - set prefix "idx" - - #note - there will be more columns in the sorting table than segments. - # (a segment equals one of the numeric & non-numeric string portions returned from 'split_numeric_sgements') - #--------------------------- - # consider - # a123b.v1.2.txt - # a123b.v1.3beta1.txt - # these have the following segments: - # a 123 b.v 1 . 2 .txt - # a 123 b.v 1 . 3 beta 1 .txt - #--------------------------- - # The first string has 7 segments (numbered 0 to 6) - # the second string has 9 segments - # - # for example when the data has any elements in a segment position that are numeric (e.g 0001 123) - # - then an index column with numeric equivalents will be created (e.g 0001 becomes 1), and any non-numeric values in that column will get mapped to a negative value (for special cases) or a high value such as NULL (with NULLS LAST sql support) - # - # when a segment - - #cycle through all strings - we cannot build tabledef as we go because the column type depends on whether all segments for a particular column are text vs int-equivalent. - array set segmentinfo {} - foreach nm $stringlist { - set segments [split_numeric_segments $nm] - if {![string length [string trim [lindex $segments 0]]]} { - if {[string is digit [string trim [lindex $segments 1]]]} { - #name is whitespace followed by a digit - special case - ignore the whitespace for numbers only. (whitespace still goes through to name column though) - set segments [lrange $segments 1 end] - } - } - - - set c 0 ;#start of index columns - if {[llength $segments] > $maxsegments} { - set maxsegments [llength $segments] - } - foreach seg $segments { - set seg [string trim $seg] - set column_exists [info exists segmentinfo($c,type)] - if {[string is digit $seg]} { - if {$column_exists} { - #override it (may currently be text or int) - set segmentinfo($c,type) "int" - } else { - #new column - set segmentinfo($c,name) ${prefix}$c - set segmentinfo($c,type) "int" - } - } else { - #text never overrides int - if {!$column_exists} { - set segmentinfo($c,name) ${prefix}$c - set segmentinfo($c,type) "text" - } - } - incr c - } - } - if {$debug} { - puts stdout "Largest number of num/non-num segments in data: $maxsegments" - #parray segmentinfo - } - - # - set tabledef "" - set ordered_column_names [list] - set ordered_segmentinfo_tags [lsort -dictionary [array names segmentinfo *]] - foreach k $ordered_segmentinfo_tags { - lassign [split $k ,] c tag - if {$tag eq "type"} { - set type [set segmentinfo($k)] - if {$type eq "int"} { - append tabledef "$segmentinfo($c,name) int," - } else { - append tabledef "$segmentinfo($c,name) text COLLATE $collate," - } - append tabledef "raw$c text COLLATE $collate," - lappend ordered_column_names $segmentinfo($c,name) - lappend ordered_column_names raw$c ;#additional index column not in segmentinfo - } - if {$tag eq "name"} { - #lappend ordered_column_names $segmentinfo($k) - } - } - append tabledef "name text" - - #puts stdout "tabledef:$tabledef" - - - db_natsort2 eval [string map [list %tabledef% $tabledef] {create table natsort(%tabledef%)}] - - - foreach nm $stringlist { - array unset intdata - array set intdata {} - array set rawdata {} - #init array and build sql values string - set sql_insert "insert into natsort values(" - for {set i 0} {$i < $maxsegments} {incr i} { - set intdata($i) "" - set rawdata($i) "" - append sql_insert "\$intdata($i),\$rawdata($i)," - } - append sql_insert "\$nm" ;#don't manipulate name value in any way - e.g must leave all whitespace as the sort must return exactly the same elements as in the original list. - append sql_insert ")" - - set segments [split_numeric_segments $nm] - if {![string length [string trim [lindex $segments 0]]]} { - if {[string is digit [string trim [lindex $segments 1]]]} { - #name is whitespace followed by a digit - special case - ignore the whitespace for numbers only. (whitespace still goes through to name column though) - set segments [lrange $segments 1 end] - } - } - set values "" - set c 0 - foreach seg $segments { - if {[set segmentinfo($c,type)] eq "int"} { - if {[string is digit [string trim $seg]]} { - set intdata($c) [trimzero [string trim $seg]] - } else { - catch {unset intdata($c)} ;#set NULL - sorts last - if {($c == 0) && ($topunderscore) && [string match _* [string trim $seg]]} { - set intdata($c) -100 - } - if {($c == 0) && ($topdot) && [string match .* [string trim $seg]]} { - set intdata($c) -50 - } - } - set rawdata($c) [string trim $seg] - } else { - #pure text column - #set intdata($c) [string trim $seg] ;#ignore leading/trailing whitespace - we sort first on trimmed version, then refine with the sort on rawdata index - #catch {unset indata($c)} - set indata($c) [string trim $seg] - set rawdata($c) $seg - } - #set rawdata($c) [string trim $seg]# - #set rawdata($c) $seg - incr c - } - db_natsort2 eval $sql_insert - } - - set orderedlist [list] - - if {$debug} { - db_natsort2 eval {select * from pragma_table_info('natsort')} rowdata { - parray rowdata - } - } - set orderby "order by " - - foreach cname $ordered_column_names { - if {[string match "idx*" $cname]} { - append orderby "$cname ASC NULLS LAST," - } else { - append orderby "$cname ASC," - } - } - append orderby " name ASC" - #append orderby " NULLS LAST" ;#?? - - #e.g "order by idx0 ASC, raw0 ASC, idx1 ASC .... name ASC" - if {$debug} { - puts stdout "orderby clause: $orderby" - } - db_natsort2 eval [string map [list %orderby% $orderby] {select * from natsort %orderby%}] rowdata { - set line "- " - #parray rowdata - set columnnames $rowdata(*) - #puts stdout "columnnames: $columnnames" - #[lsort -dictionary [array names rowdata] - append line "$rowdata(name) \n" - foreach nm $columnnames { - if {$nm ne "name"} { - append line "$nm: $rowdata($nm) " - } - } - #puts stdout $line - #puts stdout "$rowdata(name)" - lappend orderedlist $rowdata(name) - } - - db_natsort2 close - return $orderedlist - } -} - - -#application section e.g this file might be linked from /usr/local/bin/natsort -namespace eval natsort { - namespace import ::flagfilter::check_flags - - proc called_directly_namematch {} { - global argv0 - #see https://wiki.tcl-lang.org/page/main+script - #trailing ... let's us resolve symlinks in last component of the path (could be something else like ___ but ... seems unlikely to collide with anything in the filesystem) - if {[info exists argv0] - && - [file dirname [file normalize [file join [info script] ...]]] - eq - [file dirname [file normalize [file join $argv0 ...]]] - } { - return 1 - } else { - #puts stdout "norm info script: [file dirname [file normalize [file join [info script] ...]]]" - #puts stdout "norm argv0 : [file dirname [file normalize [file join $argv0 ...]]]" - return 0 - } - } - #Review issues around comparing names vs using inodes (esp with respect to samba shares) - proc called_directly_inodematch {} { - global argv0 - if {[info exists argv0] - && [file exists [info script]] && [file exists $argv0]} { - file stat $argv0 argv0Info - file stat [info script] scriptInfo - expr {$argv0Info(dev) == $scriptInfo(dev) - && $argv0Info(ino) == $scriptInfo(ino)} - } else { - return 0 - } - } - - set is_namematch [called_directly_namematch] - set is_inodematch [called_directly_inodematch] - #### - #review - reliability of mechanisms to determine direct calls - # we don't want application being called when being used as a library, but we need it to run if called directly or from symlinks etc - #-- choose a policy and leave the others commented. - #set is_called_directly $is_namematch - #set is_called_directly $is_inodematch - set is_called_directly [expr {$is_namematch || $is_inodematch}] - #set is_called_directly [expr {$is_namematch && $is_inodematch}] - ### - - - #puts stdout "called_directly_name: [called_directly_namematch] called_directly_inode: [called_directly_inodematch]" - - - # - - - proc test_pass_fail_message {pass {additional ""}} { - variable test_fail_msg - variable test_pass_msg - if {$pass} { - puts stderr $test_pass_msg - } else { - puts stderr $test_fail_msg - } - puts stderr $additional - } - - variable test_fail_msg "XXXXXXXXXXXX FAIL XXXXXXXXXXXXX" - variable test_pass_msg "------------ PASS -------------" - proc test_sort_1 {args} { - package require struct::list - puts stderr "---$args" - set args [check_flags -caller natsort:test_sort_1 -defaults [list -collate nocase -topchars "\uFFFF" -winlike 0 -debug 0 -stacktrace 0 -showsplits 0 ] -values $args] - - puts stderr "test_sort_1 got args: $args" - - set unsorted_input { - 2.2.2 - 2.2.2.2 - 1a.1.1 - 1a.2.1.1 - 1.12.1 - 1.2.1.1 - 1.02.1.1 - 1.002b.1.1 - 1.1.1.2 - 1.1.1.1 - } - set input { -1.1.1 -1.1.1.2 -1.002b.1.1 -1.02.1.1 -1.2.1.1 -1.12.1 -1a.1.1 -1a.2.1.1 -2.2.2 -2.2.2.2 - } - - set sorted [natsort::sort $input {*}$args] - set is_match [struct::list equal $input $sorted] - - set msg "windows-explorer order" - - test_pass_fail_message $is_match $msg - puts stdout [string repeat - 40] - puts stdout INPUT - puts stdout [string repeat - 40] - foreach item $input { - puts stdout $item - } - puts stdout [string repeat - 40] - puts stdout OUTPUT - puts stdout [string repeat - 40] - foreach item $sorted { - puts stdout $item - } - test_pass_fail_message $is_match $msg - return [expr {!$is_match}] - } - proc test_sort_showsplits {args} { - package require struct::list - - set args [check_flags -caller natsort:test_sort_1 \ - -defaults [list -collate nocase -topchars "\uFFFF" -winlike 0 -debug 0 -stacktrace 0 -showsplits 1 ] \ - -extras {all} \ - -values $args] - - set input1 { - a-b.txt - a.b.c.txt - b.c-txt - } - - - set input2 { - a.b.c.txt - a-b.txt - b.c-text - } - - foreach {msg testlist } [list "custom-order" $input1 "windows-explorer (should work with -winlike 1)" $input2] { - set sorted [natsort::sort $testlist {*}$args] - set is_match [struct::list equal $testlist $sorted] - - test_pass_fail_message $is_match $msg - puts stderr "INPUT" - puts stderr "[string repeat - 40]" - foreach item $testlist { - puts stdout $item - } - puts stderr "[string repeat - 40]" - puts stderr "OUTPUT" - puts stderr "[string repeat - 40]" - foreach item $sorted { - puts stdout $item - } - - test_pass_fail_message $is_match $msg - } - - #return [expr {!$is_match}] - - } - - #tcl dispatch order - non flag items up front - #trailing flags are paired even if supplied as solo flags e.g -l becomes -l 1 - proc commandline_ls {args} { - set operands [list] - set posn 0 - foreach a $args { - if {![string match -* $a]} { - lappend operands $a - } else { - set flag1_posn $posn - break - } - incr posn - } - set args [lrange $args $flag1_posn end] - - - set debug 0 - set posn [lsearch $args -debug] - if {$posn > 0} { - if {[lindex $args $posn+1]} { - set debug [lindex $args $posn+1] - } - } - if {$debug} { - puts stderr "|debug>commandline_ls got $args" - } - - #if first operand not supplied - replace it with current working dir - if {[lindex $operands 0] eq "\uFFFF"} { - lset operands 0 [pwd] - } - - set targets [list] - foreach op $operands { - if {$op ne "\uFFFF"} { - set opchars [split [file tail $op] ""] - if {"?" in $opchars || "*" in $opchars} { - lappend targets $op - } else { - #actual file or dir - set targetitem $op - set targetitem [file normalize $op] - if {![file exists $targetitem]} { - if {$debug} { - puts stderr "|debug>commandline_ls Unable to access path '$targetitem'" - } - } - lappend targets $targetitem - if {$debug} { - puts stderr "|debug>commandline_ls listing for $targetitem" - } - } - } - } - set args [check_flags -caller commandline_ls \ - -return flagged|defaults \ - -debugargs 0 \ - -defaults [list -collate nocase -algorithm sort -topchars "\uFFFF" -winlike 0 -debug 0 -stacktrace 0 -showsplits 0 -algorithm sort] \ - -required {all} \ - -extras {all} \ - -soloflags {-v -l} \ - -commandprocessors {} \ - -values $args ] - if {$debug} { - puts stderr "|debug>args: $args" - } - - - set algorithm [dict get $args -algorithm] - dict unset args -algorithm - - set allfolders [list] - set allfiles [list] - foreach item $targets { - if {[file exists $item]} { - if {[file type $item] eq "directory"} { - set dotfolders [glob -nocomplain -directory $item -type {d} -tail .*] - set folders [glob -nocomplain -directory $item -type {d} -tail *] - set allfolders [concat $allfolders $dotfolders $folders] - - set dotfiles [glob -nocomplain -directory $item -type {f} -tail .*] - set files [glob -nocomplain -directory $item -type {f} -tail *] - set allfiles [concat $allfiles $dotfiles $files] - } else { - #file (or link?) - set files [glob -nocomplain -directory [file dirname $item] -tail [file tail $item]] - set allfiles [concat $allfiles $files] - } - } else { - set folders [glob -nocomplain -directory $item -type {d} -tail [file tail $item]] - set allfolders [concat $allfolders $folders] - set files [glob -nocomplain -directory [file dirname $item] -tail [file tail $item]] - set allfiles [concat $allfiles $files] - } - } - - - set sorted_folders [natsort::sort $allfolders {*}$args] - set sorted_files [natsort::sort $allfiles {*}$args] - - foreach fold $sorted_folders { - puts stdout $fold - } - foreach file $sorted_files { - puts stdout $file - } - - return "-- ok printed to stdout [llength $sorted_folders] folders and [llength $sorted_files] files --" - } - - package require argp - argp::registerArgs commandline_test { - { -showsplits boolean 0} - { -stacktrace boolean 0} - { -debug boolean 0} - { -winlike boolean 0} - { -db string ":memory:"} - { -collate string "nocase"} - { -algorithm string "sort"} - { -topchars string "\uFFFF"} - { -testlist string {10 1 30 3}} - } - argp::setArgsNeeded commandline_test {-stacktrace} - proc commandline_test {test args} { - variable testlist - puts stdout "commandline_test got $args" - argp::parseArgs opts - puts stdout "commandline_test got [array get opts]" - set args [check_flags -caller natsort_commandline \ - -return flagged|defaults \ - -defaults [list -db :memory: -collate nocase -testlist $testlist -algorithm sort -topchars "\uFFFF" -winlike 0 -debug 0 -stacktrace 0 -showsplits 0] \ - -values $args] - - if {[string tolower $test] in [list "1" "true"]} { - set test "sort" - } else { - if {![llength [info commands $test]]} { - error "test $test not found" - } - } - dict unset args -test - set stacktrace [dict get $args -stacktrace] - # dict unset args -stacktrace - - set argtestlist [dict get $args -testlist] - dict unset args -testlist - - - set debug [dict get $args -debug] - - set collate [dict get $args -collate] - set db [dict get $args -db] - set winlike [dict get $args -winlike] - set topchars [dict get $args -topchars] - - - puts stderr "|test>-----start natsort::$test--- input list size : [llength $argtestlist]" - #set resultlist [$test $argtestlist -db $db -collate $collate -topchars $topchars -winlike $winlike] - set resultlist [$test $argtestlist {*}$args] - foreach nm $resultlist { - puts stdout $nm - } - puts stdout "|test>-----end natsort::$test--- sorted list size: [llength $resultlist]" - return "test end" - } - proc commandline_runtests {runtests args} { - set argvals [check_flags -caller commandline_runtests \ - -defaults [list -collate nocase -algorithm sort -topchars "\uFFFF" -winlike 0 -debug 0 -stacktrace 0 -showsplits "\uFFFF" -runtests 1] \ - -values $args] - - puts stderr "runtests args: $argvals" - - #set runtests [dict get $argvals -runtests] - dict unset argvals -runtests - dict unset argvals -algorithm - - puts stderr "runtests args: $argvals" - #exit 0 - - set test_prefix "::natsort::test_sort_" - - if {$runtests eq "1"} { - set runtests "*" - } - - - set testcommands [info commands ${test_prefix}${runtests}] - if {![llength $testcommands]} { - puts stderr "No test commands matched -runtests argument '$runtests'" - puts stderr "Use 1 to run all tests" - set alltests [info commands ${test_prefix}*] - puts stderr "Valid tests are:" - - set prefixlen [string length $test_prefix] - foreach t $alltests { - set shortname [string range $t $prefixlen end] - puts stderr "$t = -runtests $shortname" - } - - } else { - foreach cmd $testcommands { - puts stderr [string repeat - 40] - puts stderr "calling $cmd with args: '$argvals'" - puts stderr [string repeat - 40] - $cmd {*}$argvals - } - } - exit 0 - } - proc help {args} { - puts stdout "natsort::help got '$args'" - return "Help not implemented" - } - proc natsort_pipe {args} { - #PIPELINE to take input list on stdin and write sorted list to stdout - #strip - from arglist - #set args [check_flags -caller natsort_pipeline \ - # -return all \ - # -defaults [list -db :memory: -collate nocase -algorithm sort -topchars "\uFFFF" -winlike 0 -debug 0 -stacktrace 0 -showsplits 0] \ - # -values $args] - - - set debug [dict get $args -debug] - if {$debug} { - puts stderr "|debug> natsort_pipe got args:'$args'" - } - set algorithm [dict get $args -algorithm] - dict unset args -algorithm - - set proclist [info commands ::natsort::sort*] - set algos [list] - foreach p $proclist { - lappend algos [namespace tail $p] - } - if {$algorithm ni [list {*}$proclist {*}$algos]} { - do_error "valid sort mechanisms: $algos" 2 - } - - - set input_list [list] - while {![eof stdin]} { - if {[gets stdin line] > 0} { - lappend input_list $line - } else { - if {[eof stdin]} { - - } else { - after 10 - } - } - } - - if {$debug} { - puts stderr "|debug> received [llength $input_list] list elements" - } - - set resultlist [$algorithm $input_list {*}$args] - if {$debug} { - puts stderr "|debug> returning [llength $resultlist] list elements" - } - foreach r $resultlist { - puts stdout $r - } - #exit 0 - - } - if {($is_called_directly)} { - set cmdprocessors { - {helpfinal {match "^help$" dispatch natsort::help}} - {helpfinal {sub -topic default "NONE"}} - } - #set args [check_flags \ - # -caller test1 \ - # -debugargs 2 \ - # -return arglist \ - # -defaults [list -collate nocase -algorithm sort -topchars "\uFFFF" -winlike 0 -debug 0 -stacktrace 0 -showsplits 0] \ - # -required {none} \ - # -extras {all} \ - # -commandprocessors $cmdprocessors \ - # -values $::argv ] - interp alias {} do_filter {} ::flagfilter::check_flags - - #mashopts are generally single-letter opts that can be run together e.g -l -d as -ld - set cmdprocessors { - {helpcmd {match "^help$" dispatch natsort::help singleopts {-v}}} - {helpcmd {sub -operand default \uFFFF singleopts {-l}}} - {lscmd {match "^ls$" dispatch natsort::commandline_ls dispatchtype tcl dispatchglobal 1 mashopts {-l -a} singleopts {-l -a} pairopts {} longopts {--color=always}}} - {lscmd {sub dir default "\uFFFF"}} - {lscmd {sub dir2 default "\uFFFF"}} - {lscmd {sub dir3 default "\uFFFF"}} - {lscmd {sub dir4 default "\uFFFF"}} - {lscmd {sub dir5 default "\uFFFF"}} - {lscmd {sub dir6 default "\uFFFF"}} - {runtests {match "^-tests$" dispatch natsort::commandline_runtests singleopts {-l}}} - {runtests {sub testname default "1" singleopts {-l}}} - {pipecmd {match "^-$" dispatch natsort::natsort_pipe dispatchtype tcl}} - } - set arglist [do_filter \ - -debugargs 0 \ - -debugargsonerror 2 \ - -caller cline_dispatch1 \ - -return all \ - -soloflags {-v -x} \ - -defaults [list -collate nocase -algorithm sort -topchars "\uFFFF" -winlike 0 -debug 0 -stacktrace 0 -showsplits 0 ] \ - -required {all} \ - -extras {all} \ - -commandprocessors $cmdprocessors \ - -values $::argv ] - - - #mashopts are generally single-letter opts that can be run together e.g -l -d as -ld - set cmdprocessors { - {testcmd {match "^test$" dispatch natsort::commandline_test singleopts {-l}}} - {testcmd {sub testname default "1" singleopts {-l}}} - } - set arglist [check_flags \ - -debugargs 0 \ - -caller cline_dispatch2 \ - -return all \ - -soloflags {-v -l} \ - -defaults [list -collate nocase -algorithm sort -testlist "1 2 3 10" -topchars "\uFFFF" -winlike 0 -debug 0 -stacktrace 0 -showsplits 0 ] \ - -required {all} \ - -extras {all} \ - -commandprocessors $cmdprocessors \ - -values $::argv ] - - - - - #set cmdprocessors [list] - #set args [check_flags -caller test1 -defaults [list -collate nocase -algorithm sort -topchars "\uFFFF" -winlike 0 -debug 0 -stacktrace 0 -showsplits 0] -required {all} -extras {none} -commandprocessors $cmdprocessors -values $::argv ] - - #set args [check_flags -caller test1 -defaults [list -collate nocase -algorithm sort -topchars "\uFFFF" -winlike 0 -debug 0 -stacktrace 0 -showsplits 0] -required {all} -extras {none} -commandprocessors {-cmd {-cmd -cmdarg1 -default "."} {-cmd -cmdarg2 -default j}} -values $::argv ] - #set args [check_flags -caller test1 -defaults [list -collate nocase -algorithm sort -topchars "\uFFFF" -winlike 0 -debug 0 -stacktrace 0 -showsplits 0] -required {all} -extras {none} -commandprocessors {{-cmd -default help} {-cmd -cmdarg1 -default "."} {-cmd -cmdarg2 -default j}} -values $::argv ] - #set args [check_flags -caller test1 -defaults [list -collate nocase -algorithm sort -topchars "\uFFFF" -winlike 0 -debug 0 -stacktrace 0 -showsplits 0] -required {all} -extras {none} -commandprocessors {ls {ls lsdir -default "\uFFFF"}} -values $::argv ] - - exit 0 - - if {$::argc} { - - } - } -} - - -package provide natsort [namespace eval natsort { - variable version - set version 0.1.1.5 -}] - - diff --git a/src/bootsupport/modules/patterncmd-1.2.4.tm b/src/bootsupport/modules/patterncmd-1.2.4.tm index 4107b8af..ca061a7c 100644 --- a/src/bootsupport/modules/patterncmd-1.2.4.tm +++ b/src/bootsupport/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/bootsupport/modules/patternpredator2-1.2.4.tm b/src/bootsupport/modules/patternpredator2-1.2.4.tm index 457d5742..680ea88f 100644 --- a/src/bootsupport/modules/patternpredator2-1.2.4.tm +++ b/src/bootsupport/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/bootsupport/modules/punk/ansi-0.1.1.tm b/src/bootsupport/modules/punk/ansi-0.1.1.tm index 50ea5082..61a454fa 100644 --- a/src/bootsupport/modules/punk/ansi-0.1.1.tm +++ b/src/bootsupport/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/bootsupport/modules/punk/cap/handlers/templates-0.1.0.tm b/src/bootsupport/modules/punk/cap/handlers/templates-0.1.0.tm index 60764f07..aaa595ae 100644 --- a/src/bootsupport/modules/punk/cap/handlers/templates-0.1.0.tm +++ b/src/bootsupport/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/bootsupport/modules/punk/config-0.1.tm b/src/bootsupport/modules/punk/config-0.1.tm index ac70e97b..5532cb80 100644 --- a/src/bootsupport/modules/punk/config-0.1.tm +++ b/src/bootsupport/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/bootsupport/modules/punk/mix/base-0.1.tm b/src/bootsupport/modules/punk/mix/base-0.1.tm index 69f2f5cb..a4bc3c70 100644 --- a/src/bootsupport/modules/punk/mix/base-0.1.tm +++ b/src/bootsupport/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/bootsupport/modules/punk/mix/cli-0.3.1.tm b/src/bootsupport/modules/punk/mix/cli-0.3.1.tm index 3cf64b33..a099c9b0 100644 --- a/src/bootsupport/modules/punk/mix/cli-0.3.1.tm +++ b/src/bootsupport/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/bootsupport/modules/punk/mix/commandset/buildsuite-0.1.0.tm b/src/bootsupport/modules/punk/mix/commandset/buildsuite-0.1.0.tm index 883e02d2..409796fc 100644 --- a/src/bootsupport/modules/punk/mix/commandset/buildsuite-0.1.0.tm +++ b/src/bootsupport/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/bootsupport/modules/punk/mix/commandset/debug-0.1.0.tm b/src/bootsupport/modules/punk/mix/commandset/debug-0.1.0.tm index c6c83b69..a3784c00 100644 --- a/src/bootsupport/modules/punk/mix/commandset/debug-0.1.0.tm +++ b/src/bootsupport/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/bootsupport/modules/punk/mix/commandset/module-0.1.0.tm b/src/bootsupport/modules/punk/mix/commandset/module-0.1.0.tm index ae21d348..2bc0f01c 100644 --- a/src/bootsupport/modules/punk/mix/commandset/module-0.1.0.tm +++ b/src/bootsupport/modules/punk/mix/commandset/module-0.1.0.tm @@ -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/bootsupport/modules/punk/mix/commandset/project-0.1.0.tm b/src/bootsupport/modules/punk/mix/commandset/project-0.1.0.tm index 2ff8ac06..f670c8c0 100644 --- a/src/bootsupport/modules/punk/mix/commandset/project-0.1.0.tm +++ b/src/bootsupport/modules/punk/mix/commandset/project-0.1.0.tm @@ -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/bootsupport/modules/punk/mix/commandset/repo-0.1.0.tm b/src/bootsupport/modules/punk/mix/commandset/repo-0.1.0.tm index 73b54874..277e386e 100644 --- a/src/bootsupport/modules/punk/mix/commandset/repo-0.1.0.tm +++ b/src/bootsupport/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/bootsupport/modules/punk/mod-0.1.tm b/src/bootsupport/modules/punk/mod-0.1.tm index 58906c88..26ed2f2e 100644 --- a/src/bootsupport/modules/punk/mod-0.1.tm +++ b/src/bootsupport/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/bootsupport/modules/punk/path-0.1.0.tm b/src/bootsupport/modules/punk/path-0.1.0.tm index f0a4a444..1ddd56b7 100644 --- a/src/bootsupport/modules/punk/path-0.1.0.tm +++ b/src/bootsupport/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/bootsupport/modules/punk/repo-0.1.1.tm b/src/bootsupport/modules/punk/repo-0.1.1.tm index f53a06fd..a39fceaf 100644 --- a/src/bootsupport/modules/punk/repo-0.1.1.tm +++ b/src/bootsupport/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/bootsupport/modules/punkapp-0.1.tm b/src/bootsupport/modules/punkapp-0.1.tm index ce46856b..70fa90fc 100644 --- a/src/bootsupport/modules/punkapp-0.1.tm +++ b/src/bootsupport/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/bootsupport/modules/punkcheck-0.1.0.tm b/src/bootsupport/modules/punkcheck-0.1.0.tm index fbf9a4e4..a4113c45 100644 --- a/src/bootsupport/modules/punkcheck-0.1.0.tm +++ b/src/bootsupport/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/bootsupport/modules/test/tomlish-1.1.1.tm b/src/bootsupport/modules/test/tomlish-1.1.1.tm index 8405fae74a50ec468daaff5adfc86c3c68353219..d365bab1e00edd610a3a4ae19fa00fb3d3e10a44 100644 GIT binary patch delta 8944 zcma)hbzD?i_xCV#cS;Nr(v6gKmvnawUBZBXz|bj(9J;$Z6%=U@R3xQa5D*YS5G39a zz0cM6{_~sp%$!wwt+n@=*=z0Z8QcbU0N_MkI7A!zz}wLi>IH#1!W^KU5NmHo7nq|P z#NW}w&Wi)$?g{a+^AZ(Bun?F##MRx~4F-AW;OGMVY2g92<-&se@nVp6fk8dptYD5l zP!~Ulx7*KgUhWW>gB1({^@Vv_*}$N-5C&IwTMu_zP7i)78)qwfD5nq9)63D_4Pxi+ zVv9(^(F=k|!OO}O`j5oQ3&I6+h1ekiKjop77e!?9(}Sp}i=(xusH>GT)B+L8;+GV{ z>27D|1%<)6qKxRrFl~p?G%>5iu~(NG3`cH5oK2hYCAoiwbI7o;Zp7vqavm1 z{;Z4?S7$OGxg{}F-l|BcNtfgqyHs_0=xSo>r3@)*LGOm zA2O7xSIP(myFIPPCmr|%Si<{zp<1)4Eykdr*}isD4u6JX6}3 zP{9~3Ke`qp2QhW}W_~fLNc&}dU)+Eeu7yfir%R0tJz2$jve9s2Sn->c@&|jicHfJ< zJfyBSN({4QyvdsyXy%RXJ)jhQVo>%VJT9!8<0{6TY;>(0&$~uBg(KDDgDFnb(L%9K zdl-YjJ$mW>Mz#DSxVmTp)$IFsI3uJK4W+ze)x!Knj@b6FN3u?^J6oD#c%|>SrzPYp zP<5Q#yfW11{ap-rrqoDv>C{p*BW84-jGUQn#INb_o}~0z`Uz=s5zogr+kbwiyb!1O zI9+39>mk13Y6&Z86l$i8rqau<{U&A|YbKHyFnc~H>yY)l4qTW2i??f_|5xG0fWBMG z9%fKFeqIqdBz%t3>6IwDo*#qFlqaI$BEf(hW+@?9Z{y4Rxn36&ilWF@REy>oW0NGOlg+i1neF&2^SG>`39)Ke)Z@6jKlBWAp%PT*~kh4q66WT?5I9uCVwbO#MUki|$t`%!P(YZT_{;?u$ zm_lOc#{eAvW5^-=3lh~J1%sTDJpOzLnuH+q`D?j^;30WyGOFIwC#x*UWR_{*cU|HU ztsS7-pE399}w>&9TF!or(suQP_+ww{mxpUuDbqc z{(Y0G!Dr>KAxriax3RqMYD!GbMCOQ2n^zCuS-gZ?5Si>fo2`#}QYH(*P4%Z9XFFvM zfUneE!kb@S?K;6`A1~~O<58ts>h{*P2{DvQz;E|WUix*K;oVwh-qYVh_uXCKdh5Mt z&LF?qfgisATmoLAP@)xB;OEZ`~fC<6omu=jU$6V z+&{M|xGmI&`+>JRVv}};`fxP*@G`^IxHwjuwQN>KZkmW@1)j=zZ~{#}{bl z>TVN9zm=NZo-@Dy>?O_|6{{*oQeNV5!qN~!t{wTF;o?`H{1P)1Y2$_f*Q>4%!BgIF z%oc|Z`(^z_2KVC-@A^=q@^8moMp)y=$O~caDthoH`{zbxjK*!Ai&*f(PaV=M2NeY% z*1_wQBo6h4_SH*HWjfy~wdK0@L0TQg2npXa)rD3gCtUf{&gN;9!m|-rqc2z_S5Zqi z2v1UK_^|4XHYJpBNdEY4hB$akbhJn8bla8;te#@LD1Gv6uXskMSypj#@p(dfP%@@A z$xL7>^A)b<|85~?e4w$9=4rnRqS7?t021_K@Dc-6_w~C35(clVD~CK9%ZV7vWTM2m z=6b>M9pWSjRPTvCmKP{-Dnp4;&JS|vE7G8CtUIzCUUr>lo2;8_*g|BV8JgbnxjOlQ zs;H3kIG=?W_r&YxaMaY!qr(SmW6n)OH(Apn*j`6cx|crR4)>0{h#=K}k;FwY?ZJ`( zg-gnjv#`r;RU7MWozEg+AT856kEoAe?Pn`psZSD#oA0LtqG&yzkXc8DD_nb{s$ce~ zLO6?M65kztdWvBoPk39R0a?-0qQls$K0-?JZY(34AN(Q%bBIs$1l^r*#a_ESOW#qI zZAo}ULO9;O)VY;B`pfv&p08iY)_hr6b>R~%lmy#0&v0X?V2@7Q_ISJoQcazs)k9d@ zpf&t6TGYW$fDyBtO5 z?UO3WOafDf=tb#r@nUVO{2EKcV3I?6k*zc4jEj=gDX@eoaGzG>7#n@`*y1xuBstu- zf7KwBR7K^D1f$m>ueuA6^s38^$Fteq^j;hiL)84mjJi>ljmDUxg#;7VGjHo`RezN| z=eW74^k6?uy{NsXrQ3?%EECTOg3#qPN--{WQJV#gQh z7}o2z7Fs&=hp&%!3PemBQ5!4qJ@u8{Bn#e-3Q*{P-I79_S;`xpeRS|=W?7(jj}c3w zw*E$P+T_92d1MqVwv9H+_87#z+A~v2?Yg*snB3aE?Gt-gNJsa2x7Lzu;%qY%?v1m= z&m*e_lX`lrTRwW0Ef@$sSXNwm*KM?vrgTw#TE!Y3q{S08F_WpHkD+%@>xlr#P}lyr zavcOW)b~iS-Emy~40@!~dY0`P6u0H=y+;fWIJHkT33%vuB3k;9VuD-K&g?Y4dHs6b zzqzE^>Ph^fbGtb0i_3QEdjZl)@KZs&9v*aDJR7}rXPjk1e$T)lNp{Cr%mZVkiw;}* z2kY(ppRfk2tvESF89}$uU!8HgrqH#FX+j72SLE4ocWUq+nmc@o2$1W(EHS3N4f7SX zaMXWhR(1Z~QRP17#J9pGz4LWtOAfZr9{ee`4GMjo0(dU;m^#FqHU$+I67a*ZWBWA> zk-jN@#-{N~zc1W)8%cT1bL*(KcGh}47Z>RF)mMwg*Q3C> z+n(0WcLSy9#R}iSs$pML3NFqG%%$>lp2J}>ehwT-14$HPx|k`jzR-DGal#d-M`L$&q-*b^I5)f=S@lVy?o}A;NFrf&bXjUCs$apL ziqUrC#E2kX$sGRpG}F_Nk6!$PQY}d!n@W^TmtnSC|dw zHD0ekqWgd{)pU>tb>g-KA@R4PM}DtS+X904pIo8+yCEGAnX?(y^x6wbB1()W;-dya z1L)O+fhSq0fH*q=+VwRUQB0cD*-`HjQt$^FBTPUD$<539rcd^0Km*>`5#43r;$pY8 zf?0XNJiTpT-k#9Extr3&WoPB>>*DC<{JTaWg8*SyYJiuM4*2QjOC1*aZw(ORYLCSC zzW`tAPzfz;JYDR#VD7Fi|JZQ5858Rj2K|+kK4Jn|O?1G4FDlUGhR69cEl_LqResNO-VIS3 z0#jdE=X1Qr&XjMH8tajwjdgpEw#Xx^Pzf zg{9(#hZ626J^r9)0!fOBOwT&zF)@;pk~C9Wa?^FRH70t+P;e)zLIHOY;dH!p0Dqnu z-s=3L(n#e>sUKDWa8S4g# zE2f3ylRc4ahifDhtCX|r!<*pvff&uXzPoO1uY}0*Vl0cvi=v`Ap;4{ct4k$}z@9>R}0651e7;Si&xQ7^htxeQ-ur zG*YN`Yu%hkUFCAiCO_<<2j>K>kLcc4F7yDMbL8d5ERmxC>JR%*d`w2wEjKrD&nsJ_ zU;C;(2-sIxex^_((k7mrlcbR%{G_&c=bJ`!`Kg*P{MhcsCjwJ40qd~ z4S=eM+>S?5y}3puvjZ=POUcXfB(lx2Wfn%A$nzw6NE+o!mU^_y$(MD-YS9DrAL-af zL3=oJ9Hytwtm4Su(?|K27z{o&N>(YF3m4kxJ2PFhCArBxgtQ{v9M7 zrP_F9xRKUnSl9)4TF&Xs7C9syBaa*CqQC_7fl%xLOQmG3Bo^9;c2#1Il84Dfnlf%4 zwVXxaDp&A$naq6r$2`NVx=AOV9OaEW{M$ti>q(In)_JUVRaz37XpzLmtQ4~(;eDc1NAfWyR`4tdYNS&0 z8Jo9$_E_~ZH@g)=s0i8=Sl#(hM2VXgLQ&-@>AVV$^I@8NSBqnK=t-|2z7{E5_ zuh9gTjim~47kHSgtkx6=J9eG+ht`z~uw>`p(?tyuQ7a1bMJjncOXf$}6x3r;nZdKM zbKU(4k0OSHzborSqw-Ro zjXu!IzoR@LhxaXGRB3dG=CT>XC&|EB>jlqnng@%q>=;!xvrkfrA?dB>$hX5oi5Q$j zvdzuR%nNdeh)qMxRHl1`RK6`sJy4OYiC)Ki3{OuUkj_rmSoayEX7sFJ>!;R*`x3^315xmF5mw%=pC4crQ|`N?&B<$tQ_X_N;9R zV*0mo(aEy8NaW$l9S=eu;11g1Gif#3YI`+0Y*tf0+vbWUy1(1_yu~(=k5Wr;vM6Sj zGXV}8vh8p(;hDmFvvDzHtL7C^G3v&qVL?5Q9ean_xXBHha=Tanz9v zzPA}7t*f+JWfTBU9}Uw$5)UDGkXYj`Fw89fc*LV9vdy6P+$YbRP@`kfW$NiLzx@T@ z0Nc#C&Xe?eJe3LUon(u+mAUwOuPk!&^2}k)Lws9#f*6%f5wuS^nzxRID{WgJ>R|fA zpZ5dL3DF1M2j3ZdhnIDVoc+DCuH!I|YtX#a&$M$9G}6|h4#gy@B<&?Ypkkxj2lKTu^4sCgNefC~t#K8E+*{Qn$4S$@8?Y9s0WtmIMu}aK8 zVudVJ&khE-9WbT|KG&nLe;xT@l^OI<7QXih9cg!x9e78CJu1(kcDu5qjbYi4k-p{5 z{f&b4JpPICp+r1Xt=F?$0Tc5^LYFZY=U%;Sk?tA;Z7DxyCc!+9s3KF!KhmD1&wr{k zWe45}7}mFR2c@Iqexur<$@cH}X|uXZ9NeO-{jf5|B>8N(;;v z!w-VyQO_HT5!#h=U5uM z=;F#VTa@Xc?XFmY1*1c=WdRn+Ay2-ynNkPb@2hSHj-#AIq9vTxE@DpyQ6HJH>R&w+ zB#f^p{0KLkIH&u!VsjJ+8T1`zKldgeWY5s2PkHYFf1k^&w8rqtTcKS99 zJo@R`UAE(4aO+&?z2(^U#Bvw;Mq8&rpRo%{gN2~&&r*kv<;w`|Wb~f0m0O$%I7PU2m#0P5bSU^-lv^PI&+N$#UQGiY;8_+`RN(;nNpZ)l0i7f(!O zCP?B!mJTjIW1rj-b8*eG2ift;Ce2GvbaWrhX|zsYI-F=Q>n*_ zr9b=`hcvBzTz>zfA--Q9WbENN<$H#>ztX56knl~vhq%A+KbyIn<7;{6>;&~AS88{Xc=pt@d{ajcram2S%FpW=cuT)L0_^BJk7Z7!gO6MoN+1Oxo zt=|fCB&p*w;Crt&V@E-xu)Olw5yYllsA$$iusm*A~EAw7BWhEJ_%K*yDvdqW;q zV|zZfOL@gi-4Bz_%ICdPUwKdG?BM?3(E=Vv7EQXx=Oc*B!}o6a0GGpKTwm;jbX!qt zdrIxmrqI&~=#Q+~0yG~|*^hm}S<@zYYC-VNrAiDEFI{H2ySjVkSzBmm)p5(=oLA@^ z+7BL|vFzGLjT1^sLV-M@#;@8K@%KcaKcmWHiJ^@C6G5Vn(#@ zl)!c}!LRncMt|OIUV$KR%RsFL?3kRC5SH(d0ud5Jy;u=&IA$goh^1D>e%dj=Si(hk ze2`<5M8+!O7?Ikl_CUmI^UWf1bQJIR>Xkw(x6HG_9uOLg6xojix#`+&`6Q|V;5m3`(=3xD72}M%ChS|-_~g`G*b+zM9=>Lg z(mXTDVPd@IQ{%dykB3C({ryW3p?)zzUPjx*P@DAkuy!w|2Z3GFZ!wz=2yJVe=Ge@g zGwBC9Xe;K?sBR^7IPmnKdcA<~HIMt_;^pedPzAQ9*)VHU#+bkd8 zoI$3kV03RoBb8npMN2hap*QfDVCNn0^`#6$UDq;GoxYYPtHz+&Rt$ESDH>^L%1 zM>Z{QPpQd@pN}7p>rEQ(^OYaN{d9)5Y&&ip5T_Z#cU?4j_&f>)P|dsFnTFJRwYkTA zGeOn9!?!-1t=VG&+VRmw@3m+y7!Ru2C6!v#v`S)hKXsgw$7q>YBo(l`RUMWtZ()Q= z?(e5Xr=47MKyuK_xLs2$%u#T^nd{I3_X)tC zq5g)PK_J1uTuh-MT<`&snS{WLOj>X|~IKM?g;5WFxNn8Lgn;&e8 z576g|0)g4WU>kzpBpyJ(g9*%*;Q%B#v|x9_8}UjG4&a}|2F4-!%}Rn>f0BVyjXFWGOF0!S>z0fO^s!R6!tVSyB|lFtn$ zq(qP&;1>EDBd$VR;B^5TxZ?J2Rtj9oa6?uU@`EKAZ^%ViLV%@+4QzkshK(=$$%XM zi^21oRR$ORA}2~kz*M{lsVMNOj1Vv?V*{uD!^(ka_z)Utpi3JKP%CExQ}O?1@o#24 zSxyUP6}S<3=%N8)6>Q+)e^`9LtrQ0!s6hb+E2zK$f(R=`fUS}Z9B>ywYW`08W)JEW&?+b{${1XaIxPc zI^a>m17^MV2a5)Ls^JIE{uHqQ^|j=HX)O-qKN#Yl$$+k<0j&n6pK#(0ZuftN6M?)s zHgL4e&EPL}%mjRYdA%e1TY-A_Ukvfj|Hywa#6QQs`!yT^CbIvZz{Fpk0f~ncf338N z93l%9$bSIEKSP0D$ls)jz!ok4>^J|f*y5j)`VY4FS0GUZ;IL5=@}J|(Uq%@B5k_2y zlMNxqpPv8IBmXssO7murRx<_UKmE~PhK}06STYNlrYb7hPq`4{4WR^qp6UPO{vQpO BtlaoA1`tXGkY^BO5b= zpH_|r|9%4wc#VitYXB+<4eDB31Vexb+{PhFz(PZEH+SLX{ko6D%7w(uzLo{61RPbh zmR&0oLQ_2r0t7@73j{;}=%`BqoN^=q(%{hoTpOB|3h9(%R7F02dE}d_Iw!0M!?}tP z^u-Oe?zRg|N+YSDu17+Oh8V!5kuFJTjoG1C#v3ZM!Ze}5g^209!<(@zU5rqCOWXfd z!b3m=9hfv!m`XdNSAwGzrAUg|l}oQ*9tk z8uNB#GY-;Wnsl)b^mkLwo&cFb+Jswq0B;PQ*5*Xi$Ug4hV%F(DbLKNW2ldnEh`+D1 zGR21Z5_uann^E*I82hFw<{Ojn7l**O%n@aQ<4qe9Z`b&(@=wG`B^b6tZ zOc`p{mAn@&ti!#13gdQR-`+0#W!gA`BmD0~gqiLGRwmPbY{Owj1`Op@&<^>m0)FUn zI0oBg{k-9B@WJ3pP-;y2CFkTE21clPR)I?FE43z6EdO`bXbLn_94?p&AyEV|Y=OvZ zwI`KhZT{%t<>Y4eQYmKR)7cHwEQ8;=C?j%GBZUh)_rUdb+nuB3>1wclQz`jvoahH; zrr5L9-Sy1@mu8l`nx%`)?Dnx^2EgK12KqzW=1`k@vX7M7b^YwY?|G}skEl-SF{!&p zG+OyxGBq|dirGVIMe5MqB?2)j3L`1YE(UhoX$)&6$-X`X71hoDo`^Mb3DZafgYfK) zq2v0YaDny$neVb5Grp#3PJgRz`wOFgd+4siQ6KnH$7JhrW2;=_u*>6rs|E16V>N8Q zS@?Yj7;Tu(2Rb45b3nip%?{DPW%!@5Xu0>3Z2z2n%VkY4Z%Qa0nkVn$PDxjp1Qu3G zc8J`AR%0TS>Yni_bB!8C&iflowqL(MjeU}`JX$+CM$3XKpsP@?N3A5k=;)NebNx0= zFl4Y&FB>dNovpo@lP(I#-UsL%zTS}R0FH3eq0$Vcr1~dUv!MjIiqfQ6$;C}^(t?Yx z)`8rxlsrq6J-BnoJ3N*?N)YKkb#_si&xFfLOL)F#(gQ?TvXn(VuNKqD ztTvqZ9}Zt*$xo>NY>K$=ymF5HiatE3Wv+GU;|lNAD3vD74A+(1`lh~azm1+i1%xjP z##^vCyH-`nNG{fB%qvK#Tmqhfw@-G+?VZ}@`jq}f6ma{~t{F|(^HbzWqGjc}HV+wF zDO3cHgD~uIDb@w+p>;(?#8lP8erhyAgSd0(HB?tg8r-Z%%dZE zrD7!dYN1&#`?RHi=>I!06y?WnpD+Wc&H~bqy5kTw~p4l?4UhPV(6szh4$7@{&3o ziqxZ?>|Pxb9Uqdbc_{v)L04KK1^4rkPg-HO$*j=i7Y_ZNnBe-mt3fCFg}XD>W({V* zK&z-F1iozKfIHv1!hi}#U92BIl@W(CzKD`L-?XnzVe`xaEyONh`Y7muOAfvv(e#~s zaEXjqv}!SNkWOCh;4fKVvMx(-od|8d!+xeCd?@U~auYjt+6*mlhq|^W?N#qkfF~Tc zxd2TVy_SHdIw}wY>)SJ+vsmKX5y~T&Eajop&@su_e7%{4#3O>>r9L#UXlHfHVh@nn z*n}s_bNUzG+av|h?j^OT<-ktyC`}+Sx}np7os-bSD_%{P)bqzkomsL#{I~0NcCO-; zOBJnFHhHkJMTr4Du_$9%1R}w2>qKp|xSJk4Qgvt~`$Np{98< zgR_Xb6s40ijtnu^SYxzNkb3p> zVr+8~%w3K;aminUX=Vc_WDUUsojmpW77LN%42M^Ms1xF<)7=;X<0P8^+1hj=h$Y_H z$06Z$K~yE#+7uSj_5P9*q~FZGL@en}@9^MTkVl=PW|1q5#A%w zc!iZqu0>Ph2{vmmYB;We2-sqUGP`g{kv5u>UR|@UP;L=62Kd`)cxy@E{=Hfbsn7 zz$+3+K$g0!!!9R^plqix-Kb+tDH=tIXs7_wN-vm1s{n@nw_M5*WwCJWgb^y3w@p6w zLZSwAjtW9eIG$Js^A23+dkJmm3w`dR;J@;X&?P#MZUu$G#ep^jp_R_X$Cq#EM|6oP zgg9x#m2;TKFsJiTb%D-*XmZ4l=h%k>Fe`#&0NmFmZ9VNOh=1k_nmA%@g=wFBH@U66 zm1W##hA+#Hr*``lTD_INRV70i?2*4XSX*XLYk^9WVz3QoQ^!I)vBga91TM)!Jla`C zL1@t3?d~**kzOha!a;f|jQVa<#vH5{pVvFpU4FZL6C)6Sn+?knT`$p3R#4}PqlnyB z0W?-z3@Mow!KWF;(?k@AAv_&Jk0rS!aX_Kz7$@k>rxG*-5nLs)bTu4XBl@<|B)E)c zRnMHpQxijd7>nR}=NuZfg51f2nZ8wGr>gQP4IHB7U}fmV!!5(zZ(byAh%8tkRBM3U zX5~3aZ902rO?t1DFfc9C9567(QPd{gC`DgZl&u7OKIU{|7jU5ZPt^VG1G1V2cKR1GM}CRIN%1V z-rMLL^wcl8kmfSayn_*h<(DE#Zt{rj8-C-5@1L%v zF)4mtkX00-S_dvcxJn$klW3fTPs6%pe_4YzKURt`U<4hb^&Nm7X#iYiCn*ay&Wt>o zfGiKl00CuLcFCSjnY*D%>$aD|k`vuyu0W)*tf3vdka*1#5w-OJ|Cu4SN`}LLB^FK_ zm}|Iq_}{Jkl)kJTz1)>p*tON-db)J9yl1=ELd-}YS|~T~ub9}1^inq4Qm-kaechYX zSO%Xk`p1IyyS+Eg+7!~1S-Sd)y8w{?4XZfoK&+TASP^`6dcps|>OY;n=)b77>i60E zBYE3YnNmt27|C0=E)+7t-J7P(T39x*B804-B1s<%!fUF zAKRW`NuYL$)ef&2{I@o!8+ntzWKV^9`=3AdEzp1g)8HH3fCJo=qH?KF+^XW{<6yUl zw=_VKdRrU=&VqAks+kbefovOt#N`}s;^E7%77AF$CH|=Vpv*;^)Q27inx4L0(t2R& zx>eb=zYwWkaY%#L0cISAF)483ek%dRfcYSjXT`^qFXpM^KKj5=)<2s;Pa5M+@EILF z?$C7`Ss(j$*>k-vYbF_@%{d#;^-5ig-vGcYeP6qtxj8{fF#V}t-k>(KoQ`WR7ST3k z8v;Oz1YWpx-(*R_$73x{n~D{xs-Lh*|Yg5Zq)gZXrtFU3@9pSGI2pI=RAh|^*?1jk4o)N-&tGnC4J&vmv4jor0Wi(YW%FHrMeMcA=7tjvhPuXHoYz7nY25xYFpwc263ks>SXN)tr(0x$GCxj6uCH;C5;sRQx1vf)0XEJmAc*a-5S$)pbfycb;=HH z!)3^y=;qk)(B6iSMIf~2tjZQS?CmDP`*?XAg@Zt-1Or_@a@Zph0#p?K9Q51p@;a(nxH;Q?ZtdU|i`(GSY1009mSV7>%?!I9S=SfCVoI3LSuP(}pHG>ed_HmMcoCr8 z8S2&L*`Ofae21kSNJ%tj76TX;H@sz1m6MWA6 zLd=X!bohIC0%f4`gp}IFixFp}|B5to6)>dxXorB;zhR~I-34B+djwbe9eW4EfAz03 zl5{n?H47tqII7LhOauR_Lw=VAM}o4LP^nBcz0Al3ZpKsdMVk>($X!7C)GF`mag7xN zfvw}rk3#2es)Pw{7ixt2ED_)cq@=*3*hyeGpu=i-4?M1YwLO ztwfwB_J&2FZrGlSKqVz5fIa-z2OjkZC<%N(M{noMv6cM#_7w@9PP_GGy zD7;XmbLj4R<4%B%;JPpNEdT^)L`eWl;O7CxIzs|mDN$;tDIqygk-o%NrrJ8~(ihJ- z5dW`psb+-*o~UF0zuZfa#-`#PCyFl;+Gj6^X}up4iRW0aK(=;SQh9Qyy0^}re48!O z;KVW#wCHQ6$AHj|X$o9nr6Ky+B>NZI9#U)hzR*TkJH>9N{S2b+2G&rq1*HwUsEt_j zx8?lu9S4ZG(+n{#%VaY@g=hZ81{fbF`J*$Gqh;3*Z`55KBi76C>iW|;1Xz!=Rzq~H zE5rjY+7+v3(|oKoo`pRO2vg4=y^XHnL($>Vw(;3kl*(NfT@<{9f(h0gDs&NOp%}m} zp+35^UnG-=aAUEIN0AkfnqO6ycF}KHVoJX1>+530>XKGMd(OySJa3TT0wCSOCc2x> zC;xHn>#2e&vlRtuMD4{3IF5}x=FM9+V2S$|Q_S4PJG;WFNuc{~-QQ8j&e|=~+re&O zYs^zl2(hl$M0d?k9!=dGK;8K8>i@1(omn11Xv||FN;G?_A2fK&<1q$ovdjI&Ed?pt z3+)#Y0DYUnD|bifI}s^G1SG2DP3p6Z0ha6V;E2(E$?Lwgmank%Ivun~A<2$vgQjQ% zX{qYhuv=suJDf41`vw?Zx0hQ}QXYUrRF6P&-lf8Gv&C5>9e>+1!b8tzL>sAYsS>Kt zZdOaRCdgolEZ4gHl|6|Pg|`%+3AC1>rliJ9l>alhmSX$F{>NCD36KM%c)sgwd|eWsM8)Y+u8kU;=#*F-UCt z93wRI%oYm3b`S$2JB6+@wk?2~yQ$)qZ`OzH-Unw@2wD)tO)nwtT)!|OW z-z4T^EFpH#bK$d01IUx-(AQaw`%4L!CcaLaJFo6|$~Nyz=~x;36nB_i;4yy2?Fi!S zOv?KGOxr2vW{@w)5rt2TcQN^NdR<+@7(BW5{Yt?e*|Pgmdwy*UUmnvLiL`);`lv6u z0>t5dMPk-D0P*&X$Lz&FXE&n>@6TMxfbRNF74Zt=ualvnE<9@~gP>aB*Ek57Fj$hD`0O`xOSKZ4GJ|ej#&Um}CoW9GA zM)JBQg(<`hH!AMmV02M(aUqXf)#c@JKI7go6f#ZCS%LPkBA*m-1)H7^kUYf4udfrH zPT^cR90852R8fm3g|R*O#8rEV%QW5xC7mMy`Q6Yl)2DVHtbErOQ7V)+!$=Znh`(rX zFy4|+0jzkRVTin4kz(K?V6%LEo@4XYDABswC=t(Cm*B-CgX5gVfde~cj8czq?Q8|6 zm=s(!cpl#kzah;${DHJU<2th8hkF1q19_=H0zGHT?z%h$xM(Zd23DK%A^n;ex|JkVjiXKv$yh06F(;Bxm4NDH zy>Xx0H}m}xvNlYsAfh|>iu-Y5(8{2MLsSr$?>)R{V?`IhuI-2T94mG2Fb(v@%i{paz2FK4 z>aQ1uO!jjJg&xp6&}owWHJg)Gp-$<KtOip&CQ3J z5gO}30;y-r=+^7*j}&O;MRh8Xi{R?}(eDc*$o>^f6VN>dCbdg>9KkTS#)=W2E|zwKOpBcJd<2m1RwqO4to$#d$y`g|_X<~mSHaGy;yDU}=(Jt-a7a0`f^9QP+pQ|2z34p3u=n%*}jQ8k;z);X*#q+njYsU04vl7=$c#7?C2k?5#e(ewW=`Mfjv-^u5gR`CAb?flct0eK=Y@^Ke6 zv6WxNLoc=?nz`yb2>|`)Gsnxvy)i+IQ0R^M&Hl{`xGhxZPqldvI0Qblqd$loj|vT~ zOYoyJMjA-~SPga2=0kot+RxYZQtd0U6f*O|*=%h@eDD(8tN`GQRcdzV4ntl@2$EMNM-9}oO8`jWZh`&<;*sOAA@+yZ|J`GdzbYqTpFUUqYlz_Vbua?`RQ{

EUB0}3qBwE*P={=4g-ApNJ1{?&SbvU=J`|9rkJz60>_Re9iWKw?7*Aj=n3*YuG7 z-Ji15D`Nin<9Wfg-q`fx2($mv<_TvC_Kwyx9=e4Y_zfDED=VI8&j3Aqz%GGVh<4kmZlCAh? zPWhtcb??NJw~}{q1J+l1x^nr*a;I1WJ|jv8F`R4>DgI=VO}-PzEk*HYa#8`YNmsXf zt6QK_O-&peP)zEC(zdr;vw~dkH+!LXqWC${BDUwjxWw^tmPUuU)rKYlkks_8*N_9$ zOyLCwSADpKpYOnvoX4pRACmWo${7&;=(Xq471^LvXu@WXJaU%1096q!lY8s7s6!J- z@A-XxW1VYUfjgXDW8b*yAz$O_IKj2SE87Aaf$7ZS8cS4DxZ-YwqhcCQFOZjgx^_JNKn<@GY-9-roQns#q9Tj0FsyBR$>BT5(Sy*x2BekI-z-Pcq=W)B1#7DW@ zn(fKqlPdw9b-GzWB`hckHL7>ywincsCZ!*rbMs0X>x(Cg#V_q; zA9M|Q`!#0);08XvfJe0;J%6*BCea=KE!|z)@gI?&c3-LHaB3pYy!}ev*8b#dPj6Yl zGwY%(T?%NV)8_7vzUA5-*EP{-&@4%sUBhyZVsA+wi2fG*KB@7DV!DAc{ge?-43Luk zbbq{#o6X;D<*6bNQX+ugMBttb8-AGZD1l#-a-IA0P0wu;0O#x<7EgLO9DkB4!b?cS zvA4SP{aB#&flm52?!!29JWug6COK+|)roXIeg$>w4e=rxEsQLJs_h0VO0?4L zmjm&`gZhciS|s#Ku*(Dn>YZ(+G{rF2HU>2Qvmj^P$Ys<*XV=nhd<~j8%Ji~Q3C)jU zS!W1hnu5g)z>Xfv@hymKd>0nZ4cSiHDC(cX_PSy84tmxY&#e-%dj8D`o}4Uw`HBU( z@>zW3kuW9>WN(>f1v`#Gf74^`D7ByARKe^mu=hzYMMPmf`C&gR)l@9cT2iLgzx(mh z1>3)d^xS5~Gbr578?D}7oV7(8pi*~Ug{dE}PV5ifQ-vx}C*3)}mjOSa|2J=v_6S8# zzs$Y~90&;SS9tmFPW=xu{sWkzFKp~eA_$E7eS+r=U0vkM#1XhH?dA($(5wj54YhP@ z=G)mxvah5mbBb(z>N^WkEMJofLw;A`Cb)_B**iL+|C+my5Zv`Fsh@WrEA&(*S>~xZ zn%w2$S*(1J4h30D5o6*oD9^WS3-pB8L7kIiZH7(e1Ke+d-MS-?@=z7tYIJp{jTxak zE2w{QC~gEKUfoXd*0q;Tdn-SwHbm(9E?IkkG~dpwOu-AH`nf~vy+$EcV;LC%H|~!T zPyxD3$?!GLG!Ifwz6cc}j`b9ZF)0|dP&rQ&6hAPTA-YeUHno#&M|^pI7oVE}t)!qt09Y!;Rs^cZ><$o$s+`VlFq4RXUN=jlR{4w0+-iZ?Q_$Nf z0sw+f@UIt=n0SAa6>MRy+vTdCt;JizfHnBz@5Vu*tpcZPihI9dvt0y7x)}S+3K3^! ziC{)SoM_QG8?+qKg`PlOd`A*$MGfz?;~3;cy{BRM*9sx58_VK({qvX)nT` zG&^T>jV)fJucnD%OX1lWsk#+yS@SwOwq&?IUQrjG7=P9t=cUK_LoAI)J}5(=0MPMM z-MWPo`y4ZSCv63v#gRl`me{=Cfy%$JTkJTV^7KUbjsgQKBLHEu_>-8irY*2lR>dPH6 za7#fb1q?!xCbi48aEC}-$O(1?Y{Ttkv1Oz(_1ti&Ida^Q;C628U)BNznZmMc?P_}C zDa0<}LbyA`*d@`4RPF?Ru@v?;adV;2vh)jP*wz!77AznYV#y!T5wmCr-Y=#iB^RM{ zs63{(!Tnalq~*%TYbDRe3to$_7tbrDHc)*e1|2EIX}QLios2vR-hIoV%9@k6nM680 zR^6L%@QD_FYK`v@jVZ}dLX>gk{tVM*`T+ljBtX_s9H5gfCD11n7y7@J8fu;N$v{#6 zQ6t>?YNCW+&UpUokoYg@0`(6Kg~khH=7D&++Kb-jkQTXgGOf)iniR$!wq}L_Q2VOq1k^k(&~O?A%C$ zV7-~J!C0liy+lOB?hIQ2dF;_7*VxhEVQ}ICY>6W;W-s;t8gWC3nOTmcW#_JTcG}zF zTsaXcY*$?Rjp$#C9v)~ZFuy#ID;#QR3|T4RB;c*#bPc2Jt?&{~8PwiSR|(L6E8Yi< zdkct-T_uO>Zy0o&s21Zd3?M?>g4Xu*&Wsr}YXpC8>DUt`bCR8meJltZRe;jHiJKHy z@Uq(FPW?uas$xuFhUy7PIhfpy|2Xg|#oNWYMKuO7$Z~Xs7|#2{`U=J;e?KTuuz01H zrue^+O_OLX$N7b9ReTT-=6@l3D-;pHFih)!k>ut zGfx^ReX2lQ@=sBGyJ@>h-EWG@X^+b>YqQaaU6-{w*nZ}OZ+z^p7QQoMl|q^v3&NH2 z1T}3Cd=k~qjMmR7)ohD~e^R%o<6yMXCQI##k9IC*N;vA_@u?w6LJ)QQ?y@uOezHcQesEBnBQPAJ{p6&{8_C?da>Nk2wcT@s>Fl57KAli zZ>@v{{t|`ch^~Kq3SQxg;bws%PiHGp>PShTV*Q9?{kI=1UCL`p0w0HDRm!deSsYqPY41du`euP#$%% zX30j!h+N};9nPp$CmK+lf2#FJsibm8&KjUZckrM`=6KRu{CwGeffl1 z`5}|$+d~~Rs{MWfU8|MheqD#Po>n1_N{(&wMk0DNavyr+E1HmBbREL(*54DT>{>Eo z^-FUjA%k=fbS?T_HqHtGKA)ZmATqmlPF@~sM-7a00ihX~?3QTCh74|U28JIbkIhyX z!q()fL6TO?5vd77A@}|X9-_l!HTUqs!?l{GSfe-=!CA~!PH?J5dbGmJopl~+3My@4 z@@cV0)9K%438Fu`(WLeQvHWhxlfcGJl=JOILir2sej`#PB|S<3Brz@a2FR7D+Y}0c z(!n_o#aCThuSQp`5D!3I;Gpq{=&Chy4g{fbFL)>rl zc&o{742W%L4i^~!?BhY8Ba-X)j5y(ND^I^mJv-QizuI&H?zPu%u)eYa5jKm2kWE$1 z!E?T7Rj#!aQYJ_N$~|&k@H;1MbC=>xJ9qb#*uHmLBXW60R*14TSCFMu$P%h-#lD?j zMR6hUQixJH+h{Wpu@xY++_2c`)=2DD2*0W5JUk8!8#RIe`k>f4#M)TF@qEnM*b>|9 z+KlO3;nl-+feQ*%^5ei37T`4A7*W5p{q931y*m&9Wn7gr!m(hwtIqHM?O>CgOmS=#|vc+31<_2A`&=)M2gQY03L@Hs=Ogd2M zHVb@Wn*U6PWAjYOeK-7jom(dl%!_8lcHgw5-KR;Mpg8IN2Dp?1)C{u$Gm`>yRX7oL z7~#`3q3&&tipctVE1g6zRx3ag67Vmc|9gS$A9h>aJ=u$XVaAUD_-XYoCkb$Mu(P#t zvHTZm{v!|1)9n6Xj-L=;+$YNuSUZ-pqXFWxl1x(w6_2H8EE?|LsPY&Jsl*B&(eCxYo{rGDsDWEYw4jw?(_6APWXeq#{@~XoOv~Mua`7+DULPh)`h94t1$jMu^ z8)0Wpn~GY}7|bsqU6N_eoy+^=K@Lz{D#ZV-zUOQYsDq#EYvQYuAtz5_o7A(&y5{@)5)dC*Y*d|NlQ)M` zw-XIg-T&nwI}}ms4g7*x@7e7_iZTl;&{$ldGZ{O#-pW6rU|`T88roMn^Z+%~bNyy@~) zM~|BM3|d%&6;WzqC-E{vO)0Qx*vxd28Q^Z3nDJT#u9oQvy)KaDPZIbJbV=kba){o$03OytkIjY*!B_v7hU-sj?Y&5XCv*hOpsA)K`+ z@j*8WySDsrQoZOh5cR$BROreJ)6n4g9O;*vRU_;0z{C8?<)EXWL=j-kDoS9`LRl1<%vp)G5iRx^CwI3i?E&X1 zp7JF;ojj2DV;rPcn&xF<$HxTqdTSO6q`20Vhcv$BP>Y-9afErQ0s~DLf<J8G zR;2fcYmb(vv3(p7+IrtkjiZVZl8@Keqv?Cpn@K-Px8p5m$TiunLD;vpT2IurRu}l< z--aCxHMw4QFx`({QEW_;rFfMOk5uX78IU*Ft$LhA9_taS`W?7+_4PQyj*DIiL6=a@ zdZ#WJt-NjQ^Q5NpS;l%wf}2MBWAKY2`u6PPG(1x#A|mK^>~A6N$BjEd<90lnMM*4{v`*WdavaD<$l zr-Vd4|I?Y)uxk|oxi15uKtKS(ARw$DkRarCKx)HpfDAi_Rn9Nk=ydMnVl2TYgAuaW zvcw_x;@NhmyIKlhh}ptKiLZ*A&7hW1WN&?T>_!sExSuV#W&J4n^43Bdja%gjy4IcfvX)H8 z0P=e_PJ)>p+RAh@on^Vk>?*q%Sy;!+gG5K&a5}cp9R%H-KFmAi-j8{2?~jACcVZ>I zOkYnIcPF@K$BmbpZGj&w2JfZ;vhU=x8rS?Jw*>KJFV-E9-;7h^^717_sa3z}< z=9T_9S+ijTL(10+VG~Q9P2nTQ_46qfw(t9!bz`e8TOFsZ;oO{P=?OG5`eQ@!s1o5X z9SM>LT;8=W>a{1>85y-?^Gxx9uh~ljJZ*L5Hcp?SFS{uL1<(|eP4vY=# zr<{R;&|QeCC{n8!SuaJy^;vP{9)NpPnzv5QW>z12mtwh!?a(kcQkTGHv@m*+*>kJ; zOcvvGlLJyny8QbSXj%IDXkw}B+26;~q4ZPftkLOQkyaBoiXSS(mXzi<$VwM` z?8%e_Zc&419z6?FcjWH$5h=|5U4P;6Dpgts3+$haQLQ+xh2^QW-HQJr;Q@Y^Yj}kt z52WN8q77*N-d{?H$nT0AvH-;DJGQ4A6+8zG)?_FMz1TEnWR;F<1~RtaCH@9ib(@QI zqeJ>3K&aN)E+8b-encu{PRof3@pOZlz)-K|y<2IDmT(M_rCqJhbvy=x=V|R8)efx; zdRcFHfTXa)z0lkDviF;@HjUI^mo(KUt%#I!XP+LY+V~WHQ`sDho&q4zEs5|rtv6d- z<(V{R?9am6iZxxlBomN#|C3?7V*>2dE}9X=K~tv{Z*(=f2$b;oVFd4ruSWZAaRmRO z!lR=7;(62Ir^S8Ng73%uX=}EYg!gI%B6Fz1I{Oliz_?gv1=w)r@YbFVw0~l`54*D{~*r|;BqS5Fq6tc0Z7@p*uQc39$y0NOxaq!4wnEIGQX zCW_a9dpK9t#LIr{UP_K=Td?P=?R5iZtQuC=^IPU+SI3t!(OIG@(j@N;F(VKks_H`W<9)$Q#)vSaZxD;`23_ z%1>>rc*iGi%Sm{vzgK*ZbDv26>&qKajgT5aIrNw27NL@bmL9j4D8VYMl9{FDp}~Z` zWZ{AI7yR3fA6^-No_lvwY#_OE#k-69v8#rz!0=-SoVU-rYQAmOA%CP#0V?Z?!Va zh3>T;64*X;bJmaBt)q9IpIIe}0R_mScgk0{8kxizdvq<$pH=U;<7N3DLXY1+LI1Zk zA5Q=$YJ&s;8DabUk+H_ zxR}V-j-saHGTp*^{3&GoPB;qLI#PY#8$=yaLQE3Tb0Z!-$W3-rU(npGGbLf3IgRv@ zGb=xZ54f@Vj72up#?R%4~>1t4^fN)?msTXSmPejSsHW0_X*Imhna zmE5hHPO&lfp4W1nTif`7@7Da3UYVYOUm(S<+|JC{AIQo?4;TMgLqp+;wbhT3S>W#N zmu_~y+uwUSgQ?kWyWSq<88h7Yn!jknjqk{=8n|TJZWodN9WF4r3{jLOktfr0f-!`} z1$f=DsNC<%kS!azV!GjU;Ph&cU&R&xK0Z9b5Ri=AH$HuQ9`JR?7yT^!5f@=It~7^m zh)3@d?eljLgryi&kS30nNl-<=(Z~4$8d7tYyT-VJq!3LwIrw9rJ&lVor56nQqQ(hX z^oGXm@~RUzox{6PhZ7PQRQv1SCP++=0N~W%Vl)Rx7rPXP1N->aVNTlC*%*>*PPRXk zj@*er`SNhZGV+F=Ua?VEuAA3=DkUsr!(5eF1~P5c9uCAxDV4CB&jU$*75zc7MS(oJ zX}0V6BeSGUUS8#3?y9KzgyZ`#Or`aJfDqnZ^ zr+Yd@$nC9k0nxac`UqgkoQMF{?5~QChw}WKL`|wDJX|dZ?VD z7m9@DHnw|wqM@{@L^GMKCz=UTM!*pZ0ymSI=&~he@ZYI)IiTF~Z@21786_h7vUeF( zEe^*+#rqnOyHdU2Gl?EKHaLGBMGY6c^|FqRKPDHb?dnua$Wz9Ah_O58I)!A>lnpht z*sm__KUZ7Kxr#lWvk5pR!3Pdq;Vnl3K6$w7*_ONO5L93P4%4OfoHJK^paHlX4-hnUISrzy}mEI zD?gl;%+40n3g(+>STHt$e2O;JNv(0_KD^bCj;n(~Qm=t5`B@?|s#B^>Z119oTxm=P z;hJJd%qg2HuBS`dOkr|*VE}5UESpnGy5V&+cgVOXw|$nC>(a_~b>Y`49&K^g-G6J< zYtw9H2R0flB5`qiEI;WqS5%;k4oW2`^ROU_#hajKJ9&fnKOBt}RZVJ` zn5+kY5BvMnMRZ7OstJ(~F663umRxbEd!BP;`;X{!eEf`GJG|fgUQ#N%CIHnLx3T(; z{NMDi`f@B%IJVRcUrBf5S85{gFURt)-#i0bnXtb402$!xQq~VW*G>EE^(Vq$z6#yXBG>>D5NJMt0>hN zC7aN*r~^_n1JEyoStr@DFQxRPel(D4vDHtyPydOsxwtz0QhZSowJ_{?U3rwCv$-ezZe=SEV%s5+{SL#WkSTlGSpoL8(SAyL6@ z3q$S}UTwE%KY46C@QX9p5?w3`Z!n48$zWyzECBJZf#F3zFOpf9cYb9)m3RK&bSKe9 zi|_{RoJHrsDoUt-X?%_O13!gPCkyT4U^wgH4)|;vL-$CUwnszadvJyY3Y;R60H26k zf{JOez&keI&(I&D3AI-z*g}wL=<*C zr;Ns-w;A-}-bnNrK56m>|YIq6p) zN`(Db8QqmPcv9u~3TU;2FDumRm0laBckr1;s5V(iMniz(sOLRe5Peo}bVIRMQ5>mG z34n%|)wEtU(1I;x^bKJ6p&Yc#x;jitG-Nt9oQ8gk=cR*4BQfw`7RBwT!uZ(AIe zcT^|?5d_2V@vW=tMNFt)kBU|T7A>DuaB_p3)7P^yw$4gX0O6y5BM`AIDYdT*n?$Zl ze`uHGT{e#+gFz1g2))v2ni)3-+6!~XAqCOpy2B{SQF1ATQwoCGbuYhV5(88Q9`USI zVPaVtTLKo%n>~SJ)>>HfbuqSuzPkmf+&)w~5Xm5u!9x5tU)?T`jnO~tQF17f_hDeGOT$K zCX6wZ>O^=RdVF@3eY0`fV*tKvit_`zT(T>?h@ot;x-1KsK?G!gL_yZwiv99It;OAI zl_162?7ph!|0(0#qoLa3IIg`e-K#N-cioIpkw!O@_jr>>-bN8htF977AsJ(snaHcB zY>LuDC0vQ_rC3T{(}QWGB|TI`T5|K4VyP7OoMW!$tU2??e1E_5*^fW=nYGXSe!ngH z&Tm(O%&|T>8@`N&U*~6bXl6;@E17y5GCL&i$?GO(ce_G2b@SqJr+Uz!zvwkfqb~Z+ z^*rPJ_PW-7ua0h4f2Yo}Ym3gYD?Ao5_4QdR|2pBqUH+vgHM2iLH@ArPM)*7`Jmhvo z9OHC?)xlN?vjO(4qFxw7?i0BeK#( z{@vXXG2Hy1o7Jr&!9C3mD!_JF^wxFxwFeaX+I@=4du87$4h!>ICl_qKwNk*b&#oB` zDoH4dNY@;byW+h%L$j|#Pj#vD)P-crDuc(qz;{rYP3XCPz*-=mAEo`p)x1~z@)i2B zyMLZ^?ksw7wpyh6)%1rh>j5v%C_i4l-aDslh}6JsTGA<)xfSX6XjjS9#6t4@!@(`2 z7;CTTtqRe)ZI^>;j?{YepBLN<_ZTr!d-yD}n#6^P)!O;u|NU+CKR8(89KDEx$O_ zOk8~LBKPT#f55^0WjnGvme}5x?Y8y#wRD!F%wrAw-C0zijReS2H;ID%RIS28ClB8o zVZ0;Pc(YrXry^trbMLQ{+o`7Pq;#w+!TP1^RMV)|=UzjT3HR?IpJLT?cjgQp-|3H=;c#QYQ}lBoI}r zg+O-jF-MIeRb7n(^>m=f%?K^FhE*{H48~PA;^42k^Dxpgyd6UZ160H{Us43Au~cx> zKR#vZ%5 zhNS=>CQ!jA2eD}n#vCzO#xe$(>o9pNkp%Sc?gV+t2H09BN%0^6<^5}p+Cs!P#0lq)xJ$;Z4 z+5<4Dl0pN%n=qN4LI-bA$pZs{*gQs46<}5>6$paFragENES3vl^dTCE-7I0s!J$LO zVA&SLrH__~!7XV7ic}F9ZrQBgJ`bY{5`}Sf6*%}v7;MVWMN2H;c=TM)xZH9a{32o= zMi=ClG%~P=!dy1#dP-(Ew)_7Z@^ELe8U>#^iv}DdFYaEf7bGhVdn`~Gmp3QL%5=ug z!{{u`GswV_iMf(8bg_YOSuwb_|0IaP#n{7&4us40z`+)Y2)ueNw%?Te!N3P^kqs)Y zRXqo7C5yG18$>GBBFS$^MQ{p?%GAcDj{Ad4l9Qnx7K18SuhQ>BlJvT4F-(No;UxHP zCV?Wgt(N3vf^y~?IA>{6q_$ExxF#1_VVda9O5N8(76~CCb=kDO~~v-H0?uHv)nZA_#(ngp>#ZN(y%k zpyJlO&$;{j@15sa#LQan_j^0mw+0P#=|$sX=M1v8vj>Ab?c8iZ+Lrbpdna=%Fa+cb z0Xu^ot-w}nAWg7~yB!4V3IYS?03TVn+u6I>If8&|tzB6_P7siXwX2X2l$4tj$id0o z(GBEj3ndD?}192Y;JkW+y>0*0fxBRIXQx?o$R6T>|8+r0#|bf@b`DjT|sPa4rk2#WkDOT zBN$>1CF<^K=V&7YK!lPO60*0m5E61QzXdi0Fqodd3u1M$wsr-(xp_N-LFN!kTL30V z1o#{(B{7hQo5R^3zp!Ly4e~X#GK~2i|iw zce7;!F*rN9y4pd{aW%IF1JVJ`as~lvbA#Afx&fkd6=$UWWl_Ih{(~|>dw~xGb^%dS zgKpmjQ5l{w1opCXb#n!M|NQ?RKQ-tVFuy_r)B)wy$_@fLhXefO2vz+LJilCgak{Cw zqm?OOHW$}GoSfXwE;=XSW^QNy^Lpc72-uqglC*II8M->#+qs>c^@A9z@rBsW2wYg@ zFIS&g!(XKaAZGt=(oodj>HSfXu1@X{%X9Aj?mG6%L;$=01%V$3Z0`#GgNf1nW;;-c zxB@-~SdA0N6AZF6cLex@da${(GsMXmVh1>mz4tHVp~eb)W_fO7u3$?ykgp_2>Q6Qe zJ@rf;_V!>$8z92aN*aSiML`_E$q=xcJH!#>>-Vd&p_f2kzg{NwuP+k=8D3ia??6IV zgxU=>%+X5z#xC?@=nHy^B#2h(A5V}1(E?=tc*>ty{l2j8pFg&Cf`H9|*y05s1NlNv zW}x+A{9D0YI$i1yHgL|!g?!JV(}i1$p{MC(j>l|I>v5S28yK4e?KU z=g|}zOkJTY{7%o!(q2f&%>kM>T;2Xa>bv0WElnMuWI(j%Kra*iJ?ul5f`T}^cZ$EmhhF`QrvM2D2>fSGd9nOoF;*) z`#ZmgjrJEl{?-kkin4aMx4)=LK!!J+fHK6;(#a7>|Da!qoaGH5KSL=SgM@^j973-J zon;{>Yanl*l{O%tasfEEf)+I2--4W%Tz};4%vhiy+7wvwBB!vQ3;Ya?FO%P|K#ZZ8 z2RI*W#R{kbT2x(59>1;ex7h_ zABTQ?Ru_M-Z-s=epXEldo8@nypxn}c&7r1yQ5CofotMbpuR6o!3>b_X^nIum{Fw+) zqyqVvi-U`sl|xVn^ed5zE6YTv2t>xcZ1p$i2hP7LJt(?U`LP}P!&Q$Hx`Aw<6|e)eBm#b0f$hz`T|q!0?rG;}<>cuKa<(^j10o+# zc>~p}qmv`+SvoNXSYZ4!GHqLE@eW)FBuRG%psMu-vI#)sT>9+nfC8Y{&I?!|IRNhi z9%2sY)6LTfa_g+z{k2+ziXQs<;TdOg0WyLWQ2ByxfdRmVzZ=Nk2UBWx_H$E$R$1qc zMh$YbgE}jM1sndUyz<)#G?*$D6 zQ3&Mv-{z4YXaSvpfQ}ZZw(b5A4ODSd-+Rp8q5V+F59WTT%kMvefPy)bnyVWS3V*hs zu0Z=KCMI^tbT48nNCc`Dpc($@4`Lu|Ak6{2zLBE^V2T$k3H|BX%NJb`a&@<~1cQNL zgAov$pjFo8NdD8_e!3&*2YbJ^wBO}=`S&lZNkbz$G~l~C+d#~%&gw;A=m7!z+75_* zK==pD?mXyQ+j#*7c!mV($p5_1@8!jJ2!H>{xlS)z`0r}`W7GK8=I=jh_!kkJ*8rgJ z+C5VTG}`~m#V-^OXzpB8XY_#7XL#vf<9`<3FTuv$@f^_~@cg5PT#QeC&Pl9+1a)R6 z-+OK7cnGMm02etM!ki_n^YR5md#R}Vd#ry}rQe^U01Xg}&PDx8xdn1{w*Wd3plNmj zT;JT@6Piw;sSsLh0O)`T+mEpm(2@h=2WU%vUXyr$9qoYAfPngQP6kvzQ0qOv6wo3x z75`CA7ej@Aspa2D{$rI$V{LA4Zvm9IP=|sBf573s*HFJvf;tL~suUaO22fs{RV|i4 zT@PeWs3^{=00*!YbPNFk+|_1`1!U+VK8O#PSP{;WW8wEsffx_y1u6s`M@;KKV0vO{D@~jt9 zKN~tit@2#-fNh@5jIBTx-awt`=nm-qVy^3a7GD8Xodvlcjt6aY?17mR+uyqy6zyM- zY6Eo6rp3TW83fcuKoJ4eJh0k@djO3Vv}6FNn|~h)LyPR6vt%fMA5y&VwX+ejGr%a| zeiyT4pd9-S^`8Nrha6f!lz%j8C=dVWCeRb0ud}Ag3S{`*MZPx--%*^w`PE?mc0nk; z|H9(`Z}JLsv7exIE+RLr^?BU=1@S)uhSK@}A$~)b`Ev~a`%nIS{$D1vfTGUZg#Svc zzlq}4HGcgMdWYtR!2<>g1k<0RMN)NTc!Vo3Ffb@EQHVhXz#lMh&>z6-8gP8iKW`j5agek@=fY3{Ba4Y)gzMi@Mqk6N4>n=LHd2y(C9?0sa=9HrO59JM<{CL zl11$Hg-RQ4OEu6rj6FF`Fmrw;6WKdCk;HiLP*Cys3tPjTTC^Cxhm7GO<`3uEd64PS zD^_~C$gh$<;l0g-Vem91a?>g>|8sTi|z%3?2B##6?lu%2Z zqu^CZwV;3SIYq^WG-5!BftT6Hgn6n;DJTdm7@BCyiR)i?la5cJf|18l*Lne5JkI<; zreIrO?ukT^(d|GEwn8oQrjd*o!yE6cVZ4b&+3@RVd??;}@~*acbdJAz9QMs$fj(OVUG;&1;9~5fVJVZM>j;b&k1suSzp9;2GIr<8Hes*kV^Ut*A{P zEjb|6fRbV6xx&52?hQ4Q{2D=a_H()~kdBl~ABc_{l#|t(ki9c8HTK`9=^En~|v zvWAa3`Y^vRwlsiP#MpZK7zWHrkvTh!g+#P@Qom2upLmk^rQRQF>2Al-i_}>&7t$)^ zV;$xD^3mn5-M^-lX{@-`;dV_|(FPYY8GZ5TeA>NA$z!wb`Etz_Mf`(ofmLUG0s2?g z4D#3pL8KS7If$=8CA@^3rnc%~E+IaTD{l$7vUt`i7@5nm7kilBz9PHZggHI_d?xGg zChF(ro35?V^9uFo&4v(@5QjX&+%IeSNOrfUA_p{Re6NbgjSygLcGU%$SiJkNfHcfE zn3(VRVAbjqZwp4l49~6dowv5Dy7Gp`sPrHFyJE16MZlV`lG}N7M&Cu%->>*ukWM;8 zra_13C7nDLc%MNCLmLY@kbfxh1Gp``?d$IVr!wzef zvx#5@B*uI)Y;h5IZf3%fD-AwyYz3N@E33pM)d}T~4)2tKTh$ofdX})I*iIK~2xt1% zt=}>|**k=kA37G`xH+d$3vU~g7_c~P=1fbt{l0EB z@N<(PLpbj-W$Fus=@$j8S(p*V8Si+|)H68-Jq>o=Hn#bJTH7P%*U1N_9* z^QbStaHXBaFIZ=!>`KxU2ejKvXrk&gN|i_p=UV0O?+0*Hi1HhL6s&*xs_UqlQ$br; z{_Y^^tf=$VZ+5=l#>eKW1R-7cjXLe4as9zr{XO4(|22NtUAcOk}Iu8PoU|{N*VPH7^W8egP zutTdNP75v$D=QuWOHPi9SZNBxN}K?XJGYTld50YWDU?+wwPmjc@gbts=qDifx^M>) zGNxA07Skq=Vs1}+=2`Vs(bBsIvXU)|Oi*oJjq}_Sp6Tf5fYlU16FuNviuBQ9d5Fz? zJFtf#@yHi>;7X<%JNwYg(o~|XqC$%{B7H_W=MF#U--~5DI;(T377@Yg6H^Vy1 zRLdh+n)JyV?okxxdA*Xw{yup+*H$B{m`iTHK+<_E3m>yzuat*D%s-63;p=T*~o!M$j2y`-Luw&HwN$N?X5@L#gSQ{#ro#t zr_8K;OpC58;Ws`%n;g^TBO9`*lT+O|Y15cr#VO=`h46H=L`xeXL~?+vLc1*>4w>== zTmFY5Qpwi@!n`jcW8{d)$38N7KALB}FFr`EdfF1G*5KRm`oWzL1l%=ODcqQW`(?fi zX3qG`BiZ_q0_L!}2%m`sX_jp{e0VE*Z`5wYnl{SQ?4Im)$vXtU+D_?38_}c2`ZOxI zY^iAMfM9T>P#j%AEPsW9(%(iAG~H#B#rS?veP=a56Gs;5?Yu;4=i+TM?2Y$cvW=BY zT1d@zE!^9;?-xGp>+0`#6rG6nL^~%UE?HdOQzxhs5_C-@n{$oG24~!Tq0hecu>3mte!zhD~V9Uwyr@O>aR%Wcm3GgL>NQ_B<}rEMW;*sG;20@f$VV0`6gL zk4SdCpZ10O%lbK(Eo9%wd9j6~U63uM+W;3IB5gPJuw$I+on+JmZRkW@e>=y4mGj8$ z)@ObjF#AEg-(FWz(#sFC_=7N?)@a6xE%HfXr{hC}vvNLXeaXk6$Js+zvN%i);_oV- zzTq82@cCU9hSVc;s{;{C#bYC?J4A^Dj0kUJ@783|=q5ecn&>i|cIoAZH1KSPZR+QSpBoJO9UxW;T@wOmF5 zHi*5jaPNl5llP-)1XeFkGLn5E(hnKYcO~h-Vf1yvxW1?XOW#wqkf{mKI zYEzH%&h%5tqV^qK1BxbD>5cU{Y3)M+*j&yMvEOH+jq?NMcDYz+M z;$-)HZoYaL^XVGlNlt6gfk zxVLx}o<}SDX=eeLwK(?KBOhU|jS!^`9gn*CfVSyiYy!X6z1rUt9+XcW*High*bcbX ztChW4x2co8o*rn1!T!<9Is?zUAC|H6PO^6v)isT!>4+-gshTQ{(l^8Of_Ee2@={P+ zW?~3b6g=nX#B(2L>xhd!+o|kbRlTZb}CflH0 z5^We(j0ffBt>HJ{^eQAvSSS0gp;vOun$Q8Bx%a@XqS5CF*ElV`RXQNUBrVfl$QQ==fDI8*9u`;`7# zoSihb*j?wn+mu13Jj!oA)iB$d7e$Usx1(@{f;X|UVyQljyksDhP2%8SGV&3C5&6Q! zw4$$V{P|Ok2alc77%T1kBUwG7k7OBH^;e;zXw{CB_(WY-}IJDs4Z^f77=S zU|B1CLS)_aRqN44Y=CX8?{QbPabfDlCyptKQ|@ZxBh(>}bb6sF3is-1$J(g@kEXYd z{8Jm&P1E*usT&@Ddh;aHx+wtuXHIj52{JJ2wm>9+hk+R%0)R0lN0!Q zm91t@wlptJXDDVjo?#6SBfU=s4H^x;EZZYDo#$GJod$V%wJlNx@r1~jdI(R)4zTPR zTZ87{@j1v7Y4{MPv5FGponN?%C~~@-IPbGzd7Dw%xMp+sH`yxiAP=wW7=>Bt$EF93 zI6pBKOqn}zpq$IqRt;dZLL$-}`b^~xV}!T=Qj^ojnaswv0m6F+1PebEC~S1l?f{X# zf~D_;BEAEWFP<3*^&eS%^^WsKw?8&ZkHh1WIZ;}4i&R_XvHIdb$9Ebd6$UDfJqwDE>M)Da?LfPAu z=wYw35SX>zxw8g4Bb}+)HJ_6-m|R_RebvP?CFAM4oIy@}|ME0qIJB#o@HX4sa4o#e zALt&#m6fZEnao@bldyh5fj5ds8(KEX)Sp8`Q7PRfAWo*%Cc*KFZKwwy^O+Ru>e7`U z6b*_@la)q~L!Bd7Nr}_36patK2$tWvdbvyaxLLfF%GNPAw1-rwXy3y3MZ1rL$a8KA z*igO-pLjoE@icQ+_>LZ;AycjPJ6-~+eK!~Xvg>Z(EMwjGAH=~Mgo7C+E*>4C;`8en zuWG^eFDBY-?5{MdVbCe#D^rk-iP{fpeo1${8NsS%WBcm!_I*84dmdYoBWseT4pmFC zxLYHSKz5_?ZB&+I)G?UjhpZ%TRo1j4=pN-Q+NdYo@0H@0GvVK-n&*Mx`u zJ~|}YA*IXIXeMZvxO-NDd|!xmyP_naRHhd1t&)`_b>U>)mj0HL+O=Go{P586tb{%S z;x-JrZnsy#%c2V{AtG`O8drN(5U@IAI+j;BBPSR4gke?d90YgDqt%C%&;%|H4z z$D*NIJB3mycRcd5Sk!0L#d@8E)9fDitsM?uj-fU3<=SZ?9wx-IB>!?1CQ@gArPYZPJFeVm>!)y zi63&}D_=IB#eni@>vXrESv}FOAR)6=UE(#hy;tiB*ct}r4u)>0)^NZ-BaJE8G zQQ)pJ(0_D>;dz9S(QibOsa1v@#1HOA*GgkWw6mv^Ls}psj`7K6P|RscJtwn`(`}`HWP5&r_h-X(| z$k3!-*ViFe$eiL>r%9~BMLI`TkvH! z1SUW?(P3ctVUYfFwEk&5rsskC!iWGGup7FDx28C*_+u}MlaEMb=Z1QGG!GN8f1=-2 zmBbguDT06Hh!!`Qy>f|9a=&epp>{!esv_otIgaQ=%5M7RyIm65mwsmGA;dQr<8bqs zX|Lgxv56Vo{^-$|e&^tU%uCsJ`D^VQyB@7sjTBifiCGBI4~&A0v%kD!gkih)2~XP< ze^md?&;Uf!C#-d@kL$$%lfYgsM+#|*ybZC95D%u06{iii{usx=pJDhWpBv!jW9F4ekqq35DnLl`qKP_HuvsV6R{x zEz!wv(<(Xa%C}uuel0fliThcR6`*W5bxKrh!rlIa_}n`fT>Cn*{;Ju9xVuq#LpIrU zj|)w#??x4CE}3bB1lCPc&%TmKFH=Jnee>eEw0f8!JtKTg6n58x-fZzP?iKu)*F3nP z!8ujmjNfK*4;4xC8juj?bt^?Z7?QLLxWl}1>vc)`cG+WdQZKF#uWIa_o=V*fjL6fu zhoMfp&+bNG zb-hTkR_N`Mq$iD8UfEw+ox@Zb-x)76gIFM52cpf$Cy^R;-SoLW?QHmoVV z#9Qa9de*Z;aKqFA=Fb}AxH`~ajdG^Y2pBjfVZgxf{wJ%20FzcLV56Ti`;Wga*=+s| zWv2x`9I+d17ECXktBUYw3#IOgvQ2iu$u@~zi6tGz13$@DU{wU;Bb;oeQ$4;9u460? zX1&KfdwYkr<*+jb(btU7px`>|o|z6!Rxu*Kx^n$k@xA;p_oJ2Z2P_&H%EKZ{RqAxB z91CMS{OJ{{32hafkv9?%yGXI>YJS=;w3hGpTf&Su!aQMQ3YW5?!zB>wW z@A(jl?~67L)pk86F@%&-@gau2OL;nIrtA;XibpZ=rb=_JZb!uA=BEemP2w=T3%BrJ zYo$u3gl>>GGxgz|SiazRUXXhwT2Or8BumOU8&vC??GdjO8e1D=4yXC-?qcH7lvT}r z16}leXK60)#o-%R8LMp*f*5V@5sysubr~2r593wp)a)!CCLJTzwj}0?zMt3MB^G?Q zRA}8lnPw0Z6c#j2{v4${qL=3 zN>g8DVrnaO#fvjEY>rK3+cDPcQy|l;r&Z6xBr{h>BrC3F#0Q(!Fx5Ydi@^|e!?7bB zx|#9u0M7%lG?Lz0fSY;r=}%mm^en|ALXL#?9A#%Ba9S^W?cF#M#bD&2)~& zknl0B+iCUHhgiZ$xmP?#o)+t@!1hcwRO%B?*00VpIt0BMSXo#TXigk+=wJ!k84z42 zZZ4$r$+Qg=5roq`PE*r=jqi0Tw&j7uw%sZM9UZ$_Nfs@5UcfkdEE` zSoZD{Z=N}g$!S7as++OD{%KOFxXt?Pyq$^h!LzHg-&8E33h!B$OY5m}ehasHqcbZZ zd?H?eY#d4YWm7{d%@S_4N&zD1(Tbt0ss)KWDdBqedjbbMq{d}jO^cY@)SCHw z(fvb+=T}yP_3g$)4s&4}7Hyt-cy&K0(j&Oi+3!u)H6=V@t^d5_1FO8LR((?&LqJ>7 z=}t*AneP>$69PO7&%xRETwLVa-=10-bqM3*Uo%;;2nl^pB;i*blRWH6zcYo+MK${w zeSGDMm_Lz9z``?K>I&R2@?+$*fF0ba>iNU8dr<@(1}xiEZEbXg6&kx`piouPNKZQk zjD0EhoFp=IDRbod9EeL^&d0kdC_|Wu7IJ+o*^`;Vu10+BbHWOX@q|I#5z;FTNn-QI zsI7;OcR1jMO7FSwM}IRD0KLw{#HT3a-%LbzJlOq2@$FL3+B9L(FYU776$kFIK!8K# zUj!{v=D^T%lv%kB{QRLg-*C`k!}&pNSF{>vP8dv zd^VZ_3G?XM7K9N5Ba1p`Xoc5ln3=yG-65n@I~Z%$8D51NDI47;m>H>EbFJJ|AFl85|| z{n$r+@K9QKZI8c>rLpDfNTbNs3=*qoD_trdhq!FKaLq-M&(BbJs>o%_ioIGYSV&q9 z;&hXWJ?++XnBtB0>U{YP)wTwf}5|R^^L5TUV zhHw-^Z?5~Q&jVE1Rn>B8Y-?#4ZIJ3ti2`9amP}u(f<0XfaJI3%P@`Y`Mm@_o zl+KjRW*<#9@@ej2Y2%}mw>)7vY?Y=dddYg@ikT7SyqeF6BUq(&Cn=?-> zluv`qp`o)Wm@s?YZFG>j|FfAf6K7P%(5`;;bzm%Ti;zf^3YuPxHLvLjwW<%(8BgJVytIl?C!VV6 z828!j#t6&2iiD6vm~g}<^3Ng!0dSC{BjM;&z?VM*ha7PH_hmH+yAxGbay+y?D9wDm`v=OxLOHS~3D&5`Rb0PY3HVLm}XO$J3 zr&(y21$kX`V%u;YA>0%BAemxY6fcqjJD5A4i*dzlchKuhqv1whhq32V?oLEjbnR76 zVt23p%6?5;lUOFe_E+Fg`#)pLj1fZz@%BX zv-;_vGh{~^|7J+Iw_@66I~qZ^*9@N0p;U4rY6&?i9%GK*xThCMj|gb$!$T|+x z25mQd9J-&MuAi93C&TQt9=-Dv|5X-C2d(pbfDE8!@IS;#3t&?Tbno%cSovhQv_?ls zMM-ylzIa%tLPuSR6}GbDWnS7d44fvoXMN8H5UXOM179B7#}_4VD%5j5C4LTjDSklh zRBdwuEC2x01djh9e*6ONhngg`-N2@2oAgZ`%ptc-!4A%Dz^vmeO#(60 zx6N1l(!x*?3FN~|r~->>0f)}NPtAW_7`n~c6uQIVQjW&#>%hDN!ay8u(mI|a$I`M7 z>@mP=hp+Z_roA!j>9_f<#05*zfd!NPDLfAj-IFFCx$DHT!ikUCW$P_RPc@#u4M`x| zNMx&S7$&sP6Z_Q+Yo}PtHO^Rofie02ij7OEht?dJeFIQ_kcOL3g>QEVk{3*D<5$wE zW54{+kzgb_`=w>CI?OKUjlPiT8uD`-T7t10RMt)iNq9b*b_jCGw>Xu49pcBY**+J$ zH-_?EZ8p5b5+a}(lCMVNrvOVFz*=(u-Xs7efT7!UFV`V436+k)KpoZ0t?>QqA_0KC|j@#|3Yr^zOw{=)44X#8z=0omOb$l#>Cg2SNBdi1=Mmn zccu|#-0pmEYM}MoG()xi_z{j(6~XI+_s($rM{4_5-*Q_ByD@4Ei9kKZlt!Ho^M~GV z$W3(}-syd|uwsV4>5kq@_PSJ)H=il?p$}@?12k{NR@k4W1C?{0#3U60;2a`=oYnrl z>HI~`f3cMx5~rPcpNC-#$CZalg(qED?0es%Y2un5msm(#U|l(pSHUN+J&1}-wx+uFjP&hv+@ib4_~M7)Yb!2DYnbq! zq%4Xx5)SLU@Ir{X?DZ4TZli*Ol9 z<_V?noSMK2rH~?4%Bjtca3J?2i*7lxS{~uVs9HKbwNm!n4XsW`X?{pA5c@uaXvEpg zI`%$<$1d@j|89xs9f4*M@s0(hh%BBDTK8_fmRV>PdT`sl#w&M+AHq`Q#6fXO)_AO8 z@&njieav6$Q*!@UtR)LiRxcLOyg^=Ns;$|xCg%JI-a+;>-U=-xFcl$ZO8X}mxk_C4 z>y)xcof-14tcUHbTxOB(6~1ltb)%0=Zq2T{G4sU0k$dIfZG4huhuZN=sZYW0MrN+z z(fi7^k~-MdsB@JBO}Sd9W5r$f9SPnKc3(WzSi&4L575sx{VC`gBUXKjapYUVC@?Sq zz}`2Re_upj2%76c(r2~vQ#}W#DFM8bGE>fYqOH~mgDHp!`8&$tTVzJqzSG^;qFPL> z>T6`C-YMiLYq~Vco*s!xD|sXm-bMVBNEjgl3FF4j^v?EaIo(tnU4Nx)tW)KoF`E0N z^h#aLcucm^7~)3KRQ!~}BuW!iQ+Z0G%8C!oUd@{tuEyA9U3I*zIG_}#OiW)Ynj7e?}2K!0EVkhapJmFwml$ zw}7(co&~pA2qO_MLG%NQK+2ZnH+?zW5B3VCM1_`IJBC-M8u>d9M0+P&{YzjG}2g=O+8FA zjac0Z6gbMX)FVOhqe3fjY^BM%#W?R1X+Iueb`I|jV@_w~sz zoza;>@V7Js)EEL}ghMUA4Hq2~QY%Mb(gmU_JK#pDm0ITX39)nPb7XJ#R9s<*?c2LL zdrv~3?R1xt_Vpd_-m2QC7<{V~_}Y!>Ng2^`OR1!WdX#&E9G=?GnIffowN{@CE@8qi zJXp?pCvQN7MsaV`;Kt`WO1LxrNCv9oU9)+Q^CMQZYQ~B^Ocp8Idc!%6ADYd3V;%RC zkf*4Lwj27)>XQ2lSMFKeQcEf^wPm+uEa^wq=FQjYis$N7c$~(QL(VZcyk{mUd~XwqeYs`Xg>l>G#ijI`AD1 zgQnH#ss*f)UVf9FDj|t68LB#zPe)fxe%REgGN0?=xGI>@^WQM zqM_h`KJAo%)VEHjlW}4@bGWE2N&MNf0n+^4j{Ynf`k!64BhZCL@CtI{Uv?SbtrD0E00O@9~65YdGBvEun!VlP4AZEb2VQ(D|x{$<4rbH%8Lz2Zm) zn|zOaLkkQblv$ZibyTM*ZqaUW^d4A)jF?}nEew4ga$^K)6*e@Ww z=^`^}TVes9*3^NR|MJ(v}!S89G`1^>Aoq* zFZ^mt`Ev&8NEp#75pds$Wsg(OO1yTld!DZRNeLs8zQ^wtVuq{bV*K@2kjGEqW(~1> zqF&jK9ynJi6jpazaeXo(VZRpT#%Y|k|9tIfgx6bvc-bqS{b3$+`hzD`qn(}~*=@Vy zjPOdT-rXxxS1jr#@GEiI<=ubibh6%XtLy2qbH;29Nwq9WdMnC+D+y1Iu3sE}ryPS@ zJLc2-y$_LQ(iR!E?qDx0!dO3wE?l^W)%Tu(BnG=Gy+3y`;@FXERi<})7sT%^nnu2u zg3=@1{~)WFh0U*rCMLT`SJi_bT+uQEq9J9%M0u3yMs=x!o%d z2e+L_KQrAF8~Dl@lDhd?FhOgm1{(A_%&Z-!C;xBhWRqw z6@Nv?CU;yl-!`<^&71^N$TWNEG1L)f%4VwhsDRs1r)#Omb~$dDBO`qvEcf2~#g9I2 z9to;!a=8IlW9K^FF}%dAWRS5wTte)7d0Mlc(Yrv@6W$Uh>5tMX)tr8JMv zIXlI|hJYIBc!R%wbQdK7*@y7CasDE+_Y*DZS{Ywl8E#Wlt1mZNH)fr{&zI{{UF>g= zPefOk-HY9taaI-~QCHf*8Y7FWBzUyu#V$B{VCOL0-D`e*Z5%=J(L&GzEL)+hd)^N+ z#L{CCZ|QB9i}X;hg{BgntWO~`xa6*GuG)Xf2In#l(CJp_Y2~T#G^T-PKww~rXIN**)Gql^6lLual*^?33cWmDxY3oow zoa|jf)HP2J|K@Mq0Yod!D&%jckjiaV5Bltdl!r3dPOG*Iv-?%uAY!7zf@(H)N$Ysv zb!6+tiC&F8++f_7uS5hsB%Y$-d-d3QmVr`m>1QUA?UK5zWu_flbE6x&uiQZz4vSrcj4 zt?$|ehb0+g9nX}eOy)c1Zh^sspQVcsIzaHPb}1b#UkXE}P~efUWDN^x-{R+n=HK5u zCe(WQk_~xsSTNHv@4auW)v_Ro0+Jmy9mn&4pLH3OXSB+jV~GI2qrh<;IR51j?H8VZ zbRDcOMbUsN7;#Q?P8fv?30?U_QN-(`po#&x0g9rc=a`cs={}?2&Hmq!4{NJG|>XA`R3HtmR0jN9ALF&5@X#2GC&yK+S7Dyfu<8^M;C;1`F;Md4Qq$#t$)Z1x zzw9pzFs%z5691lgTXTrj+3Zkj4w$}Z-hs>Cj(&#cONVHPnE(7(Gc@T~eKg5S`S|xidqeSCMnr=oA-B?^YMx@oQvc|pFR1DH% z7&|M;G)>Y)Il+9G0oWsz$={N8cmxdl&{hqtq#m>02vo~@8~db;rqIe$WY8r3@k=<4 zR-bkb-$we+%z{}RK_m<5=_RpyCP-Wm?VNN2-6pI^u0lSzGaGC5%<4%A z(c5TyQE4PH;AHHKCzc@SE?rs3Yhl&2to(G>lTj?6JYn+qYl;%jw*u1r{&u^orx^XK zCM4tm`HDX3%e{@dGw4cQ5UKm4D`AqkVS+G+#Z>!Dt2X}Q8+unC;0cF4_o8nw>CnJ{ z;NvS=x_mI1bx{zvy4u0bOMs^$RD(g|y-1D3Eq)sA*KSovD1FMR+m5AL6M>SbCRtVO z9K+};5W#~HQ8D@Too6Ik!jM_1p3e*yWt>E`XL+ZlIOfNjwzo7^GuMV+o9Aqtu9;?{B~9Qs4K6!XB9A^4xE5o>DEPx!*dpBOLUCPbiIZ zQbEu$$-!pU-ppYm>KNt95>l=%~DCp>^(61Py`<-W$wtKqE9u7jrWK) zBUJ-`rdPJ{| z8_P2VbT6ylMf)Kpep=l*{EGf6YxUCyxleR+#zK(B=o7eK!&jP7GeQ^ODA|CcX#D%O z@;68M5yCF!tM1yBj==t`Y52vfWutSlE(x{Dfk<*;7>JryMZ#Aepf*3OH2jQEkq&`0mA$Y$Rj54X5V>yVnHldjxnVyb4~mMl1bl6_Ybpvwel-vHwRa zby`a^rPMSmNfIU-@;DQ~{PUQEZffo9fhaN|X^;#g8)bdCRz$q?*L^xY>REA%e$^|*bRB~@aMrQ2cRx2#c zTCKMnn2n9|PAv&m)6z5+6J#W*k)?V}(M@1``Wda2V+OPWDtDXeh_B))j0!Zh7QhXN zKOybl;`lVZDJeM39K1fnqlk_AO;4xaR}wupdYEaf(fUJ?MeJPLW7H0%!-oM+JW66q zq9~-3TJITgEVC3eC@YNU88sI2D~))*l|NxoM-5TDn-Y;1u99a@xO%m(j(B_2;-u{v z(r$JXUxIXGpP~n0HZHexyaIQE!V~+U(!vrPUd%Ul!GrCDa zRylg*&k!O!EnLvXJamQ(Ysg}Rx?fNBcz=BM2s0J=+o)ZxE_+EGZX3?Q0V>%-c0Nh! zc5=#y0eCJ{NuHdF!&Z`B`?Tij2T0zmlc(spXBG!BI=Z`(&Df z`gQqNtu^At@ofE$yX`H~dx^Va$L_AY?iNeNC>qioIG9NHz&F$q^3_IaShsf?AUBqL z#m9nojahl|P_i@knKaK$i}V!4B=!~@lY2Xk91?nOMz>A_CUai7RfruAL@)M%>>sLL zeH|P4{z-z>y2L#9$a(?hsNqB=_dGKfhBLhi$=yfwTz8gX%MSL8?udGMFiEVHOFO1w zcdvKtioDCGXXi9pSw61f<8!bMBj^4~SJRjsH?^)N6I{T4<3?4&+`bSO+~w2<&HH?$ zBqmuv%2NRbUsC@*!vGI^|EzQXQtq)$(2OtZ84%i@%Q>;l-Ibqdp_EFMl&2i#@9%(E z#WM!EDv!cCg;k#7U;~GZnZ?0_$H274MipUgg{LLNG%7!IWcl%p3GonBK|(>s$A`_q zPNLy^9C!x(vS?wVQM&Z>;Pz+aQszXE>y=5`)0LFwC)o%`QN>x&3yy&#)|7)nbjFCc zeA*n9#Al~Ul1%QGx=Y+2-}N~~X}P_C{%iDz!3unw4+y~uK(74nqsJv7{1!JZpZS!1;Lmb~Ufk#emDMm}Q9SNTv_at?L9>zTeS6PT&51+BA5lbe9 z#CB6&gw}wY{So&2Ix`dzDjSPu54{*~QBRz(H_0vAbx3{=^VmQlW#_=kklMz2?v1rA5|aTI zc~Hqd5$95j;o*Zqq~H-PrZT<cH$2|n-VtKo zNz6uG53+bfL>J|I; zzU(KMsu(t(6bJqA$6tKSrQgdLyElEB_!@a2ccM{4`&=VU{niz9oW#RBIVSB1-H&f7 zSekg2yM(BTMAJ+J+;x=?+v{Og{0Q-Se}APUlP9)RmQ;adWcsEM6~0;XrEUfZh-y~~ zwaP$%HBke{^?!dC#R2*~GN#aHA%L&B1HKU9`wd~B(16t%R9sL3?g?wo&ugl(!9f!3 zlM^M=(s)9j?LK=c!gk5bp@2yD8yM*UFm%8H?K1wgng0pUk6`mFrhdhRC8a7I;GQ+K z8yQs8QczKQ`SKSJM1wh1pcHl41GaC%0Nd7qJA41(Ig!8LKH=zO>In8ce{SUL?#Efb z%dE)CR;i=Js;GO}@u3p=+`dAI11yOJ9E$%w@wnPSZ@8GcyIBidzNg5{s#sm2(^&DP zGbPGF>GGB;=-QNxTy?m>y4b*>`R~o+_qBg$;$k1zFDQQ5*#(6WHDUbb5dfhVIR1y& zcmCy>-_tK^EGK#=$CZ%1lSmp0A^qZ1X%|iPXWfb@3gOsf_S+TSlHc~O<-d0EeAg@c z&EyB^jK zXi?9Kiw6Z>%xK{_-??`!NE|j7J?TY$PH+0X5|dr#u8yPW=mSEcxA!m(ux+FB)TOU2 z^x(0q7av~Q@D63ZNL^$-9bkMAI8^@!9h`l0=nv+9Zl{9!=(#L#LieOjyZ$1KqPv)U zg7$1hr!yfQLalpVSBb3Fk~F}$RtCAjLT|8;B1!`IhSz#r}&b3lVGU)1bmtrn5AX1XGz-K7{T5_Pgkp1_8 z?Ynz%U#?@o!=lhR9^za}VFmD%@3*Tyu~_Y9c-lFdITp(&tbCebvA3~BEyIKhufrbL2C@zd z(l zhFX7W49b6#dIAzOyf6U#LpRm@%bfEo|35Sa9=?v%3Bmy+5aIb?7oqlqUF0sh8K=4h z8FSvt-4isG+z91Xq8SdHLPE!3hDSsyl=f14yD9~59mBQma}TMuSZw#G3TV&TActa; z2g7of)MsGld!iE3V+`(zN8-!wU*r0y$5u2K5i|T)vvRP+hj1Y7u)JY$R}2I{S zfk&*!-4|fo(wo-|A#zt5odTV ztN@UyGLZeX!!?+I6c?eP$uM|>q3;IpP|)?4y7QNl9TWuZFer=?002CS38>;<=h*M6 zI0x}V6&JIKf55YJ8IUmZw%$w37x<9?7<_;a?f*Uc@|r@oTtUD2*25h5y72QV{5%Ib zL~}y-QOfS6%`?B0h2x`j?3kcqbz}@7POQmKqm-A#fMu^e+4E&49}0;rUGjDomD;U> zi>BvM&MUSw&4=G5zT2k9@iqGr@HC3=T`J6zLn$G~~szf`BQ z7WK73vQ=r4RNpvWcE!raw_vrC_=7Kgk!}4Whu80&T-pT=Rf*)F;@Dk40vLbCZDDBnEj_p z(3?$f%_AS`D|b^{_V3zs`}g2qdqdT0i!G2}An3^&x`B7&vAyr59T!kW^WI>fL+@s= z0*w9-weT;DUNSvso;8kb!0MF1kU3H~xSPQEPT#)1jV@<`SqBA?=UBAKLjpZ{d0>B1 z#P0z&VZaOQclQs*JaY{`O?q+&Y9G+O)&V_c?;; zff)axlx^d?H^V4{yy^2uhtq0`3usqXuik6v$G=u4=37oc9z?=fCZ|+lBdGl0OV6bq z7RvkM;MoyrfOqI-y#HZ8=mqcJcbfo$j8YxdQj28N7}rvYWz>jVDz4Be)}D`)Bh*ok z)KMRN!LF#o(5Ilo!KS3apn84i`T(=Wa~55NJ{4tURydb-gP5ehB&&A~#2=tFpf+&) z5BFbwLHa{We?@x%cL~6I4Zqg?Z-8JNl) zd~=e*wJ$X51TVLCx1&1)rmTt5&3VW5LOs9C+n4&Y^&jL}Yqt19Ce_e*|ZFtJ8 zcJ8bBgPwhgB35PQDE4jC4Sqx0R2zNx>|p}Uz7+YW#Vy%K8PoqyZD#>hW%jjkI;B&( zr5i~J3F+F$t5K#;g}DiRXXNQ=@f9U>ql-AE%K-*v_rE;0X^ar|K2wFH*uxA%MA zd){-;+0Sz}@b&-@8-%Nw`&khk!m_x&6iu`kp_6jbw;)9T8aG!7&(96Z>Dv1Z6!(JeyT$y7rYLoRKP zG*Nip@36|G23WU<%}$xJFBp44YTU(8%eD@u5)FyrSA9$>5lwZ1NlbAEu*K^q;e0R4 zGw+Lig;E2Gb^59pL;+Fkm|!}R=2~n+0FLuRQk3)=jP&q{xCJq;5W3N0qvGuh1v_`q zMCW8G(*muJOrIH`4ZszeEj3idEW-$PszdIt@=Aj}TTi9EHDoE?z=sEQ;+(8cspq4~ z@yL?7hC1065BK$yqeUNT=)x45?Hzy2ZafocRtnXb{>Y*Qwt^seuJE!?0R^|B3TI*7 zjXze7NQ$xwkINW`Cd*LikRvqGr)C-XQg6K&Q&}@cp^&jg;rtb|VQqomw4%Ds^sYkh zHxA?2(Z}UzJU;knU=pL5$V-+(G_Qy|MmrOnJMMS35Mc=Suswjzg4J|{ ziE{HXEJ^fHFN>?I;<-I{Pv3B|nw%9~KW$HN~=ext1EhHVyWE zVSqLv(Zu^#9a0pJ14~QO<7fNph~#W72u^!D&WKHSJMJ7!CQH6)E>&ow7w#a-fkY}X z69wCA4G@5ggu~%_l1#K0RygQ$|CFhvgeG;(bDM$ngZndGk>=PD=05doN~1-V&~?d| z6^X$Gqn@gtS?XIi;TW0ZhMC->p&rB!46`D3r{|QYzHP8ecEFf#d}74&P-|MgKaO>T zTqPZgAL@RGqwc!~aCGd~t<$X;4A}dVpO+lIXw@9CX+3$24Zw#4)F?g@TatCKT^*lddG>sizPh1ZlSkU))BS-HROGSp%;)W+C9?I_vK-xE1~I z(BO62>;2$QGf2iTyHx%eMi4w>lMQ+F59?r#E-adjluN-svLVv)qKCextOo?B z7$^H|yDO9j-yc8cK105keB!csU9$Bv{JVMI_vK5+8;tnK85!xm7q0_nf4`gcUH<8} z5tPxyz}XGB_+t5EE(q!jhyon0qZjDXzCTv%fiH%C7Kp{4%c(!wR8mv~D%uu57u+pZ zp%rJK?d?+B{pAbwbmZ%fcN zeYL7Hy_i_=NLgUmbCk`nP0PgF-6t@I>OE&(2!6nh-|N@SgPwY&YJTS*wQR8C?-H(5 zf2*w>)hbgu2!RbW<=2=>>&}nR(Zbb(YZ6OX>>Y|ar}E6jo59{iV`)&kbC+Apfx@!8 zPCv)}TcX(>p3TS+{KcEsDB|*)SNES?@gH`bdcT`9{MqF{eoc47pZ|R0g7&vPx}Rnw z^Zl0uz#G8{2@H(=Z|T4lSD;NOlhI{Mk&T3DpbrFU`!wV+F*1|fV?L*em~>lsE%k)g zt@2`O{)W#n&@^1EYGjzdO}jo_IC?OMg1Sw$Od7L(DK29T3DA+ngwVbO<~mss>4N20is|v+$eUCkYyFi-s_|b3fa}NB7DWs zdd2cy%trQS}{O9&W`tK?B%^bZn<f2 z4Tx>r{+jw^MhU4=VZS-1pAJ>h0K!AJF933#QBd303_MCn0n-+&m4<@9J{T&*EpUvUIGbou$Y@&x#FU)3cVwJckjUv| zBE6CDrD(_qM)HeaPK1-8p@?hY*xTZLNv(nNKEbGJto-1yaa1#DE4Qgr&~{X|B%L^v zUITknnklA}gB<-ZHCeQ3!y=%-pt$+_1I5yN4UCT$O#e z{5^>-Y)tQ;s8+)`sjZQb!3e$J!cbmd&ZFXLy!{$8VzT>A42ACSBGahg7JpM=7Zulv z1BDpGwp0qD_rhF+drgGa;X`KTQg~~thygW6s5|D8_FkJpfJu`2IT!zdSI5I4yUUu% zx`4r3_76?8My<3t#>X(@+i;hK2U3d1V3Lf;K1633+>TX2Bnz^`VsD!ltjX};c{=7K zX*@C1Mrc{PX7k*#_|pg~s=XwXp?*!}sEmCmet~5*%ZrSS#hugLvHce%Z*jekJzZF! z_M$45Mk#pxNP$5iZ^3W1qTWbh90;Cj$n+0*e6WzB&Be2m zyCQp)-sM*7BbkV3QHFe0Sbaj@sQOh98i8^?2(^t>HWyvM{3ZO?20}6JK*`tDGL$2M zU!}9D#{)7Hvd73HRaB*pox*gzWo+Rq zhAxuKvK^x8EiYU~I^Zh~<>_l?*o1s0ljFaQ1J;*TNT4e`Ti4M1K-k^^Y#IfzE^jEq zPKCG*8Nk8SYj1ojYSHeMDjdB>vb=H$ahsJ5e#p|0KDb*JPZNx+Nh7$OEo}9ML=kdU z(V64!NbPc3F)tM4^fM@yexh>lG6t`dkc@~>VGN4akmRJ~KFPk1ao%E3yq%Wi)KlsU zQc%j7>3B%87`&a52w3>F5NKo)Ay^dNe5m>{l$P-SC4$-T&`IST!i6^Rj58XtHOXg_pN*El4mK0TN-(XX@(^_JNdsvEY+FCU$>oXF|d zX2qP}6+Ps^`w3z-hU9# zLY>Dk?~`$O_|0f`X}?~tB~}U3wL(DuNDrilm9NxK6XyIY_bhPJHJJP#)NA}0x|#l% zk^C_I1D-!;V0CFcPqzMT2BF6kxn*Y**p$YUT!*;c`VoRos&>F6b^s>xqa=>i&@P&Ga93*f16qwN=!+%g;q zz+Wgrcf$hBUSyk^Z)d-Nv5O8{v!Z_M?&7opw{pbC$>$hJl2&IbGrNBF>K>Wfwwgze zQt?|U?&mdP*+jGa+$&CEiqZtTNV3esB-4R+B%*mzDc+^NXB81LQZ$RA5Z6SIn1WF% zv^wZ=!JxO*Cx;8??SE0qO{?l+f8IKL*j?zPNJ+1?y@+0fkOlB{5OsxLDjf*!Qhd9= zPY*+nU8y}@pa*5Q=pgBdsacJxi+(~xS2&yQNm`nIzMtpnesa4>PVeMwGlyxC7&U0o z3tM!XsHpDnYr?zt-iM3AC{1gdI$Jw$5IqCh6ant99OB4{>V|dCf7ifOU(x6fdTXo=xL*INGw?O&>t0of`)q82WBDo@} zMOICfy8EwLcHy@^-eudAtZLmr%pDCWwR}fJujY4@9o=H8;TbOkw`D^b(2;?)Xf7>V z=T*HjQTtR@W2$nFJ|FFYIa!6yZf{w+O6h*e$^(+rc6N+9^U6tIvl1bFlo^Z97N2z) z?Q`1i7rkR}*nr}3#$B~ow^-L@c6l(jX{fcy*!8LLHb2Uym^Ew@z9Cr-pf@3v=X+csoK^ zM`Np%l}{_ipi17Ho3II6YV@hz6DDvA$~~fV2XK>%WQQqj-r0~*?BvW)GlB*!(m{~PtPAfke{cLwG6j3 zwSvvfI6bT&tm;ui+_ThQ)fU7jCg!#69di8q1|Fe49UR85K1W1fo>WCW@9f>#y&y4l zD(V*BEwn(JQFhEbug~uFw|D!8p)w5%QZZ`;xP9&f$w3de$n|M3JWTu)3PyuH-##ecCUqn`G$i z>g=ZsAIdgM7_F4XU+W;-VJe0tB9~j?x%D1~t7vl9$E!Otq}tl7me(LqCH; zUjl80A6*uhXkH!?g-qKDO#;t?_69NAEg*@(s-i3-S%;|Ga}%%Ie<6uqv^nrSXW&D* zH+Rn3qjWXrU-jGga~2nYze7EFyku(Jl-S!6<<%eCj{H?3wIbZNJVKJB`3#IKHMw=V z$s4*Loo$$yELcQP`GG&dPOMn}D7;Q5asefh$EJ&KEmkTtO>}dEH}B`BDQfG!)eal} zEun&#XU7MRbI_Ye(W!^WY$;)EMlqI|P&OtJN`T5Z_s%MY<6_+%YpJO(K+8mjbB#LZ zP64;hX$P+Z$>ha*Yz*Is3>w6x@3$!HOEyYCbJL*6Jjskk!xSsZEl`f5iv@7H68SRt zEE?4$cw$5|VV(_J)-5m#Y(G8e9`BB_p5UZ2S0GJaADppwca-9uj5~atMosqAE{GZv zG13=Po!I^OzGYJBr=74KV_OG6sH(Iq+1Uv^^# zLz?AyXuR_$)x_Zzg*<5I^7GhH%2*4gSyg*4rV}ZYe zySs|gLM~m(*e5A~Ha&epe6h$RTjH&0=P=@S3|!I^0*<;||MG)3=rYrf&)?5uCoF(I z%|Tm-G(jzql{5Ekp=+o`KWi-Om(Hr`N z(xSWP=P9g9mb}a{i&@oJ`=vjc;G&C7&#YT5!^=e5NihuE!w#`54b0Zna*W$t>yU|& zs-?L#%NnT~D8KKe#rQbnQC84I zYbK_7Q6#yQiKh(`GdeQv@Wci#{T3~`O?6}Ko9(-wkm*wh6YbV_N$$J$+oZ)XnuQ^` zAx0z`@fe!kR_rVDKO8bXNf}FralsN^Xz@+?p!Gu9+h;vnoSgri)fiJlW77mp1tF0P zQZBpn@3vk8N~|78+0U94$tLLyk;;;zyFKF9F|a*+{$yR&=1 zqE4#6ysLgp{(nDQ2zbQak9(+4b;4#s4ApB%O}YodJT5w7D8np{gtHdFO2<1P3h7H_t4cAG={<$^7tMUWH*PbwIFz$@tfq(l zZS$*#+qd;&IZ`UysRqJFPr(^qW-L{;p~^MZfV+6`9lW8<^6<^yqdkja>-?OJnQEri zfMcA_yG4dmlu+RSGHbQ)y zcCA??lgW25ur)9Vlix|;%SGu8zKBtRDTr+>SNiB2tt|Fp7QXfcz{DBMQ?DbkP63WX)SmYh4yi89h!{)0 z^?zOiVSr;ZjkTWe^reJJ?+AC+OINVrFE5dUe9VLw&NMkKeR(q4*k$y#$_fCet2y;d zX2X^0uq>f~y#&wT*P)0Mbmi=!T7oOq2eLw?k{kjJ^XzSqU|EhIRM{-ceb<1c_NEPr# z`=2TNxpR6^LUb*U>jtl&2&>!w9s%l~de!a~G`Z_ut)OIly#Gf2qr~tk@vt#YPy##BSDGtzleBave!KzLD3N;KcDPhIznE}{IU}yC?1ydm*Fq_LS7Bw zvWp{V2)+MbA>7y-zgd!8vR?#^B^|h9`;+%Q@c9X9#t54Kcjjd)LQp0=#jj%CnDBK& zK2W$X3hg3S6Q3ufX36he3(I_30&>8Bk(4(@zsG8L(U>UNw2SVEQrt z8sd%pd6UJ;1=^eCr_p~Ju7DKYTlQ{$e_%fpJ!f|2Vccr)**vpZ3KQg)$7Tj#6|46F>8pHR?cU7fw5d|6W*pq*7`TkO~0!q3`opC{m1)d)A4@iHMKK_JO12mSK zv>F$&pez4fEH^7RKnd6D^Do*51M>yi3H|SEFPCXuTQR?0I||you=c-e{*U9MFDgkv zQ@LJa2FiM(|1&I*iZf8u_2LRp)UoluM1kBTpp@&I?VuDnv%jKT+GGN5y~|5M!+igr Q_kiCPz=ivlR^Na6KT%u?`2YX_ literal 0 HcmV?d00001 diff --git a/src/bootsupport/modules/textblock-0.1.1.tm b/src/bootsupport/modules/textblock-0.1.1.tm deleted file mode 100644 index d7a828a4..00000000 --- a/src/bootsupport/modules/textblock-0.1.1.tm +++ /dev/null @@ -1,7408 +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.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/bootsupport/modules/textblock-0.1.2.tm b/src/bootsupport/modules/textblock-0.1.2.tm deleted file mode 100644 index a3d5b967..00000000 --- a/src/bootsupport/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/bootsupport/modules/tomlish-1.1.2.tm b/src/bootsupport/modules/tomlish-1.1.2.tm index 9270ca9c..c7da645b 100644 --- a/src/bootsupport/modules/tomlish-1.1.2.tm +++ b/src/bootsupport/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/bootsupport/modules/tomlish-1.1.1.tm b/src/bootsupport/modules/tomlish-1.1.3.tm similarity index 75% rename from src/bootsupport/modules/tomlish-1.1.1.tm rename to src/bootsupport/modules/tomlish-1.1.3.tm index 0c8d0b1a..3da39427 100644 --- a/src/bootsupport/modules/tomlish-1.1.1.tm +++ b/src/bootsupport/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/bootsupport/modules/zipper-0.11.tm b/src/bootsupport/modules/zipper-0.11.tm deleted file mode 100644 index 2f72c19e1ff3e27507484b1e6fa13f6ddc982b17..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 9248 zcmcgxd0b5U`yW)6(&b9l>Z78L$xC0$8$RhCw#nKLytTXW8|O6a;o_9aA!L?Zi= zt}V-z^(%?Q6-v26x|X=*`+UyK)J#p?`@662>o@+G>738!`8><}d7k&@(FLh|%wqWx z#N!J{6vd}QkvB(x1Y&|qN|8iLN=OlxgeL`+e9yoMrpB)A4vNf5-0mhw3? z_>FS3GF3Y?UhOYzgtH9h*1=YID`o7!|6*%BvP?N%7?5G#HfkKV1;)aImRfGL!&q+~zuxA6{8SEaO-Xzr#tp7<=1wil z#jo)PFL6TV&TTGmM&=+!;}XrLDi4m+{F*10k_6P2XwVGB;l-Bb(N?WGPGz~X1`Nmz zQTUgsPKxBlLN&rsxdVR-02a^_kwNlG97K^J zLQ(|9$q!dLQ3#YsfjFu$?VC~vojDNDgcc)lR?qKMTe9EE5I@4A}qc| z%&^h;6AXC~uJLV4+_Ze6<~DORJ6cTx94MYlAW%>eleR?d%=yBNJB02mrS$0*P&1Q;sx;}OF~jARcRXN%N@ zD0a%5G$Ty25UyBcL1SDY3l%P60j!)9AsSdAE|pChQ9vLmF;FU{?g+poAPI^_A;8j+ z5K|)f=8^&;hC;x?qxd4OIEq3N0YO9M1KJJjRU{U%nRY^e309gl^A5$#9X3LflnH^= z#y~d#A#(5A*gycVZgK((%>kZ6h7b@>I!Y`JXXvgvTg0x%pT^8!`~n?;3(OaVlc2C) zOMtXqOigWUBy^ifNl3_$LxtcQh1Hsnny@KGLWy z#0J=C1}N{CEmdm_NuzO%;fnuTC9pD#*C-lFVbc|qg6pS)gM$im6}1)F z;jqAExG5hT5D(fMT=e}#!2m^tNw%8ys%}yUqGTKnNy4PTA8He3S*n%132#m5h#JjP zztSrGs`{;F+C*I0alw~KLZk$j;fpZwkV0Pbq547j2iVDrK93&_0Aw`5iQM)5M^``ZYsxj@bVkTSYVIB>Q9mxn6?50R6*ijfDc&rjvgfVQ2d zR%~P|F+S0Qz+>#8}F@tUiE z8Pp=VtJUZhqGZ8v6M;*!7*d}QMB#RdTOlSJpdF0YpuTfLakGUhIgB6hm0ZqAB1sV+ zmO(*n8j=C~!RVE5g(%`ytkF-3p~An6ato1dvP3f;ArJ%uy~PQIi$5fsl0&tSgcHSV znzJ>U1@wYpEgazW&^@s$7#1KTxp)kLz;6^{!|)M$9lVp{1egqPYRn8M&4Fl{W*7l@ zu+ms8+e{$5Us-vZ@$*Kb{$aUi2nrQ~Oq)=OXRVE58mR%eO>UhMpYW}OG4xA_xjeft zQ6M6r@-o9g`Ea(`luucQl;4UAyb#oYoHcdh0kM(~b>$*eXSswFz}P6Bt?)WCbi}BX zyB@H~42-!bI0ks4NCvT240R<;eT7glMXoXN@I^-eGbiiTQw?j|OjB==!;Feyo{WGS z0g1qohtm}40T(Sy89+LroCsr*-84wX3N(6Ak!#HSSOSJZ`Y8s>K*yA-wymJN*?M> z%Yen|)QL5H+Kf5vyoT=a?#N=D=)q!{vREu-|6xQ(*~6@d562f9n6EIup&uTY9Zo$O zV_5$tC?dS@1IKjMjMvHQO6u0qncGCXk&mYD%Z^3gul4lWJ!QdKBcE@-z6@MoYIWuD zn`2up89F_6(7zR5w{(6(nVE-2mesA1e=Hjj851Enx)uY2cu z>*?!{IDW@){HUr8Q}#!tcDR^X^Cn_*ua#4ITYuVDm+dw%>6U+uR{ZAd{;y4li2W$Z zafnav(F-FAcb^&a)6A$@0mj##-Pd&-;pO|so}NAIZ|Zvd(SFFoWbcnJD*n1$e#hCq z;JUNRy2CFjN)q#RZSu~$bE3a3F6;60MW>dg?k<_SPMCOdUgU?0u9n?LZ|XO*Jj-=jewRF> zx94;g@{c|~VC>O-lh?>0Wqy~mWQz*~SzE7-+=5njn{L1D^6B1Hy&{)<%Q1Yh;`vi7;Z zrO)fEgDWTPJ?wZzw|e~4qU0|^%e0M$em-mO+`j$0>Q0+{^*417>$=Xm=;4iG(ZuXOlTXW9sdG}{gb?ui=R$uZumub7dj!n4v#C`Kv zr+4f=Kj|OVn{{%+{3Bbry^DHrOOrBOI=B{32zwOCF&J|7&y3sqHhcPCvRQKc=CSe( z2g@gwo=Ra?-3wdjqNg?B%eEeCNBo#>Hv7+v)b5ENYibQn*M*;dV=&YBbM50#K^4m? zUkMIIe0So9^RMTR_oeDDfAeHf;pXgg{m)Z&RrYU}ewPY5U9p$4jLX!1mN8kfF2Z+8 z$@-HGgHLnIy`q2a+hJlx?7;F7qYqC%ZFy)J!pHQ`XXN6WdJ*W5j zS)1~0ew`UNGd0Nf@$mlluVj?=J=b}3^72uRk)y{L+?Vbv&Oc|K@aU7yb~G~py4Pq}jEstJGO zjsac2{?_v^j(b$s+3%9fi|XDbMJBD8sI|s$bPw(MZi`BK93uW>8Z#_!kD&v{EpW+) z1~>j)7i-bmEayz^FN0ztpPd?omaHD-xWb^}JKJwj@o#gD?Qf^)cS~^nEw;GsTzqzy zl(U~EEHtrsYhAUmD&k?nwLf=w-MKDZw`teHvTHiSuMv-uPuLdhuBi%+I-NglL7ZF4 zw{E=p2*2ZV51;fdzcFoB1RBF7`8X zJXhs;tXgrYM8x@2&9eHI(sRbc_%2C(En>HR4tLzb*SdBJJ@gv5+5Y$>lroEb#P8y( zM9#fc&N<0}#m~-ty?y4>C8IUZ{>nd=n;Tco|B#hXRA76%8?UnS^D612oD<*ct$AuR z|48wF(lY9GM(mvR=hDSzI_Aw-?lI=(aJ}^9m)_M5qe^lQ9~)nGq1MUwWByQ!K<9Cj zyOFCU-j1A$?zN+PlDzs#FKzd%f}v@<$e-pf3$T0<+OHR{D%Wst@QGK;8?q!eyJKn+ zEGoAZPCl~POGoQnYR0&Ci6w^|^DYIre;52RCdqtk;bzz2leb5=FV9lp%>yKUQ7Kc2Dy>(yo>d;d* z=Z)p3{GnxubJ9)f(|DtPaN%gBRvqFj*f*j|r}vfgd+$xAyB;02{oSU^0i1#zaj)m! ztQkF}a-N;>+v7e`qa)X5*Y)%me<0=Mx~bDrgWg!5tugbW0>esH9KQ8j+ihFdgb>>U z4n^A4zx1Cy^4Yl|zs>9KANX18i*}D;S7$%&du*U>WW8vyPPYX8RVVkEvJB z56+Q!KMWlB`-Fie;cH98i5=c|v;4s!J8FOtQOO?33l<-LR961EVn$|3^(|B0H&#O!>bnP8I)z} zR{W7*&0!h8W1U=n=FGr(wZ`_@TfF-pbP4G=`ohOe?2!g}5&N!dZ??Mp`&CiOp(O8X zI(<5a_E|A})%uZ!NJsZ!?yrw`P8qi%sdzxgtOHX=k7aqKbXfF&9upfFHg-Yb-sApv zUpQO*ylRC>P<-^K>=Spl7cJh;?)i(eS@&`JU6Y1h@$FRSdv6LSX8zBi<7F#-M15uk zN)K9_53=dA*uY}j^ZvOn_6@Lj;H72Man*|IiAE#sPOmOC?mg*lZS8UX#E2VqRbie< zK|{4~`c==oxTk`B!~fL%vo2|2(cD><#oozv4PhG|^tq=^Ur0&ol2+Yt`JEM+931Cw zxwEY9?QFXZ)5Ff}&FRV8sGRAn_k)g{HKCUZCb#>6Y_}U*1=oa!@uqD9d3sI`Y%z/src folders and place them and associated data files/scripts in the parent folder of src. #e.g in 'bin' and 'modules' folders at same level as 'src' folder. +if {[info exists ::env(NO_COLOR)]} { + namespace eval ::punk::console {variable colour_disabled 1} +} set hashline "# ## ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ###" puts $hashline -puts " Punk Boot" +puts " Punk Boot" puts $hashline\n -package prefer latest +package prefer latest lassign [split [info tclversion] .] tclmajorv tclminorv global A ;#UI Ansi code array @@ -104,7 +107,7 @@ namespace eval ::punkboot::lib { } } return [join $newparts .] - } + } proc tm_version_required_canonical {versionspec} { #also trim leading zero from any dottedpart? #Tcl *allows* leading zeros in any of the dotted parts - but they are not significant. @@ -112,10 +115,10 @@ namespace eval ::punkboot::lib { #also 1b3 == 1b0003 if {[string trim $versionspec] eq ""} {return ""} ;#unspecified = any version - set errmsg "punkboot::lib::tm_version_required_canonical - invalid version specification" + set errmsg "punkboot::lib::tm_version_required_canonical - invalid version specification" if {[string first - $versionspec] < 0} { - #no dash - #looks like a minbounded version (ie a single version with no dash) convert to min-max form + #no dash + #looks like a minbounded version (ie a single version with no dash) convert to min-max form set from $versionspec if {![::punkboot::lib::tm_version_isvalid $from]} { error "$errmsg '$versionpec'" @@ -127,7 +130,7 @@ namespace eval ::punkboot::lib { error "$errmsg '$versionspec'" } } else { - # min- or min-max + # min- or min-max #validation and canonicalisation (strip leading zeroes from each segment, including either side of a or b) set parts [split $versionspec -] ;#we expect only 2 parts lassign $parts from to @@ -162,18 +165,18 @@ if {"::try" ni [info commands ::try]} { #------------------------------------------------------------------------------ #Module loading from src/bootsupport or [pwd]/modules if pwd is a 'src' folder #------------------------------------------------------------------------------ -#If there is a folder under the current directory, in the subpath src/bootsupport/modules which contains .tm files +#If there is a folder under the current directory, in the subpath src/bootsupport/modules which contains .tm files # - then it will attempt to preference these modules # This allows a source update via 'fossil update' 'git pull' etc to pull in a minimal set of support modules for the boot script # and load these in preference to ones that may have been in the interp's tcl::tm::list or auto_path due to environment variables set startdir [pwd] #we are focussed on pure-tcl libs/modules in bootsupport for now. -#There may be cases where we want to use compiled packages from src/bootsupport/modules_tcl9 etc +#There may be cases where we want to use compiled packages from src/bootsupport/modules_tcl9 etc #REVIEW - punkboot can really speed up with appropriate accelerators and/or external binaries # - we need to support that without binary downloads from repos unless the user explicitly asks for that. # - They may already be available in the vfs (or pointed to package paths) of the running executable. # - todo: some user prompting regarding installs with platform-appropriate package managers -# - todo: some user prompting regarding building accelerators from source. +# - todo: some user prompting regarding building accelerators from source. # ------------------------------------------------------------------------------------- set bootsupport_module_paths [list] @@ -209,7 +212,7 @@ if {[file tail $startdir] eq "src"} { #todo - other src 'module' dirs.. foreach p [list $startdir/modules $startdir/modules_tcl$::tclmajorv $startdir/vendormodules $startdir/vendormodules_tcl$::tclmajorv] { if {[file exists $p]} { - lappend sourcesupport_module_paths $p + lappend sourcesupport_module_paths $p } } # -- -- -- @@ -219,7 +222,7 @@ if {[file tail $startdir] eq "src"} { } } # -- -- -- - + foreach p [list {*}$sourcesupport_module_paths {*}$sourcesupport_library_paths] { if {[file exists $p]} { set sourcesupport_paths_exist 1 @@ -228,7 +231,7 @@ if {[file tail $startdir] eq "src"} { } if {$sourcesupport_paths_exist} { - #launch from auto_path $::auto_path" @@ -281,18 +284,19 @@ if {$bootsupport_paths_exist || $sourcesupport_paths_exist} { #package require Thread # - the full repl requires Threading and punk,shellfilter,shellrun to call and display properly. - - + # tm list already indexed - need 'package forget' to find modules based on current tcl::tm::list - #These are strong dependencies + #These are strong dependencies package forget punk::mix - package forget punk::repo - package forget punkcheck + package forget punk::repo + package forget punkcheck package require punk::repo ;#todo - push our requirements to a smaller punk::repo::xxx package with minimal dependencies package require punk::mix package require punkcheck package require punk::lib + package require punk::args + package require punk::ansi set package_paths_modified 1 @@ -302,11 +306,12 @@ if {$bootsupport_paths_exist || $sourcesupport_paths_exist} { set ::punkboot::pkg_requirements_found [list] #we will treat 'package require .' (minbounded) as .- ie explicitly convert to corresponding bounded form -#put some with leading zeros to test normalisation +#put some with leading zeros to test normalisation set ::punkboot::bootsupport_requirements [dict create\ punk::repo [list version "00.01.01-"]\ punk::mix [list version ""]\ punk::ansi [list]\ + punk::args [list]\ overtype [list version "1.6.5-"]\ punkcheck [list]\ fauxlink [list version "0.1.1-"]\ @@ -322,7 +327,7 @@ dict for {pkg pkginfo} $::punkboot::bootsupport_requirements { if {![catch {::punkboot::lib::tm_version_required_canonical $ver} canonical]} { if {$canonical ne $ver} { dict set pkginfo version $canonical ;# plain ver mapped to min-max. min- and min-max and empty left as is - dict set ::punkboot::bootsupport_requirements $pkg $pkginfo + dict set ::punkboot::bootsupport_requirements $pkg $pkginfo } } else { puts stderr "punkboot::bootsupport_requirements - package $pkg has invalid version specification '$ver'" @@ -331,9 +336,9 @@ dict for {pkg pkginfo} $::punkboot::bootsupport_requirements { } else { #make sure each has a blank version entry if nothing was there. dict set pkginfo version "" - dict set ::punkboot::bootsupport_requirements $pkg $pkginfo + dict set ::punkboot::bootsupport_requirements $pkg $pkginfo } -} +} #Assert - our bootsupport_requirement version numbers should now be either empty or of the form min- or min-max #dict for {k v} $::punkboot::bootsupport_requirements { # puts "- $k $v" @@ -356,7 +361,7 @@ set ::punkboot::bootsupport_recommended [dict create\ # create an interp in which we hijack package command # This allows us to auto-gather some dependencies (not necessarily all and not necessarily strictly required) # Note: even in a separate interp we could still possibly get side-effects if a package has compiled components - REVIEW -# Hopefully the only side-effect is that a subsequent load of the package will be faster... +# Hopefully the only side-effect is that a subsequent load of the package will be faster... # (punk boot is intended to operate without compiled components - but some could be pulled in by tcl modules if they're found) # (tcllibc is also highly desirable as the performance impact when not available can be dramatic.) # ... but if the binary is loaded with a different path name when we come to actually use it - there could be issues. @@ -378,7 +383,7 @@ proc ::punkboot::check_package_availability {args} { #best effort at auto-determinining packages required (dependencies) based on top-level packages in the list. #Without fully parsing the package-loading Tcl scripts and examining all side-effects (an unlikely capability), # this is not going to be as accurate as the package developer providing a definitive list of which packages are required and which are optional. - # 'optionality' is a contextual concept anyway depending on how the package is intended to be used. + # 'optionality' is a contextual concept anyway depending on how the package is intended to be used. # The package developer may consider a feature optional - but it may not be optional in a particular usecase. set bootsupport_requirements [lindex $args end] @@ -484,7 +489,7 @@ proc ::punkboot::check_package_availability {args} { #should still distinguish: {pkgname {}} -valid vs {pkgname {{}}} due to empty string supplied in call - invalid - but leave for underlying package command to error on set pkgrequest [list $pkgname $requirements_list] if {$pkgrequest ni $::test::pkg_requested} { - lappend ::test::pkg_requested $pkgrequest + lappend ::test::pkg_requested $pkgrequest } # -- -- --- --- --- --- --- -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- @@ -507,13 +512,13 @@ proc ::punkboot::check_package_availability {args} { } if {[llength $::test::pkg_stack]} { set caller [lindex $::test::pkg_stack end] - set required_by [dict get $pinfo required_by] + set required_by [dict get $pinfo required_by] if {$caller ni $required_by} { lappend required_by $caller } dict set pinfo required_by $required_by } - lappend ::test::pkg_stack $pkgname + lappend ::test::pkg_stack $pkgname #At this point we could short circuit if we've already classified this package/requirements combo as missing/broken from a previous require #review - there is some chance the exact pkg/requirements combo may succeed after an earlier failure if some package adjusted search paths.. @@ -527,23 +532,23 @@ proc ::punkboot::check_package_availability {args} { #use our normalised requirements instead of original args #if {[catch [list ::package_orig {*}$args] result]} {} if {[catch [list ::package_orig require $pkgname {*}$requirements_list] result]} { - dict set pinfo testerror $result + dict set pinfo testerror $result #package missing - or exists - but failing to initialise if {!$::opt_quiet} { set parent_path [lrange $::test::pkg_stack 0 end-1] puts stderr "\x1b\[32m $pkgname versions: $versions error: $result\x1b\[m" set parent_path [join $parent_path " -> "] - puts stderr "pkg requirements: $parent_path" + puts stderr "pkg requirements: $parent_path" puts stderr "error during : '$args'" puts stderr " \x1b\[93m$result\x1b\[m" } #the failed package may still exist - so we could check 'package files' and 'package ifneeded' here too - REVIEW - #to determine the version that we attempted to load, + #to determine the version that we attempted to load, #- we need to look at 'pkg versions' vs -exact / ver / ver-ver (using package vsatisfies) if {![llength $versions]} { #no versions *and* we had an error - missing is our best guess. review. - #'package versions Tcl' never shows any results + #'package versions Tcl' never shows any results #so requests for old versions will show as missing not broken. #This is probably better anyway. if {$pkgrequest ni $::test::pkg_missing} { @@ -572,21 +577,21 @@ proc ::punkboot::check_package_availability {args} { lappend selectable_versions $v } } else { - #we are operating under 'package prefer' = latest + #we are operating under 'package prefer' = latest set selectable_versions $ordered_versions } if {[llength $requirements_list]} { #add one or no entry for each requirement. #pick highest at end - set satisfiers [list] + set satisfiers [list] foreach requirement $requirements_list { foreach ver [lreverse $selectable_versions] { if {[package vsatisfies $ver $requirement]} { lappend satisfiers $ver break - } - } + } + } } if {[llength $satisfiers]} { set satisfiers [lsort -command {::package_orig vcompare} $satisfiers] @@ -622,7 +627,7 @@ proc ::punkboot::check_package_availability {args} { if {![catch {::package_orig files Tcl} ]} { #tcl9 (also some 8.6/8.7) has 'package files' subcommand. #unfortunately, in some cases (e.g md5 when no accelerators available) this can be a huge list (1000+) showing all scanned pkgIndex.tcl files from unrelated packages. - #We expect this to be fixed - but early Tcl9 (and some 8.6/8.7) versions may persist and have this behaviour + #We expect this to be fixed - but early Tcl9 (and some 8.6/8.7) versions may persist and have this behaviour #see: https://core.tcl-lang.org/tcl/tktview/209fd9adce set all_files [::package_orig files $pkgname] #some arbitrary threshold? REVIEW @@ -637,7 +642,7 @@ proc ::punkboot::check_package_availability {args} { dict set pinfo packagefiles {} ;#default #there are all sorts of scripts, so this is not predictably structured #e.g using things like apply - #we will attempt to get a trailing source .. + #we will attempt to get a trailing source .. set parts [split [string trim $ifneeded_script] {;}] set trimparts [list] foreach p $parts { @@ -648,7 +653,7 @@ proc ::punkboot::check_package_availability {args} { if {$last_with_text ne "" && [regexp -- {\S+$} $last_with_text lastword]} { #if it's a file or dir - close enough (?) #e.g tcllibc uses apply and the last entry is actuall a folder used to find the file.. - #we aren't brave enough to try to work out the actual file(s) + #we aren't brave enough to try to work out the actual file(s) if {[file exists $lastword]} { dict set pinfo packagefiles $lastword } @@ -662,10 +667,10 @@ proc ::punkboot::check_package_availability {args} { return [uplevel 1 [list ::package_orig {*}$args]] } } - + set ::test::pkg_stack [list] catch {::package_orig require zzz-non-existant} ;#scan so we get 'package versions' results - dict for {pkg pkgdict} $::test::bootsupport_requirements { + dict for {pkg pkgdict} $::test::bootsupport_requirements { #set nsquals [namespace qualifiers $pkg] #if {$nsquals ne ""} { # catch {::package_orig require ${nsquals}::zzz-non-existant} ;#force scan of every level encountered @@ -690,7 +695,7 @@ proc ::punkboot::check_package_availability {args} { # set ver [package provide $pkg] # if {$ver eq ""} { # #puts stderr "missing pkg: $pkg" - # lappend ::test::pkg_missing $pkg + # lappend ::test::pkg_missing $pkg # } else { # if {[string tolower $pkg] eq "tcl"} { # #ignore @@ -1180,17 +1185,17 @@ if {$::punkboot::command eq "check"} { puts stdout "- tcl::tm::list" foreach fld [tcl::tm::list] { if {[file exists $fld]} { - puts stdout " $fld" + puts stdout " $fld" } else { - puts stdout " $fld (not present)" + puts stdout " $fld (not present)" } } puts stdout "- auto_path" foreach fld $::auto_path { if {[file exists $fld]} { - puts stdout " $fld" + puts stdout " $fld" } else { - puts stdout " $fld (not present)" + puts stdout " $fld (not present)" } } flush stdout @@ -1283,22 +1288,22 @@ if {$::punkboot::command eq "info"} { set vendormodulefolders [glob -nocomplain -dir $sourcefolder -type d -tails vendormodules_tcl*] puts stdout "- vendorlib folders: ([llength $vendorlibfolders])" foreach fld $vendorlibfolders { - puts stdout " src/$fld" + puts stdout " src/$fld" } puts stdout "- vendormodule folders: ([llength $vendormodulefolders])" foreach fld $vendormodulefolders { - puts stdout " src/$fld" + puts stdout " src/$fld" } set source_module_folderlist [punk::mix::cli::lib::find_source_module_paths $projectroot] puts stdout "- source module paths: [llength $source_module_folderlist]" foreach fld $source_module_folderlist { - puts stdout " $fld" + puts stdout " $fld" } set projectlibfolders [glob -nocomplain -dir $sourcefolder -type d -tails lib_tcl*] lappend projectlibfolders lib puts stdout "- source libary paths: [llength $projectlibfolders]" foreach fld $projectlibfolders { - puts stdout " src/$fld" + puts stdout " src/$fld" } if {[punk::repo::find_fossil $scriptfolder] eq $projectroot} { set vc "fossil" @@ -1389,10 +1394,9 @@ if {$::punkboot::command eq "vendorupdate"} { #todo vendor/lib set vendorlibfolders [glob -nocomplain -dir $sourcefolder -type d -tails vendorlib_tcl*] - set vendormodulefolders [glob -nocomplain -dir $sourcefolder -type d -tails vendormodules_tcl*] - lappend vendormodulefolders vendormodules + set vendormodulefolders [glob -nocomplain -dir $sourcefolder -type d -tails vendormodules vendormodules_tcl*] + #lappend vendormodulefolders vendormodules foreach vf $vendormodulefolders { - if {[file exists $sourcefolder/$vf]} { lassign [split $vf _] _vm tclx if {$tclx ne ""} { set which _$tclx @@ -1481,7 +1485,6 @@ if {$::punkboot::command eq "vendorupdate"} { } else { puts stderr "No config at $vendor_config - nothing configured to update" } - } } } @@ -1508,105 +1511,102 @@ if {$::punkboot::command eq "bootsupport"} { set bootsupport_modules [list] ;#variable populated by include_modules.config file - review set sourcefolder $projectroot/src - set bootmodulefolders [glob -nocomplain -dir $sourcefolder/bootsupport -type d -tails modules_tcl*] - lappend bootmodulefolders modules + set bootmodulefolders [glob -nocomplain -dir $sourcefolder/bootsupport -type d -tails modules modules_tcl*] foreach bm $bootmodulefolders { - if {[file exists $sourcefolder/bootsupport/$bm]} { - lassign [split $bm _] _bm tclx - if {$tclx ne ""} { - set which _$tclx + lassign [split $bm _] _bm tclx + if {$tclx ne ""} { + set which _$tclx + } else { + set which "" + } + set bootsupport_config $projectroot/src/bootsupport/modules$which/include_modules.config ;# + if {[file exists $bootsupport_config]} { + set targetroot $projectroot/src/bootsupport/modules$which + source $bootsupport_config ;#populate $bootsupport_modules with project-specific list + if {![llength $bootsupport_modules]} { + puts stderr "bootsupport/modules$which - No local bootsupport modules configured for updating" } else { - set which "" - } - set bootsupport_config $projectroot/src/bootsupport/modules$which/include_modules.config ;# - if {[file exists $bootsupport_config]} { - set targetroot $projectroot/src/bootsupport/modules$which - source $bootsupport_config ;#populate $bootsupport_modules with project-specific list - if {![llength $bootsupport_modules]} { - puts stderr "bootsupport/modules$which - No local bootsupport modules configured for updating" - } else { - if {[catch { - #---------- - set boot_installer [punkcheck::installtrack new make.tcl $projectroot/src/bootsupport/.punkcheck] - $boot_installer set_source_target $projectroot $projectroot/src/bootsupport - set boot_event [$boot_installer start_event {-make_step bootsupport}] - #---------- - } errM]} { - puts stderr "Unable to use punkcheck for bootsupport error: $errM" - set boot_event "" - } + if {[catch { + #---------- + set boot_installer [punkcheck::installtrack new make.tcl $projectroot/src/bootsupport/.punkcheck] + $boot_installer set_source_target $projectroot $projectroot/src/bootsupport + set boot_event [$boot_installer start_event {-make_step bootsupport}] + #---------- + } errM]} { + puts stderr "Unable to use punkcheck for bootsupport error: $errM" + set boot_event "" + } - foreach {relpath modulematch} $bootsupport_modules { - set modulematch [string trim $modulematch :] - set module_subpath [string map [list :: /] [namespace qualifiers $modulematch]] - set srclocation [file join $projectroot $relpath $module_subpath] - #puts stdout "$relpath $modulematch $module_subpath $srclocation" - if {[string first - $modulematch]} { - set pkgmatches [glob -nocomplain -dir $srclocation -tail -type f [namespace tail $modulematch]*.tm] - } else { - set pkgmatches [glob -nocomplain -dir $srclocation -tail -type f [namespace tail $modulematch]-*.tm] - } - if {![llength $pkgmatches]} { - puts stderr "Missing source for bootsupport module $modulematch - no matches in $srclocation" - continue - } + foreach {relpath modulematch} $bootsupport_modules { + set modulematch [string trim $modulematch :] + set module_subpath [string map [list :: /] [namespace qualifiers $modulematch]] + set srclocation [file join $projectroot $relpath $module_subpath] + #puts stdout "$relpath $modulematch $module_subpath $srclocation" + if {[string first - $modulematch]} { + set pkgmatches [glob -nocomplain -dir $srclocation -tail -type f [namespace tail $modulematch]*.tm] + } else { + set pkgmatches [glob -nocomplain -dir $srclocation -tail -type f [namespace tail $modulematch]-*.tm] + } + if {![llength $pkgmatches]} { + puts stderr "Missing source for bootsupport module $modulematch - no matches in $srclocation" + continue + } - set modulematch_is_glob [regexp {[*?\[\]]} $modulematch] - if {!$modulematch_is_glob} { - #if modulematch was specified without globs - only copy latest - #lsort won't sort version numbers properly e.g with -dictionary 0.1.1 comes before 0.1b3 - use helper func - set pkgmatches [lsort -command modfile_sort $pkgmatches] - set latestfile [lindex $pkgmatches end] - #set latestver [lindex [split [file rootname $latestfile] -] 1] - set copy_files $latestfile - } else { - #globs in modulematch - may be different packages matched by glob - copy all versions of matches - #review - set copy_files $pkgmatches - } - foreach cfile $copy_files { - set srcfile [file join $srclocation $cfile] - set tgtfile [file join $targetroot $module_subpath $cfile] - if {$boot_event ne ""} { - #---------- - $boot_event targetset_init INSTALL $tgtfile - $boot_event targetset_addsource $srcfile - #---------- - if {\ - [llength [dict get [$boot_event targetset_source_changes] changed]]\ - || [llength [$boot_event get_targets_exist]] < [llength [$boot_event get_targets]]\ - } { - file mkdir [file dirname $tgtfile] ;#ensure containing folder for target exists - $boot_event targetset_started - # -- --- --- --- --- --- - puts "BOOTSUPPORT module$which update: $srcfile -> $tgtfile" - if {[catch { - file copy -force $srcfile $tgtfile - } errM]} { - $boot_event targetset_end FAILED - } else { - $boot_event targetset_end OK - } - # -- --- --- --- --- --- + set modulematch_is_glob [regexp {[*?\[\]]} $modulematch] + if {!$modulematch_is_glob} { + #if modulematch was specified without globs - only copy latest + #lsort won't sort version numbers properly e.g with -dictionary 0.1.1 comes before 0.1b3 - use helper func + set pkgmatches [lsort -command modfile_sort $pkgmatches] + set latestfile [lindex $pkgmatches end] + #set latestver [lindex [split [file rootname $latestfile] -] 1] + set copy_files $latestfile + } else { + #globs in modulematch - may be different packages matched by glob - copy all versions of matches + #review + set copy_files $pkgmatches + } + foreach cfile $copy_files { + set srcfile [file join $srclocation $cfile] + set tgtfile [file join $targetroot $module_subpath $cfile] + if {$boot_event ne ""} { + #---------- + $boot_event targetset_init INSTALL $tgtfile + $boot_event targetset_addsource $srcfile + #---------- + if {\ + [llength [dict get [$boot_event targetset_source_changes] changed]]\ + || [llength [$boot_event get_targets_exist]] < [llength [$boot_event get_targets]]\ + } { + file mkdir [file dirname $tgtfile] ;#ensure containing folder for target exists + $boot_event targetset_started + # -- --- --- --- --- --- + puts "BOOTSUPPORT module$which update: $srcfile -> $tgtfile" + if {[catch { + file copy -force $srcfile $tgtfile + } errM]} { + $boot_event targetset_end FAILED } else { - puts -nonewline stderr "." - $boot_event targetset_end SKIPPED + $boot_event targetset_end OK } - $boot_event end + # -- --- --- --- --- --- } else { - file copy -force $srcfile $tgtfile + puts -nonewline stderr "." + $boot_event targetset_end SKIPPED } + $boot_event end + } else { + file copy -force $srcfile $tgtfile } } - if {$boot_event ne ""} { - puts \n - $boot_event destroy - $boot_installer destroy - } } - + if {$boot_event ne ""} { + puts \n + $boot_event destroy + $boot_installer destroy + } } + } } } @@ -1699,59 +1699,53 @@ if {$::punkboot::command ni {project modules vfs}} { #install src vendor contents (from version controlled src folder) to base of project (same target folders as our own src/modules etc ie to paths that go on the auto_path and in tcl::tm::list) if {$::punkboot::command in {project modules}} { - set vendorlibfolders [glob -nocomplain -dir $sourcefolder -type d -tails vendorlib_tcl*] - lappend vendorlibfolders vendorlib - foreach lf $vendorlibfolders { - if {[file exists $sourcefolder/$lf]} { - lassign [split $lf _] _vm tclx - if {$tclx ne ""} { - set which _$tclx - } else { - set which "" - } - set target_lib_folder $projectroot/lib$which - file mkdir $projectroot/lib$which - #exclude README.md from source folder - but only the root one - #-antiglob_paths takes relative patterns e.g - # */test.txt will only match test.txt exactly one level deep. - # */*/*.foo will match any path ending in .foo that is exactly 2 levels deep. - # **/test.txt will match at any level below the root (but not in the root) - set antipaths [list\ - README.md\ - ] - puts stdout "VENDORLIB$which: copying from $sourcefolder/$lf to $target_lib_folder (if source file changed)" - set resultdict [punkcheck::install $sourcefolder/$lf $target_lib_folder -overwrite installedsourcechanged-targets -antiglob_paths $antipaths] - puts stdout [punkcheck::summarize_install_resultdict $resultdict] - } - } - if {![llength $vendorlibfolders]} { - puts stderr "VENDORLIB: No src/vendorlib or src/vendorlib_tcl* folder found." - } - - set vendormodulefolders [glob -nocomplain -dir $sourcefolder -type d -tails vendormodules_tcl*] - lappend vendormodulefolders vendormodules - + set vendormodulefolders [glob -nocomplain -dir $sourcefolder -type d -tails vendormodules vendormodules_tcl*] foreach vf $vendormodulefolders { - if {[file exists $sourcefolder/$vf]} { - lassign [split $vf _] _vm tclx - if {$tclx ne ""} { - set which _$tclx - } else { - set which "" - } - set target_module_folder $projectroot/modules$which - file mkdir $target_module_folder - - #install .tm *and other files* - puts stdout "VENDORMODULES$which: copying from $sourcefolder/$vf to $target_module_folder (if source file changed)" - set resultdict [punkcheck::install $sourcefolder/$vf $target_module_folder -installer make.tcl -overwrite installedsourcechanged-targets -antiglob_paths {README.md include_modules.config}] - puts stdout [punkcheck::summarize_install_resultdict $resultdict] + lassign [split $vf _] _vm tclx + if {$tclx ne ""} { + set which _$tclx + } else { + set which "" } + set target_module_folder $projectroot/modules$which + file mkdir $target_module_folder + + #install .tm *and other files* + puts stdout "VENDORMODULES$which: copying from $sourcefolder/$vf to $target_module_folder (if source file changed)" + set resultdict [punkcheck::install $sourcefolder/$vf $target_module_folder -installer make.tcl -overwrite installedsourcechanged-targets -antiglob_paths {README.md include_modules.config}] + puts stdout [punkcheck::summarize_install_resultdict $resultdict] } if {![llength $vendormodulefolders]} { puts stderr "VENDORMODULES: No src/vendormodules or src/vendormodules_tcl* folders found." } + set vendorlibfolders [glob -nocomplain -dir $sourcefolder -type d -tails vendorlib vendorlib_tcl*] + foreach lf $vendorlibfolders { + lassign [split $lf _] _vm tclx + if {$tclx ne ""} { + set which _$tclx + } else { + set which "" + } + set target_lib_folder $projectroot/lib$which + file mkdir $projectroot/lib$which + #exclude README.md from source folder - but only the root one + #-antiglob_paths takes relative patterns e.g + # */test.txt will only match test.txt exactly one level deep. + # */*/*.foo will match any path ending in .foo that is exactly 2 levels deep. + # **/test.txt will match at any level below the root (but not in the root) + set antipaths [list\ + README.md\ + ] + puts stdout "VENDORLIB$which: copying from $sourcefolder/$lf to $target_lib_folder (if source file changed)" + set resultdict [punkcheck::install $sourcefolder/$lf $target_lib_folder -overwrite installedsourcechanged-targets -antiglob_paths $antipaths] + puts stdout [punkcheck::summarize_install_resultdict $resultdict] + } + if {![llength $vendorlibfolders]} { + puts stderr "VENDORLIB: No src/vendorlib or src/vendorlib_tcl* folder found." + } + + ######################################################## #templates #e.g The default project layout is mainly folder structure and readme files - but has some scripts developed under the main src that we want to sync @@ -1760,10 +1754,10 @@ if {$::punkboot::command in {project modules}} { set old_layout_update_list [list\ [list project $sourcefolder/modules/punk/mix/templates]\ [list basic $sourcefolder/mixtemplates]\ - ] + ] set layout_bases [list\ $sourcefolder/project_layouts/custom/_project\ - ] + ] foreach layoutbase $layout_bases { if {![file exists $layoutbase]} { @@ -1823,27 +1817,25 @@ if {$::punkboot::command in {project modules}} { set projectlibfolders [glob -nocomplain -dir $sourcefolder -type d -tails lib_tcl*] lappend projectlibfolders lib foreach lf $projectlibfolders { - if {[file exists $sourcefolder/$lf]} { - lassign [split $lf _] _vm tclx - if {$tclx ne ""} { - set which _$tclx - } else { - set which "" - } - set target_lib_folder $projectroot/lib$which - file mkdir $projectroot/lib$which - #exclude README.md from source folder - but only the root one - #-antiglob_paths takes relative patterns e.g - # */test.txt will only match test.txt exactly one level deep. - # */*/*.foo will match any path ending in .foo that is exactly 2 levels deep. - # **/test.txt will match at any level below the root (but not in the root) - set antipaths [list\ - README.md\ - ] - puts stdout "PROJECTLIB$which: copying from $sourcefolder/$lf to $target_lib_folder (if source file changed)" - set resultdict [punkcheck::install $sourcefolder/$lf $target_lib_folder -overwrite installedsourcechanged-targets -antiglob_paths $antipaths] - puts stdout [punkcheck::summarize_install_resultdict $resultdict] - } + lassign [split $lf _] _vm tclx + if {$tclx ne ""} { + set which _$tclx + } else { + set which "" + } + set target_lib_folder $projectroot/lib$which + file mkdir $projectroot/lib$which + #exclude README.md from source folder - but only the root one + #-antiglob_paths takes relative patterns e.g + # */test.txt will only match test.txt exactly one level deep. + # */*/*.foo will match any path ending in .foo that is exactly 2 levels deep. + # **/test.txt will match at any level below the root (but not in the root) + set antipaths [list\ + README.md\ + ] + puts stdout "PROJECTLIB$which: copying from $sourcefolder/$lf to $target_lib_folder (if source file changed)" + set resultdict [punkcheck::install $sourcefolder/$lf $target_lib_folder -overwrite installedsourcechanged-targets -antiglob_paths $antipaths] + puts stdout [punkcheck::summarize_install_resultdict $resultdict] } if {![llength $projectlibfolders]} { puts stderr "PROJECTLIB: No src/lib or src/lib_tcl* folder found." @@ -2355,7 +2347,7 @@ foreach vfstail $vfs_tails { } else { lappend runtimes $matchrt } - } + } } #assert $runtimes is a list of executable names suffixed with .exe if on windows - whether or not specified with .exe in the mapvfs.config