14 changed files with 2407 additions and 839 deletions
@ -0,0 +1,512 @@ |
|||||||
|
|
||||||
|
|
||||||
|
#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 |
||||||
|
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. |
||||||
|
#<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." |
||||||
|
} 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)" |
||||||
|
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}} { |
||||||
|
#review - probably don't need a warning anyway |
||||||
|
puts stderr "(commandstack::rename_command) WARNING - Something may have 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 { |
||||||
|
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 {[package provide punk::lib] ne ""} { |
||||||
|
return [punk::lib::pdict -channel none all_stacks $commandname_glob/@*/@*.@*] |
||||||
|
} else { |
||||||
|
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]] |
||||||
|
} |
||||||
|
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.3 |
||||||
|
}] |
||||||
|
|
||||||
|
|
||||||
@ -0,0 +1,267 @@ |
|||||||
|
# -*- tcl -*- |
||||||
|
# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'pmix make' or bin/punkmake to update from <pkg>-buildversion.txt |
||||||
|
# module template: shellspy/src/decktemplates/vendor/punk/modules/template_module-0.0.3.tm |
||||||
|
# |
||||||
|
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. |
||||||
|
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# (C) 2024 |
||||||
|
# |
||||||
|
# @@ Meta Begin |
||||||
|
# Application punk::packagepreference 0.1.0 |
||||||
|
# Meta platform tcl |
||||||
|
# Meta license <unspecified> |
||||||
|
# @@ Meta End |
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# doctools header |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
#*** !doctools |
||||||
|
#[manpage_begin shellspy_module_punk::packagepreference 0 0.1.0] |
||||||
|
#[copyright "2024"] |
||||||
|
#[titledesc {Module API}] [comment {-- Name section and table of contents description --}] |
||||||
|
#[moddesc {-}] [comment {-- Description at end of page heading --}] |
||||||
|
#[require punk::packagepreference] |
||||||
|
#[keywords module] |
||||||
|
#[description] |
||||||
|
#[para] - |
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[section Overview] |
||||||
|
#[para] overview of punk::packagepreference |
||||||
|
#[subsection Concepts] |
||||||
|
#[para] - |
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
## Requirements |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[subsection dependencies] |
||||||
|
#[para] packages used by punk::packagepreference |
||||||
|
#[list_begin itemized] |
||||||
|
|
||||||
|
package require Tcl 8.6- |
||||||
|
package require commandstack |
||||||
|
#*** !doctools |
||||||
|
#[item] [package {Tcl 8.6}] |
||||||
|
#[item] [package {commandstack}] |
||||||
|
|
||||||
|
# #package require frobz |
||||||
|
# #*** !doctools |
||||||
|
# #[item] [package {frobz}] |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[list_end] |
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
#*** !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 |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
tcl::namespace::eval punk::packagepreference { |
||||||
|
tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase |
||||||
|
#variable xyz |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[subsection {Namespace punk::packagepreference}] |
||||||
|
#[para] Core API functions for punk::packagepreference |
||||||
|
#[list_begin definitions] |
||||||
|
|
||||||
|
proc uninstall {} { |
||||||
|
#*** !doctools |
||||||
|
#[call [fun uninstall]] |
||||||
|
#[para]Return to the previous ::package implementation (This will be the builtin if no other override was present when install was called) |
||||||
|
|
||||||
|
commandstack::remove_rename {::package punk::packagepreference} |
||||||
|
} |
||||||
|
proc install {} { |
||||||
|
#*** !doctools |
||||||
|
#[call [fun install]] |
||||||
|
#[para]Override ::package builtin (or the current implementation if it has already been renamed/overridden) to check for and prefer lowercase packages/modules |
||||||
|
#[para]The overriding package command will call whatever implementation was in place before install to do the actual work - once it has modified 'package require' names to lowercase. |
||||||
|
#[para]This is intended to be in alignment with tip 590 "Recommend lowercase Package Names" |
||||||
|
#[para] https://core.tcl-lang.org/tips/doc/trunk/tip/590.md |
||||||
|
#[para]It prevents some loading errors when multiple package versions are available to an interpreter and the latest version is only provided by a lowercased module (.tm file) |
||||||
|
#[para]A package provided by the standard pkgIndex.tcl mechanism might override a later-versioned package because it may support both upper and lowercased names. |
||||||
|
#[para]The overriding of ::package only looks at 'package require' calls and preferentially tries the lowercase version (if the package isn't already loaded with either upper or lowercase name) |
||||||
|
#[para]This comes at some slight cost for packages that are only available with uppercase letters in the name - but at minimal cost for recommended lowercase package names |
||||||
|
#[para]Return to the standard ::package builtin by calling punk::packagepreference::uninstall |
||||||
|
|
||||||
|
#todo - review/update commandstack package |
||||||
|
#modern module/lib names should preferably be lower case |
||||||
|
#see tip 590 - "Recommend lowercase Package names". Where non-lowercase are deprecated (but not removed even in Tcl9) |
||||||
|
#Mixed case causes problems esp on windows where we can't have Package.tm and package.tm as they aren't distinguishable. |
||||||
|
#We enforce package to try lowercase first - at some potentially significant speed penalty if the lib actually does use uppercase |
||||||
|
#(also just overloading the package builtin comes at a cost!) |
||||||
|
#Without the lowercase-first mechanism - a lower versioned package such as Tablelist provided by a pkgIndex.tcl may be loaded in precedence to a higher versioned tablelist provided by a .tm |
||||||
|
#As punk kits launched with dev first arg may use tcl::tm::paths coming from both the system and zipkits for example - this is a problem. |
||||||
|
#(or in any environment where multiple versions of Tcl libraries may be available) |
||||||
|
#We can't provide a modernised .tm package for an old package that is commonly used with uppercase letters, in both the old form and lowercased form from a single .tm file. |
||||||
|
#It could be done by providing a redirecting .tm in a separate module path, or by providing a packageIndex.tcl to redirect it but both these solutions are error prone from a sysops perspective. |
||||||
|
set stackrecord [commandstack::rename_command -renamer punk::packagepreference package {args} { |
||||||
|
#::package override installed by punk::packagepreference::install |
||||||
|
#return to previous 'package' implementation with: punk::packagepreference::uninstall |
||||||
|
|
||||||
|
#uglier but faster than tcl::prefix::match in this instance |
||||||
|
#maintenance - check no prefixes of require are added to builtin package command |
||||||
|
switch -exact -- [lindex $args 0] { |
||||||
|
r - re - req - requi - requir - require { |
||||||
|
#puts "==>package $args" |
||||||
|
#puts "==>[info level 1]" |
||||||
|
#despite preference for lowercase - we need to handle packages that insist on providing as uppercase |
||||||
|
#(e.g we will still need to handle things like: package provide Tcl 8.6) |
||||||
|
#Where the package is already provided uppercase we shouldn't waste time deferring to lowercase |
||||||
|
if {[lindex $args 1] eq "-exact"} { |
||||||
|
set pkg [lindex $args 2] |
||||||
|
set vwant [lindex $args 3] |
||||||
|
if {[set ver [package provide $pkg]] ne ""} { |
||||||
|
if {$ver eq $vwant} { |
||||||
|
return $vwant |
||||||
|
} else { |
||||||
|
#package already provided with a different version.. we will defer to underlying implementation to return the standard error |
||||||
|
return [$COMMANDSTACKNEXT {*}$args] |
||||||
|
} |
||||||
|
} |
||||||
|
} else { |
||||||
|
set pkg [lindex $args 1] |
||||||
|
if {[set ver [package provide $pkg]] ne ""} { |
||||||
|
return $ver |
||||||
|
} |
||||||
|
} |
||||||
|
if {[regexp {[A-Z]} $pkg]} { |
||||||
|
#only apply catch & retry if there was a cap - otherwise we'll double try for errors unrelated to capitalisation |
||||||
|
if {[catch {$COMMANDSTACKNEXT {*}[string tolower $args]} v]} { |
||||||
|
return [$COMMANDSTACKNEXT {*}$args] |
||||||
|
} else { |
||||||
|
return $v |
||||||
|
} |
||||||
|
} else { |
||||||
|
return [$COMMANDSTACKNEXT {*}$args] |
||||||
|
} |
||||||
|
} |
||||||
|
default { |
||||||
|
return [$COMMANDSTACKNEXT {*}$args] |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
}] |
||||||
|
if {[dict get $stackrecord implementation] ne ""} { |
||||||
|
set impl [dict get $stackrecord implementation] ;#use hardcoded name rather than slower (but more flexible) commandstack::get_next_command |
||||||
|
puts stdout "punk::packagepreference renamed ::package to $impl" |
||||||
|
} else { |
||||||
|
puts stderr "punk::packagepreference failed to rename ::package" |
||||||
|
} |
||||||
|
#puts stdout [info body ::package] |
||||||
|
} |
||||||
|
|
||||||
|
#proc sample1 {p1 n args} { |
||||||
|
# #*** !doctools |
||||||
|
# #[call [fun sample1] [arg p1] [arg n] [opt {option value...}]] |
||||||
|
# #[para]Description of sample1 |
||||||
|
# #[para] Arguments: |
||||||
|
# # [list_begin arguments] |
||||||
|
# # [arg_def tring p1] A description of string argument p1. |
||||||
|
# # [arg_def integer n] A description of integer argument n. |
||||||
|
# # [list_end] |
||||||
|
# return "ok" |
||||||
|
#} |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[list_end] [comment {--- end definitions namespace punk::packagepreference ---}] |
||||||
|
} |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# Secondary API namespace |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
tcl::namespace::eval punk::packagepreference::lib { |
||||||
|
tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase |
||||||
|
tcl::namespace::path [tcl::namespace::parent] |
||||||
|
#*** !doctools |
||||||
|
#[subsection {Namespace punk::packagepreference::lib}] |
||||||
|
#[para] Secondary functions that are part of the API |
||||||
|
#[list_begin definitions] |
||||||
|
|
||||||
|
#proc utility1 {p1 args} { |
||||||
|
# #*** !doctools |
||||||
|
# #[call lib::[fun utility1] [arg p1] [opt {?option value...?}]] |
||||||
|
# #[para]Description of utility1 |
||||||
|
# return 1 |
||||||
|
#} |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[list_end] [comment {--- end definitions namespace punk::packagepreference::lib ---}] |
||||||
|
} |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
#*** !doctools |
||||||
|
#[section Internal] |
||||||
|
#tcl::namespace::eval punk::packagepreference::system { |
||||||
|
#*** !doctools |
||||||
|
#[subsection {Namespace punk::packagepreference::system}] |
||||||
|
#[para] Internal functions that are not part of the API |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
#} |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
## Ready |
||||||
|
package provide punk::packagepreference [tcl::namespace::eval punk::packagepreference { |
||||||
|
variable pkg punk::packagepreference |
||||||
|
variable version |
||||||
|
set version 0.1.0 |
||||||
|
}] |
||||||
|
return |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[manpage_end] |
||||||
|
|
||||||
@ -0,0 +1,512 @@ |
|||||||
|
|
||||||
|
|
||||||
|
#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 |
||||||
|
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. |
||||||
|
#<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." |
||||||
|
} 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)" |
||||||
|
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}} { |
||||||
|
#review - probably don't need a warning anyway |
||||||
|
puts stderr "(commandstack::rename_command) WARNING - Something may have 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 { |
||||||
|
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 {[package provide punk::lib] ne ""} { |
||||||
|
return [punk::lib::pdict -channel none all_stacks $commandname_glob/@*/@*.@*] |
||||||
|
} else { |
||||||
|
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]] |
||||||
|
} |
||||||
|
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.3 |
||||||
|
}] |
||||||
|
|
||||||
|
|
||||||
@ -0,0 +1,267 @@ |
|||||||
|
# -*- tcl -*- |
||||||
|
# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'pmix make' or bin/punkmake to update from <pkg>-buildversion.txt |
||||||
|
# module template: shellspy/src/decktemplates/vendor/punk/modules/template_module-0.0.3.tm |
||||||
|
# |
||||||
|
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. |
||||||
|
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# (C) 2024 |
||||||
|
# |
||||||
|
# @@ Meta Begin |
||||||
|
# Application punk::packagepreference 0.1.0 |
||||||
|
# Meta platform tcl |
||||||
|
# Meta license <unspecified> |
||||||
|
# @@ Meta End |
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# doctools header |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
#*** !doctools |
||||||
|
#[manpage_begin shellspy_module_punk::packagepreference 0 0.1.0] |
||||||
|
#[copyright "2024"] |
||||||
|
#[titledesc {Module API}] [comment {-- Name section and table of contents description --}] |
||||||
|
#[moddesc {-}] [comment {-- Description at end of page heading --}] |
||||||
|
#[require punk::packagepreference] |
||||||
|
#[keywords module] |
||||||
|
#[description] |
||||||
|
#[para] - |
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[section Overview] |
||||||
|
#[para] overview of punk::packagepreference |
||||||
|
#[subsection Concepts] |
||||||
|
#[para] - |
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
## Requirements |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[subsection dependencies] |
||||||
|
#[para] packages used by punk::packagepreference |
||||||
|
#[list_begin itemized] |
||||||
|
|
||||||
|
package require Tcl 8.6- |
||||||
|
package require commandstack |
||||||
|
#*** !doctools |
||||||
|
#[item] [package {Tcl 8.6}] |
||||||
|
#[item] [package {commandstack}] |
||||||
|
|
||||||
|
# #package require frobz |
||||||
|
# #*** !doctools |
||||||
|
# #[item] [package {frobz}] |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[list_end] |
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
#*** !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 |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
tcl::namespace::eval punk::packagepreference { |
||||||
|
tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase |
||||||
|
#variable xyz |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[subsection {Namespace punk::packagepreference}] |
||||||
|
#[para] Core API functions for punk::packagepreference |
||||||
|
#[list_begin definitions] |
||||||
|
|
||||||
|
proc uninstall {} { |
||||||
|
#*** !doctools |
||||||
|
#[call [fun uninstall]] |
||||||
|
#[para]Return to the previous ::package implementation (This will be the builtin if no other override was present when install was called) |
||||||
|
|
||||||
|
commandstack::remove_rename {::package punk::packagepreference} |
||||||
|
} |
||||||
|
proc install {} { |
||||||
|
#*** !doctools |
||||||
|
#[call [fun install]] |
||||||
|
#[para]Override ::package builtin (or the current implementation if it has already been renamed/overridden) to check for and prefer lowercase packages/modules |
||||||
|
#[para]The overriding package command will call whatever implementation was in place before install to do the actual work - once it has modified 'package require' names to lowercase. |
||||||
|
#[para]This is intended to be in alignment with tip 590 "Recommend lowercase Package Names" |
||||||
|
#[para] https://core.tcl-lang.org/tips/doc/trunk/tip/590.md |
||||||
|
#[para]It prevents some loading errors when multiple package versions are available to an interpreter and the latest version is only provided by a lowercased module (.tm file) |
||||||
|
#[para]A package provided by the standard pkgIndex.tcl mechanism might override a later-versioned package because it may support both upper and lowercased names. |
||||||
|
#[para]The overriding of ::package only looks at 'package require' calls and preferentially tries the lowercase version (if the package isn't already loaded with either upper or lowercase name) |
||||||
|
#[para]This comes at some slight cost for packages that are only available with uppercase letters in the name - but at minimal cost for recommended lowercase package names |
||||||
|
#[para]Return to the standard ::package builtin by calling punk::packagepreference::uninstall |
||||||
|
|
||||||
|
#todo - review/update commandstack package |
||||||
|
#modern module/lib names should preferably be lower case |
||||||
|
#see tip 590 - "Recommend lowercase Package names". Where non-lowercase are deprecated (but not removed even in Tcl9) |
||||||
|
#Mixed case causes problems esp on windows where we can't have Package.tm and package.tm as they aren't distinguishable. |
||||||
|
#We enforce package to try lowercase first - at some potentially significant speed penalty if the lib actually does use uppercase |
||||||
|
#(also just overloading the package builtin comes at a cost!) |
||||||
|
#Without the lowercase-first mechanism - a lower versioned package such as Tablelist provided by a pkgIndex.tcl may be loaded in precedence to a higher versioned tablelist provided by a .tm |
||||||
|
#As punk kits launched with dev first arg may use tcl::tm::paths coming from both the system and zipkits for example - this is a problem. |
||||||
|
#(or in any environment where multiple versions of Tcl libraries may be available) |
||||||
|
#We can't provide a modernised .tm package for an old package that is commonly used with uppercase letters, in both the old form and lowercased form from a single .tm file. |
||||||
|
#It could be done by providing a redirecting .tm in a separate module path, or by providing a packageIndex.tcl to redirect it but both these solutions are error prone from a sysops perspective. |
||||||
|
set stackrecord [commandstack::rename_command -renamer punk::packagepreference package {args} { |
||||||
|
#::package override installed by punk::packagepreference::install |
||||||
|
#return to previous 'package' implementation with: punk::packagepreference::uninstall |
||||||
|
|
||||||
|
#uglier but faster than tcl::prefix::match in this instance |
||||||
|
#maintenance - check no prefixes of require are added to builtin package command |
||||||
|
switch -exact -- [lindex $args 0] { |
||||||
|
r - re - req - requi - requir - require { |
||||||
|
#puts "==>package $args" |
||||||
|
#puts "==>[info level 1]" |
||||||
|
#despite preference for lowercase - we need to handle packages that insist on providing as uppercase |
||||||
|
#(e.g we will still need to handle things like: package provide Tcl 8.6) |
||||||
|
#Where the package is already provided uppercase we shouldn't waste time deferring to lowercase |
||||||
|
if {[lindex $args 1] eq "-exact"} { |
||||||
|
set pkg [lindex $args 2] |
||||||
|
set vwant [lindex $args 3] |
||||||
|
if {[set ver [package provide $pkg]] ne ""} { |
||||||
|
if {$ver eq $vwant} { |
||||||
|
return $vwant |
||||||
|
} else { |
||||||
|
#package already provided with a different version.. we will defer to underlying implementation to return the standard error |
||||||
|
return [$COMMANDSTACKNEXT {*}$args] |
||||||
|
} |
||||||
|
} |
||||||
|
} else { |
||||||
|
set pkg [lindex $args 1] |
||||||
|
if {[set ver [package provide $pkg]] ne ""} { |
||||||
|
return $ver |
||||||
|
} |
||||||
|
} |
||||||
|
if {[regexp {[A-Z]} $pkg]} { |
||||||
|
#only apply catch & retry if there was a cap - otherwise we'll double try for errors unrelated to capitalisation |
||||||
|
if {[catch {$COMMANDSTACKNEXT {*}[string tolower $args]} v]} { |
||||||
|
return [$COMMANDSTACKNEXT {*}$args] |
||||||
|
} else { |
||||||
|
return $v |
||||||
|
} |
||||||
|
} else { |
||||||
|
return [$COMMANDSTACKNEXT {*}$args] |
||||||
|
} |
||||||
|
} |
||||||
|
default { |
||||||
|
return [$COMMANDSTACKNEXT {*}$args] |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
}] |
||||||
|
if {[dict get $stackrecord implementation] ne ""} { |
||||||
|
set impl [dict get $stackrecord implementation] ;#use hardcoded name rather than slower (but more flexible) commandstack::get_next_command |
||||||
|
puts stdout "punk::packagepreference renamed ::package to $impl" |
||||||
|
} else { |
||||||
|
puts stderr "punk::packagepreference failed to rename ::package" |
||||||
|
} |
||||||
|
#puts stdout [info body ::package] |
||||||
|
} |
||||||
|
|
||||||
|
#proc sample1 {p1 n args} { |
||||||
|
# #*** !doctools |
||||||
|
# #[call [fun sample1] [arg p1] [arg n] [opt {option value...}]] |
||||||
|
# #[para]Description of sample1 |
||||||
|
# #[para] Arguments: |
||||||
|
# # [list_begin arguments] |
||||||
|
# # [arg_def tring p1] A description of string argument p1. |
||||||
|
# # [arg_def integer n] A description of integer argument n. |
||||||
|
# # [list_end] |
||||||
|
# return "ok" |
||||||
|
#} |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[list_end] [comment {--- end definitions namespace punk::packagepreference ---}] |
||||||
|
} |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# Secondary API namespace |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
tcl::namespace::eval punk::packagepreference::lib { |
||||||
|
tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase |
||||||
|
tcl::namespace::path [tcl::namespace::parent] |
||||||
|
#*** !doctools |
||||||
|
#[subsection {Namespace punk::packagepreference::lib}] |
||||||
|
#[para] Secondary functions that are part of the API |
||||||
|
#[list_begin definitions] |
||||||
|
|
||||||
|
#proc utility1 {p1 args} { |
||||||
|
# #*** !doctools |
||||||
|
# #[call lib::[fun utility1] [arg p1] [opt {?option value...?}]] |
||||||
|
# #[para]Description of utility1 |
||||||
|
# return 1 |
||||||
|
#} |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[list_end] [comment {--- end definitions namespace punk::packagepreference::lib ---}] |
||||||
|
} |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
#*** !doctools |
||||||
|
#[section Internal] |
||||||
|
#tcl::namespace::eval punk::packagepreference::system { |
||||||
|
#*** !doctools |
||||||
|
#[subsection {Namespace punk::packagepreference::system}] |
||||||
|
#[para] Internal functions that are not part of the API |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
#} |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
## Ready |
||||||
|
package provide punk::packagepreference [tcl::namespace::eval punk::packagepreference { |
||||||
|
variable pkg punk::packagepreference |
||||||
|
variable version |
||||||
|
set version 0.1.0 |
||||||
|
}] |
||||||
|
return |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[manpage_end] |
||||||
|
|
||||||
@ -0,0 +1,512 @@ |
|||||||
|
|
||||||
|
|
||||||
|
#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 |
||||||
|
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. |
||||||
|
#<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." |
||||||
|
} 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)" |
||||||
|
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}} { |
||||||
|
#review - probably don't need a warning anyway |
||||||
|
puts stderr "(commandstack::rename_command) WARNING - Something may have 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 { |
||||||
|
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 {[package provide punk::lib] ne ""} { |
||||||
|
return [punk::lib::pdict -channel none all_stacks $commandname_glob/@*/@*.@*] |
||||||
|
} else { |
||||||
|
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]] |
||||||
|
} |
||||||
|
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.3 |
||||||
|
}] |
||||||
|
|
||||||
|
|
||||||
@ -0,0 +1,267 @@ |
|||||||
|
# -*- tcl -*- |
||||||
|
# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'pmix make' or bin/punkmake to update from <pkg>-buildversion.txt |
||||||
|
# module template: shellspy/src/decktemplates/vendor/punk/modules/template_module-0.0.3.tm |
||||||
|
# |
||||||
|
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. |
||||||
|
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# (C) 2024 |
||||||
|
# |
||||||
|
# @@ Meta Begin |
||||||
|
# Application punk::packagepreference 0.1.0 |
||||||
|
# Meta platform tcl |
||||||
|
# Meta license <unspecified> |
||||||
|
# @@ Meta End |
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# doctools header |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
#*** !doctools |
||||||
|
#[manpage_begin shellspy_module_punk::packagepreference 0 0.1.0] |
||||||
|
#[copyright "2024"] |
||||||
|
#[titledesc {Module API}] [comment {-- Name section and table of contents description --}] |
||||||
|
#[moddesc {-}] [comment {-- Description at end of page heading --}] |
||||||
|
#[require punk::packagepreference] |
||||||
|
#[keywords module] |
||||||
|
#[description] |
||||||
|
#[para] - |
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[section Overview] |
||||||
|
#[para] overview of punk::packagepreference |
||||||
|
#[subsection Concepts] |
||||||
|
#[para] - |
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
## Requirements |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[subsection dependencies] |
||||||
|
#[para] packages used by punk::packagepreference |
||||||
|
#[list_begin itemized] |
||||||
|
|
||||||
|
package require Tcl 8.6- |
||||||
|
package require commandstack |
||||||
|
#*** !doctools |
||||||
|
#[item] [package {Tcl 8.6}] |
||||||
|
#[item] [package {commandstack}] |
||||||
|
|
||||||
|
# #package require frobz |
||||||
|
# #*** !doctools |
||||||
|
# #[item] [package {frobz}] |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[list_end] |
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
#*** !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 |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
tcl::namespace::eval punk::packagepreference { |
||||||
|
tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase |
||||||
|
#variable xyz |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[subsection {Namespace punk::packagepreference}] |
||||||
|
#[para] Core API functions for punk::packagepreference |
||||||
|
#[list_begin definitions] |
||||||
|
|
||||||
|
proc uninstall {} { |
||||||
|
#*** !doctools |
||||||
|
#[call [fun uninstall]] |
||||||
|
#[para]Return to the previous ::package implementation (This will be the builtin if no other override was present when install was called) |
||||||
|
|
||||||
|
commandstack::remove_rename {::package punk::packagepreference} |
||||||
|
} |
||||||
|
proc install {} { |
||||||
|
#*** !doctools |
||||||
|
#[call [fun install]] |
||||||
|
#[para]Override ::package builtin (or the current implementation if it has already been renamed/overridden) to check for and prefer lowercase packages/modules |
||||||
|
#[para]The overriding package command will call whatever implementation was in place before install to do the actual work - once it has modified 'package require' names to lowercase. |
||||||
|
#[para]This is intended to be in alignment with tip 590 "Recommend lowercase Package Names" |
||||||
|
#[para] https://core.tcl-lang.org/tips/doc/trunk/tip/590.md |
||||||
|
#[para]It prevents some loading errors when multiple package versions are available to an interpreter and the latest version is only provided by a lowercased module (.tm file) |
||||||
|
#[para]A package provided by the standard pkgIndex.tcl mechanism might override a later-versioned package because it may support both upper and lowercased names. |
||||||
|
#[para]The overriding of ::package only looks at 'package require' calls and preferentially tries the lowercase version (if the package isn't already loaded with either upper or lowercase name) |
||||||
|
#[para]This comes at some slight cost for packages that are only available with uppercase letters in the name - but at minimal cost for recommended lowercase package names |
||||||
|
#[para]Return to the standard ::package builtin by calling punk::packagepreference::uninstall |
||||||
|
|
||||||
|
#todo - review/update commandstack package |
||||||
|
#modern module/lib names should preferably be lower case |
||||||
|
#see tip 590 - "Recommend lowercase Package names". Where non-lowercase are deprecated (but not removed even in Tcl9) |
||||||
|
#Mixed case causes problems esp on windows where we can't have Package.tm and package.tm as they aren't distinguishable. |
||||||
|
#We enforce package to try lowercase first - at some potentially significant speed penalty if the lib actually does use uppercase |
||||||
|
#(also just overloading the package builtin comes at a cost!) |
||||||
|
#Without the lowercase-first mechanism - a lower versioned package such as Tablelist provided by a pkgIndex.tcl may be loaded in precedence to a higher versioned tablelist provided by a .tm |
||||||
|
#As punk kits launched with dev first arg may use tcl::tm::paths coming from both the system and zipkits for example - this is a problem. |
||||||
|
#(or in any environment where multiple versions of Tcl libraries may be available) |
||||||
|
#We can't provide a modernised .tm package for an old package that is commonly used with uppercase letters, in both the old form and lowercased form from a single .tm file. |
||||||
|
#It could be done by providing a redirecting .tm in a separate module path, or by providing a packageIndex.tcl to redirect it but both these solutions are error prone from a sysops perspective. |
||||||
|
set stackrecord [commandstack::rename_command -renamer punk::packagepreference package {args} { |
||||||
|
#::package override installed by punk::packagepreference::install |
||||||
|
#return to previous 'package' implementation with: punk::packagepreference::uninstall |
||||||
|
|
||||||
|
#uglier but faster than tcl::prefix::match in this instance |
||||||
|
#maintenance - check no prefixes of require are added to builtin package command |
||||||
|
switch -exact -- [lindex $args 0] { |
||||||
|
r - re - req - requi - requir - require { |
||||||
|
#puts "==>package $args" |
||||||
|
#puts "==>[info level 1]" |
||||||
|
#despite preference for lowercase - we need to handle packages that insist on providing as uppercase |
||||||
|
#(e.g we will still need to handle things like: package provide Tcl 8.6) |
||||||
|
#Where the package is already provided uppercase we shouldn't waste time deferring to lowercase |
||||||
|
if {[lindex $args 1] eq "-exact"} { |
||||||
|
set pkg [lindex $args 2] |
||||||
|
set vwant [lindex $args 3] |
||||||
|
if {[set ver [package provide $pkg]] ne ""} { |
||||||
|
if {$ver eq $vwant} { |
||||||
|
return $vwant |
||||||
|
} else { |
||||||
|
#package already provided with a different version.. we will defer to underlying implementation to return the standard error |
||||||
|
return [$COMMANDSTACKNEXT {*}$args] |
||||||
|
} |
||||||
|
} |
||||||
|
} else { |
||||||
|
set pkg [lindex $args 1] |
||||||
|
if {[set ver [package provide $pkg]] ne ""} { |
||||||
|
return $ver |
||||||
|
} |
||||||
|
} |
||||||
|
if {[regexp {[A-Z]} $pkg]} { |
||||||
|
#only apply catch & retry if there was a cap - otherwise we'll double try for errors unrelated to capitalisation |
||||||
|
if {[catch {$COMMANDSTACKNEXT {*}[string tolower $args]} v]} { |
||||||
|
return [$COMMANDSTACKNEXT {*}$args] |
||||||
|
} else { |
||||||
|
return $v |
||||||
|
} |
||||||
|
} else { |
||||||
|
return [$COMMANDSTACKNEXT {*}$args] |
||||||
|
} |
||||||
|
} |
||||||
|
default { |
||||||
|
return [$COMMANDSTACKNEXT {*}$args] |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
}] |
||||||
|
if {[dict get $stackrecord implementation] ne ""} { |
||||||
|
set impl [dict get $stackrecord implementation] ;#use hardcoded name rather than slower (but more flexible) commandstack::get_next_command |
||||||
|
puts stdout "punk::packagepreference renamed ::package to $impl" |
||||||
|
} else { |
||||||
|
puts stderr "punk::packagepreference failed to rename ::package" |
||||||
|
} |
||||||
|
#puts stdout [info body ::package] |
||||||
|
} |
||||||
|
|
||||||
|
#proc sample1 {p1 n args} { |
||||||
|
# #*** !doctools |
||||||
|
# #[call [fun sample1] [arg p1] [arg n] [opt {option value...}]] |
||||||
|
# #[para]Description of sample1 |
||||||
|
# #[para] Arguments: |
||||||
|
# # [list_begin arguments] |
||||||
|
# # [arg_def tring p1] A description of string argument p1. |
||||||
|
# # [arg_def integer n] A description of integer argument n. |
||||||
|
# # [list_end] |
||||||
|
# return "ok" |
||||||
|
#} |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[list_end] [comment {--- end definitions namespace punk::packagepreference ---}] |
||||||
|
} |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# Secondary API namespace |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
tcl::namespace::eval punk::packagepreference::lib { |
||||||
|
tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase |
||||||
|
tcl::namespace::path [tcl::namespace::parent] |
||||||
|
#*** !doctools |
||||||
|
#[subsection {Namespace punk::packagepreference::lib}] |
||||||
|
#[para] Secondary functions that are part of the API |
||||||
|
#[list_begin definitions] |
||||||
|
|
||||||
|
#proc utility1 {p1 args} { |
||||||
|
# #*** !doctools |
||||||
|
# #[call lib::[fun utility1] [arg p1] [opt {?option value...?}]] |
||||||
|
# #[para]Description of utility1 |
||||||
|
# return 1 |
||||||
|
#} |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[list_end] [comment {--- end definitions namespace punk::packagepreference::lib ---}] |
||||||
|
} |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
#*** !doctools |
||||||
|
#[section Internal] |
||||||
|
#tcl::namespace::eval punk::packagepreference::system { |
||||||
|
#*** !doctools |
||||||
|
#[subsection {Namespace punk::packagepreference::system}] |
||||||
|
#[para] Internal functions that are not part of the API |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
#} |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
## Ready |
||||||
|
package provide punk::packagepreference [tcl::namespace::eval punk::packagepreference { |
||||||
|
variable pkg punk::packagepreference |
||||||
|
variable version |
||||||
|
set version 0.1.0 |
||||||
|
}] |
||||||
|
return |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[manpage_end] |
||||||
|
|
||||||
@ -1,283 +0,0 @@ |
|||||||
|
|
||||||
|
|
||||||
#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> <renamingpkg>' 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. |
|
||||||
# |
|
||||||
|
|
||||||
namespace eval commandstack { |
|
||||||
variable all_stacks |
|
||||||
variable known_packages [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 IMPLEMENTORPACKAGE_*! 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_IMPLEMENTORPACKAGE {command} { |
|
||||||
if {[llength [uplevel 1 [list info procs $command]]]} { |
|
||||||
#look for *IMPLEMENTORPACKAGE_*! |
|
||||||
set prefix IMPLEMENTORPACKAGE_ |
|
||||||
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 { |
|
||||||
return undetermined |
|
||||||
} |
|
||||||
} |
|
||||||
} |
|
||||||
namespace eval commandstack::renamed_commands {} |
|
||||||
|
|
||||||
proc commandstack::help {} { |
|
||||||
return { |
|
||||||
|
|
||||||
} |
|
||||||
} |
|
||||||
|
|
||||||
proc commandstack::get_stack {command} { |
|
||||||
variable all_stacks |
|
||||||
if {[dict exists $all_stacks $command]} { |
|
||||||
return [dict get $all_stacks $command] |
|
||||||
} else { |
|
||||||
return [list] |
|
||||||
} |
|
||||||
} |
|
||||||
|
|
||||||
|
|
||||||
#get the implementation to which the calling_package 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 commandstack::get_next_command {command calling_package} { |
|
||||||
variable all_stacks |
|
||||||
if {[dict exists $all_stacks $command]} { |
|
||||||
set stack [dict get $all_stacks $command] |
|
||||||
set posn [lsearch -index 1 $stack $calling_package] |
|
||||||
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'" |
|
||||||
} |
|
||||||
} else { |
|
||||||
return $command |
|
||||||
} |
|
||||||
} |
|
||||||
|
|
||||||
|
|
||||||
namespace eval commandstack::work {} |
|
||||||
|
|
||||||
#review. |
|
||||||
#Does <responsible_package> even really need to be a package? Is it it intended to somehow automatically call remove_renaming_package e.g with package forget or unload? |
|
||||||
#currently it checks 'package names' - but <responsible_package> could perhaps be changed to be an arbitrary string representing the renamer? |
|
||||||
proc commandstack::rename_command {command {renamer {}} { |
|
||||||
variable all_stacks |
|
||||||
variable known_packages |
|
||||||
if {$responsible_package ni $known_packages} { |
|
||||||
if {$responsible_package in [package names]} { |
|
||||||
lappend known_packages $responsible_package |
|
||||||
} else { |
|
||||||
error "(commandstack::rename_command) ERROR: package '$responsible_package' not in package names" |
|
||||||
} |
|
||||||
} |
|
||||||
#shift it to the work namespace so we don't pollute global ns |
|
||||||
#review - why? presumably due to use of uplevel 1 script below. |
|
||||||
#alternatively we could string-map the script being uplevelled, or use apply? |
|
||||||
|
|
||||||
set mungedcommand [string map {:: _ns_} $command] |
|
||||||
|
|
||||||
#e.g packageTrace and packageSuppress packages use this convention. |
|
||||||
set next_target ::commandstack::renamed_commands::_originalcommand_${mungedcommand} ;#default is to assume we are the only one playing around with it, but we'll check for known associates too. |
|
||||||
uplevel 1 { |
|
||||||
apply {{command next_target} { |
|
||||||
if {[llength [info procs $command]] || [llength [info commands $next_target]]} { |
|
||||||
#$::commandstack::work::command is not the standard builtin - something has replaced it, could be ourself. |
|
||||||
set ::commandstack::work::implementor_package [::commandstack::util::get_IMPLEMENTORPACKAGE $command] |
|
||||||
#if undetermined/unspecified it could be the latest responsible_package on the stack - but we can't know for sure something else didn't rename it. |
|
||||||
|
|
||||||
if {$::commandstack::work::implementor_package eq $::commandstack::work::responsible_package} { |
|
||||||
#it was us. Assume our job is done. |
|
||||||
#review - same responsible_package can never do multiple rename_command calls for one command? Probably an unlikely requirement (?) |
|
||||||
return |
|
||||||
} elseif {$::commandstack::work::implementor_package in $::commandstack::known_packages} { |
|
||||||
set ::commandstack::work::next_target ::commandstack::renamed_commands::_renamedcommand_${::commandstack::work::mungedcommand}_${::commandstack::work::implementor_package}_version |
|
||||||
rename $::commandstack::work::command $::commandstack::work::next_target |
|
||||||
} elseif {$::commandstack::work::implementor_package in {unspecified undetermined}} { |
|
||||||
puts stderr "(commandstack::rename_command) WARNING - Something has renamed the '$::commandstack::work::command' command. Attempting to cooperate.(untested)" |
|
||||||
set ::commandstack::work::next_target ::commandstack::renamed_commands::_renamedcommand_${::commandstack::work::mungedcommand}_${::commandstack::work::implementor_package}_version |
|
||||||
rename $::commandstack::work::command $::commandstack::work::next_target |
|
||||||
} else { |
|
||||||
puts stderr "(commandstack::rename_command) Warning - pkg:'$::commandstack::work::implementor_package' has renamed the '$::commandstack::work::command' command. Attempting to cooperate. (untested)" |
|
||||||
set ::commandstack::work::next_target ::commandstack::renamed_commands::_renamedcommand_${::commandstack::work::mungedcommand}_${::commandstack::work::implementor_package}_version |
|
||||||
rename $::commandstack::work::command $::commandstack::work::next_target |
|
||||||
} |
|
||||||
} else { |
|
||||||
#_originalcommand_<mungedcommand> |
|
||||||
#assume builtin/original |
|
||||||
set ::commandstack::work::implementor_package original |
|
||||||
rename $::commandstack::work::command $::commandstack::work::next_target |
|
||||||
} |
|
||||||
#There are of course other ways in which $::commandstack::work::command may have been renamed - but we can't detect. |
|
||||||
} } $command $next_target |
|
||||||
} |
|
||||||
|
|
||||||
set debug 1 |
|
||||||
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 $::commandstack::work::next_target" |
|
||||||
} else { |
|
||||||
#assume this is the original |
|
||||||
puts stderr "(commandstack::rename_command) 1st detected rename of command '$command'. Renaming to $::commandstack::work::next_target" |
|
||||||
} |
|
||||||
} |
|
||||||
|
|
||||||
#responsible_package is always first element. (Needs to be searched with lsearch -index 1 ) |
|
||||||
set new_record [dict create\ |
|
||||||
responsible_package $responsible_package\ |
|
||||||
implementor_package $::commandstack::work::implementor_package\ |
|
||||||
next [list ::commandstack::get_next_command $command $responsible_package]\ |
|
||||||
implementation $::commandstack::work::next_target\ |
|
||||||
] |
|
||||||
#review - implementor_package better described as next_implementor ?? |
|
||||||
|
|
||||||
dict lappend all_stacks $command $new_record |
|
||||||
return $new_record |
|
||||||
} |
|
||||||
|
|
||||||
proc commandstack::remove_renaming_package {command responsible_package} { |
|
||||||
variable all_stacks |
|
||||||
variable known_packages |
|
||||||
if {$responsible_package ni $known_packages} { |
|
||||||
error "(commandstack::remove_renaming_package) ERROR: package $responsible_package not in list of known_packages '$known_packages'" |
|
||||||
} |
|
||||||
if {[dict exists $all_stacks $command]} { |
|
||||||
set stack [dict get $all_stacks $command] |
|
||||||
set doomed_posn [lsearch -index 1 $stack $responsible_package] |
|
||||||
if {$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 implementor_package] ne $responsible_package} { |
|
||||||
puts stderr "(commandstack::remove_renaming_package) WARNING: next record on the commandstack didn't record $responsible_package as the implementor_package - not deleting implementation [dict get $rewrite_record implementation]" |
|
||||||
} else { |
|
||||||
uplevel #0 [list rename [dict get $rewrite_record implementation] ""] |
|
||||||
} |
|
||||||
dict set rewrite_record implementor_package [dict get $doomed_record implementor_package] |
|
||||||
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] |
|
||||||
} |
|
||||||
|
|
||||||
#review |
|
||||||
#document when this is to be called. Wiping stacks without undoing renames seems odd. |
|
||||||
proc commandstack::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 commandstack::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] |
|
||||||
} |
|
||||||
} |
|
||||||
} |
|
||||||
proc commandstack::show_stack {{commandname_glob *}} { |
|
||||||
variable all_stacks |
|
||||||
if {[package provide punk::lib] ne ""} { |
|
||||||
return [punk::lib::pdict -channel none all_stacks $commandname_glob/@*/@*.@*] |
|
||||||
} else { |
|
||||||
set result "" |
|
||||||
set matchedkeys [dict keys $all_stacks $commandname_glob] |
|
||||||
set widest [tcl::mathfunc::max {*}[lmap v $matchedkeys {tcl::string::length $v}]] |
|
||||||
set indent [string repeat " " $widest+3] |
|
||||||
set indent2 "${indent} " ;#8 spaces for " i = " where i is 4 wide |
|
||||||
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" |
|
||||||
} |
|
||||||
append result "$k = $v" |
|
||||||
incr j |
|
||||||
} |
|
||||||
incr i |
|
||||||
} |
|
||||||
append result \n |
|
||||||
} |
|
||||||
return $result |
|
||||||
} |
|
||||||
} |
|
||||||
|
|
||||||
package provide commandstack [namespace eval commandstack { |
|
||||||
set version 0.2 |
|
||||||
}] |
|
||||||
|
|
||||||
|
|
||||||
@ -1,218 +0,0 @@ |
|||||||
|
|
||||||
|
|
||||||
#JMN 2021 - Public Domain |
|
||||||
# |
|
||||||
# |
|
||||||
#changes: |
|
||||||
#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. |
|
||||||
# |
|
||||||
package provide commandstack [namespace eval commandstack { |
|
||||||
variable all_stacks |
|
||||||
variable known_packages [list packageTrace packageSuppress] |
|
||||||
if {![info exists all_stacks]} { |
|
||||||
#don't wipe it |
|
||||||
set all_stacks [dict create] |
|
||||||
} |
|
||||||
set version 0.1 |
|
||||||
}] |
|
||||||
|
|
||||||
namespace eval commandstack::util { |
|
||||||
#note - we can't use something like md5 to ID proc body text because we can't 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 IMPLEMENTORPACKAGE_*! 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_IMPLEMENTORPACKAGE {command} { |
|
||||||
if {[llength [uplevel 1 [list info procs $command]]]} { |
|
||||||
#look for *IMPLEMENTORPACKAGE_*! |
|
||||||
set prefix IMPLEMENTORPACKAGE_ |
|
||||||
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 { |
|
||||||
return undetermined |
|
||||||
} |
|
||||||
} |
|
||||||
} |
|
||||||
namespace eval commandstack::renamed_commands {} |
|
||||||
|
|
||||||
proc commandstack::help {} { |
|
||||||
return { |
|
||||||
|
|
||||||
} |
|
||||||
} |
|
||||||
|
|
||||||
proc commandstack::get_stack {command} { |
|
||||||
variable all_stacks |
|
||||||
if {[dict exists $all_stacks $command]} { |
|
||||||
return [dict get $all_stacks $command] |
|
||||||
} else { |
|
||||||
return [list] |
|
||||||
} |
|
||||||
} |
|
||||||
|
|
||||||
|
|
||||||
#get the implementation to which the calling_package originally renamed it, or the implementation it now points to. |
|
||||||
proc commandstack::get_next_command {command calling_package} { |
|
||||||
variable all_stacks |
|
||||||
if {[dict exists $all_stacks $command]} { |
|
||||||
set stack [dict get $all_stacks $command] |
|
||||||
set posn [lsearch -index 1 $stack $calling_package] |
|
||||||
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'" |
|
||||||
} |
|
||||||
} else { |
|
||||||
return $command |
|
||||||
} |
|
||||||
} |
|
||||||
|
|
||||||
|
|
||||||
namespace eval commandstack::work {} |
|
||||||
|
|
||||||
proc commandstack::rename_command {command responsible_package} { |
|
||||||
variable all_stacks |
|
||||||
variable known_packages |
|
||||||
if {$responsible_package ni $known_packages} { |
|
||||||
if {$responsible_package in [package names]} { |
|
||||||
lappend known_packages $responsible_package |
|
||||||
} else { |
|
||||||
error "(commandstack::rename_command) ERROR: package '$responsible_package' not in package names" |
|
||||||
} |
|
||||||
} |
|
||||||
#shift it to the work namespace so we don't pollute global ns |
|
||||||
set ::commandstack::work::responsible_package $responsible_package |
|
||||||
set ::commandstack::work::command $command |
|
||||||
|
|
||||||
#e.g packageTrace and packageSuppress packages use this convention. |
|
||||||
set ::commandstack::work::next_target ::commandstack::renamed_commands::_originalcommand_package ;#default is to assume we are the only one playing around with it, but we'll check for known associates too. |
|
||||||
uplevel 1 { |
|
||||||
if {[llength [info procs $::commandstack::work::command]] || [llength [info commands $::commandstack::work::next_target]]} { |
|
||||||
#$::commandstack::work::command is not the standard builtin - something has replaced it, could be ourself. |
|
||||||
set ::commandstack::work::implementor_package [::commandstack::util::get_IMPLEMENTORPACKAGE $::commandstack::work::command] |
|
||||||
#if undetermined/unspecified it could be the latest responsible_package on the stack - but we can't know for sure something else didn't rename it. |
|
||||||
|
|
||||||
if {$::commandstack::work::implementor_package eq $::commandstack::work::responsible_package} { |
|
||||||
#it was us. Assume our job is done. |
|
||||||
return |
|
||||||
} elseif {$::commandstack::work::implementor_package in $::commandstack::known_packages} { |
|
||||||
set ::commandstack::work::next_target ::commandstack::renamed_commands::_renamedcommand_${::commandstack::work::command}_${::commandstack::work::implementor_package}_version |
|
||||||
rename $::commandstack::work::command $::commandstack::work::next_target |
|
||||||
} elseif {$::commandstack::work::implementor_package in {unspecified undetermined}} { |
|
||||||
puts stderr "(commandstack::rename_command) WARNING - Something has renamed the '$::commandstack::work::command' command. Attempting to cooperate.(untested)" |
|
||||||
set ::commandstack::work::next_target ::commandstack::renamed_commands::_renamedcommand_${::commandstack::work::command}_${::commandstack::work::implementor_package}_version |
|
||||||
rename $::commandstack::work::command $::commandstack::work::next_target |
|
||||||
} else { |
|
||||||
puts stderr "(commandstack::rename_command) Warning - pkg:'$::commandstack::work::implementor_package' has renamed the '$::commandstack::work::command' command. Attempting to cooperate. (untested)" |
|
||||||
set ::commandstack::work::next_target ::commandstack::renamed_commands::_renamedcommand_${::commandstack::work::command}_${::commandstack::work::implementor_package}_version |
|
||||||
rename $::commandstack::work::command $::commandstack::work::next_target |
|
||||||
} |
|
||||||
} else { |
|
||||||
#_originalcommand_package |
|
||||||
#assume builtin/original |
|
||||||
set ::commandstack::work::implementor_package original |
|
||||||
rename $::commandstack::work::command $::commandstack::work::next_target |
|
||||||
} |
|
||||||
#There are of course other ways in which $::commandstack::work::command may have been renamed - but we can't detect. |
|
||||||
} |
|
||||||
|
|
||||||
set debug 1 |
|
||||||
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 $::commandstack::work::next_target" |
|
||||||
} else { |
|
||||||
#assume this is the original |
|
||||||
puts stderr "(commandstack::rename_command) 1st detected rename of command $command. Renaming to $::commandstack::work::next_target" |
|
||||||
} |
|
||||||
} |
|
||||||
|
|
||||||
#responsible_package is always first element. (Needs to be searched with lsearch -index 1 ) |
|
||||||
set new_record [list responsible_package $responsible_package implementor_package $::commandstack::work::implementor_package implementation $::commandstack::work::next_target ] |
|
||||||
dict lappend all_stacks $command $new_record |
|
||||||
return $new_record |
|
||||||
} |
|
||||||
|
|
||||||
proc commandstack::remove_renaming_package {command responsible_package} { |
|
||||||
variable all_stacks |
|
||||||
variable known_packages |
|
||||||
if {$responsible_package ni $known_packages} { |
|
||||||
error "(commandstack::remove_renaming_package) ERROR: package $responsible_package not in list of known_packages '$known_packages'" |
|
||||||
} |
|
||||||
if {[dict exists $all_stacks $command]} { |
|
||||||
set stack [dict get $all_stacks $command] |
|
||||||
set doomed_posn [lsearch -index 1 $stack $responsible_package] |
|
||||||
if {$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 implementor_package] ne $responsible_package} { |
|
||||||
puts stderr "(commandstack::remove_renaming_package) WARNING: next record on the commandstack didn't record $responsible_package as the implementor_package - not deleting implementation [dict get $rewrite_record implementation]" |
|
||||||
} else { |
|
||||||
uplevel #0 [list rename [dict get $rewrite_record implementation] ""] |
|
||||||
} |
|
||||||
dict set rewrite_record implementor_package [dict get $doomed_record implementor_package] |
|
||||||
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 commandstack::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. |
|
||||||
proc commandstack::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] |
|
||||||
} |
|
||||||
} |
|
||||||
} |
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
@ -1,283 +0,0 @@ |
|||||||
|
|
||||||
|
|
||||||
#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> <renamingpkg>' 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. |
|
||||||
# |
|
||||||
|
|
||||||
namespace eval commandstack { |
|
||||||
variable all_stacks |
|
||||||
variable known_packages [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 IMPLEMENTORPACKAGE_*! 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_IMPLEMENTORPACKAGE {command} { |
|
||||||
if {[llength [uplevel 1 [list info procs $command]]]} { |
|
||||||
#look for *IMPLEMENTORPACKAGE_*! |
|
||||||
set prefix IMPLEMENTORPACKAGE_ |
|
||||||
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 { |
|
||||||
return undetermined |
|
||||||
} |
|
||||||
} |
|
||||||
} |
|
||||||
namespace eval commandstack::renamed_commands {} |
|
||||||
|
|
||||||
proc commandstack::help {} { |
|
||||||
return { |
|
||||||
|
|
||||||
} |
|
||||||
} |
|
||||||
|
|
||||||
proc commandstack::get_stack {command} { |
|
||||||
variable all_stacks |
|
||||||
if {[dict exists $all_stacks $command]} { |
|
||||||
return [dict get $all_stacks $command] |
|
||||||
} else { |
|
||||||
return [list] |
|
||||||
} |
|
||||||
} |
|
||||||
|
|
||||||
|
|
||||||
#get the implementation to which the calling_package 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 commandstack::get_next_command {command calling_package} { |
|
||||||
variable all_stacks |
|
||||||
if {[dict exists $all_stacks $command]} { |
|
||||||
set stack [dict get $all_stacks $command] |
|
||||||
set posn [lsearch -index 1 $stack $calling_package] |
|
||||||
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'" |
|
||||||
} |
|
||||||
} else { |
|
||||||
return $command |
|
||||||
} |
|
||||||
} |
|
||||||
|
|
||||||
|
|
||||||
namespace eval commandstack::work {} |
|
||||||
|
|
||||||
#review. |
|
||||||
#Does <responsible_package> even really need to be a package? Is it it intended to somehow automatically call remove_renaming_package e.g with package forget or unload? |
|
||||||
#currently it checks 'package names' - but <responsible_package> could perhaps be changed to be an arbitrary string representing the renamer? |
|
||||||
proc commandstack::rename_command {command {renamer {}} { |
|
||||||
variable all_stacks |
|
||||||
variable known_packages |
|
||||||
if {$responsible_package ni $known_packages} { |
|
||||||
if {$responsible_package in [package names]} { |
|
||||||
lappend known_packages $responsible_package |
|
||||||
} else { |
|
||||||
error "(commandstack::rename_command) ERROR: package '$responsible_package' not in package names" |
|
||||||
} |
|
||||||
} |
|
||||||
#shift it to the work namespace so we don't pollute global ns |
|
||||||
#review - why? presumably due to use of uplevel 1 script below. |
|
||||||
#alternatively we could string-map the script being uplevelled, or use apply? |
|
||||||
|
|
||||||
set mungedcommand [string map {:: _ns_} $command] |
|
||||||
|
|
||||||
#e.g packageTrace and packageSuppress packages use this convention. |
|
||||||
set next_target ::commandstack::renamed_commands::_originalcommand_${mungedcommand} ;#default is to assume we are the only one playing around with it, but we'll check for known associates too. |
|
||||||
uplevel 1 { |
|
||||||
apply {{command next_target} { |
|
||||||
if {[llength [info procs $command]] || [llength [info commands $next_target]]} { |
|
||||||
#$::commandstack::work::command is not the standard builtin - something has replaced it, could be ourself. |
|
||||||
set ::commandstack::work::implementor_package [::commandstack::util::get_IMPLEMENTORPACKAGE $command] |
|
||||||
#if undetermined/unspecified it could be the latest responsible_package on the stack - but we can't know for sure something else didn't rename it. |
|
||||||
|
|
||||||
if {$::commandstack::work::implementor_package eq $::commandstack::work::responsible_package} { |
|
||||||
#it was us. Assume our job is done. |
|
||||||
#review - same responsible_package can never do multiple rename_command calls for one command? Probably an unlikely requirement (?) |
|
||||||
return |
|
||||||
} elseif {$::commandstack::work::implementor_package in $::commandstack::known_packages} { |
|
||||||
set ::commandstack::work::next_target ::commandstack::renamed_commands::_renamedcommand_${::commandstack::work::mungedcommand}_${::commandstack::work::implementor_package}_version |
|
||||||
rename $::commandstack::work::command $::commandstack::work::next_target |
|
||||||
} elseif {$::commandstack::work::implementor_package in {unspecified undetermined}} { |
|
||||||
puts stderr "(commandstack::rename_command) WARNING - Something has renamed the '$::commandstack::work::command' command. Attempting to cooperate.(untested)" |
|
||||||
set ::commandstack::work::next_target ::commandstack::renamed_commands::_renamedcommand_${::commandstack::work::mungedcommand}_${::commandstack::work::implementor_package}_version |
|
||||||
rename $::commandstack::work::command $::commandstack::work::next_target |
|
||||||
} else { |
|
||||||
puts stderr "(commandstack::rename_command) Warning - pkg:'$::commandstack::work::implementor_package' has renamed the '$::commandstack::work::command' command. Attempting to cooperate. (untested)" |
|
||||||
set ::commandstack::work::next_target ::commandstack::renamed_commands::_renamedcommand_${::commandstack::work::mungedcommand}_${::commandstack::work::implementor_package}_version |
|
||||||
rename $::commandstack::work::command $::commandstack::work::next_target |
|
||||||
} |
|
||||||
} else { |
|
||||||
#_originalcommand_<mungedcommand> |
|
||||||
#assume builtin/original |
|
||||||
set ::commandstack::work::implementor_package original |
|
||||||
rename $::commandstack::work::command $::commandstack::work::next_target |
|
||||||
} |
|
||||||
#There are of course other ways in which $::commandstack::work::command may have been renamed - but we can't detect. |
|
||||||
} } $command $next_target |
|
||||||
} |
|
||||||
|
|
||||||
set debug 1 |
|
||||||
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 $::commandstack::work::next_target" |
|
||||||
} else { |
|
||||||
#assume this is the original |
|
||||||
puts stderr "(commandstack::rename_command) 1st detected rename of command '$command'. Renaming to $::commandstack::work::next_target" |
|
||||||
} |
|
||||||
} |
|
||||||
|
|
||||||
#responsible_package is always first element. (Needs to be searched with lsearch -index 1 ) |
|
||||||
set new_record [dict create\ |
|
||||||
responsible_package $responsible_package\ |
|
||||||
implementor_package $::commandstack::work::implementor_package\ |
|
||||||
next [list ::commandstack::get_next_command $command $responsible_package]\ |
|
||||||
implementation $::commandstack::work::next_target\ |
|
||||||
] |
|
||||||
#review - implementor_package better described as next_implementor ?? |
|
||||||
|
|
||||||
dict lappend all_stacks $command $new_record |
|
||||||
return $new_record |
|
||||||
} |
|
||||||
|
|
||||||
proc commandstack::remove_renaming_package {command responsible_package} { |
|
||||||
variable all_stacks |
|
||||||
variable known_packages |
|
||||||
if {$responsible_package ni $known_packages} { |
|
||||||
error "(commandstack::remove_renaming_package) ERROR: package $responsible_package not in list of known_packages '$known_packages'" |
|
||||||
} |
|
||||||
if {[dict exists $all_stacks $command]} { |
|
||||||
set stack [dict get $all_stacks $command] |
|
||||||
set doomed_posn [lsearch -index 1 $stack $responsible_package] |
|
||||||
if {$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 implementor_package] ne $responsible_package} { |
|
||||||
puts stderr "(commandstack::remove_renaming_package) WARNING: next record on the commandstack didn't record $responsible_package as the implementor_package - not deleting implementation [dict get $rewrite_record implementation]" |
|
||||||
} else { |
|
||||||
uplevel #0 [list rename [dict get $rewrite_record implementation] ""] |
|
||||||
} |
|
||||||
dict set rewrite_record implementor_package [dict get $doomed_record implementor_package] |
|
||||||
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] |
|
||||||
} |
|
||||||
|
|
||||||
#review |
|
||||||
#document when this is to be called. Wiping stacks without undoing renames seems odd. |
|
||||||
proc commandstack::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 commandstack::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] |
|
||||||
} |
|
||||||
} |
|
||||||
} |
|
||||||
proc commandstack::show_stack {{commandname_glob *}} { |
|
||||||
variable all_stacks |
|
||||||
if {[package provide punk::lib] ne ""} { |
|
||||||
return [punk::lib::pdict -channel none all_stacks $commandname_glob/@*/@*.@*] |
|
||||||
} else { |
|
||||||
set result "" |
|
||||||
set matchedkeys [dict keys $all_stacks $commandname_glob] |
|
||||||
set widest [tcl::mathfunc::max {*}[lmap v $matchedkeys {tcl::string::length $v}]] |
|
||||||
set indent [string repeat " " $widest+3] |
|
||||||
set indent2 "${indent} " ;#8 spaces for " i = " where i is 4 wide |
|
||||||
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" |
|
||||||
} |
|
||||||
append result "$k = $v" |
|
||||||
incr j |
|
||||||
} |
|
||||||
incr i |
|
||||||
} |
|
||||||
append result \n |
|
||||||
} |
|
||||||
return $result |
|
||||||
} |
|
||||||
} |
|
||||||
|
|
||||||
package provide commandstack [namespace eval commandstack { |
|
||||||
set version 0.2 |
|
||||||
}] |
|
||||||
|
|
||||||
|
|
||||||
Loading…
Reference in new issue