7 changed files with 578 additions and 85 deletions
@ -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 <cmd> <renamer>' for delegating to command as it was prior to rename |
||||
#changes: |
||||
#2024 |
||||
# - mungecommand to support namespaced commands |
||||
# - fix mistake - hardcoded _originalcommand_package -> _originalcommand_<mungedcommand> |
||||
#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 {<cmd> <renamer> <tokenid>} |
||||
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. |
||||
#<renamer> 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 <string>? 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 <mungedrenamer>::<mungedcommand> 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_<mungedcommand> |
||||
#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% <procargs> <procbody> ) |
||||
set COMMANDSTACKNEXT_ORIGINAL %original_implementation% ;#informational/debug for overriding proc. |
||||
set COMMANDSTACKNEXT [%next_getter%] |
||||
#<commandstack_separator># |
||||
}] |
||||
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 {<command> <renamer>}" |
||||
} |
||||
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 "#<commandstack_separator>#" |
||||
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 |
||||
}] |
||||
|
||||
|
||||
Loading…
Reference in new issue