From 8c71cd4c42c112e18d88012e6f15b49de20c4237 Mon Sep 17 00:00:00 2001 From: Julian Noble Date: Mon, 22 Dec 2025 23:35:38 +1100 Subject: [PATCH] overtype::renderline support nonstandard pablodraw 24bit colour; packagepreference calls via uplevel 1 --- .../modules/commandstack-0.4.tm} | 2 +- .../modules/punk/libunknown-0.1.tm | 4 +- .../modules/punk/packagepreference-0.1.0.tm | 47 +- src/modules/overtype-999999.0a1.0.tm | 41 ++ src/modules/punk/libunknown-0.1.tm | 4 +- .../punk/packagepreference-999999.0a1.0.tm | 47 +- src/vendormodules/commandstack-0.4.tm | 518 ++++++++++++++++++ 7 files changed, 578 insertions(+), 85 deletions(-) rename src/{vendormodules/commandstack-0.3.tm => bootsupport/modules/commandstack-0.4.tm} (99%) create mode 100644 src/vendormodules/commandstack-0.4.tm diff --git a/src/vendormodules/commandstack-0.3.tm b/src/bootsupport/modules/commandstack-0.4.tm similarity index 99% rename from src/vendormodules/commandstack-0.3.tm rename to src/bootsupport/modules/commandstack-0.4.tm index b2561a20..19c21289 100644 --- a/src/vendormodules/commandstack-0.3.tm +++ b/src/bootsupport/modules/commandstack-0.4.tm @@ -512,7 +512,7 @@ namespace eval commandstack::lib { } package provide commandstack [namespace eval commandstack { - set version 0.3 + set version 0.4 }] diff --git a/src/bootsupport/modules/punk/libunknown-0.1.tm b/src/bootsupport/modules/punk/libunknown-0.1.tm index d7eaf639..2b63010c 100644 --- a/src/bootsupport/modules/punk/libunknown-0.1.tm +++ b/src/bootsupport/modules/punk/libunknown-0.1.tm @@ -1367,7 +1367,7 @@ tcl::namespace::eval ::punk::libunknown { } } if {[llength $ok_forgets]} { - return [::package:: forget {*}$ok_forgets] + return [uplevel 1 [list ::package:: forget {*}$ok_forgets]] } else { return } @@ -1449,7 +1449,7 @@ tcl::namespace::eval ::punk::libunknown { } } default { - return [::package:: {*}$args] + return [uplevel 1 [list ::package:: {*}$args]] } } } diff --git a/src/bootsupport/modules/punk/packagepreference-0.1.0.tm b/src/bootsupport/modules/punk/packagepreference-0.1.0.tm index 5b504e58..330018ae 100644 --- a/src/bootsupport/modules/punk/packagepreference-0.1.0.tm +++ b/src/bootsupport/modules/punk/packagepreference-0.1.0.tm @@ -63,39 +63,6 @@ package require commandstack #*** !doctools #[section API] -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# oo::class namespace -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -#tcl::namespace::eval punk::packagepreference::class { - #*** !doctools - #[subsection {Namespace punk::packagepreference::class}] - #[para] class definitions - #if {[tcl::info::commands [tcl::namespace::current]::interface_sample1] eq ""} { - #*** !doctools - #[list_begin enumerated] - - # oo::class create interface_sample1 { - # #*** !doctools - # #[enum] CLASS [class interface_sample1] - # #[list_begin definitions] - - # method test {arg1} { - # #*** !doctools - # #[call class::interface_sample1 [method test] [arg arg1]] - # #[para] test method - # puts "test: $arg1" - # } - - # #*** !doctools - # #[list_end] [comment {-- end definitions interface_sample1}] - # } - - #*** !doctools - #[list_end] [comment {--- end class enumeration ---}] - #} -#} -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ # Base namespace # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ @@ -188,7 +155,7 @@ tcl::namespace::eval punk::packagepreference { #although we could shortcircuit using vsatisfies to return the ver #we should instead pass through to COMMANDSTACKNEXT so as not to interfere with whatever it does. #e.g a package require logger further down the commandstack - return [$COMMANDSTACKNEXT {*}$args] + return [uplevel 1 [list $COMMANDSTACKNEXT {*}$args]] } if {!$is_exact && [llength $vwant] <= 1 } { @@ -238,7 +205,7 @@ tcl::namespace::eval punk::packagepreference { } #return [$COMMANDSTACKNEXT require $pkg $lversion-$lversion] try { - set result [$COMMANDSTACKNEXT require $pkg $lversion-$lversion] + set result [uplevel 1 [list $COMMANDSTACKNEXT require $pkg $lversion-$lversion]] } trap {} {emsg eopts} { #REVIEW - this occurred in punkmagic (rebuild of tclmagic) - probably due to multiple versions of registry #under different auto_path folders - and mal-ordering in punk::libunknown's tclPkgUnknown @@ -282,9 +249,9 @@ tcl::namespace::eval punk::packagepreference { if {[regexp {[A-Z]} $pkg]} { #legacy package names #only apply catch & retry if there was a cap - otherwise we'll double try for errors unrelated to capitalisation - if {[catch {$COMMANDSTACKNEXT require [string tolower $pkg] {*}$vwant} v]} { + if {[catch {uplevel 1 [list $COMMANDSTACKNEXT require [string tolower $pkg] {*}$vwant]} v]} { try { - set require_result [$COMMANDSTACKNEXT require $pkg {*}$vwant] + set require_result [uplevel 1 [list $COMMANDSTACKNEXT require $pkg {*}$vwant]] } trap {} {emsg eopts} { return -options $eopts $emsg } @@ -294,7 +261,7 @@ tcl::namespace::eval punk::packagepreference { } else { #return [$COMMANDSTACKNEXT require $pkg {*}$vwant] try { - set require_result [$COMMANDSTACKNEXT require $pkg {*}$vwant] + set require_result [uplevel 1 [list $COMMANDSTACKNEXT require $pkg {*}$vwant]] } trap {} {emsg eopts} { return -options $eopts $emsg } @@ -328,14 +295,14 @@ tcl::namespace::eval punk::packagepreference { catch { #$COMMANDSTACKNEXT require $pkg {*}$vwant #j2 - $COMMANDSTACKNEXT require punk::args::moduledoc::$dp + uplevel 1 [list $COMMANDSTACKNEXT require punk::args::moduledoc::$dp] } } #--------------------------------------------------------------- return $require_result } default { - return [$COMMANDSTACKNEXT {*}$args] + return [uplevel 1 [list $COMMANDSTACKNEXT {*}$args]] } } diff --git a/src/modules/overtype-999999.0a1.0.tm b/src/modules/overtype-999999.0a1.0.tm index 7a64f3db..0efea4da 100644 --- a/src/modules/overtype-999999.0a1.0.tm +++ b/src/modules/overtype-999999.0a1.0.tm @@ -2765,6 +2765,21 @@ tcl::namespace::eval overtype { set o_codestack [lremove $o_codestack {*}$dup_posns] lappend o_codestack $code lappend overlay_grapheme_control_list [list sgr $code] + } elseif {[regexp {\x1b\[[0-1];[0-9][0-9]?[0-9]?;[0-9][0-9]?[0-9]?;[0-9][0-9]?[0-9]?t} $code]} { + #pablodraw 24bit color - convert to standard sgr RGB code + #we could do a more precise 000-255 regexp for each r g b, something like: ((?:[0-1]?[0-9]?[0-9])|(?:2[0-4][0-9])|(?:25[0-5])) + #but that seems more expensive for little likely use (?) review + lassign [regexp -all -inline {\x1b\[([0-1]);([0-9][0-9]?[0-9]?);([0-9][0-9]?[0-9]?);([0-9][0-9]?[0-9]?)t} $code] _ isfg pablo_r pablo_g pablo_b + #todo - if any r g b value > 255 - add as [list other $code] + if {$isfg} { + set rgbcode "\x1b\[38\;2\;$pablo_r\;$pablo_g\;${pablo_b}m" + } else { + set rgbcode "\x1b\[48\;2\;$pablo_r\;$pablo_g\;${pablo_b}m" + } + set dup_posns [lsearch -all -exact $o_codestack $rgbcode] ;#must be -exact because of square-bracket glob chars + set o_codestack [lremove $o_codestack {*}$dup_posns] + lappend o_codestack $rgbcode + lappend overlay_grapheme_control_list [list sgr $rgbcode] } elseif {[regexp {\x1b7|\x1b\[s} $code]} { #experiment #cursor_save - for the replays review. @@ -4290,6 +4305,32 @@ tcl::namespace::eval overtype { } } } + t { + set params [split $param {;}] + if {[llength $params] == 4} { + #pablodraw 24bit color + #see also: https://github.com/ansilove/libansilove/blob/master/src/loaders/ansi.c + lassign $params isfg pablo_r pablo_g pablo_b + #e.g esc\[0\;171\;87\;0t + set stack [lindex $overlay_grapheme_control_stacks $gci] + puts stderr "pablodraw debug [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + #foreach s $stack { + # puts stderr " - [ansistring VIEW -lf 1 -vt 1 -nul 1 $s]" + #} + #we expect first param to be 0 for background, 1 for foreground + if {$isfg} { + set rgbcode "\x1b\[38\;2\;$pablo_r\;$pablo_g\;${pablo_b}m" + } else { + set rgbcode "\x1b\[48\;2\;$pablo_r\;$pablo_g\;${pablo_b}m" + } + #too late here !! + #lappend stack $rgbcode + #lset overlay_grapheme_control_stacks $gci $stack + + } else { + puts stderr "overtype::renderline unrecognised custom CSI code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code] not implemented" + } + } default { puts stderr "overtype::renderline CSI code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code] not implemented" } diff --git a/src/modules/punk/libunknown-0.1.tm b/src/modules/punk/libunknown-0.1.tm index d7eaf639..2b63010c 100644 --- a/src/modules/punk/libunknown-0.1.tm +++ b/src/modules/punk/libunknown-0.1.tm @@ -1367,7 +1367,7 @@ tcl::namespace::eval ::punk::libunknown { } } if {[llength $ok_forgets]} { - return [::package:: forget {*}$ok_forgets] + return [uplevel 1 [list ::package:: forget {*}$ok_forgets]] } else { return } @@ -1449,7 +1449,7 @@ tcl::namespace::eval ::punk::libunknown { } } default { - return [::package:: {*}$args] + return [uplevel 1 [list ::package:: {*}$args]] } } } diff --git a/src/modules/punk/packagepreference-999999.0a1.0.tm b/src/modules/punk/packagepreference-999999.0a1.0.tm index 22511824..1df68610 100644 --- a/src/modules/punk/packagepreference-999999.0a1.0.tm +++ b/src/modules/punk/packagepreference-999999.0a1.0.tm @@ -63,39 +63,6 @@ package require commandstack #*** !doctools #[section API] -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# oo::class namespace -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -#tcl::namespace::eval punk::packagepreference::class { - #*** !doctools - #[subsection {Namespace punk::packagepreference::class}] - #[para] class definitions - #if {[tcl::info::commands [tcl::namespace::current]::interface_sample1] eq ""} { - #*** !doctools - #[list_begin enumerated] - - # oo::class create interface_sample1 { - # #*** !doctools - # #[enum] CLASS [class interface_sample1] - # #[list_begin definitions] - - # method test {arg1} { - # #*** !doctools - # #[call class::interface_sample1 [method test] [arg arg1]] - # #[para] test method - # puts "test: $arg1" - # } - - # #*** !doctools - # #[list_end] [comment {-- end definitions interface_sample1}] - # } - - #*** !doctools - #[list_end] [comment {--- end class enumeration ---}] - #} -#} -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ # Base namespace # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ @@ -188,7 +155,7 @@ tcl::namespace::eval punk::packagepreference { #although we could shortcircuit using vsatisfies to return the ver #we should instead pass through to COMMANDSTACKNEXT so as not to interfere with whatever it does. #e.g a package require logger further down the commandstack - return [$COMMANDSTACKNEXT {*}$args] + return [uplevel 1 [list $COMMANDSTACKNEXT {*}$args]] } if {!$is_exact && [llength $vwant] <= 1 } { @@ -238,7 +205,7 @@ tcl::namespace::eval punk::packagepreference { } #return [$COMMANDSTACKNEXT require $pkg $lversion-$lversion] try { - set result [$COMMANDSTACKNEXT require $pkg $lversion-$lversion] + set result [uplevel 1 [list $COMMANDSTACKNEXT require $pkg $lversion-$lversion]] } trap {} {emsg eopts} { #REVIEW - this occurred in punkmagic (rebuild of tclmagic) - probably due to multiple versions of registry #under different auto_path folders - and mal-ordering in punk::libunknown's tclPkgUnknown @@ -282,9 +249,9 @@ tcl::namespace::eval punk::packagepreference { if {[regexp {[A-Z]} $pkg]} { #legacy package names #only apply catch & retry if there was a cap - otherwise we'll double try for errors unrelated to capitalisation - if {[catch {$COMMANDSTACKNEXT require [string tolower $pkg] {*}$vwant} v]} { + if {[catch {uplevel 1 [list $COMMANDSTACKNEXT require [string tolower $pkg] {*}$vwant]} v]} { try { - set require_result [$COMMANDSTACKNEXT require $pkg {*}$vwant] + set require_result [uplevel 1 [list $COMMANDSTACKNEXT require $pkg {*}$vwant]] } trap {} {emsg eopts} { return -options $eopts $emsg } @@ -294,7 +261,7 @@ tcl::namespace::eval punk::packagepreference { } else { #return [$COMMANDSTACKNEXT require $pkg {*}$vwant] try { - set require_result [$COMMANDSTACKNEXT require $pkg {*}$vwant] + set require_result [uplevel 1 [list $COMMANDSTACKNEXT require $pkg {*}$vwant]] } trap {} {emsg eopts} { return -options $eopts $emsg } @@ -328,14 +295,14 @@ tcl::namespace::eval punk::packagepreference { catch { #$COMMANDSTACKNEXT require $pkg {*}$vwant #j2 - $COMMANDSTACKNEXT require punk::args::moduledoc::$dp + uplevel 1 [list $COMMANDSTACKNEXT require punk::args::moduledoc::$dp] } } #--------------------------------------------------------------- return $require_result } default { - return [$COMMANDSTACKNEXT {*}$args] + return [uplevel 1 [list $COMMANDSTACKNEXT {*}$args]] } } diff --git a/src/vendormodules/commandstack-0.4.tm b/src/vendormodules/commandstack-0.4.tm new file mode 100644 index 00000000..19c21289 --- /dev/null +++ b/src/vendormodules/commandstack-0.4.tm @@ -0,0 +1,518 @@ + + +#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 + if {$command eq ""} { + return $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] + #stack is a list of dicts, 1st entry is token { } + 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.4 +}] + +