You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
1025 lines
56 KiB
1025 lines
56 KiB
|
|
|
|
#JMN 2021 - Public Domain |
|
#cooperative command renaming |
|
# |
|
# REVIEW 2024 - code was originally for specific use in packageTrace |
|
# - code should be reviewed for more generic utility. |
|
# - API is obscure and undocumented. |
|
# - unclear if intention was only for builtins |
|
# - consider use of newer 'info cmdtype' - (but need also support for safe interps) |
|
# - oo dispatch features may be a better implementation - especially for allowing undoing command renames in the middle of a stack. |
|
# - document that replacement command should use 'commandstack::get_next_command <cmd> <renamer>' for delegating to command as it was prior to rename |
|
#changes: |
|
#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_<mungedcommand> |
|
#2021-09-18 |
|
# - initial version |
|
# - e.g Support cooperation between packageSuppress and packageTrace which both rename the package command |
|
# - They need to be able to load and unload in any order. |
|
# |
|
|
|
#strive for no other package dependencies here. |
|
|
|
|
|
namespace eval commandstack { |
|
variable all_stacks |
|
variable debug |
|
set debug 0 |
|
#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 {<renamer> <command>} - 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 {<command> <renamer> <tokenid>} -> 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_<name>! (which rename_command adds |
|
automatically, keyed by renamer) and returns the <name> |
|
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 <mypkg> <command> <procargs> <procbody>] |
|
Renames <command> aside and installs <procbody> 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 <token_or_command> |
|
Undo a rename. Accepts the token from the rename record |
|
([dict get $record token] = {<command> <renamer> <tokenid>}), |
|
a 2-element {<command> <renamer>}, or just <command> 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_<renamer>! (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. |
|
#<renamer> 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 <string>? command procargs procbody" |
|
} |
|
if {[llength $arglist] != 3} { |
|
error "commandstack::rename_command usage: rename_command ?-renamer <string>? 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_<mungedcommand> |
|
#assume builtin/original |
|
set next_implementor original |
|
#rename $command $next_target |
|
set do_rename 1 |
|
} |
|
#There are of course other ways in which $command may have been renamed - but we can't detect. |
|
set token [list $command $renamer $tokenid] |
|
return [dict create next_target $next_target next_implementor $next_implementor token $token do_rename $do_rename] |
|
} } $command $renamer $procbody $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% <procargs> <procbody> ) |
|
set COMMANDSTACKNEXT_ORIGINAL %original_implementation% ;#informational/debug for overriding proc. |
|
set COMMANDSTACKNEXT [%next_getter%] |
|
#<commandstack_separator># |
|
}] |
|
set final_procbody "$nextinit$procbody" |
|
#build the proc at a temp location so that if it raises an error we don't adjust the stack or replace the original command |
|
#(e.g due to invalid argument specifiers) |
|
proc ::commandstack::temp::testproc $procargs $final_procbody |
|
uplevel 1 [list rename $command [dict get $nextinfo next_target]] |
|
uplevel 1 [list rename ::commandstack::temp::testproc $command] |
|
dict lappend all_stacks $command $new_record |
|
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 {<command> <renamer>}" |
|
} |
|
if {[dict exists $all_stacks $command]} { |
|
set stack [dict get $all_stacks $command] |
|
if {$tokenid ne ""} { |
|
#token_or_command is a token as returned within the rename_command result dictionary |
|
#search first dict value |
|
set doomed_posn [lsearch -index 1 $stack $token_or_command] |
|
} else { |
|
#search second dict value |
|
set matches [lsearch -all -index 3 $stack $renamer] |
|
set doomed_posn [lindex $matches end] ;#we don't have a full token - pop last entry for this renamer |
|
} |
|
if {$doomed_posn ne "" && $doomed_posn > -1} { |
|
set doomed_record [lindex $stack $doomed_posn] |
|
if {[llength $stack] == ($doomed_posn + 1)} { |
|
#last on stack - put the implemenation from the doomed_record back as the actual command |
|
uplevel #0 [list rename $command ""] |
|
uplevel #0 [list rename [dict get $doomed_record implementation] $command] |
|
} elseif {[llength $stack] > ($doomed_posn + 1)} { |
|
#there is at least one more record on the stack - rewrite it to point where the doomed_record pointed |
|
set rewrite_posn [expr {$doomed_posn + 1}] |
|
set rewrite_record [lindex $stack $rewrite_posn] |
|
|
|
if {[dict get $rewrite_record next_implementor] ne $renamer} { |
|
#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 #<commandstack_separator># 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 <command>')." |
|
}] |
|
} |
|
proc split_body {procbody} { |
|
set marker "#<commandstack_separator>#" |
|
set header "" |
|
set code "" |
|
set found_marker 0 |
|
foreach ln [split $procbody \n] { |
|
if {!$found_marker} { |
|
if {[string trim $ln] eq $marker} { |
|
set found_marker 1 |
|
} else { |
|
append header $ln \n |
|
} |
|
} else { |
|
append code $ln \n |
|
} |
|
} |
|
if {$found_marker} { |
|
return [list $header $code] |
|
} else { |
|
return [list "" $procbody] |
|
} |
|
} |
|
} |
|
|
|
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 |
|
}] |
|
|
|
|
|
|