diff --git a/src/bootsupport/modules/commandstack-0.3.tm b/src/bootsupport/modules/commandstack-0.3.tm deleted file mode 100644 index b2561a20..00000000 --- a/src/bootsupport/modules/commandstack-0.3.tm +++ /dev/null @@ -1,518 +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 ' for delegating to command as it was prior to rename -#changes: -#2024 -# - mungecommand to support namespaced commands -# - fix mistake - hardcoded _originalcommand_package -> _originalcommand_ -#2021-09-18 -# - initial version -# - e.g Support cooperation between packageSuppress and packageTrace which both rename the package command -# - They need to be able to load and unload in any order. -# - -#strive for no other package dependencies here. - - -namespace eval commandstack { - variable all_stacks - variable debug - set debug 0 - variable known_renamers [list ::packagetrace ::packageSuppress] - if {![info exists all_stacks]} { - #don't wipe it - set all_stacks [dict create] - } -} - -namespace eval commandstack::util { - #note - we can't use something like md5 to ID proc body text because we don't want to require additional packages. - #We could store the full text of the body to compare - but we need to identify magic strings from cooperating packages such as packageTrace - #A magic comment was chosen as the identifying method. - #The string IMPLEMENTOR_*! is searched for where the text between _ and ! is the name of the package that implemented the proc. - - #return unspecified if the command is a proc with a body but no magic comment ID - #return unknown if the command doesn't have a proc body to analyze - #otherwise return the package name identified in the magic comment - proc get_IMPLEMENTOR {command} { - #assert - command has already been resolved to a namespace ie fully qualified - if {[llength [info procs $command]]} { - #look for *IMPLEMENTOR_*! - set prefix IMPLEMENTOR_ - set suffix "!" - set body [uplevel 1 [list info body $command]] - if {[string match "*$prefix*$suffix*" $body]} { - set prefixposn [string first "$prefix" $body] - set pkgposn [expr {$prefixposn + [string length $prefix]}] - #set suffixposn [string first $suffix [string range $body $pkgposn $pkgposn+60]] - set suffixposn [string first $suffix $body $pkgposn] - return [string range $body $pkgposn $suffixposn-1] - } else { - return unspecified - } - } else { - if {[info commands tcl::info::cmdtype] ne ""} { - #tcl9 and maybe some tcl 8.7s ? - switch -- [tcl::info::cmdtype $command] { - native { - return builtin - } - default { - return undetermined - } - } - } else { - return undetermined - } - } - } -} -namespace eval commandstack::renamed_commands {} -namespace eval commandstack::temp {} ;#where we create proc initially before renaming into place - -namespace eval commandstack { - namespace export {[a-z]*} - proc help {} { - return { - - } - } - - proc debug {{on_off {}}} { - variable debug - if {$on_off eq ""} { - return $debug - } else { - if {[string is boolean -strict $debug]} { - set debug [expr {$on_off && 1}] - return $debug - } - } - } - - proc get_stack {{command ""}} { - variable all_stacks - if {$command eq ""} { - return $all_stacks - } - set command [uplevel 1 [list namespace which $command]] - if {[dict exists $all_stacks $command]} { - return [dict get $all_stacks $command] - } else { - return [list] - } - } - - #get the implementation to which the renamer (renamer is usually calling namespace) originally renamed it, or the implementation it now points to. - #review - performance impact. Possible to use oo for faster dispatch whilst allowing stack re-orgs? - #e.g if renaming builtin 'package' - this command is generally called 'a lot' - proc get_next_command {command renamer tokenid} { - variable all_stacks - if {[dict exists $all_stacks $command]} { - set stack [dict get $all_stacks $command] - #stack is a list of dicts, 1st entry is token { } - set posn [lsearch -index 1 $stack [list $command $renamer $tokenid]] - if {$posn > -1} { - set record [lindex $stack $posn] - return [dict get $record implementation] - } else { - error "(commandstack::get_next_command) ERROR: unable to determine next command for '$command' using token: $command $renamer $tokenid" - } - } else { - return $command - } - } - proc basecall {command args} { - variable all_stacks - set command [uplevel 1 [list namespace which $command]] - if {[dict exists $all_stacks $command]} { - set stack [dict get $all_stacks $command] - if {[llength $stack]} { - set rec1 [lindex $stack 0] - tailcall [dict get $rec1 implementation] {*}$args - } else { - tailcall $command {*}$args - } - } else { - tailcall $command {*}$args - } - } - - - #review. - # defaults to calling namespace - but can be arbitrary string - proc rename_command {args} { - #todo: consider -forcebase 1 or similar to allow this rename to point to bottom of stack (original command) bypassing existing renames - # - need to consider that upon removing, that any remaining rename that was higher on the stack should not also be diverted to the base - but rather to the next lower in the stack - # - if {[lindex $args 0] eq "-renamer"} { - set renamer [lindex $args 1] - set arglist [lrange $args 2 end] - } else { - set renamer "" - set arglist $args - } - if {[llength $arglist] != 3} { - error "commandstack::rename_command usage: rename_command ?-renamer ? command procargs procbody" - } - lassign $arglist command procargs procbody - - set command [uplevel 1 [list namespace which $command]] - set mungedcommand [string map {:: _ns_} $command] - set mungedrenamer [string map {:: _ns_} $renamer] - variable all_stacks - variable known_renamers - variable renamer_command_tokens ;#monotonically increasing int per :: representing number of renames ever done. - if {$renamer eq ""} { - set renamer [uplevel 1 [list namespace current]] - } - if {$renamer ni $known_renamers} { - lappend known_renamers $renamer - dict set renamer_command_tokens [list $renamer $command] 0 - } - - #TODO - reduce emissions to stderr - flag for debug? - - #e.g packageTrace and packageSuppress packages use this convention. - set nextinfo [uplevel 1 [list\ - apply {{command renamer procbody} { - #todo - munge dash so we can make names in renamed_commands separable - # {- _dash_} ? - set mungedcommand [string map {:: _ns_} $command] - set mungedrenamer [string map {:: _ns_} $renamer] - set tokenid [lindex [dict incr renamer_command_tokens [list $renamer $command]] 1] - set next_target ::commandstack::renamed_commands::${mungedcommand}-original-$mungedrenamer-$tokenid ;#default is to assume we are the only one playing around with it, but we'll check for known associates too. - set do_rename 0 - if {[llength [info procs $command]] || [llength [info commands $next_target]]} { - #$command is not the standard builtin - something has replaced it, could be ourself. - set next_implementor [::commandstack::util::get_IMPLEMENTOR $command] - set munged_next_implementor [string map {:: _ns_} $next_implementor] - #if undetermined/unspecified it could be the latest renamer on the stack - but we can't know for sure something else didn't rename it. - if {[dict exists $::commandstack::all_stacks $command]} { - set comstacks [dict get $::commandstack::all_stacks $command] - } else { - set comstacks [list] - } - set this_renamer_previous_entries [lsearch -all -index 3 $comstacks $renamer] ;#index 3 is value for second dict entry - (value for key 'renamer') - if {[llength $this_renamer_previous_entries]} { - if {$next_implementor eq $renamer} { - #previous renamer was us. Rather than assume our job is done.. compare the implementations - #don't rename if immediate predecessor is same code. - #set topstack [lindex $comstacks end] - #set next_impl [dict get $topstack implementation] - set current_body [info body $command] - lassign [commandstack::lib::split_body $current_body] _ current_code - set current_code [string trim $current_code] - set new_code [string trim $procbody] - if {$current_code eq $new_code} { - puts stderr "(commandstack::rename_command) WARNING - renamer '$renamer' has already renamed the '$command' command with same procbody - Aborting rename." - puts stderr [::commandstack::show_stack $command] - } else { - puts stderr "(commandstack::rename_command) WARNING - renamer '$renamer' has already renamed the '$command' command - but appears to be with new code - proceeding." - puts stdout "----------" - puts stdout "$current_code" - puts stdout "----------" - puts stdout "$new_code" - puts stdout "----------" - set next_target ::commandstack::renamed_commands::${mungedcommand}-${munged_next_implementor}-$mungedrenamer-$tokenid - set do_rename 1 - } - } else { - puts stderr "(commandstack::rename_command) WARNING - renamer '$renamer' has already renamed the '$command' command, but is not immediate predecessor - proceeding anyway... (untested)" - puts stderr - set next_target ::commandstack::renamed_commands::${mungedcommand}-${munged_next_implementor}-$mungedrenamer-$tokenid - set do_rename 1 - } - } elseif {$next_implementor in $::commandstack::known_renamers} { - set next_target ::commandstack::renamed_commands::${mungedcommand}-${munged_next_implementor}-$mungedrenamer-$tokenid - set do_rename 1 - } elseif {$next_implementor in {builtin}} { - #native/builtin could still have been renamed - set next_target ::commandstack::renamed_commands::${mungedcommand}_${munged_next_implementor}-$mungedrenamer-$tokenid - set do_rename 1 - } elseif {$next_implementor in {unspecified undetermined}} { - #could be a standard tcl proc, or from application or package - set next_target ::commandstack::renamed_commands::${mungedcommand}_${munged_next_implementor}-$mungedrenamer-$tokenid - set do_rename 1 - } else { - puts stderr "(commandstack::rename_command) Warning - pkg:'$next_implementor' has renamed the '$command' command. Attempting to cooperate. (untested)" - set next_target ::commandstack::renamed_commands::${mungedcommand}_${munged_next_implementor}-$mungedrenamer-$tokenid - set do_rename 1 - } - } else { - #_originalcommand_ - #assume builtin/original - set next_implementor original - #rename $command $next_target - set do_rename 1 - } - #There are of course other ways in which $command may have been renamed - but we can't detect. - set token [list $command $renamer $tokenid] - return [dict create next_target $next_target next_implementor $next_implementor token $token do_rename $do_rename] - } } $command $renamer $procbody] - ] - - - variable debug - if {$debug} { - if {[dict exists $all_stacks $command]} { - set stack [dict get $all_stacks $command] - puts stderr "(commandstack::rename_command) Subsequent rename of command '$command'. (previous renames: [llength $stack]). Renaming to [dict get $nextinfo next_target]" - } else { - #assume this is the original - puts stderr "(commandstack::rename_command) 1st detected rename of command '$command'. Renaming to [dict get $nextinfo next_target]" - } - } - - #token is always first dict entry. (Value needs to be searched with lsearch -index 1 ) - #renamer is always second dict entry (Value needs to be searched with lsearch -index 3) - set new_record [dict create\ - token [dict get $nextinfo token]\ - renamer $renamer\ - next_implementor [dict get $nextinfo next_implementor]\ - next_getter [list ::commandstack::get_next_command {*}[dict get $nextinfo token]]\ - implementation [dict get $nextinfo next_target]\ - ] - if {![dict get $nextinfo do_rename]} { - #review - puts stderr "no rename performed" - return [dict create implementation ""] - } - catch {rename ::commandstack::temp::testproc ""} - set nextinit [string map [list %command% $command %renamer% $renamer %next_getter% [dict get $new_record next_getter] %original_implementation% [dict get $new_record implementation]] { - #IMPLEMENTOR_%renamer%! (mechanism: 'commandstack::rename_command -renamer %renamer% %command% ) - set COMMANDSTACKNEXT_ORIGINAL %original_implementation% ;#informational/debug for overriding proc. - set COMMANDSTACKNEXT [%next_getter%] - ## - }] - set final_procbody "$nextinit$procbody" - #build the proc at a temp location so that if it raises an error we don't adjust the stack or replace the original command - #(e.g due to invalid argument specifiers) - proc ::commandstack::temp::testproc $procargs $final_procbody - uplevel 1 [list rename $command [dict get $nextinfo next_target]] - uplevel 1 [list rename ::commandstack::temp::testproc $command] - dict lappend all_stacks $command $new_record - - - return $new_record - } - - #todo - concept of 'pop' for renamer. Remove topmost entry specific to the renamer - #todo - removal by token to allow renamer to have multiple entries for one command but to remove one that is not the topmost - #todo - removal of all entries pertaining to a particular renamer - #todo - allow restore to bottom-most implementation (original) - regardless of what renamers have cooperated in the stack? - - #remove by token, or by commandname if called from same context as original rename_command - #If only a commandname is supplied, and there were multiple renames from the same context (same -renamer) only the topmost is removed. - #A call to remove_rename with no token or renamer, and from a namespace context which didn't perform a rename will not remove anything. - #similarly a nonexistant token or renamer will not remove anything and will just return the current stack - proc remove_rename {token_or_command} { - if {[llength $token_or_command] == 3} { - #is token - lassign $token_or_command command renamer tokenid - } elseif {[llength $token_or_command] == 2} { - #command and renamer only supplied - lassign $token_or_command command renamer - set tokenid "" - } elseif {[llength $token_or_command] == 1} { - #is command name only - set command $token_or_command - set renamer [uplevel 1 [list namespace current]] - set tokenid "" - } - set command [uplevel 1 [list namespace which $command]] - variable all_stacks - variable known_renamers - if {$renamer ni $known_renamers} { - error "(commandstack::remove_rename) ERROR: renamer $renamer not in list of known_renamers '$known_renamers' for command '$command'. Ensure remove_rename called from same context as rename_command was, or explicitly supply exact token or { }" - } - if {[dict exists $all_stacks $command]} { - set stack [dict get $all_stacks $command] - if {$tokenid ne ""} { - #token_or_command is a token as returned within the rename_command result dictionary - #search first dict value - set doomed_posn [lsearch -index 1 $stack $token_or_command] - } else { - #search second dict value - set matches [lsearch -all -index 3 $stack $renamer] - set doomed_posn [lindex $matches end] ;#we don't have a full token - pop last entry for this renamer - } - if {$doomed_posn ne "" && $doomed_posn > -1} { - set doomed_record [lindex $stack $doomed_posn] - if {[llength $stack] == ($doomed_posn + 1)} { - #last on stack - put the implemenation from the doomed_record back as the actual command - uplevel #0 [list rename $command ""] - uplevel #0 [list rename [dict get $doomed_record implementation] $command] - } elseif {[llength $stack] > ($doomed_posn + 1)} { - #there is at least one more record on the stack - rewrite it to point where the doomed_record pointed - set rewrite_posn [expr {$doomed_posn + 1}] - set rewrite_record [lindex $stack $rewrite_posn] - - if {[dict get $rewrite_record next_implementor] ne $renamer} { - puts stderr "(commandstack::remove_rename) WARNING: next record on the commandstack didn't record '$renamer' as the next_implementor - not deleting implementation [dict get $rewrite_record implementation]" - } else { - uplevel #0 [list rename [dict get $rewrite_record implementation] ""] - } - dict set rewrite_record next_implementor [dict get $doomed_record next_implementor] - #don't update next_getter - it always refers to self - dict set rewrite_record implementation [dict get $doomed_record implementation] - lset stack $rewrite_posn $rewrite_record - dict set all_stacks $command $stack - } - set stack [lreplace $stack $doomed_posn $doomed_posn] - dict set all_stacks $command $stack - - } - return $stack - } - return [list] - } - - proc show_stack {{commandname_glob *}} { - variable all_stacks - if {![regexp {[?*]} $commandname_glob]} { - #if caller is attempting exact match - use the calling context to resolve in case they didn't supply namespace - set commandname_glob [uplevel 1 [list namespace which $commandname_glob]] - } - if {[package provide punk::lib] ne "" && [package provide punk] ne ""} { - #punk pipeline also needed for patterns - return [punk::lib::pdict -channel none all_stacks $commandname_glob/@*/@*.@*] - } else { - set result "" - set matchedkeys [dict keys $all_stacks $commandname_glob] - #don't try to calculate widest on empty list - if {[llength $matchedkeys]} { - set widest [tcl::mathfunc::max {*}[lmap v $matchedkeys {tcl::string::length $v}]] - set indent [string repeat " " [expr {$widest + 3}]] - set indent2 "${indent} " ;#8 spaces for " i = " where i is 4 wide - set padkey [string repeat " " 20] - foreach k $matchedkeys { - append result "$k = " - set i 0 - foreach stackmember [dict get $all_stacks $k] { - if {$i > 0} { - append result "\n$indent" - } - append result [string range "$i " 0 4] " = " - set j 0 - dict for {k v} $stackmember { - if {$j > 0} { - append result "\n$indent2" - } - set displaykey [string range "$k$padkey" 0 20] - append result "$displaykey = $v" - incr j - } - incr i - } - append result \n - } - } - return $result - } - } - - #review - #document when this is to be called. Wiping stacks without undoing renames seems odd. - proc Delete_stack {command} { - variable all_stacks - if {[dict exists $all_stacks $command]} { - dict unset all_stacks $command - return 1 - } else { - return 1 - } - } - - #can be used to temporarily put a stack aside - should manually rename back when done. - #review - document how/when to use. example? intention? - proc Rename_stack {oldname newname} { - variable all_stacks - if {[dict exists $all_stacks $oldname]} { - if {[dict exists $all_stacks $newname]} { - error "(commandstack::rename_stack) cannot rename $oldname to $newname - $newname already exists in stack" - } else { - #set stackval [dict get $all_stacks $oldname] - #dict unset all_stacks $oldname - #dict set all_stacks $newname $stackval - dict set all_stacks $newname [lindex [list [dict get $all_stacks $oldname] [dict unset all_stacks $oldname]] 0] - } - } - } -} - - - - - - - - -namespace eval commandstack::lib { - proc splitx {str {regexp {[\t \r\n]+}}} { - #snarfed from tcllib textutil::splitx to avoid the dependency - # Bugfix 476988 - if {[string length $str] == 0} { - return {} - } - if {[string length $regexp] == 0} { - return [::split $str ""] - } - if {[regexp $regexp {}]} { - return -code error "splitting on regexp \"$regexp\" would cause infinite loop" - } - - set list {} - set start 0 - while {[regexp -start $start -indices -- $regexp $str match submatch]} { - foreach {subStart subEnd} $submatch break - foreach {matchStart matchEnd} $match break - incr matchStart -1 - incr matchEnd - lappend list [string range $str $start $matchStart] - if {$subStart >= $start} { - lappend list [string range $str $subStart $subEnd] - } - set start $matchEnd - } - lappend list [string range $str $start end] - return $list - } - proc split_body {procbody} { - set marker "##" - set header "" - set code "" - set found_marker 0 - foreach ln [split $procbody \n] { - if {!$found_marker} { - if {[string trim $ln] eq $marker} { - set found_marker 1 - } else { - append header $ln \n - } - } else { - append code $ln \n - } - } - if {$found_marker} { - return [list $header $code] - } else { - return [list "" $procbody] - } - } -} - -package provide commandstack [namespace eval commandstack { - set version 0.3 -}] - - diff --git a/src/bootsupport/modules/commandstack-0.4.tm b/src/bootsupport/modules/commandstack-0.4.tm deleted file mode 100644 index 165bd16a..00000000 --- a/src/bootsupport/modules/commandstack-0.4.tm +++ /dev/null @@ -1,525 +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 ' for delegating to command as it was prior to rename -#changes: -#2024 -# - mungecommand to support namespaced commands -# - fix mistake - hardcoded _originalcommand_package -> _originalcommand_ -#2021-09-18 -# - initial version -# - e.g Support cooperation between packageSuppress and packageTrace which both rename the package command -# - They need to be able to load and unload in any order. -# - -#strive for no other package dependencies here. - - -namespace eval commandstack { - variable all_stacks - variable debug - set debug 0 - variable known_renamers [list ::packagetrace ::packageSuppress] - if {![info exists all_stacks]} { - #don't wipe it - set all_stacks [dict create] - } -} - -namespace eval commandstack::util { - #note - we can't use something like md5 to ID proc body text because we don't want to require additional packages. - #We could store the full text of the body to compare - but we need to identify magic strings from cooperating packages such as packageTrace - #A magic comment was chosen as the identifying method. - #The string IMPLEMENTOR_*! is searched for where the text between _ and ! is the name of the package that implemented the proc. - - #return unspecified if the command is a proc with a body but no magic comment ID - #return unknown if the command doesn't have a proc body to analyze - #otherwise return the package name identified in the magic comment - proc get_IMPLEMENTOR {command} { - #assert - command has already been resolved to a namespace ie fully qualified - if {[llength [info procs $command]]} { - #look for *IMPLEMENTOR_*! - set prefix IMPLEMENTOR_ - set suffix "!" - set body [uplevel 1 [list info body $command]] - if {[string match "*$prefix*$suffix*" $body]} { - set prefixposn [string first "$prefix" $body] - set pkgposn [expr {$prefixposn + [string length $prefix]}] - #set suffixposn [string first $suffix [string range $body $pkgposn $pkgposn+60]] - set suffixposn [string first $suffix $body $pkgposn] - return [string range $body $pkgposn $suffixposn-1] - } else { - return unspecified - } - } else { - if {[info commands tcl::info::cmdtype] ne ""} { - #tcl9 and maybe some tcl 8.7s ? - switch -- [tcl::info::cmdtype $command] { - native { - return builtin - } - default { - return undetermined - } - } - } else { - return undetermined - } - } - } -} -namespace eval commandstack::renamed_commands {} -namespace eval commandstack::temp {} ;#where we create proc initially before renaming into place - -namespace eval commandstack { - namespace export {[a-z]*} - proc help {} { - return { - - } - } - - proc debug {{on_off {}}} { - variable debug - if {$on_off eq ""} { - return $debug - } else { - if {[string is boolean -strict $debug]} { - set debug [expr {$on_off && 1}] - return $debug - } - } - } - - proc get_stack {{command ""}} { - variable all_stacks - if {$command eq ""} { - return $all_stacks - } - set command [uplevel 1 [list namespace which $command]] - if {[dict exists $all_stacks $command]} { - return [dict get $all_stacks $command] - } else { - return [list] - } - } - - #get the implementation to which the renamer (renamer is usually calling namespace) originally renamed it, or the implementation it now points to. - #review - performance impact. Possible to use oo for faster dispatch whilst allowing stack re-orgs? - #e.g if renaming builtin 'package' - this command is generally called 'a lot' - proc get_next_command {command renamer tokenid} { - variable all_stacks - if {[dict exists $all_stacks $command]} { - set stack [dict get $all_stacks $command] - #stack is a list of dicts, 1st entry is token { } - set posn [lsearch -index 1 $stack [list $command $renamer $tokenid]] - if {$posn > -1} { - set record [lindex $stack $posn] - return [dict get $record implementation] - } else { - error "(commandstack::get_next_command) ERROR: unable to determine next command for '$command' using token: $command $renamer $tokenid" - } - } else { - return $command - } - } - proc basecall {command args} { - variable all_stacks - set command [uplevel 1 [list namespace which $command]] - if {[dict exists $all_stacks $command]} { - set stack [dict get $all_stacks $command] - if {[llength $stack]} { - set rec1 [lindex $stack 0] - tailcall [dict get $rec1 implementation] {*}$args - } else { - tailcall $command {*}$args - } - } else { - tailcall $command {*}$args - } - } - - - #review. - # defaults to calling namespace - but can be arbitrary string - proc rename_command {args} { - #todo: consider -forcebase 1 or similar to allow this rename to point to bottom of stack (original command) bypassing existing renames - # - need to consider that upon removing, that any remaining rename that was higher on the stack should not also be diverted to the base - but rather to the next lower in the stack - # - if {[lindex $args 0] eq "-renamer"} { - set renamer [lindex $args 1] - set arglist [lrange $args 2 end] - } else { - set renamer "" - set arglist $args - } - if {[llength $arglist] != 3} { - error "commandstack::rename_command usage: rename_command ?-renamer ? command procargs procbody" - } - lassign $arglist command procargs procbody - - set command [uplevel 1 [list namespace which $command]] - if {$command eq ""} { - #review - puts stderr "commandstack::rename_command no rename performed for command '$command' by '$renamer'. command '$command' not found in calling context. Ensure command name is fully qualified or that command exists." - #add something to stack? - return [dict create implementation ""] - } - set mungedcommand [string map {:: _ns_} $command] - set mungedrenamer [string map {:: _ns_} $renamer] - variable all_stacks - variable known_renamers - variable renamer_command_tokens ;#monotonically increasing int per :: representing number of renames ever done. - if {$renamer eq ""} { - set renamer [uplevel 1 [list namespace current]] - } - if {$renamer ni $known_renamers} { - lappend known_renamers $renamer - dict set renamer_command_tokens [list $renamer $command] 0 - } - - #TODO - reduce emissions to stderr - flag for debug? - - #e.g packageTrace and packageSuppress packages use this convention. - set nextinfo [uplevel 1 [list\ - apply {{command renamer procbody} { - #todo - munge dash so we can make names in renamed_commands separable - # {- _dash_} ? - set mungedcommand [string map {:: _ns_} $command] - set mungedrenamer [string map {:: _ns_} $renamer] - set tokenid [lindex [dict incr renamer_command_tokens [list $renamer $command]] 1] - set next_target ::commandstack::renamed_commands::${mungedcommand}-original-$mungedrenamer-$tokenid ;#default is to assume we are the only one playing around with it, but we'll check for known associates too. - set do_rename 0 - if {[llength [info procs $command]] || [llength [info commands $next_target]]} { - #$command is not the standard builtin - something has replaced it, could be ourself. - set next_implementor [::commandstack::util::get_IMPLEMENTOR $command] - set munged_next_implementor [string map {:: _ns_} $next_implementor] - #if undetermined/unspecified it could be the latest renamer on the stack - but we can't know for sure something else didn't rename it. - if {[dict exists $::commandstack::all_stacks $command]} { - set comstacks [dict get $::commandstack::all_stacks $command] - } else { - set comstacks [list] - } - set this_renamer_previous_entries [lsearch -all -index 3 $comstacks $renamer] ;#index 3 is value for second dict entry - (value for key 'renamer') - if {[llength $this_renamer_previous_entries]} { - if {$next_implementor eq $renamer} { - #previous renamer was us. Rather than assume our job is done.. compare the implementations - #don't rename if immediate predecessor is same code. - #set topstack [lindex $comstacks end] - #set next_impl [dict get $topstack implementation] - set current_body [info body $command] - lassign [commandstack::lib::split_body $current_body] _ current_code - set current_code [string trim $current_code] - set new_code [string trim $procbody] - if {$current_code eq $new_code} { - puts stderr "(commandstack::rename_command) WARNING - renamer '$renamer' has already renamed the '$command' command with same procbody - Aborting rename." - puts stderr [::commandstack::show_stack $command] - } else { - puts stderr "(commandstack::rename_command) WARNING - renamer '$renamer' has already renamed the '$command' command - but appears to be with new code - proceeding." - puts stdout "----------" - puts stdout "$current_code" - puts stdout "----------" - puts stdout "$new_code" - puts stdout "----------" - set next_target ::commandstack::renamed_commands::${mungedcommand}-${munged_next_implementor}-$mungedrenamer-$tokenid - set do_rename 1 - } - } else { - puts stderr "(commandstack::rename_command) WARNING - renamer '$renamer' has already renamed the '$command' command, but is not immediate predecessor - proceeding anyway... (untested)" - puts stderr - set next_target ::commandstack::renamed_commands::${mungedcommand}-${munged_next_implementor}-$mungedrenamer-$tokenid - set do_rename 1 - } - } elseif {$next_implementor in $::commandstack::known_renamers} { - set next_target ::commandstack::renamed_commands::${mungedcommand}-${munged_next_implementor}-$mungedrenamer-$tokenid - set do_rename 1 - } elseif {$next_implementor in {builtin}} { - #native/builtin could still have been renamed - set next_target ::commandstack::renamed_commands::${mungedcommand}_${munged_next_implementor}-$mungedrenamer-$tokenid - set do_rename 1 - } elseif {$next_implementor in {unspecified undetermined}} { - #could be a standard tcl proc, or from application or package - set next_target ::commandstack::renamed_commands::${mungedcommand}_${munged_next_implementor}-$mungedrenamer-$tokenid - set do_rename 1 - } else { - puts stderr "(commandstack::rename_command) Warning - pkg:'$next_implementor' has renamed the '$command' command. Attempting to cooperate. (untested)" - set next_target ::commandstack::renamed_commands::${mungedcommand}_${munged_next_implementor}-$mungedrenamer-$tokenid - set do_rename 1 - } - } else { - #_originalcommand_ - #assume builtin/original - set next_implementor original - #rename $command $next_target - set do_rename 1 - } - #There are of course other ways in which $command may have been renamed - but we can't detect. - set token [list $command $renamer $tokenid] - return [dict create next_target $next_target next_implementor $next_implementor token $token do_rename $do_rename] - } } $command $renamer $procbody] - ] - - - variable debug - if {$debug} { - if {[dict exists $all_stacks $command]} { - set stack [dict get $all_stacks $command] - puts stderr "(commandstack::rename_command) Subsequent rename of command '$command'. (previous renames: [llength $stack]). Renaming to [dict get $nextinfo next_target]" - } else { - #assume this is the original - puts stderr "(commandstack::rename_command) 1st detected rename of command '$command'. Renaming to [dict get $nextinfo next_target]" - } - } - - #token is always first dict entry. (Value needs to be searched with lsearch -index 1 ) - #renamer is always second dict entry (Value needs to be searched with lsearch -index 3) - set new_record [dict create\ - token [dict get $nextinfo token]\ - renamer $renamer\ - next_implementor [dict get $nextinfo next_implementor]\ - next_getter [list ::commandstack::get_next_command {*}[dict get $nextinfo token]]\ - implementation [dict get $nextinfo next_target]\ - ] - if {![dict get $nextinfo do_rename]} { - #review - puts stderr "commandstack::rename_command no rename performed for command '$command' by '$renamer'" - #add something to stack? - return [dict create implementation ""] - } - catch {rename ::commandstack::temp::testproc ""} - set nextinit [string map [list %command% $command %renamer% $renamer %next_getter% [dict get $new_record next_getter] %original_implementation% [dict get $new_record implementation]] { - #IMPLEMENTOR_%renamer%! (mechanism: 'commandstack::rename_command -renamer %renamer% %command% ) - set COMMANDSTACKNEXT_ORIGINAL %original_implementation% ;#informational/debug for overriding proc. - set COMMANDSTACKNEXT [%next_getter%] - ## - }] - set final_procbody "$nextinit$procbody" - #build the proc at a temp location so that if it raises an error we don't adjust the stack or replace the original command - #(e.g due to invalid argument specifiers) - proc ::commandstack::temp::testproc $procargs $final_procbody - uplevel 1 [list rename $command [dict get $nextinfo next_target]] - uplevel 1 [list rename ::commandstack::temp::testproc $command] - dict lappend all_stacks $command $new_record - - - return $new_record - } - - #todo - concept of 'pop' for renamer. Remove topmost entry specific to the renamer - #todo - removal by token to allow renamer to have multiple entries for one command but to remove one that is not the topmost - #todo - removal of all entries pertaining to a particular renamer - #todo - allow restore to bottom-most implementation (original) - regardless of what renamers have cooperated in the stack? - - #remove by token, or by commandname if called from same context as original rename_command - #If only a commandname is supplied, and there were multiple renames from the same context (same -renamer) only the topmost is removed. - #A call to remove_rename with no token or renamer, and from a namespace context which didn't perform a rename will not remove anything. - #similarly a nonexistant token or renamer will not remove anything and will just return the current stack - proc remove_rename {token_or_command} { - if {[llength $token_or_command] == 3} { - #is token - lassign $token_or_command command renamer tokenid - } elseif {[llength $token_or_command] == 2} { - #command and renamer only supplied - lassign $token_or_command command renamer - set tokenid "" - } elseif {[llength $token_or_command] == 1} { - #is command name only - set command $token_or_command - set renamer [uplevel 1 [list namespace current]] - set tokenid "" - } - set command [uplevel 1 [list namespace which $command]] - variable all_stacks - variable known_renamers - if {$renamer ni $known_renamers} { - error "(commandstack::remove_rename) ERROR: renamer $renamer not in list of known_renamers '$known_renamers' for command '$command'. Ensure remove_rename called from same context as rename_command was, or explicitly supply exact token or { }" - } - if {[dict exists $all_stacks $command]} { - set stack [dict get $all_stacks $command] - if {$tokenid ne ""} { - #token_or_command is a token as returned within the rename_command result dictionary - #search first dict value - set doomed_posn [lsearch -index 1 $stack $token_or_command] - } else { - #search second dict value - set matches [lsearch -all -index 3 $stack $renamer] - set doomed_posn [lindex $matches end] ;#we don't have a full token - pop last entry for this renamer - } - if {$doomed_posn ne "" && $doomed_posn > -1} { - set doomed_record [lindex $stack $doomed_posn] - if {[llength $stack] == ($doomed_posn + 1)} { - #last on stack - put the implemenation from the doomed_record back as the actual command - uplevel #0 [list rename $command ""] - uplevel #0 [list rename [dict get $doomed_record implementation] $command] - } elseif {[llength $stack] > ($doomed_posn + 1)} { - #there is at least one more record on the stack - rewrite it to point where the doomed_record pointed - set rewrite_posn [expr {$doomed_posn + 1}] - set rewrite_record [lindex $stack $rewrite_posn] - - if {[dict get $rewrite_record next_implementor] ne $renamer} { - puts stderr "(commandstack::remove_rename) WARNING: next record on the commandstack didn't record '$renamer' as the next_implementor - not deleting implementation [dict get $rewrite_record implementation]" - } else { - uplevel #0 [list rename [dict get $rewrite_record implementation] ""] - } - dict set rewrite_record next_implementor [dict get $doomed_record next_implementor] - #don't update next_getter - it always refers to self - dict set rewrite_record implementation [dict get $doomed_record implementation] - lset stack $rewrite_posn $rewrite_record - dict set all_stacks $command $stack - } - set stack [lreplace $stack $doomed_posn $doomed_posn] - dict set all_stacks $command $stack - - } - return $stack - } - return [list] - } - - proc show_stack {{commandname_glob *}} { - variable all_stacks - if {![regexp {[?*]} $commandname_glob]} { - #if caller is attempting exact match - use the calling context to resolve in case they didn't supply namespace - set commandname_glob [uplevel 1 [list namespace which $commandname_glob]] - } - if {[package provide punk::lib] ne "" && [package provide punk] ne ""} { - #punk pipeline also needed for patterns - return [punk::lib::pdict -channel none all_stacks $commandname_glob/@*/@*.@*] - } else { - set result "" - set matchedkeys [dict keys $all_stacks $commandname_glob] - #don't try to calculate widest on empty list - if {[llength $matchedkeys]} { - set widest [tcl::mathfunc::max {*}[lmap v $matchedkeys {tcl::string::length $v}]] - set indent [string repeat " " [expr {$widest + 3}]] - set indent2 "${indent} " ;#8 spaces for " i = " where i is 4 wide - set padkey [string repeat " " 20] - foreach k $matchedkeys { - append result "$k = " - set i 0 - foreach stackmember [dict get $all_stacks $k] { - if {$i > 0} { - append result "\n$indent" - } - append result [string range "$i " 0 4] " = " - set j 0 - dict for {k v} $stackmember { - if {$j > 0} { - append result "\n$indent2" - } - set displaykey [string range "$k$padkey" 0 20] - append result "$displaykey = $v" - incr j - } - incr i - } - append result \n - } - } - return $result - } - } - - #review - #document when this is to be called. Wiping stacks without undoing renames seems odd. - proc Delete_stack {command} { - variable all_stacks - if {[dict exists $all_stacks $command]} { - dict unset all_stacks $command - return 1 - } else { - return 1 - } - } - - #can be used to temporarily put a stack aside - should manually rename back when done. - #review - document how/when to use. example? intention? - proc Rename_stack {oldname newname} { - variable all_stacks - if {[dict exists $all_stacks $oldname]} { - if {[dict exists $all_stacks $newname]} { - error "(commandstack::rename_stack) cannot rename $oldname to $newname - $newname already exists in stack" - } else { - #set stackval [dict get $all_stacks $oldname] - #dict unset all_stacks $oldname - #dict set all_stacks $newname $stackval - dict set all_stacks $newname [lindex [list [dict get $all_stacks $oldname] [dict unset all_stacks $oldname]] 0] - } - } - } -} - - - - - - - - -namespace eval commandstack::lib { - proc splitx {str {regexp {[\t \r\n]+}}} { - #snarfed from tcllib textutil::splitx to avoid the dependency - # Bugfix 476988 - if {[string length $str] == 0} { - return {} - } - if {[string length $regexp] == 0} { - return [::split $str ""] - } - if {[regexp $regexp {}]} { - return -code error "splitting on regexp \"$regexp\" would cause infinite loop" - } - - set list {} - set start 0 - while {[regexp -start $start -indices -- $regexp $str match submatch]} { - foreach {subStart subEnd} $submatch break - foreach {matchStart matchEnd} $match break - incr matchStart -1 - incr matchEnd - lappend list [string range $str $start $matchStart] - if {$subStart >= $start} { - lappend list [string range $str $subStart $subEnd] - } - set start $matchEnd - } - lappend list [string range $str $start end] - return $list - } - proc split_body {procbody} { - set marker "##" - set header "" - set code "" - set found_marker 0 - foreach ln [split $procbody \n] { - if {!$found_marker} { - if {[string trim $ln] eq $marker} { - set found_marker 1 - } else { - append header $ln \n - } - } else { - append code $ln \n - } - } - if {$found_marker} { - return [list $header $code] - } else { - return [list "" $procbody] - } - } -} - -package provide commandstack [namespace eval commandstack { - set version 0.4 -}] - - diff --git a/src/bootsupport/modules/commandstack-0.6.0.tm b/src/bootsupport/modules/commandstack-0.6.0.tm new file mode 100644 index 00000000..9dece8e5 --- /dev/null +++ b/src/bootsupport/modules/commandstack-0.6.0.tm @@ -0,0 +1,1025 @@ + + +#JMN 2021 - Public Domain +#cooperative command renaming +# +# REVIEW 2024 - code was originally for specific use in packageTrace +# - code should be reviewed for more generic utility. +# - API is obscure and undocumented. +# - unclear if intention was only for builtins +# - consider use of newer 'info cmdtype' - (but need also support for safe interps) +# - oo dispatch features may be a better implementation - especially for allowing undoing command renames in the middle of a stack. +# - document that replacement command should use 'commandstack::get_next_command ' for delegating to command as it was prior to rename +#changes: +#2026-08-03 (hygiene pass - G-160) +# - fix tokenid counter: was incremented on an apply-local variable so it was stuck at 1 - +# tokenids are now unique and monotonic per (renamer,command), so same-renamer re-renames +# dispatch through the full chain and are individually removable by exact token +# - get_next_command resolves tokens via a token->implementation dict (token_implementations) +# instead of scanning the stack list on every dispatch +# - get_IMPLEMENTOR: qualify ::tcl::info::cmdtype in guard and call (the unqualified +# 'info commands' pattern never matched from inside commandstack::util, so the +# 'builtin' classification branch was unreachable) +# - debug validates its argument (clean error for non-boolean) instead of testing the variable +# - informational/warning output is debug-gated (stderr); stray bare 'puts stderr' removed; +# errors remain errors +# - rename records carry a trailing did_rename 0|1 (token/renamer stay 1st/2nd keys - the +# lsearch -index 1 / -index 3 contract is unchanged); no-rename returns are +# {implementation {} did_rename 0} +# - rename_command errors if -renamer appears anywhere but the leading position +# (was silently consumed as a value argument) +# - get_stack tries the raw stacks-dict key before namespace which resolution, so +# Rename_stack-parked stacks are retrievable by key +# - Rename_stack returns 1 (moved) / 0 (no stack) instead of leaking the whole stacks dict +# - Delete_stack errors while the stack still holds live rename records (deleting them +# broke COMMANDSTACKNEXT delegation -> recursion); empty/missing stacks return 1 +# - new delegation helper commandstack::next - equivalent to +# 'uplevel 1 [list $COMMANDSTACKNEXT {*}$args]' from an override body +# - known_renamers defaults reconciled to the vendored packages' actual registration +# strings (packagetrace packagesuppress - were stale ::packagetrace ::packageSuppress) +#2026-08-03 +# - implement commandstack::help overview text (was returning empty string) +# - add PUNKARGS documentation blocks for the API (lazy punk::args registration - no punk::args dependency added) +#2024 +# - mungecommand to support namespaced commands +# - fix mistake - hardcoded _originalcommand_package -> _originalcommand_ +#2021-09-18 +# - initial version +# - e.g Support cooperation between packageSuppress and packageTrace which both rename the package command +# - They need to be able to load and unload in any order. +# + +#strive for no other package dependencies here. + + +namespace eval commandstack { + variable all_stacks + variable debug + set debug 0 + #the strings the vendored cooperating packages actually pass as -renamer + #(reconciled 2026-08-03 - the historical defaults ::packagetrace ::packageSuppress matched no actual registration) + variable known_renamers [list packagetrace packagesuppress] + if {![info exists all_stacks]} { + #don't wipe it + set all_stacks [dict create] + } + variable renamer_command_tokens + if {![info exists renamer_command_tokens]} { + #monotonically increasing int per { } - number of rename_command calls + #that reached the stacking logic (aborted same-body renames consume an id - gaps are fine, + #uniqueness is the contract) + set renamer_command_tokens [dict create] + } + variable token_implementations + if {![info exists token_implementations]} { + #token { } -> implementation command. + #Kept in sync with the stack records by rename_command/remove_rename so that + #get_next_command (called on every invocation of every renamed command) is a + #single dict lookup instead of a stack-list scan. + set token_implementations [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 + namespace eval ::commandstack::argdoc { + lappend PUNKARGS [list { + @id -id ::commandstack::util::get_IMPLEMENTOR + @cmd -name "commandstack::util::get_IMPLEMENTOR" -& + -summary -& + "Identify which package implemented a command's current proc body." -& + -help -& + {Searches the proc body of command for the magic comment + marker IMPLEMENTOR_! (which rename_command adds + automatically, keyed by renamer) and returns the + portion. Returns 'unspecified' for a proc body without the + marker, 'builtin' for a native command when + tcl::info::cmdtype is available (Tcl 8.7+/9), otherwise + 'undetermined'.} + @values -min 1 -max 1 + command -type string -help -& + "Command name - must already be fully qualified." + }] + } + 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 { + #fully qualified guard AND call: 'info commands' pattern namespaces resolve + #relative-only (no global fallback) - the unqualified form never matched from + #inside commandstack::util, making this branch unreachable + 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]*} + + namespace eval argdoc { + lappend PUNKARGS [list { + @id -id ::commandstack::help + @cmd -name "commandstack::help" -& + -summary -& + "Plain-text overview of the commandstack module." -& + -help -& + "Returns a dependency-free plain text overview of the + cooperative command renaming system: the core + rename_command/remove_rename workflow, the COMMANDSTACKNEXT + delegation variables injected into installed proc bodies, + and the inspection commands." + @values -min 0 -max 0 + }] + } + proc help {} { + return {commandstack - cooperative command renaming (stacked command overrides) + + Purpose + Allows multiple packages to override the same command (e.g the ::package + builtin) and to load/unload their overrides in any order. Each override is + recorded on a per-command stack so that removing one re-links the + surrounding entries instead of clobbering them. + + Core workflow + set record [commandstack::rename_command -renamer ] + Renames aside and installs in its place. + The previous implementation is preserved at the command name given by + [dict get $record implementation] (empty string means no rename was + performed). Two variables are pre-set at the top of the installed + proc body: + COMMANDSTACKNEXT - the implementation to delegate to, + re-resolved on every call via + commandstack::get_next_command (so it + stays correct when the stack changes) + COMMANDSTACKNEXT_ORIGINAL - the implementation as at rename time + (static - informational/debug) + A delegating body normally contains: + uplevel 1 [list $COMMANDSTACKNEXT {*}$args] + or equivalently calls the helper: + commandstack::next {*}$args + The record also carries a trailing did_rename 0|1 verdict. + + commandstack::remove_rename + Undo a rename. Accepts the token from the rename record + ([dict get $record token] = { }), + a 2-element { }, or just when called from + the same namespace context that performed the rename. tokenids are + unique per (renamer, command), so any entry - not just the topmost - + is removable by its exact token. + + Inspection + commandstack::get_stack ?command? - rename records (or all stacks; + raw stacks-dict key tried first, + then namespace which resolution) + commandstack::show_stack ?glob? - printable stack display + commandstack::basecall command ?arg ...? - call bottom-of-stack (original) + commandstack::get_next_command command renamer tokenid + - implementation a record points to + commandstack::debug ?on_off? - query/set debug messages + (informational warnings emit only + when enabled; errors always raise) + + Notes + - The renamer string defaults to the calling namespace. + - Cooperating packages are identified by a magic comment in installed proc + bodies: IMPLEMENTOR_! (added automatically by rename_command). + - Per-command detail is registered lazily with punk::args - e.g + `i commandstack::rename_command` in punkshell, or + `punk::args::usage ::commandstack::rename_command` when punk::args is loaded. + + In-tree users: punk::packagepreference, punk::nav::fs, punk (auto_execok), + packagetrace, packagesuppress. +} + } + + namespace eval argdoc { + lappend PUNKARGS [list { + @id -id ::commandstack::debug + @cmd -name "commandstack::debug" -& + -summary -& + "Query or set commandstack debug messaging." -& + -help -& + "With no argument, returns the current debug state (0|1). + With a boolean argument, sets the state and returns it; a + non-boolean argument raises an error naming the on_off + argument. When enabled, rename_command and remove_rename + report progress and informational warnings on stderr - with + debug off (the default) they emit nothing (errors are still + raised as errors)." + @values -min 0 -max 1 + on_off -type boolean -optional 1 -help -& + "New debug state. Omit to query the current state." + }] + } + proc debug {{on_off {}}} { + variable debug + if {$on_off eq ""} { + return $debug + } + if {![string is boolean -strict $on_off]} { + error "(commandstack::debug) ERROR: on_off argument '$on_off' is not a boolean" + } + set debug [expr {$on_off && 1}] + return $debug + } + + namespace eval argdoc { + lappend PUNKARGS [list { + @id -id ::commandstack::get_stack + @cmd -name "commandstack::get_stack" -& + -summary -& + "Return the rename-record stack for a command, or all stacks." -& + -help -& + {With no argument, returns the entire stacks dict keyed by + fully qualified command name - each value a list of rename + records (bottom of stack first). + With a command argument, returns that command's list of + rename records - empty if the command has never been renamed. + The argument is tried as a raw stacks-dict key first (so + records parked under a non-command key by Rename_stack are + retrievable), then resolved with 'namespace which' in the + caller's context. + Each record is a dict with keys in this order: + token renamer next_implementor next_getter implementation did_rename + The leading key order is a contract: cooperating code may + locate records with 'lsearch -index 1' (token value) or + 'lsearch -index 3' (renamer value). Any new keys are appended.} + @values -min 0 -max 1 + command -type string -optional 1 -help -& + "Command name (raw stacks-dict key, else resolved in the + caller's namespace context). + Omit to return the dict of all stacks." + }] + } + proc get_stack {{command ""}} { + variable all_stacks + if {$command eq ""} { + return $all_stacks + } + if {[dict exists $all_stacks $command]} { + #raw key match first - also reaches records parked under a + #non-command key by Rename_stack (namespace which cannot resolve those) + return [dict get $all_stacks $command] + } + set resolved [uplevel 1 [list namespace which $command]] + if {$resolved ne "" && [dict exists $all_stacks $resolved]} { + return [dict get $all_stacks $resolved] + } + 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' + namespace eval argdoc { + lappend PUNKARGS [list { + @id -id ::commandstack::get_next_command + @cmd -name "commandstack::get_next_command" -& + -summary -& + "Resolve the implementation a rename record delegates to." -& + -help -& + {Returns the implementation command to which the stack entry + identified by the token elements (command renamer tokenid) + currently points. Installed override bodies call this on + every invocation (via the pre-set COMMANDSTACKNEXT variable), + so removals from the stack re-route delegation automatically. + Resolution is a single dict lookup on the maintained + token->implementation map (no stack scan), so a known token + resolves even while its stack is parked under another key by + Rename_stack. If the token is unknown and the command has no + stack, command is returned unchanged. An error is raised when + a stack exists but no record matches the token.} + @values -min 3 -max 3 + command -type string -help -& + "Fully qualified command name (first token element)." + renamer -type string -help -& + "Renamer string recorded at rename time (second token element)." + tokenid -type int -help -& + "Token id recorded at rename time (third token element)." + }] + } + proc get_next_command {command renamer tokenid} { + #hot path - called on every invocation of every renamed command (e.g ::package) + #token_implementations is maintained by rename_command/remove_rename so this is + #a single dict lookup rather than an lsearch scan of the stack list + variable token_implementations + if {[dict exists $token_implementations [list $command $renamer $tokenid]]} { + return [dict get $token_implementations [list $command $renamer $tokenid]] + } + variable all_stacks + if {[dict exists $all_stacks $command]} { + error "(commandstack::get_next_command) ERROR: unable to determine next command for '$command' using token: $command $renamer $tokenid" + } + return $command + } + namespace eval argdoc { + lappend PUNKARGS [list { + @id -id ::commandstack::basecall + @cmd -name "commandstack::basecall" -& + -summary -& + "Call the original (bottom-of-stack) implementation of a command." -& + -help -& + {Tailcalls the implementation recorded at the bottom of the + command's rename stack (the original command as it was first + renamed aside), bypassing all stacked overrides. A command + with no rename stack is called directly. The command name is + resolved with 'namespace which' in the caller's context.} + @values -min 1 -max -1 + command -type string -help -& + "Command name (resolved in the caller's namespace context)." + arg -type any -optional 1 -multiple 1 -help -& + "Arguments passed through to the implementation." + }] + } + proc basecall {command args} { + variable all_stacks + set command [uplevel 1 [list namespace which $command]] + if {[dict exists $all_stacks $command]} { + set stack [dict get $all_stacks $command] + if {[llength $stack]} { + set rec1 [lindex $stack 0] + tailcall [dict get $rec1 implementation] {*}$args + } else { + tailcall $command {*}$args + } + } else { + tailcall $command {*}$args + } + } + + + #review. + # defaults to calling namespace - but can be arbitrary string + namespace eval argdoc { + lappend PUNKARGS [list { + @id -id ::commandstack::rename_command + @cmd -name "commandstack::rename_command" -& + -summary -& + "Cooperatively rename a command, stacking the override." -& + -help -& + {Renames command aside (to a name under + ::commandstack::renamed_commands) and installs a proc with + procargs/procbody in its place, recording the operation on + the command's rename stack so overrides from multiple + cooperating packages can be added and removed in any order. + + A header is prepended to procbody which sets two variables: + COMMANDSTACKNEXT - the implementation to delegate + to (re-resolved every call via + commandstack::get_next_command) + COMMANDSTACKNEXT_ORIGINAL - the implementation as at rename + time (static/debug) + A delegating procbody normally contains: + uplevel 1 [list $COMMANDSTACKNEXT {*}$args] + or equivalently calls the helper: + commandstack::next {*}$args + + Returns the new stack record - a dict with keys: + token renamer next_implementor next_getter implementation did_rename + The tokenid (third token element) is unique and monotonic per + (renamer, command) pairing, so repeat renames by the same + renamer are individually addressable. When no rename was + performed (command not found, or this renamer already + installed an identical procbody) the returned dict is + {implementation {} did_rename 0} - consumers may test either + key. Keep the token ({command renamer tokenid}) or the + {command renamer} pair for a later remove_rename. + + The proc is first built at a temp location so a procargs or + procbody compile error raises before the stack or the live + command are touched.} + @opts + -renamer -type string -optional 1 -help -& + "Identity string recorded for this rename - defaults to + the calling namespace. Cooperating packages use their + package/namespace name. Note: this flag is recognised + only as the FIRST argument (manual parse) - appearing + in any later position is an error." + @values -min 3 -max 3 + command -type string -help -& + "Command to rename (resolved with 'namespace which' in + the caller's context - builtins and procs both work)." + procargs -type list -help -& + "Argument list for the replacement proc (commonly {args}, + but any signature matching the target's call pattern)." + procbody -type string -help -& + "Body for the replacement proc. Delegate onward via the + pre-set COMMANDSTACKNEXT variable." + }] + } + 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 {"-renamer" in $arglist} { + error "commandstack::rename_command -renamer is recognised only as the leading argument. usage: rename_command ?-renamer ? command procargs procbody" + } + if {[llength $arglist] != 3} { + error "commandstack::rename_command usage: rename_command ?-renamer ? command procargs procbody" + } + lassign $arglist command procargs procbody + + variable debug + set command [uplevel 1 [list namespace which $command]] + if {$command eq ""} { + if {$debug} { + puts stderr "commandstack::rename_command no rename performed for command '[lindex $arglist 0]' by '$renamer'. command not found in calling context. Ensure command name is fully qualified or that command exists." + } + return [dict create implementation "" did_rename 0] + } + variable all_stacks + variable known_renamers + variable renamer_command_tokens + variable token_implementations + if {$renamer eq ""} { + set renamer [uplevel 1 [list namespace current]] + } + if {$renamer ni $known_renamers} { + lappend known_renamers $renamer + } + #unique monotonic tokenid per (renamer,command) - incremented on the REAL namespace + #variable in this proc frame (the historical in-apply 'dict incr' hit an apply-local + #copy, leaving every tokenid at 1 - duplicate tokens broke dispatch and removal for + #same-renamer re-renames). Aborted renames consume an id - gaps are harmless. + dict incr renamer_command_tokens [list $renamer $command] + set tokenid [dict get $renamer_command_tokens [list $renamer $command]] + + #e.g packageTrace and packageSuppress packages use this convention. + set nextinfo [uplevel 1 [list\ + apply {{command renamer procbody tokenid} { + #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 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} { + if {$::commandstack::debug} { + puts stderr "(commandstack::rename_command) WARNING - renamer '$renamer' has already renamed the '$command' command with same procbody - Aborting rename." + puts stderr [::commandstack::show_stack $command] + } + } else { + if {$::commandstack::debug} { + puts stderr "(commandstack::rename_command) WARNING - renamer '$renamer' has already renamed the '$command' command - but appears to be with new code - proceeding." + puts stderr "----------" + puts stderr "$current_code" + puts stderr "----------" + puts stderr "$new_code" + puts stderr "----------" + } + set next_target ::commandstack::renamed_commands::${mungedcommand}-${munged_next_implementor}-$mungedrenamer-$tokenid + set do_rename 1 + } + } else { + if {$::commandstack::debug} { + 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}} { + #could be a standard tcl proc, or from application or package + set next_target ::commandstack::renamed_commands::${mungedcommand}_${munged_next_implementor}-$mungedrenamer-$tokenid + set do_rename 1 + } else { + if {$::commandstack::debug} { + puts stderr "(commandstack::rename_command) Warning - pkg:'$next_implementor' has renamed the '$command' command. Attempting to cooperate. (untested)" + } + set next_target ::commandstack::renamed_commands::${mungedcommand}_${munged_next_implementor}-$mungedrenamer-$tokenid + set do_rename 1 + } + } else { + #_originalcommand_ + #assume builtin/original + set next_implementor original + #rename $command $next_target + set do_rename 1 + } + #There are of course other ways in which $command may have been renamed - but we can't detect. + set token [list $command $renamer $tokenid] + return [dict create next_target $next_target next_implementor $next_implementor token $token do_rename $do_rename] + } } $command $renamer $procbody $tokenid] + ] + + + 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) + #additive keys (did_rename) must be APPENDED - the leading key order is a contract. + 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]\ + did_rename 1\ + ] + if {![dict get $nextinfo do_rename]} { + if {$debug} { + puts stderr "commandstack::rename_command no rename performed for command '$command' by '$renamer'" + } + return [dict create implementation "" did_rename 0] + } + catch {rename ::commandstack::temp::testproc ""} + set nextinit [string map [list %command% $command %renamer% $renamer %next_getter% [dict get $new_record next_getter] %original_implementation% [dict get $new_record implementation]] { + #IMPLEMENTOR_%renamer%! (mechanism: 'commandstack::rename_command -renamer %renamer% %command% ) + set COMMANDSTACKNEXT_ORIGINAL %original_implementation% ;#informational/debug for overriding proc. + set COMMANDSTACKNEXT [%next_getter%] + ## + }] + set final_procbody "$nextinit$procbody" + #build the proc at a temp location so that if it raises an error we don't adjust the stack or replace the original command + #(e.g due to invalid argument specifiers) + proc ::commandstack::temp::testproc $procargs $final_procbody + uplevel 1 [list rename $command [dict get $nextinfo next_target]] + uplevel 1 [list rename ::commandstack::temp::testproc $command] + dict lappend all_stacks $command $new_record + dict set token_implementations [dict get $nextinfo token] [dict get $nextinfo next_target] + + return $new_record + } + + namespace eval argdoc { + lappend PUNKARGS [list { + @id -id ::commandstack::next + @cmd -name "commandstack::next" -& + -summary -& + "Delegate from an override body to the next implementation on the stack." -& + -help -& + {Convenience delegation helper for proc bodies installed by + rename_command. Called directly from an override body it + resolves the body's pre-set COMMANDSTACKNEXT variable and + invokes that implementation with the given arguments at the + override's caller level - exactly equivalent to the manual + convention: + uplevel 1 [list $COMMANDSTACKNEXT {*}$args] + Returns the implementation's result. An error is raised when + called from a frame without a COMMANDSTACKNEXT variable (i.e + from anywhere other than directly inside an installed + override body). The COMMANDSTACKNEXT variables remain the + primitive interface - existing consumers need not change.} + @values -min 0 -max -1 + arg -type any -optional 1 -multiple 1 -help -& + "Arguments passed through to the next implementation." + }] + } + proc next {args} { + #call directly from a rename_command-installed override body only: + #COMMANDSTACKNEXT is set at the top of such bodies by the injected header + upvar 1 COMMANDSTACKNEXT COMMANDSTACKNEXT + if {![info exists COMMANDSTACKNEXT]} { + error "(commandstack::next) ERROR: no COMMANDSTACKNEXT variable in the calling frame. commandstack::next must be called directly from a proc body installed by commandstack::rename_command" + } + #uplevel 2 = the override's caller frame - same frame the manual + #'uplevel 1 [list $COMMANDSTACKNEXT {*}$args]' convention evaluates in + uplevel 2 [list $COMMANDSTACKNEXT {*}$args] + } + + #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 + namespace eval argdoc { + lappend PUNKARGS [list { + @id -id ::commandstack::remove_rename + @cmd -name "commandstack::remove_rename" -& + -summary -& + "Undo a rename previously made with rename_command." -& + -help -& + {Removes one entry from a command's rename stack, restoring + or re-linking implementations as needed. Entries other than + the topmost can be removed - the entry above is re-pointed at + what the removed entry delegated to (the load/unload-in-any- + order design goal). + + token_or_command is one of: + 3 elements - the exact token from the rename record: + {command renamer tokenid} + 2 elements - {command renamer} - removes that renamer's + topmost entry for the command + 1 element - command name only - renamer defaults to the + calling namespace + The renamer must be known to commandstack (recorded by a + rename_command call) or an error is raised. A token or + renamer with no matching stack entry removes nothing. + Returns the command's stack after the removal (empty list if + the command has no stack).} + @values -min 1 -max 1 + token_or_command -type list -help -& + "Token {command renamer tokenid}, pair {command renamer}, + or bare command name (see -help above)." + }] + } + 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 + variable token_implementations + variable debug + if {$renamer ni $known_renamers} { + error "(commandstack::remove_rename) ERROR: renamer $renamer not in list of known_renamers '$known_renamers' for command '$command'. Ensure remove_rename called from same context as rename_command was, or explicitly supply exact token or { }" + } + if {[dict exists $all_stacks $command]} { + set stack [dict get $all_stacks $command] + if {$tokenid ne ""} { + #token_or_command is a token as returned within the rename_command result dictionary + #search first dict value + set doomed_posn [lsearch -index 1 $stack $token_or_command] + } else { + #search second dict value + set matches [lsearch -all -index 3 $stack $renamer] + set doomed_posn [lindex $matches end] ;#we don't have a full token - pop last entry for this renamer + } + if {$doomed_posn ne "" && $doomed_posn > -1} { + set doomed_record [lindex $stack $doomed_posn] + if {[llength $stack] == ($doomed_posn + 1)} { + #last on stack - put the implemenation from the doomed_record back as the actual command + uplevel #0 [list rename $command ""] + uplevel #0 [list rename [dict get $doomed_record implementation] $command] + } elseif {[llength $stack] > ($doomed_posn + 1)} { + #there is at least one more record on the stack - rewrite it to point where the doomed_record pointed + set rewrite_posn [expr {$doomed_posn + 1}] + set rewrite_record [lindex $stack $rewrite_posn] + + if {[dict get $rewrite_record next_implementor] ne $renamer} { + #anomalous stack state (external interference or historical duplicate + #tokens) - conservatively leave the parked implementation in place + if {$debug} { + 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 + #re-point the rewritten record's token at its new implementation + dict set token_implementations [dict get $rewrite_record token] [dict get $doomed_record implementation] + } + set stack [lreplace $stack $doomed_posn $doomed_posn] + dict set all_stacks $command $stack + dict unset token_implementations [dict get $doomed_record token] + + } + return $stack + } + return [list] + } + + namespace eval argdoc { + lappend PUNKARGS [list { + @id -id ::commandstack::show_stack + @cmd -name "commandstack::show_stack" -& + -summary -& + "Return a printable display of rename stacks." -& + -help -& + {Returns a formatted text display of the rename stacks whose + command names match commandname_glob. An argument without + glob characters is resolved with 'namespace which' in the + caller's context first. When the punk and punk::lib packages + are already loaded the display is rendered with + punk::lib::pdict - otherwise a plain aligned-text fallback is + used. Returns an empty string when nothing matches.} + @values -min 0 -max 1 + commandname_glob -type string -default * -optional 1 -help -& + "Glob pattern (or exact command name) selecting which + command stacks to display." + }] + } + proc show_stack {{commandname_glob *}} { + variable all_stacks + if {![regexp {[?*]} $commandname_glob]} { + #if caller is attempting exact match - use the calling context to resolve in case they didn't supply namespace + set commandname_glob [uplevel 1 [list namespace which $commandname_glob]] + } + if {[package provide punk::lib] ne "" && [package provide punk] ne ""} { + #punk pipeline also needed for patterns + return [punk::lib::pdict -channel none all_stacks $commandname_glob/@*/@*.@*] + } else { + set result "" + set matchedkeys [dict keys $all_stacks $commandname_glob] + #don't try to calculate widest on empty list + if {[llength $matchedkeys]} { + set widest [tcl::mathfunc::max {*}[lmap v $matchedkeys {tcl::string::length $v}]] + set indent [string repeat " " [expr {$widest + 3}]] + set indent2 "${indent} " ;#8 spaces for " i = " where i is 4 wide + set padkey [string repeat " " 20] + foreach k $matchedkeys { + append result "$k = " + set i 0 + foreach stackmember [dict get $all_stacks $k] { + if {$i > 0} { + append result "\n$indent" + } + append result [string range "$i " 0 4] " = " + set j 0 + dict for {k v} $stackmember { + if {$j > 0} { + append result "\n$indent2" + } + set displaykey [string range "$k$padkey" 0 20] + append result "$displaykey = $v" + incr j + } + incr i + } + append result \n + } + } + return $result + } + } + + #review + #document when this is to be called. Wiping stacks without undoing renames seems odd. + namespace eval argdoc { + lappend PUNKARGS [list { + @id -id ::commandstack::Delete_stack + @cmd -name "commandstack::Delete_stack" -& + -summary -& + "Discard a command's rename-stack records (maintenance - unexported)." -& + -help -& + {Removes the command's entry from the stacks dict. An error + is raised when the stack still holds rename records - live + overrides installed by rename_command must be removed with + remove_rename first (deleting the records of a live override + historically broke the COMMANDSTACKNEXT lookup so the next + call recursed to the interp limit). An empty stack entry + (the residue after the last remove_rename) is deleted and 1 + is returned; a command with no stack entry also returns 1. + Not exported - intended for maintenance/experimentation only + (under review).} + @values -min 1 -max 1 + command -type string -help -& + "Stacks-dict key - fully qualified command name or parked + stack name (no resolution is performed)." + }] + } + proc Delete_stack {command} { + variable all_stacks + if {[dict exists $all_stacks $command]} { + set stack [dict get $all_stacks $command] + if {[llength $stack]} { + #records represent live renames - deleting them would break the + #COMMANDSTACKNEXT delegation of the installed overrides (the next + #call would recurse to the interp limit) + error "(commandstack::Delete_stack) ERROR: stack for '$command' still holds [llength $stack] live rename record(s) - remove them with commandstack::remove_rename first" + } + 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? + namespace eval argdoc { + lappend PUNKARGS [list { + @id -id ::commandstack::Rename_stack + @cmd -name "commandstack::Rename_stack" -& + -summary -& + "Re-key a command's rename-stack records (maintenance - unexported)." -& + -help -& + {Moves the stack records stored under oldname to newname in + the stacks dict. No commands are renamed - this only changes + the dict key, e.g to temporarily put a stack aside (rename + back manually when done). Returns 1 when a stack was moved, + 0 when oldname has no stack. An error is raised if newname + already has a stack. get_stack tries its argument as a raw + stacks-dict key first, so parked records are retrievable by + the parked name; COMMANDSTACKNEXT delegation of live + overrides keeps working while parked (token resolution uses + the token->implementation map, not the stacks-dict key). Not + exported - intended for maintenance/experimentation only + (under review).} + @values -min 2 -max 2 + oldname -type string -help -& + "Existing stacks-dict key (no resolution is performed)." + newname -type string -help -& + "New stacks-dict key." + }] + } + proc Rename_stack {oldname newname} { + variable all_stacks + if {![dict exists $all_stacks $oldname]} { + return 0 + } + if {[dict exists $all_stacks $newname]} { + error "(commandstack::rename_stack) cannot rename $oldname to $newname - $newname already exists in stack" + } + dict set all_stacks $newname [dict get $all_stacks $oldname] + dict unset all_stacks $oldname + return 1 + } +} + + + + + + + + +namespace eval commandstack::lib { + namespace eval ::commandstack::argdoc { + lappend PUNKARGS [list { + @id -id ::commandstack::lib::splitx + @cmd -name "commandstack::lib::splitx" -& + -summary -& + "Split a string on a regexp separator." -& + -help -& + {Local copy of tcllib textutil::split::splitx (to avoid the + dependency). Splits str on each match of regexp. A + parenthesised subexpression in regexp includes the separator + match in the result list. An empty regexp splits into + characters. A regexp matching the empty string raises an + 'infinite loop' error.} + @values -min 1 -max 2 + str -type string -help -& + "String to split." + regexp -type string -optional 1 -default {[\t \r\n]+} -help -& + "Separator regular expression." + }] + } + 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 + } + namespace eval ::commandstack::argdoc { + lappend PUNKARGS [list { + @id -id ::commandstack::lib::split_body + @cmd -name "commandstack::lib::split_body" -& + -summary -& + "Split an installed override body into commandstack header and original code." -& + -help -& + {Splits a proc body at the ## marker + line that rename_command embeds between its generated header + (the COMMANDSTACKNEXT setup) and the renamer-supplied + procbody. Returns a 2-element list {header code}. A body + without the marker returns {"" procbody}.} + @values -min 1 -max 1 + procbody -type string -help -& + "Proc body text (e.g from 'info body ')." + }] + } + proc split_body {procbody} { + set marker "##" + set header "" + set code "" + set found_marker 0 + foreach ln [split $procbody \n] { + if {!$found_marker} { + if {[string trim $ln] eq $marker} { + set found_marker 1 + } else { + append header $ln \n + } + } else { + append code $ln \n + } + } + if {$found_marker} { + return [list $header $code] + } else { + return [list "" $procbody] + } + } +} + +namespace eval ::punk::args::register { + #use fully qualified so 8.6 doesn't find existing var in global namespace + #Register namespaces punk::args should scan for PUNKARGS documentation. + #The PUNKARGS metadata here is inert documentation - this module deliberately + #does not depend on (or call) punk::args. + lappend ::punk::args::register::NAMESPACES ::commandstack ::commandstack::argdoc +} + +package provide commandstack [namespace eval commandstack { + set version 0.6.0 +}] + + diff --git a/src/vfs/_vfscommon.vfs/modules/punk/packagepreference-0.2.0.tm b/src/bootsupport/modules/punk/packagepreference-0.2.1.tm similarity index 99% rename from src/vfs/_vfscommon.vfs/modules/punk/packagepreference-0.2.0.tm rename to src/bootsupport/modules/punk/packagepreference-0.2.1.tm index 48713fce..a9ee911a 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/packagepreference-0.2.0.tm +++ b/src/bootsupport/modules/punk/packagepreference-0.2.1.tm @@ -8,7 +8,7 @@ # (C) 2024 # # @@ Meta Begin -# Application punk::packagepreference 0.2.0 +# Application punk::packagepreference 0.2.1 # Meta platform tcl # Meta license # @@ Meta End @@ -18,7 +18,7 @@ # doctools header # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #*** !doctools -#[manpage_begin punkshell_module_punk::packagepreference 0 0.2.0] +#[manpage_begin punkshell_module_punk::packagepreference 0 0.2.1] #[copyright "2024"] #[titledesc {punkshell package/module loading}] [comment {-- Name section and table of contents description --}] #[moddesc {package/module load}] [comment {-- Description at end of page heading --}] @@ -114,7 +114,7 @@ tcl::namespace::eval punk::packagepreference { if {[dict exists $cstack ::package]} { set pstack [dict get $cstack ::package] foreach record $pstack { - if {[dict get $record rename] eq "punk::packagepreference"} { + if {[dict get $record renamer] eq "punk::packagepreference"} { #already installed - silently ignore. return 0 } @@ -512,7 +512,7 @@ namespace eval ::punk::args::register { package provide punk::packagepreference [tcl::namespace::eval punk::packagepreference { variable pkg punk::packagepreference variable version - set version 0.2.0 + set version 0.2.1 }] return diff --git a/src/modules/punk/mix/#modpod-templates-999999.0a1.0/templates/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/include_modules.config b/src/modules/punk/mix/#modpod-templates-999999.0a1.0/templates/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/include_modules.config index 223df580..d446ccc8 100644 --- a/src/modules/punk/mix/#modpod-templates-999999.0a1.0/templates/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/include_modules.config +++ b/src/modules/punk/mix/#modpod-templates-999999.0a1.0/templates/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/include_modules.config @@ -18,7 +18,7 @@ # Files without punkcheck install records are never pruned automatically. # (glob detection: [regexp {[*?\[\]]} $modulematch] in make.tcl bootsupport_localupdate; see also src/bootsupport/AGENTS.md) set bootsupport_modules [list\ - src/vendormodules commandstack\ + modules commandstack\ src/vendormodules cksum\ src/vendormodules cmdline\ src/vendormodules debug\ diff --git a/src/project_layouts/vendor/punk/basic/src/bootsupport/modules/include_modules.config b/src/project_layouts/vendor/punk/basic/src/bootsupport/modules/include_modules.config index 223df580..d446ccc8 100644 --- a/src/project_layouts/vendor/punk/basic/src/bootsupport/modules/include_modules.config +++ b/src/project_layouts/vendor/punk/basic/src/bootsupport/modules/include_modules.config @@ -18,7 +18,7 @@ # Files without punkcheck install records are never pruned automatically. # (glob detection: [regexp {[*?\[\]]} $modulematch] in make.tcl bootsupport_localupdate; see also src/bootsupport/AGENTS.md) set bootsupport_modules [list\ - src/vendormodules commandstack\ + modules commandstack\ src/vendormodules cksum\ src/vendormodules cmdline\ src/vendormodules debug\ diff --git a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/include_modules.config b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/include_modules.config index 223df580..d446ccc8 100644 --- a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/include_modules.config +++ b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/include_modules.config @@ -18,7 +18,7 @@ # Files without punkcheck install records are never pruned automatically. # (glob detection: [regexp {[*?\[\]]} $modulematch] in make.tcl bootsupport_localupdate; see also src/bootsupport/AGENTS.md) set bootsupport_modules [list\ - src/vendormodules commandstack\ + modules commandstack\ src/vendormodules cksum\ src/vendormodules cmdline\ src/vendormodules debug\ diff --git a/src/vfs/_vfscommon.vfs/modules/commandstack-0.4.1.tm b/src/vfs/_vfscommon.vfs/modules/commandstack-0.4.1.tm deleted file mode 100644 index 48166be6..00000000 --- a/src/vfs/_vfscommon.vfs/modules/commandstack-0.4.1.tm +++ /dev/null @@ -1,525 +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 ' for delegating to command as it was prior to rename -#changes: -#2024 -# - mungecommand to support namespaced commands -# - fix mistake - hardcoded _originalcommand_package -> _originalcommand_ -#2021-09-18 -# - initial version -# - e.g Support cooperation between packageSuppress and packageTrace which both rename the package command -# - They need to be able to load and unload in any order. -# - -#strive for no other package dependencies here. - - -namespace eval commandstack { - variable all_stacks - variable debug - set debug 0 - variable known_renamers [list ::packagetrace ::packageSuppress] - if {![info exists all_stacks]} { - #don't wipe it - set all_stacks [dict create] - } -} - -namespace eval commandstack::util { - #note - we can't use something like md5 to ID proc body text because we don't want to require additional packages. - #We could store the full text of the body to compare - but we need to identify magic strings from cooperating packages such as packageTrace - #A magic comment was chosen as the identifying method. - #The string IMPLEMENTOR_*! is searched for where the text between _ and ! is the name of the package that implemented the proc. - - #return unspecified if the command is a proc with a body but no magic comment ID - #return unknown if the command doesn't have a proc body to analyze - #otherwise return the package name identified in the magic comment - proc get_IMPLEMENTOR {command} { - #assert - command has already been resolved to a namespace ie fully qualified - if {[llength [info procs $command]]} { - #look for *IMPLEMENTOR_*! - set prefix IMPLEMENTOR_ - set suffix "!" - set body [uplevel 1 [list info body $command]] - if {[string match "*$prefix*$suffix*" $body]} { - set prefixposn [string first "$prefix" $body] - set pkgposn [expr {$prefixposn + [string length $prefix]}] - #set suffixposn [string first $suffix [string range $body $pkgposn $pkgposn+60]] - set suffixposn [string first $suffix $body $pkgposn] - return [string range $body $pkgposn $suffixposn-1] - } else { - return unspecified - } - } else { - if {[info commands tcl::info::cmdtype] ne ""} { - #tcl9 and maybe some tcl 8.7s ? - switch -- [tcl::info::cmdtype $command] { - native { - return builtin - } - default { - return undetermined - } - } - } else { - return undetermined - } - } - } -} -namespace eval commandstack::renamed_commands {} -namespace eval commandstack::temp {} ;#where we create proc initially before renaming into place - -namespace eval commandstack { - namespace export {[a-z]*} - proc help {} { - return { - - } - } - - proc debug {{on_off {}}} { - variable debug - if {$on_off eq ""} { - return $debug - } else { - if {[string is boolean -strict $debug]} { - set debug [expr {$on_off && 1}] - return $debug - } - } - } - - proc get_stack {{command ""}} { - variable all_stacks - if {$command eq ""} { - return $all_stacks - } - set command [uplevel 1 [list namespace which $command]] - if {[dict exists $all_stacks $command]} { - return [dict get $all_stacks $command] - } else { - return [list] - } - } - - #get the implementation to which the renamer (renamer is usually calling namespace) originally renamed it, or the implementation it now points to. - #review - performance impact. Possible to use oo for faster dispatch whilst allowing stack re-orgs? - #e.g if renaming builtin 'package' - this command is generally called 'a lot' - proc get_next_command {command renamer tokenid} { - variable all_stacks - if {[dict exists $all_stacks $command]} { - set stack [dict get $all_stacks $command] - #stack is a list of dicts, 1st entry is token { } - set posn [lsearch -index 1 $stack [list $command $renamer $tokenid]] - if {$posn > -1} { - set record [lindex $stack $posn] - return [dict get $record implementation] - } else { - error "(commandstack::get_next_command) ERROR: unable to determine next command for '$command' using token: $command $renamer $tokenid" - } - } else { - return $command - } - } - proc basecall {command args} { - variable all_stacks - set command [uplevel 1 [list namespace which $command]] - if {[dict exists $all_stacks $command]} { - set stack [dict get $all_stacks $command] - if {[llength $stack]} { - set rec1 [lindex $stack 0] - tailcall [dict get $rec1 implementation] {*}$args - } else { - tailcall $command {*}$args - } - } else { - tailcall $command {*}$args - } - } - - - #review. - # defaults to calling namespace - but can be arbitrary string - proc rename_command {args} { - #todo: consider -forcebase 1 or similar to allow this rename to point to bottom of stack (original command) bypassing existing renames - # - need to consider that upon removing, that any remaining rename that was higher on the stack should not also be diverted to the base - but rather to the next lower in the stack - # - if {[lindex $args 0] eq "-renamer"} { - set renamer [lindex $args 1] - set arglist [lrange $args 2 end] - } else { - set renamer "" - set arglist $args - } - if {[llength $arglist] != 3} { - error "commandstack::rename_command usage: rename_command ?-renamer ? command procargs procbody" - } - lassign $arglist command procargs procbody - - set command [uplevel 1 [list namespace which $command]] - if {$command eq ""} { - #review - puts stderr "commandstack::rename_command no rename performed for command '$command' by '$renamer'. command '$command' not found in calling context. Ensure command name is fully qualified or that command exists." - #add something to stack? - return [dict create implementation ""] - } - set mungedcommand [string map {:: _ns_} $command] - set mungedrenamer [string map {:: _ns_} $renamer] - variable all_stacks - variable known_renamers - variable renamer_command_tokens ;#monotonically increasing int per :: representing number of renames ever done. - if {$renamer eq ""} { - set renamer [uplevel 1 [list namespace current]] - } - if {$renamer ni $known_renamers} { - lappend known_renamers $renamer - dict set renamer_command_tokens [list $renamer $command] 0 - } - - #TODO - reduce emissions to stderr - flag for debug? - - #e.g packageTrace and packageSuppress packages use this convention. - set nextinfo [uplevel 1 [list\ - apply {{command renamer procbody} { - #todo - munge dash so we can make names in renamed_commands separable - # {- _dash_} ? - set mungedcommand [string map {:: _ns_} $command] - set mungedrenamer [string map {:: _ns_} $renamer] - set tokenid [lindex [dict incr renamer_command_tokens [list $renamer $command]] 1] - set next_target ::commandstack::renamed_commands::${mungedcommand}-original-$mungedrenamer-$tokenid ;#default is to assume we are the only one playing around with it, but we'll check for known associates too. - set do_rename 0 - if {[llength [info procs $command]] || [llength [info commands $next_target]]} { - #$command is not the standard builtin - something has replaced it, could be ourself. - set next_implementor [::commandstack::util::get_IMPLEMENTOR $command] - set munged_next_implementor [string map {:: _ns_} $next_implementor] - #if undetermined/unspecified it could be the latest renamer on the stack - but we can't know for sure something else didn't rename it. - if {[dict exists $::commandstack::all_stacks $command]} { - set comstacks [dict get $::commandstack::all_stacks $command] - } else { - set comstacks [list] - } - set this_renamer_previous_entries [lsearch -all -index 3 $comstacks $renamer] ;#index 3 is value for second dict entry - (value for key 'renamer') - if {[llength $this_renamer_previous_entries]} { - if {$next_implementor eq $renamer} { - #previous renamer was us. Rather than assume our job is done.. compare the implementations - #don't rename if immediate predecessor is same code. - #set topstack [lindex $comstacks end] - #set next_impl [dict get $topstack implementation] - set current_body [info body $command] - lassign [commandstack::lib::split_body $current_body] _ current_code - set current_code [string trim $current_code] - set new_code [string trim $procbody] - if {$current_code eq $new_code} { - puts stderr "(commandstack::rename_command) WARNING - renamer '$renamer' has already renamed the '$command' command with same procbody - Aborting rename." - puts stderr [::commandstack::show_stack $command] - } else { - puts stderr "(commandstack::rename_command) WARNING - renamer '$renamer' has already renamed the '$command' command - but appears to be with new code - proceeding." - puts stdout "----------" - puts stdout "$current_code" - puts stdout "----------" - puts stdout "$new_code" - puts stdout "----------" - set next_target ::commandstack::renamed_commands::${mungedcommand}-${munged_next_implementor}-$mungedrenamer-$tokenid - set do_rename 1 - } - } else { - puts stderr "(commandstack::rename_command) WARNING - renamer '$renamer' has already renamed the '$command' command, but is not immediate predecessor - proceeding anyway... (untested)" - puts stderr - set next_target ::commandstack::renamed_commands::${mungedcommand}-${munged_next_implementor}-$mungedrenamer-$tokenid - set do_rename 1 - } - } elseif {$next_implementor in $::commandstack::known_renamers} { - set next_target ::commandstack::renamed_commands::${mungedcommand}-${munged_next_implementor}-$mungedrenamer-$tokenid - set do_rename 1 - } elseif {$next_implementor in {builtin}} { - #native/builtin could still have been renamed - set next_target ::commandstack::renamed_commands::${mungedcommand}_${munged_next_implementor}-$mungedrenamer-$tokenid - set do_rename 1 - } elseif {$next_implementor in {unspecified undetermined}} { - #could be a standard tcl proc, or from application or package - set next_target ::commandstack::renamed_commands::${mungedcommand}_${munged_next_implementor}-$mungedrenamer-$tokenid - set do_rename 1 - } else { - puts stderr "(commandstack::rename_command) Warning - pkg:'$next_implementor' has renamed the '$command' command. Attempting to cooperate. (untested)" - set next_target ::commandstack::renamed_commands::${mungedcommand}_${munged_next_implementor}-$mungedrenamer-$tokenid - set do_rename 1 - } - } else { - #_originalcommand_ - #assume builtin/original - set next_implementor original - #rename $command $next_target - set do_rename 1 - } - #There are of course other ways in which $command may have been renamed - but we can't detect. - set token [list $command $renamer $tokenid] - return [dict create next_target $next_target next_implementor $next_implementor token $token do_rename $do_rename] - } } $command $renamer $procbody] - ] - - - variable debug - if {$debug} { - if {[dict exists $all_stacks $command]} { - set stack [dict get $all_stacks $command] - puts stderr "(commandstack::rename_command) Subsequent rename of command '$command'. (previous renames: [llength $stack]). Renaming to [dict get $nextinfo next_target]" - } else { - #assume this is the original - puts stderr "(commandstack::rename_command) 1st detected rename of command '$command'. Renaming to [dict get $nextinfo next_target]" - } - } - - #token is always first dict entry. (Value needs to be searched with lsearch -index 1 ) - #renamer is always second dict entry (Value needs to be searched with lsearch -index 3) - set new_record [dict create\ - token [dict get $nextinfo token]\ - renamer $renamer\ - next_implementor [dict get $nextinfo next_implementor]\ - next_getter [list ::commandstack::get_next_command {*}[dict get $nextinfo token]]\ - implementation [dict get $nextinfo next_target]\ - ] - if {![dict get $nextinfo do_rename]} { - #review - puts stderr "commandstack::rename_command no rename performed for command '$command' by '$renamer'" - #add something to stack? - return [dict create implementation ""] - } - catch {rename ::commandstack::temp::testproc ""} - set nextinit [string map [list %command% $command %renamer% $renamer %next_getter% [dict get $new_record next_getter] %original_implementation% [dict get $new_record implementation]] { - #IMPLEMENTOR_%renamer%! (mechanism: 'commandstack::rename_command -renamer %renamer% %command% ) - set COMMANDSTACKNEXT_ORIGINAL %original_implementation% ;#informational/debug for overriding proc. - set COMMANDSTACKNEXT [%next_getter%] - ## - }] - set final_procbody "$nextinit$procbody" - #build the proc at a temp location so that if it raises an error we don't adjust the stack or replace the original command - #(e.g due to invalid argument specifiers) - proc ::commandstack::temp::testproc $procargs $final_procbody - uplevel 1 [list rename $command [dict get $nextinfo next_target]] - uplevel 1 [list rename ::commandstack::temp::testproc $command] - dict lappend all_stacks $command $new_record - - - return $new_record - } - - #todo - concept of 'pop' for renamer. Remove topmost entry specific to the renamer - #todo - removal by token to allow renamer to have multiple entries for one command but to remove one that is not the topmost - #todo - removal of all entries pertaining to a particular renamer - #todo - allow restore to bottom-most implementation (original) - regardless of what renamers have cooperated in the stack? - - #remove by token, or by commandname if called from same context as original rename_command - #If only a commandname is supplied, and there were multiple renames from the same context (same -renamer) only the topmost is removed. - #A call to remove_rename with no token or renamer, and from a namespace context which didn't perform a rename will not remove anything. - #similarly a nonexistant token or renamer will not remove anything and will just return the current stack - proc remove_rename {token_or_command} { - if {[llength $token_or_command] == 3} { - #is token - lassign $token_or_command command renamer tokenid - } elseif {[llength $token_or_command] == 2} { - #command and renamer only supplied - lassign $token_or_command command renamer - set tokenid "" - } elseif {[llength $token_or_command] == 1} { - #is command name only - set command $token_or_command - set renamer [uplevel 1 [list namespace current]] - set tokenid "" - } - set command [uplevel 1 [list namespace which $command]] - variable all_stacks - variable known_renamers - if {$renamer ni $known_renamers} { - error "(commandstack::remove_rename) ERROR: renamer $renamer not in list of known_renamers '$known_renamers' for command '$command'. Ensure remove_rename called from same context as rename_command was, or explicitly supply exact token or { }" - } - if {[dict exists $all_stacks $command]} { - set stack [dict get $all_stacks $command] - if {$tokenid ne ""} { - #token_or_command is a token as returned within the rename_command result dictionary - #search first dict value - set doomed_posn [lsearch -index 1 $stack $token_or_command] - } else { - #search second dict value - set matches [lsearch -all -index 3 $stack $renamer] - set doomed_posn [lindex $matches end] ;#we don't have a full token - pop last entry for this renamer - } - if {$doomed_posn ne "" && $doomed_posn > -1} { - set doomed_record [lindex $stack $doomed_posn] - if {[llength $stack] == ($doomed_posn + 1)} { - #last on stack - put the implemenation from the doomed_record back as the actual command - uplevel #0 [list rename $command ""] - uplevel #0 [list rename [dict get $doomed_record implementation] $command] - } elseif {[llength $stack] > ($doomed_posn + 1)} { - #there is at least one more record on the stack - rewrite it to point where the doomed_record pointed - set rewrite_posn [expr {$doomed_posn + 1}] - set rewrite_record [lindex $stack $rewrite_posn] - - if {[dict get $rewrite_record next_implementor] ne $renamer} { - puts stderr "(commandstack::remove_rename) WARNING: next record on the commandstack didn't record '$renamer' as the next_implementor - not deleting implementation [dict get $rewrite_record implementation]" - } else { - uplevel #0 [list rename [dict get $rewrite_record implementation] ""] - } - dict set rewrite_record next_implementor [dict get $doomed_record next_implementor] - #don't update next_getter - it always refers to self - dict set rewrite_record implementation [dict get $doomed_record implementation] - lset stack $rewrite_posn $rewrite_record - dict set all_stacks $command $stack - } - set stack [lreplace $stack $doomed_posn $doomed_posn] - dict set all_stacks $command $stack - - } - return $stack - } - return [list] - } - - proc show_stack {{commandname_glob *}} { - variable all_stacks - if {![regexp {[?*]} $commandname_glob]} { - #if caller is attempting exact match - use the calling context to resolve in case they didn't supply namespace - set commandname_glob [uplevel 1 [list namespace which $commandname_glob]] - } - if {[package provide punk::lib] ne "" && [package provide punk] ne ""} { - #punk pipeline also needed for patterns - return [punk::lib::pdict -channel none all_stacks $commandname_glob/@*/@*.@*] - } else { - set result "" - set matchedkeys [dict keys $all_stacks $commandname_glob] - #don't try to calculate widest on empty list - if {[llength $matchedkeys]} { - set widest [tcl::mathfunc::max {*}[lmap v $matchedkeys {tcl::string::length $v}]] - set indent [string repeat " " [expr {$widest + 3}]] - set indent2 "${indent} " ;#8 spaces for " i = " where i is 4 wide - set padkey [string repeat " " 20] - foreach k $matchedkeys { - append result "$k = " - set i 0 - foreach stackmember [dict get $all_stacks $k] { - if {$i > 0} { - append result "\n$indent" - } - append result [string range "$i " 0 4] " = " - set j 0 - dict for {k v} $stackmember { - if {$j > 0} { - append result "\n$indent2" - } - set displaykey [string range "$k$padkey" 0 20] - append result "$displaykey = $v" - incr j - } - incr i - } - append result \n - } - } - return $result - } - } - - #review - #document when this is to be called. Wiping stacks without undoing renames seems odd. - proc Delete_stack {command} { - variable all_stacks - if {[dict exists $all_stacks $command]} { - dict unset all_stacks $command - return 1 - } else { - return 1 - } - } - - #can be used to temporarily put a stack aside - should manually rename back when done. - #review - document how/when to use. example? intention? - proc Rename_stack {oldname newname} { - variable all_stacks - if {[dict exists $all_stacks $oldname]} { - if {[dict exists $all_stacks $newname]} { - error "(commandstack::rename_stack) cannot rename $oldname to $newname - $newname already exists in stack" - } else { - #set stackval [dict get $all_stacks $oldname] - #dict unset all_stacks $oldname - #dict set all_stacks $newname $stackval - dict set all_stacks $newname [lindex [list [dict get $all_stacks $oldname] [dict unset all_stacks $oldname]] 0] - } - } - } -} - - - - - - - - -namespace eval commandstack::lib { - proc splitx {str {regexp {[\t \r\n]+}}} { - #snarfed from tcllib textutil::splitx to avoid the dependency - # Bugfix 476988 - if {[string length $str] == 0} { - return {} - } - if {[string length $regexp] == 0} { - return [::split $str ""] - } - if {[regexp $regexp {}]} { - return -code error "splitting on regexp \"$regexp\" would cause infinite loop" - } - - set list {} - set start 0 - while {[regexp -start $start -indices -- $regexp $str match submatch]} { - foreach {subStart subEnd} $submatch break - foreach {matchStart matchEnd} $match break - incr matchStart -1 - incr matchEnd - lappend list [string range $str $start $matchStart] - if {$subStart >= $start} { - lappend list [string range $str $subStart $subEnd] - } - set start $matchEnd - } - lappend list [string range $str $start end] - return $list - } - proc split_body {procbody} { - set marker "##" - set header "" - set code "" - set found_marker 0 - foreach ln [split $procbody \n] { - if {!$found_marker} { - if {[string trim $ln] eq $marker} { - set found_marker 1 - } else { - append header $ln \n - } - } else { - append code $ln \n - } - } - if {$found_marker} { - return [list $header $code] - } else { - return [list "" $procbody] - } - } -} - -package provide commandstack [namespace eval commandstack { - set version 0.4.1 -}] - - diff --git a/src/vfs/_vfscommon.vfs/modules/commandstack-0.6.0.tm b/src/vfs/_vfscommon.vfs/modules/commandstack-0.6.0.tm new file mode 100644 index 00000000..9dece8e5 --- /dev/null +++ b/src/vfs/_vfscommon.vfs/modules/commandstack-0.6.0.tm @@ -0,0 +1,1025 @@ + + +#JMN 2021 - Public Domain +#cooperative command renaming +# +# REVIEW 2024 - code was originally for specific use in packageTrace +# - code should be reviewed for more generic utility. +# - API is obscure and undocumented. +# - unclear if intention was only for builtins +# - consider use of newer 'info cmdtype' - (but need also support for safe interps) +# - oo dispatch features may be a better implementation - especially for allowing undoing command renames in the middle of a stack. +# - document that replacement command should use 'commandstack::get_next_command ' for delegating to command as it was prior to rename +#changes: +#2026-08-03 (hygiene pass - G-160) +# - fix tokenid counter: was incremented on an apply-local variable so it was stuck at 1 - +# tokenids are now unique and monotonic per (renamer,command), so same-renamer re-renames +# dispatch through the full chain and are individually removable by exact token +# - get_next_command resolves tokens via a token->implementation dict (token_implementations) +# instead of scanning the stack list on every dispatch +# - get_IMPLEMENTOR: qualify ::tcl::info::cmdtype in guard and call (the unqualified +# 'info commands' pattern never matched from inside commandstack::util, so the +# 'builtin' classification branch was unreachable) +# - debug validates its argument (clean error for non-boolean) instead of testing the variable +# - informational/warning output is debug-gated (stderr); stray bare 'puts stderr' removed; +# errors remain errors +# - rename records carry a trailing did_rename 0|1 (token/renamer stay 1st/2nd keys - the +# lsearch -index 1 / -index 3 contract is unchanged); no-rename returns are +# {implementation {} did_rename 0} +# - rename_command errors if -renamer appears anywhere but the leading position +# (was silently consumed as a value argument) +# - get_stack tries the raw stacks-dict key before namespace which resolution, so +# Rename_stack-parked stacks are retrievable by key +# - Rename_stack returns 1 (moved) / 0 (no stack) instead of leaking the whole stacks dict +# - Delete_stack errors while the stack still holds live rename records (deleting them +# broke COMMANDSTACKNEXT delegation -> recursion); empty/missing stacks return 1 +# - new delegation helper commandstack::next - equivalent to +# 'uplevel 1 [list $COMMANDSTACKNEXT {*}$args]' from an override body +# - known_renamers defaults reconciled to the vendored packages' actual registration +# strings (packagetrace packagesuppress - were stale ::packagetrace ::packageSuppress) +#2026-08-03 +# - implement commandstack::help overview text (was returning empty string) +# - add PUNKARGS documentation blocks for the API (lazy punk::args registration - no punk::args dependency added) +#2024 +# - mungecommand to support namespaced commands +# - fix mistake - hardcoded _originalcommand_package -> _originalcommand_ +#2021-09-18 +# - initial version +# - e.g Support cooperation between packageSuppress and packageTrace which both rename the package command +# - They need to be able to load and unload in any order. +# + +#strive for no other package dependencies here. + + +namespace eval commandstack { + variable all_stacks + variable debug + set debug 0 + #the strings the vendored cooperating packages actually pass as -renamer + #(reconciled 2026-08-03 - the historical defaults ::packagetrace ::packageSuppress matched no actual registration) + variable known_renamers [list packagetrace packagesuppress] + if {![info exists all_stacks]} { + #don't wipe it + set all_stacks [dict create] + } + variable renamer_command_tokens + if {![info exists renamer_command_tokens]} { + #monotonically increasing int per { } - number of rename_command calls + #that reached the stacking logic (aborted same-body renames consume an id - gaps are fine, + #uniqueness is the contract) + set renamer_command_tokens [dict create] + } + variable token_implementations + if {![info exists token_implementations]} { + #token { } -> implementation command. + #Kept in sync with the stack records by rename_command/remove_rename so that + #get_next_command (called on every invocation of every renamed command) is a + #single dict lookup instead of a stack-list scan. + set token_implementations [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 + namespace eval ::commandstack::argdoc { + lappend PUNKARGS [list { + @id -id ::commandstack::util::get_IMPLEMENTOR + @cmd -name "commandstack::util::get_IMPLEMENTOR" -& + -summary -& + "Identify which package implemented a command's current proc body." -& + -help -& + {Searches the proc body of command for the magic comment + marker IMPLEMENTOR_! (which rename_command adds + automatically, keyed by renamer) and returns the + portion. Returns 'unspecified' for a proc body without the + marker, 'builtin' for a native command when + tcl::info::cmdtype is available (Tcl 8.7+/9), otherwise + 'undetermined'.} + @values -min 1 -max 1 + command -type string -help -& + "Command name - must already be fully qualified." + }] + } + 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 { + #fully qualified guard AND call: 'info commands' pattern namespaces resolve + #relative-only (no global fallback) - the unqualified form never matched from + #inside commandstack::util, making this branch unreachable + 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]*} + + namespace eval argdoc { + lappend PUNKARGS [list { + @id -id ::commandstack::help + @cmd -name "commandstack::help" -& + -summary -& + "Plain-text overview of the commandstack module." -& + -help -& + "Returns a dependency-free plain text overview of the + cooperative command renaming system: the core + rename_command/remove_rename workflow, the COMMANDSTACKNEXT + delegation variables injected into installed proc bodies, + and the inspection commands." + @values -min 0 -max 0 + }] + } + proc help {} { + return {commandstack - cooperative command renaming (stacked command overrides) + + Purpose + Allows multiple packages to override the same command (e.g the ::package + builtin) and to load/unload their overrides in any order. Each override is + recorded on a per-command stack so that removing one re-links the + surrounding entries instead of clobbering them. + + Core workflow + set record [commandstack::rename_command -renamer ] + Renames aside and installs in its place. + The previous implementation is preserved at the command name given by + [dict get $record implementation] (empty string means no rename was + performed). Two variables are pre-set at the top of the installed + proc body: + COMMANDSTACKNEXT - the implementation to delegate to, + re-resolved on every call via + commandstack::get_next_command (so it + stays correct when the stack changes) + COMMANDSTACKNEXT_ORIGINAL - the implementation as at rename time + (static - informational/debug) + A delegating body normally contains: + uplevel 1 [list $COMMANDSTACKNEXT {*}$args] + or equivalently calls the helper: + commandstack::next {*}$args + The record also carries a trailing did_rename 0|1 verdict. + + commandstack::remove_rename + Undo a rename. Accepts the token from the rename record + ([dict get $record token] = { }), + a 2-element { }, or just when called from + the same namespace context that performed the rename. tokenids are + unique per (renamer, command), so any entry - not just the topmost - + is removable by its exact token. + + Inspection + commandstack::get_stack ?command? - rename records (or all stacks; + raw stacks-dict key tried first, + then namespace which resolution) + commandstack::show_stack ?glob? - printable stack display + commandstack::basecall command ?arg ...? - call bottom-of-stack (original) + commandstack::get_next_command command renamer tokenid + - implementation a record points to + commandstack::debug ?on_off? - query/set debug messages + (informational warnings emit only + when enabled; errors always raise) + + Notes + - The renamer string defaults to the calling namespace. + - Cooperating packages are identified by a magic comment in installed proc + bodies: IMPLEMENTOR_! (added automatically by rename_command). + - Per-command detail is registered lazily with punk::args - e.g + `i commandstack::rename_command` in punkshell, or + `punk::args::usage ::commandstack::rename_command` when punk::args is loaded. + + In-tree users: punk::packagepreference, punk::nav::fs, punk (auto_execok), + packagetrace, packagesuppress. +} + } + + namespace eval argdoc { + lappend PUNKARGS [list { + @id -id ::commandstack::debug + @cmd -name "commandstack::debug" -& + -summary -& + "Query or set commandstack debug messaging." -& + -help -& + "With no argument, returns the current debug state (0|1). + With a boolean argument, sets the state and returns it; a + non-boolean argument raises an error naming the on_off + argument. When enabled, rename_command and remove_rename + report progress and informational warnings on stderr - with + debug off (the default) they emit nothing (errors are still + raised as errors)." + @values -min 0 -max 1 + on_off -type boolean -optional 1 -help -& + "New debug state. Omit to query the current state." + }] + } + proc debug {{on_off {}}} { + variable debug + if {$on_off eq ""} { + return $debug + } + if {![string is boolean -strict $on_off]} { + error "(commandstack::debug) ERROR: on_off argument '$on_off' is not a boolean" + } + set debug [expr {$on_off && 1}] + return $debug + } + + namespace eval argdoc { + lappend PUNKARGS [list { + @id -id ::commandstack::get_stack + @cmd -name "commandstack::get_stack" -& + -summary -& + "Return the rename-record stack for a command, or all stacks." -& + -help -& + {With no argument, returns the entire stacks dict keyed by + fully qualified command name - each value a list of rename + records (bottom of stack first). + With a command argument, returns that command's list of + rename records - empty if the command has never been renamed. + The argument is tried as a raw stacks-dict key first (so + records parked under a non-command key by Rename_stack are + retrievable), then resolved with 'namespace which' in the + caller's context. + Each record is a dict with keys in this order: + token renamer next_implementor next_getter implementation did_rename + The leading key order is a contract: cooperating code may + locate records with 'lsearch -index 1' (token value) or + 'lsearch -index 3' (renamer value). Any new keys are appended.} + @values -min 0 -max 1 + command -type string -optional 1 -help -& + "Command name (raw stacks-dict key, else resolved in the + caller's namespace context). + Omit to return the dict of all stacks." + }] + } + proc get_stack {{command ""}} { + variable all_stacks + if {$command eq ""} { + return $all_stacks + } + if {[dict exists $all_stacks $command]} { + #raw key match first - also reaches records parked under a + #non-command key by Rename_stack (namespace which cannot resolve those) + return [dict get $all_stacks $command] + } + set resolved [uplevel 1 [list namespace which $command]] + if {$resolved ne "" && [dict exists $all_stacks $resolved]} { + return [dict get $all_stacks $resolved] + } + 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' + namespace eval argdoc { + lappend PUNKARGS [list { + @id -id ::commandstack::get_next_command + @cmd -name "commandstack::get_next_command" -& + -summary -& + "Resolve the implementation a rename record delegates to." -& + -help -& + {Returns the implementation command to which the stack entry + identified by the token elements (command renamer tokenid) + currently points. Installed override bodies call this on + every invocation (via the pre-set COMMANDSTACKNEXT variable), + so removals from the stack re-route delegation automatically. + Resolution is a single dict lookup on the maintained + token->implementation map (no stack scan), so a known token + resolves even while its stack is parked under another key by + Rename_stack. If the token is unknown and the command has no + stack, command is returned unchanged. An error is raised when + a stack exists but no record matches the token.} + @values -min 3 -max 3 + command -type string -help -& + "Fully qualified command name (first token element)." + renamer -type string -help -& + "Renamer string recorded at rename time (second token element)." + tokenid -type int -help -& + "Token id recorded at rename time (third token element)." + }] + } + proc get_next_command {command renamer tokenid} { + #hot path - called on every invocation of every renamed command (e.g ::package) + #token_implementations is maintained by rename_command/remove_rename so this is + #a single dict lookup rather than an lsearch scan of the stack list + variable token_implementations + if {[dict exists $token_implementations [list $command $renamer $tokenid]]} { + return [dict get $token_implementations [list $command $renamer $tokenid]] + } + variable all_stacks + if {[dict exists $all_stacks $command]} { + error "(commandstack::get_next_command) ERROR: unable to determine next command for '$command' using token: $command $renamer $tokenid" + } + return $command + } + namespace eval argdoc { + lappend PUNKARGS [list { + @id -id ::commandstack::basecall + @cmd -name "commandstack::basecall" -& + -summary -& + "Call the original (bottom-of-stack) implementation of a command." -& + -help -& + {Tailcalls the implementation recorded at the bottom of the + command's rename stack (the original command as it was first + renamed aside), bypassing all stacked overrides. A command + with no rename stack is called directly. The command name is + resolved with 'namespace which' in the caller's context.} + @values -min 1 -max -1 + command -type string -help -& + "Command name (resolved in the caller's namespace context)." + arg -type any -optional 1 -multiple 1 -help -& + "Arguments passed through to the implementation." + }] + } + proc basecall {command args} { + variable all_stacks + set command [uplevel 1 [list namespace which $command]] + if {[dict exists $all_stacks $command]} { + set stack [dict get $all_stacks $command] + if {[llength $stack]} { + set rec1 [lindex $stack 0] + tailcall [dict get $rec1 implementation] {*}$args + } else { + tailcall $command {*}$args + } + } else { + tailcall $command {*}$args + } + } + + + #review. + # defaults to calling namespace - but can be arbitrary string + namespace eval argdoc { + lappend PUNKARGS [list { + @id -id ::commandstack::rename_command + @cmd -name "commandstack::rename_command" -& + -summary -& + "Cooperatively rename a command, stacking the override." -& + -help -& + {Renames command aside (to a name under + ::commandstack::renamed_commands) and installs a proc with + procargs/procbody in its place, recording the operation on + the command's rename stack so overrides from multiple + cooperating packages can be added and removed in any order. + + A header is prepended to procbody which sets two variables: + COMMANDSTACKNEXT - the implementation to delegate + to (re-resolved every call via + commandstack::get_next_command) + COMMANDSTACKNEXT_ORIGINAL - the implementation as at rename + time (static/debug) + A delegating procbody normally contains: + uplevel 1 [list $COMMANDSTACKNEXT {*}$args] + or equivalently calls the helper: + commandstack::next {*}$args + + Returns the new stack record - a dict with keys: + token renamer next_implementor next_getter implementation did_rename + The tokenid (third token element) is unique and monotonic per + (renamer, command) pairing, so repeat renames by the same + renamer are individually addressable. When no rename was + performed (command not found, or this renamer already + installed an identical procbody) the returned dict is + {implementation {} did_rename 0} - consumers may test either + key. Keep the token ({command renamer tokenid}) or the + {command renamer} pair for a later remove_rename. + + The proc is first built at a temp location so a procargs or + procbody compile error raises before the stack or the live + command are touched.} + @opts + -renamer -type string -optional 1 -help -& + "Identity string recorded for this rename - defaults to + the calling namespace. Cooperating packages use their + package/namespace name. Note: this flag is recognised + only as the FIRST argument (manual parse) - appearing + in any later position is an error." + @values -min 3 -max 3 + command -type string -help -& + "Command to rename (resolved with 'namespace which' in + the caller's context - builtins and procs both work)." + procargs -type list -help -& + "Argument list for the replacement proc (commonly {args}, + but any signature matching the target's call pattern)." + procbody -type string -help -& + "Body for the replacement proc. Delegate onward via the + pre-set COMMANDSTACKNEXT variable." + }] + } + 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 {"-renamer" in $arglist} { + error "commandstack::rename_command -renamer is recognised only as the leading argument. usage: rename_command ?-renamer ? command procargs procbody" + } + if {[llength $arglist] != 3} { + error "commandstack::rename_command usage: rename_command ?-renamer ? command procargs procbody" + } + lassign $arglist command procargs procbody + + variable debug + set command [uplevel 1 [list namespace which $command]] + if {$command eq ""} { + if {$debug} { + puts stderr "commandstack::rename_command no rename performed for command '[lindex $arglist 0]' by '$renamer'. command not found in calling context. Ensure command name is fully qualified or that command exists." + } + return [dict create implementation "" did_rename 0] + } + variable all_stacks + variable known_renamers + variable renamer_command_tokens + variable token_implementations + if {$renamer eq ""} { + set renamer [uplevel 1 [list namespace current]] + } + if {$renamer ni $known_renamers} { + lappend known_renamers $renamer + } + #unique monotonic tokenid per (renamer,command) - incremented on the REAL namespace + #variable in this proc frame (the historical in-apply 'dict incr' hit an apply-local + #copy, leaving every tokenid at 1 - duplicate tokens broke dispatch and removal for + #same-renamer re-renames). Aborted renames consume an id - gaps are harmless. + dict incr renamer_command_tokens [list $renamer $command] + set tokenid [dict get $renamer_command_tokens [list $renamer $command]] + + #e.g packageTrace and packageSuppress packages use this convention. + set nextinfo [uplevel 1 [list\ + apply {{command renamer procbody tokenid} { + #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 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} { + if {$::commandstack::debug} { + puts stderr "(commandstack::rename_command) WARNING - renamer '$renamer' has already renamed the '$command' command with same procbody - Aborting rename." + puts stderr [::commandstack::show_stack $command] + } + } else { + if {$::commandstack::debug} { + puts stderr "(commandstack::rename_command) WARNING - renamer '$renamer' has already renamed the '$command' command - but appears to be with new code - proceeding." + puts stderr "----------" + puts stderr "$current_code" + puts stderr "----------" + puts stderr "$new_code" + puts stderr "----------" + } + set next_target ::commandstack::renamed_commands::${mungedcommand}-${munged_next_implementor}-$mungedrenamer-$tokenid + set do_rename 1 + } + } else { + if {$::commandstack::debug} { + 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}} { + #could be a standard tcl proc, or from application or package + set next_target ::commandstack::renamed_commands::${mungedcommand}_${munged_next_implementor}-$mungedrenamer-$tokenid + set do_rename 1 + } else { + if {$::commandstack::debug} { + puts stderr "(commandstack::rename_command) Warning - pkg:'$next_implementor' has renamed the '$command' command. Attempting to cooperate. (untested)" + } + set next_target ::commandstack::renamed_commands::${mungedcommand}_${munged_next_implementor}-$mungedrenamer-$tokenid + set do_rename 1 + } + } else { + #_originalcommand_ + #assume builtin/original + set next_implementor original + #rename $command $next_target + set do_rename 1 + } + #There are of course other ways in which $command may have been renamed - but we can't detect. + set token [list $command $renamer $tokenid] + return [dict create next_target $next_target next_implementor $next_implementor token $token do_rename $do_rename] + } } $command $renamer $procbody $tokenid] + ] + + + 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) + #additive keys (did_rename) must be APPENDED - the leading key order is a contract. + 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]\ + did_rename 1\ + ] + if {![dict get $nextinfo do_rename]} { + if {$debug} { + puts stderr "commandstack::rename_command no rename performed for command '$command' by '$renamer'" + } + return [dict create implementation "" did_rename 0] + } + catch {rename ::commandstack::temp::testproc ""} + set nextinit [string map [list %command% $command %renamer% $renamer %next_getter% [dict get $new_record next_getter] %original_implementation% [dict get $new_record implementation]] { + #IMPLEMENTOR_%renamer%! (mechanism: 'commandstack::rename_command -renamer %renamer% %command% ) + set COMMANDSTACKNEXT_ORIGINAL %original_implementation% ;#informational/debug for overriding proc. + set COMMANDSTACKNEXT [%next_getter%] + ## + }] + set final_procbody "$nextinit$procbody" + #build the proc at a temp location so that if it raises an error we don't adjust the stack or replace the original command + #(e.g due to invalid argument specifiers) + proc ::commandstack::temp::testproc $procargs $final_procbody + uplevel 1 [list rename $command [dict get $nextinfo next_target]] + uplevel 1 [list rename ::commandstack::temp::testproc $command] + dict lappend all_stacks $command $new_record + dict set token_implementations [dict get $nextinfo token] [dict get $nextinfo next_target] + + return $new_record + } + + namespace eval argdoc { + lappend PUNKARGS [list { + @id -id ::commandstack::next + @cmd -name "commandstack::next" -& + -summary -& + "Delegate from an override body to the next implementation on the stack." -& + -help -& + {Convenience delegation helper for proc bodies installed by + rename_command. Called directly from an override body it + resolves the body's pre-set COMMANDSTACKNEXT variable and + invokes that implementation with the given arguments at the + override's caller level - exactly equivalent to the manual + convention: + uplevel 1 [list $COMMANDSTACKNEXT {*}$args] + Returns the implementation's result. An error is raised when + called from a frame without a COMMANDSTACKNEXT variable (i.e + from anywhere other than directly inside an installed + override body). The COMMANDSTACKNEXT variables remain the + primitive interface - existing consumers need not change.} + @values -min 0 -max -1 + arg -type any -optional 1 -multiple 1 -help -& + "Arguments passed through to the next implementation." + }] + } + proc next {args} { + #call directly from a rename_command-installed override body only: + #COMMANDSTACKNEXT is set at the top of such bodies by the injected header + upvar 1 COMMANDSTACKNEXT COMMANDSTACKNEXT + if {![info exists COMMANDSTACKNEXT]} { + error "(commandstack::next) ERROR: no COMMANDSTACKNEXT variable in the calling frame. commandstack::next must be called directly from a proc body installed by commandstack::rename_command" + } + #uplevel 2 = the override's caller frame - same frame the manual + #'uplevel 1 [list $COMMANDSTACKNEXT {*}$args]' convention evaluates in + uplevel 2 [list $COMMANDSTACKNEXT {*}$args] + } + + #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 + namespace eval argdoc { + lappend PUNKARGS [list { + @id -id ::commandstack::remove_rename + @cmd -name "commandstack::remove_rename" -& + -summary -& + "Undo a rename previously made with rename_command." -& + -help -& + {Removes one entry from a command's rename stack, restoring + or re-linking implementations as needed. Entries other than + the topmost can be removed - the entry above is re-pointed at + what the removed entry delegated to (the load/unload-in-any- + order design goal). + + token_or_command is one of: + 3 elements - the exact token from the rename record: + {command renamer tokenid} + 2 elements - {command renamer} - removes that renamer's + topmost entry for the command + 1 element - command name only - renamer defaults to the + calling namespace + The renamer must be known to commandstack (recorded by a + rename_command call) or an error is raised. A token or + renamer with no matching stack entry removes nothing. + Returns the command's stack after the removal (empty list if + the command has no stack).} + @values -min 1 -max 1 + token_or_command -type list -help -& + "Token {command renamer tokenid}, pair {command renamer}, + or bare command name (see -help above)." + }] + } + 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 + variable token_implementations + variable debug + if {$renamer ni $known_renamers} { + error "(commandstack::remove_rename) ERROR: renamer $renamer not in list of known_renamers '$known_renamers' for command '$command'. Ensure remove_rename called from same context as rename_command was, or explicitly supply exact token or { }" + } + if {[dict exists $all_stacks $command]} { + set stack [dict get $all_stacks $command] + if {$tokenid ne ""} { + #token_or_command is a token as returned within the rename_command result dictionary + #search first dict value + set doomed_posn [lsearch -index 1 $stack $token_or_command] + } else { + #search second dict value + set matches [lsearch -all -index 3 $stack $renamer] + set doomed_posn [lindex $matches end] ;#we don't have a full token - pop last entry for this renamer + } + if {$doomed_posn ne "" && $doomed_posn > -1} { + set doomed_record [lindex $stack $doomed_posn] + if {[llength $stack] == ($doomed_posn + 1)} { + #last on stack - put the implemenation from the doomed_record back as the actual command + uplevel #0 [list rename $command ""] + uplevel #0 [list rename [dict get $doomed_record implementation] $command] + } elseif {[llength $stack] > ($doomed_posn + 1)} { + #there is at least one more record on the stack - rewrite it to point where the doomed_record pointed + set rewrite_posn [expr {$doomed_posn + 1}] + set rewrite_record [lindex $stack $rewrite_posn] + + if {[dict get $rewrite_record next_implementor] ne $renamer} { + #anomalous stack state (external interference or historical duplicate + #tokens) - conservatively leave the parked implementation in place + if {$debug} { + 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 + #re-point the rewritten record's token at its new implementation + dict set token_implementations [dict get $rewrite_record token] [dict get $doomed_record implementation] + } + set stack [lreplace $stack $doomed_posn $doomed_posn] + dict set all_stacks $command $stack + dict unset token_implementations [dict get $doomed_record token] + + } + return $stack + } + return [list] + } + + namespace eval argdoc { + lappend PUNKARGS [list { + @id -id ::commandstack::show_stack + @cmd -name "commandstack::show_stack" -& + -summary -& + "Return a printable display of rename stacks." -& + -help -& + {Returns a formatted text display of the rename stacks whose + command names match commandname_glob. An argument without + glob characters is resolved with 'namespace which' in the + caller's context first. When the punk and punk::lib packages + are already loaded the display is rendered with + punk::lib::pdict - otherwise a plain aligned-text fallback is + used. Returns an empty string when nothing matches.} + @values -min 0 -max 1 + commandname_glob -type string -default * -optional 1 -help -& + "Glob pattern (or exact command name) selecting which + command stacks to display." + }] + } + proc show_stack {{commandname_glob *}} { + variable all_stacks + if {![regexp {[?*]} $commandname_glob]} { + #if caller is attempting exact match - use the calling context to resolve in case they didn't supply namespace + set commandname_glob [uplevel 1 [list namespace which $commandname_glob]] + } + if {[package provide punk::lib] ne "" && [package provide punk] ne ""} { + #punk pipeline also needed for patterns + return [punk::lib::pdict -channel none all_stacks $commandname_glob/@*/@*.@*] + } else { + set result "" + set matchedkeys [dict keys $all_stacks $commandname_glob] + #don't try to calculate widest on empty list + if {[llength $matchedkeys]} { + set widest [tcl::mathfunc::max {*}[lmap v $matchedkeys {tcl::string::length $v}]] + set indent [string repeat " " [expr {$widest + 3}]] + set indent2 "${indent} " ;#8 spaces for " i = " where i is 4 wide + set padkey [string repeat " " 20] + foreach k $matchedkeys { + append result "$k = " + set i 0 + foreach stackmember [dict get $all_stacks $k] { + if {$i > 0} { + append result "\n$indent" + } + append result [string range "$i " 0 4] " = " + set j 0 + dict for {k v} $stackmember { + if {$j > 0} { + append result "\n$indent2" + } + set displaykey [string range "$k$padkey" 0 20] + append result "$displaykey = $v" + incr j + } + incr i + } + append result \n + } + } + return $result + } + } + + #review + #document when this is to be called. Wiping stacks without undoing renames seems odd. + namespace eval argdoc { + lappend PUNKARGS [list { + @id -id ::commandstack::Delete_stack + @cmd -name "commandstack::Delete_stack" -& + -summary -& + "Discard a command's rename-stack records (maintenance - unexported)." -& + -help -& + {Removes the command's entry from the stacks dict. An error + is raised when the stack still holds rename records - live + overrides installed by rename_command must be removed with + remove_rename first (deleting the records of a live override + historically broke the COMMANDSTACKNEXT lookup so the next + call recursed to the interp limit). An empty stack entry + (the residue after the last remove_rename) is deleted and 1 + is returned; a command with no stack entry also returns 1. + Not exported - intended for maintenance/experimentation only + (under review).} + @values -min 1 -max 1 + command -type string -help -& + "Stacks-dict key - fully qualified command name or parked + stack name (no resolution is performed)." + }] + } + proc Delete_stack {command} { + variable all_stacks + if {[dict exists $all_stacks $command]} { + set stack [dict get $all_stacks $command] + if {[llength $stack]} { + #records represent live renames - deleting them would break the + #COMMANDSTACKNEXT delegation of the installed overrides (the next + #call would recurse to the interp limit) + error "(commandstack::Delete_stack) ERROR: stack for '$command' still holds [llength $stack] live rename record(s) - remove them with commandstack::remove_rename first" + } + 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? + namespace eval argdoc { + lappend PUNKARGS [list { + @id -id ::commandstack::Rename_stack + @cmd -name "commandstack::Rename_stack" -& + -summary -& + "Re-key a command's rename-stack records (maintenance - unexported)." -& + -help -& + {Moves the stack records stored under oldname to newname in + the stacks dict. No commands are renamed - this only changes + the dict key, e.g to temporarily put a stack aside (rename + back manually when done). Returns 1 when a stack was moved, + 0 when oldname has no stack. An error is raised if newname + already has a stack. get_stack tries its argument as a raw + stacks-dict key first, so parked records are retrievable by + the parked name; COMMANDSTACKNEXT delegation of live + overrides keeps working while parked (token resolution uses + the token->implementation map, not the stacks-dict key). Not + exported - intended for maintenance/experimentation only + (under review).} + @values -min 2 -max 2 + oldname -type string -help -& + "Existing stacks-dict key (no resolution is performed)." + newname -type string -help -& + "New stacks-dict key." + }] + } + proc Rename_stack {oldname newname} { + variable all_stacks + if {![dict exists $all_stacks $oldname]} { + return 0 + } + if {[dict exists $all_stacks $newname]} { + error "(commandstack::rename_stack) cannot rename $oldname to $newname - $newname already exists in stack" + } + dict set all_stacks $newname [dict get $all_stacks $oldname] + dict unset all_stacks $oldname + return 1 + } +} + + + + + + + + +namespace eval commandstack::lib { + namespace eval ::commandstack::argdoc { + lappend PUNKARGS [list { + @id -id ::commandstack::lib::splitx + @cmd -name "commandstack::lib::splitx" -& + -summary -& + "Split a string on a regexp separator." -& + -help -& + {Local copy of tcllib textutil::split::splitx (to avoid the + dependency). Splits str on each match of regexp. A + parenthesised subexpression in regexp includes the separator + match in the result list. An empty regexp splits into + characters. A regexp matching the empty string raises an + 'infinite loop' error.} + @values -min 1 -max 2 + str -type string -help -& + "String to split." + regexp -type string -optional 1 -default {[\t \r\n]+} -help -& + "Separator regular expression." + }] + } + 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 + } + namespace eval ::commandstack::argdoc { + lappend PUNKARGS [list { + @id -id ::commandstack::lib::split_body + @cmd -name "commandstack::lib::split_body" -& + -summary -& + "Split an installed override body into commandstack header and original code." -& + -help -& + {Splits a proc body at the ## marker + line that rename_command embeds between its generated header + (the COMMANDSTACKNEXT setup) and the renamer-supplied + procbody. Returns a 2-element list {header code}. A body + without the marker returns {"" procbody}.} + @values -min 1 -max 1 + procbody -type string -help -& + "Proc body text (e.g from 'info body ')." + }] + } + proc split_body {procbody} { + set marker "##" + set header "" + set code "" + set found_marker 0 + foreach ln [split $procbody \n] { + if {!$found_marker} { + if {[string trim $ln] eq $marker} { + set found_marker 1 + } else { + append header $ln \n + } + } else { + append code $ln \n + } + } + if {$found_marker} { + return [list $header $code] + } else { + return [list "" $procbody] + } + } +} + +namespace eval ::punk::args::register { + #use fully qualified so 8.6 doesn't find existing var in global namespace + #Register namespaces punk::args should scan for PUNKARGS documentation. + #The PUNKARGS metadata here is inert documentation - this module deliberately + #does not depend on (or call) punk::args. + lappend ::punk::args::register::NAMESPACES ::commandstack ::commandstack::argdoc +} + +package provide commandstack [namespace eval commandstack { + set version 0.6.0 +}] + + diff --git a/src/bootsupport/modules/punk/packagepreference-0.2.0.tm b/src/vfs/_vfscommon.vfs/modules/punk/packagepreference-0.2.1.tm similarity index 99% rename from src/bootsupport/modules/punk/packagepreference-0.2.0.tm rename to src/vfs/_vfscommon.vfs/modules/punk/packagepreference-0.2.1.tm index 48713fce..a9ee911a 100644 --- a/src/bootsupport/modules/punk/packagepreference-0.2.0.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/packagepreference-0.2.1.tm @@ -8,7 +8,7 @@ # (C) 2024 # # @@ Meta Begin -# Application punk::packagepreference 0.2.0 +# Application punk::packagepreference 0.2.1 # Meta platform tcl # Meta license # @@ Meta End @@ -18,7 +18,7 @@ # doctools header # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #*** !doctools -#[manpage_begin punkshell_module_punk::packagepreference 0 0.2.0] +#[manpage_begin punkshell_module_punk::packagepreference 0 0.2.1] #[copyright "2024"] #[titledesc {punkshell package/module loading}] [comment {-- Name section and table of contents description --}] #[moddesc {package/module load}] [comment {-- Description at end of page heading --}] @@ -114,7 +114,7 @@ tcl::namespace::eval punk::packagepreference { if {[dict exists $cstack ::package]} { set pstack [dict get $cstack ::package] foreach record $pstack { - if {[dict get $record rename] eq "punk::packagepreference"} { + if {[dict get $record renamer] eq "punk::packagepreference"} { #already installed - silently ignore. return 0 } @@ -512,7 +512,7 @@ namespace eval ::punk::args::register { package provide punk::packagepreference [tcl::namespace::eval punk::packagepreference { variable pkg punk::packagepreference variable version - set version 0.2.0 + set version 0.2.1 }] return