diff --git a/src/modules/commandstack-999999.0a1.0.tm b/src/modules/commandstack-999999.0a1.0.tm index c025c7ca..decc833d 100644 --- a/src/modules/commandstack-999999.0a1.0.tm +++ b/src/modules/commandstack-999999.0a1.0.tm @@ -11,6 +11,32 @@ # - 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) @@ -30,11 +56,28 @@ namespace eval commandstack { variable all_stacks variable debug set debug 0 - variable known_renamers [list ::packagetrace ::packageSuppress] + #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 { @@ -82,9 +125,12 @@ namespace eval commandstack::util { return unspecified } } else { - if {[info commands tcl::info::cmdtype] ne ""} { + #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] { + switch -- [::tcl::info::cmdtype $command] { native { return builtin } @@ -143,20 +189,29 @@ namespace eval commandstack { (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. + 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) + 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. @@ -179,9 +234,12 @@ namespace eval commandstack { "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. - When enabled, rename_command reports rename progress on - stderr." + 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." @@ -191,12 +249,12 @@ namespace eval commandstack { variable debug if {$on_off eq ""} { return $debug - } else { - if {[string is boolean -strict $debug]} { - set debug [expr {$on_off && 1}] - 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 { @@ -209,17 +267,21 @@ namespace eval commandstack { {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 (resolved with 'namespace which' in - the caller's context), returns that command's list of rename - records - empty if the command has never been renamed. + 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 - The key order is a contract: cooperating code may locate - records with 'lsearch -index 1' (token value) or - 'lsearch -index 3' (renamer value).} + 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 (resolved in the caller's namespace context). + "Command name (raw stacks-dict key, else resolved in the + caller's namespace context). Omit to return the dict of all stacks." }] } @@ -228,12 +290,16 @@ namespace eval commandstack { if {$command eq ""} { return $all_stacks } - set command [uplevel 1 [list namespace which $command]] 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] - } else { - return [list] } + 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. @@ -251,9 +317,12 @@ namespace eval commandstack { 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. - If the command has no stack at all, command is returned - unchanged. An error is raised when a stack exists but no - record matches the token.} + 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)." @@ -264,20 +333,18 @@ namespace eval commandstack { }] } 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]} { - 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 + 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 { @@ -338,14 +405,19 @@ namespace eval commandstack { 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 - An implementation value of empty string means no rename was + 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). Keep the token - ({command renamer tokenid}) or the {command renamer} pair for - a later remove_rename. + 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 @@ -355,7 +427,8 @@ namespace eval commandstack { "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)." + 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 @@ -379,41 +452,46 @@ namespace eval commandstack { 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 ""} { - #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 ""] + 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] } - 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. + 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 - dict set renamer_command_tokens [list $renamer $command] 0 } - - #TODO - reduce emissions to stderr - flag for debug? + #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} { + 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 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]]} { @@ -438,21 +516,26 @@ namespace eval commandstack { 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] + 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 { - 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 "----------" + 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 { - puts stderr "(commandstack::rename_command) WARNING - renamer '$renamer' has already renamed the '$command' command, but is not immediate predecessor - proceeding anyway... (untested)" - puts stderr + 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 } @@ -468,7 +551,9 @@ namespace eval commandstack { 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)" + 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 } @@ -482,11 +567,10 @@ namespace eval commandstack { #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] + } } $command $renamer $procbody $tokenid] ] - variable debug if {$debug} { if {[dict exists $all_stacks $command]} { set stack [dict get $all_stacks $command] @@ -499,18 +583,20 @@ namespace eval commandstack { #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]} { - #review - puts stderr "commandstack::rename_command no rename performed for command '$command' by '$renamer'" - #add something to stack? - return [dict create implementation ""] + 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]] { @@ -526,11 +612,47 @@ namespace eval commandstack { 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 @@ -588,6 +710,8 @@ namespace eval commandstack { 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 { }" } @@ -614,7 +738,11 @@ namespace eval commandstack { 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]" + #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] ""] } @@ -623,9 +751,12 @@ namespace eval commandstack { 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 @@ -706,23 +837,32 @@ namespace eval commandstack { -summary -& "Discard a command's rename-stack records (maintenance - unexported)." -& -help -& - {Removes the command's entry from the stacks dict WITHOUT - undoing any renames - the renamed commands themselves are - left in place. Always returns 1, whether or not a stack - existed. CAUTION: if overrides installed by rename_command - are still live, deleting their stack breaks the - COMMANDSTACKNEXT lookup - get_next_command then resolves to - the (overridden) command itself and the next call recurses - until the interp recursion limit. Not exported - intended for - maintenance/experimentation only (under review).} + {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 -& - "Fully qualified command name key (no resolution is performed)." + "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 { @@ -742,12 +882,15 @@ namespace eval commandstack { {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). An error is raised if newname - already has a stack. Note that get_stack resolves its - argument with 'namespace which', so records parked under a - name that is not an existing command are only visible via the - no-argument get_stack dict. Not exported - intended for - maintenance/experimentation only (under review).} + 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)." @@ -757,16 +900,15 @@ namespace eval commandstack { } 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] - } + 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 } } diff --git a/src/modules/commandstack-buildversion.txt b/src/modules/commandstack-buildversion.txt index 00541ab5..3a035b10 100644 --- a/src/modules/commandstack-buildversion.txt +++ b/src/modules/commandstack-buildversion.txt @@ -1,6 +1,27 @@ -0.5.0 +0.6.0 #First line must be a tm version number #all other lines are ignored. +#0.6.0 - G-160 hygiene pass: +# - tokenid unique+monotonic per (renamer,command) - the counter now increments the real +# namespace variable (was an apply-local copy stuck at 1); same-renamer re-renames +# dispatch through the full chain and are removable by exact token; a third +# same-renamer rename no longer collides on the parked name +# - get_next_command resolves via a maintained token->implementation dict (O(1) dispatch, +# no stack-list scan; parked stacks keep dispatching) +# - get_IMPLEMENTOR builtin branch reachable (::tcl::info::cmdtype qualified in guard+call) +# - debug validates its argument (clean error naming on_off for non-boolean) +# - informational/warning output debug-gated on stderr (silent by default); stray bare +# 'puts stderr' (which wrote the literal word stderr to stdout) removed +# - records carry trailing did_rename 0|1; no-rename returns {implementation {} did_rename 0} +# (token first / renamer second key order contract unchanged) +# - rename_command errors when -renamer appears anywhere but the leading position +# - get_stack tries the raw stacks-dict key first (Rename_stack-parked stacks retrievable) +# - Rename_stack returns 1/0 (was leaking the whole stacks dict) +# - Delete_stack errors while records are live (was breaking delegation -> recursion); +# empty/missing stacks return 1 +# - new delegation helper commandstack::next (= uplevel 1 [list $COMMANDSTACKNEXT {*}$args]) +# - known_renamers defaults reconciled to the vendored packages' actual renamer strings +# (packagetrace packagesuppress) #0.5.0 - commandstack::help now returns a real overview (was empty string) # - PUNKARGS documentation blocks added for all API procs (lazy punk::args # registration via ::punk::args::register::NAMESPACES - no punk::args diff --git a/src/modules/punk/packagepreference-999999.0a1.0.tm b/src/modules/punk/packagepreference-999999.0a1.0.tm index fbb2c717..21ccbed3 100644 --- a/src/modules/punk/packagepreference-999999.0a1.0.tm +++ b/src/modules/punk/packagepreference-999999.0a1.0.tm @@ -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 } diff --git a/src/modules/punk/packagepreference-buildversion.txt b/src/modules/punk/packagepreference-buildversion.txt index ba459500..b3aaf869 100644 --- a/src/modules/punk/packagepreference-buildversion.txt +++ b/src/modules/punk/packagepreference-buildversion.txt @@ -1,5 +1,6 @@ -0.2.0 +0.2.1 #First line must be a semantic version number #all other lines are ignored. +#0.2.1 - G-160: install's already-installed guard reads record key 'renamer' (the key that exists) - the historical 'rename' read made a second install throw a dict error instead of silently returning 0 (latent in kits, which install once per interp) #0.2.0 - G-058 static-vs-bundled policy: on require of a package in the runtime static baseline (::punkboot::static_packages), ensure the static ifneeded mapping exists and trigger the package unknown index scan so bundled vfs/module copies register BEFORE resolution - version comparison then applies (highest wins; identical versions resolve to the bundled copy). Static REGISTRATIONS (empty-filename info loaded entries) are now excluded from the loaded-shared-object same-version forcing, which would otherwise pin resolution to the static version even when a bundled copy is genuinely newer. #0.1.1 - moduledoc auto-load success notice moved from stdout to stderr (stdout must stay clean for script/exec contexts e.g the punk 'script' subcommand; failure branch already used stderr) diff --git a/src/tests/modules/commandstack/testsuites/commandstack/commandstack.test b/src/tests/modules/commandstack/testsuites/commandstack/commandstack.test index c880d464..334b6c48 100644 --- a/src/tests/modules/commandstack/testsuites/commandstack/commandstack.test +++ b/src/tests/modules/commandstack/testsuites/commandstack/commandstack.test @@ -20,19 +20,21 @@ # 4. remove_rename forms: 3-element token, {command renamer} pair, bare # command name resolved against the calling namespace; unknown renamer # errors. -# 5. Known defects pinned as _GAP_ tests: the per-renamer token counter -# increments an apply-local variable so tokenid never advances past 1 - -# a same-renamer re-rename creates a DUPLICATE token, dispatch then -# resolves to the first (oldest) record and bypasses intermediate layers, -# and a third same-renamer rename dies on a renamed_commands name -# collision; Delete_stack under a live rename leaves the override -# delegating to itself (infinite recursion at next call); the -# get_IMPLEMENTOR 'builtin' classification branch is unreachable (its -# tcl::info::cmdtype guard uses an unqualified info commands pattern from -# inside commandstack::util) so builtins report 'undetermined' everywhere. +# 5. The G-160 hygiene-pass contract (the 2026-08-03 characterisation +# suite's _GAP_ defect pins flipped to fixed-behaviour pins at +# commandstack 0.6.0): tokenids unique and monotonic per +# (renamer,command) - same-renamer re-renames chain and are removable by +# exact token, a third rename succeeds; Delete_stack errors while records +# are live (empty/missing stacks return 1); get_IMPLEMENTOR classifies +# builtins where ::tcl::info::cmdtype exists; records carry a trailing +# did_rename 0|1 (leading key order unchanged); informational output is +# debug-gated (silent full cycle with debug off); -renamer misplacement +# errors; get_next_command resolves via the token->implementation map; +# get_stack reaches Rename_stack-parked records (raw key first) and +# Rename_stack returns 1/0; the commandstack::next delegation helper. # 6. util::get_IMPLEMENTOR magic-comment classification, lib::split_body # header/code round-trip, lib::splitx, debug accessor, show_stack -# fallback rendering, Rename_stack parking quirks, help overview text, +# fallback rendering, Rename_stack parking, help overview text, # and lazy punk::args registration of the PUNKARGS documentation. # # Tests run against the SOURCE-TREE module. Behavioural tests use a fresh @@ -136,9 +138,10 @@ namespace eval ::testspace { #rename_command on a plain proc: full record pinned - the dict KEY ORDER is a #documented contract (lsearch -index 1 / -index 3), token {command renamer 1}, - #next_implementor 'unspecified' (proc body without magic comment), and the - #munged renamed_commands implementation name (underscore form for unspecified). - test commandstack_rename_basic_record {rename_command plain-proc record: key order, token, unspecified implementor, munged implementation name}\ + #next_implementor 'unspecified' (proc body without magic comment), the + #munged renamed_commands implementation name (underscore form for unspecified), + #and the trailing did_rename verdict (G-160 - additive keys are appended). + test commandstack_rename_basic_record {rename_command plain-proc record: key order, token, unspecified implementor, munged implementation name, trailing did_rename}\ -constraints commandstacksrc -body { cs_probe { proc ::tgt {args} {return [list base $args]} @@ -146,7 +149,7 @@ namespace eval ::testspace { return [list A [uplevel 1 [list $COMMANDSTACKNEXT {*}$args]]] } } - } -result {token {::tgt ::csA 1} renamer ::csA next_implementor unspecified next_getter {::commandstack::get_next_command ::tgt ::csA 1} implementation ::commandstack::renamed_commands::_ns_tgt_unspecified-_ns_csA-1} + } -result {token {::tgt ::csA 1} renamer ::csA next_implementor unspecified next_getter {::commandstack::get_next_command ::tgt ::csA 1} implementation ::commandstack::renamed_commands::_ns_tgt_unspecified-_ns_csA-1 did_rename 1} #installed body sees COMMANDSTACKNEXT (dynamic, re-resolved per call) and #COMMANDSTACKNEXT_ORIGINAL (static) - both equal the record implementation @@ -216,6 +219,51 @@ namespace eval ::testspace { } } -result {1 ::lrepeat 1 1} + #added 2026-08-03 (agent, G-160) + #record key-order contract with the additive did_rename key: token stays the + #FIRST dict entry (lsearch -index 1) and renamer the SECOND (lsearch -index 3), + #did_rename is appended LAST; and the token->implementation map that + #get_next_command resolves through (the G-160 O(1) dispatch mechanism) stays + #consistent with the stack records across renames and removals. + test commandstack_record_key_order_and_token_map {record keys stay token-first renamer-second with did_rename appended; token map mirrors stack implementations across rename/remove}\ + -constraints commandstacksrc -body { + cs_probe { + proc ::tgt {args} {return [list base $args]} + set r1 [commandstack::rename_command -renamer ::csA ::tgt {args} { + return [list A [uplevel 1 [list $COMMANDSTACKNEXT {*}$args]]] + }] + commandstack::rename_command -renamer ::csB ::tgt {args} { + return [list B [uplevel 1 [list $COMMANDSTACKNEXT {*}$args]]] + } + proc ::mapcheck {} { + set total 0 + dict for {cmd stack} [commandstack::get_stack] { + foreach record $stack { + incr total + set mapped [dict get $::commandstack::token_implementations [dict get $record token]] + if {$mapped ne [dict get $record implementation]} { + return [list MISMATCH [dict get $record token] $mapped] + } + } + } + if {$total != [dict size $::commandstack::token_implementations]} { + return [list SIZE $total [dict size $::commandstack::token_implementations]] + } + return [list ok $total] + } + set keys [dict keys $r1] + set stack [commandstack::get_stack ::tgt] + set bytoken [lsearch -index 1 $stack [dict get $r1 token]] + set byrenamer [lsearch -index 3 $stack ::csB] + set map2 [mapcheck] + commandstack::remove_rename {::tgt ::csA} + set map1 [mapcheck] + commandstack::remove_rename {::tgt ::csB} + set map0 [mapcheck] + list $keys [lindex $keys end] $bytoken $byrenamer $map2 $map1 $map0 + } + } -result {{token renamer next_implementor next_getter implementation did_rename} did_rename 0 1 {ok 2} {ok 1} {ok 0}} + #overrides from two different renamers stack bottom-first; the second record #identifies the first renamer via the injected IMPLEMENTOR magic comment and #parks its proc at the dash-form name; calls run top-down through the chain. @@ -337,11 +385,12 @@ namespace eval ::testspace { } } -result {1 1 1 1} - #known_renamers ships preseeded with ::packagetrace and ::packageSuppress (the - #original cooperating packages - note the vendored packages currently register - #as plain-word 'packagetrace'/'packagesuppress', so these defaults do not match - #them); new renamers are appended by rename_command. - test commandstack_known_renamers_defaults {known_renamers preseeded with ::packagetrace ::packageSuppress; rename_command appends new renamers}\ + #known_renamers ships preseeded with the strings the vendored cooperating + #packages actually pass as -renamer: plain-word packagetrace/packagesuppress + #(G-160 reconciliation - the historical ::packagetrace/::packageSuppress + #defaults matched no actual registration); new renamers are appended by + #rename_command. + test commandstack_known_renamers_defaults {known_renamers preseeded with the vendored packages' actual renamer strings; rename_command appends new renamers}\ -constraints commandstacksrc -body { cs_probe { set initial $::commandstack::known_renamers @@ -351,19 +400,23 @@ namespace eval ::testspace { } list $initial $::commandstack::known_renamers } - } -result {{::packagetrace ::packageSuppress} {::packagetrace ::packageSuppress ::csA}} + } -result {{packagetrace packagesuppress} {packagetrace packagesuppress ::csA}} - #rename_command on a nonexistent command performs no rename: returns a record of - #just 'implementation {}' (the signal consumers test for), warns on stderr, and - #adds nothing to the stacks. - test commandstack_rename_missing_command {rename of a nonexistent command returns implementation {} and warns, stacks untouched}\ + #rename_command on a nonexistent command performs no rename: returns + #{implementation {} did_rename 0} (consumers may test either key), adds nothing + #to the stacks, and stays silent with debug off; with debug on the + #not-found warning is emitted (G-160 channel discipline). + test commandstack_rename_missing_command {rename of a nonexistent command returns implementation {} did_rename 0; warning only under debug}\ -constraints commandstacksrc -body { cs_probe { + set rec_quiet [commandstack::rename_command -renamer ::csX ::definitely_not_here {args} {}] + set quiet_emissions [llength $::PUTS_LOG] + commandstack::debug 1 set rec [commandstack::rename_command -renamer ::csX ::definitely_not_here {args} {}] - list $rec [dict size [commandstack::get_stack]] \ + list $rec_quiet $quiet_emissions $rec [dict size [commandstack::get_stack]] \ [putslog_matches "*not found in calling context*"] } - } -result {{implementation {}} 0 1} + } -result {{implementation {} did_rename 0} 0 {implementation {} did_rename 0} 0 1} test commandstack_rename_command_usage_error {rename_command arg-count validation message is pinned}\ -constraints commandstacksrc -body { @@ -373,9 +426,27 @@ namespace eval ::testspace { } } -result {commandstack::rename_command usage: rename_command ?-renamer ? command procargs procbody} + #added 2026-08-03 (agent, G-160) + #-renamer is recognised only as the leading argument - anywhere else it now + #errors instead of being silently consumed as the command/procargs/procbody + #value (the historical misparse: 'rename_command ::tgt -renamer ::x' treated + #-renamer as the procargs). The stack stays untouched in both error forms. + test commandstack_renamer_flag_misplacement_errors {rename_command errors when -renamer appears anywhere but the leading position}\ + -constraints commandstacksrc -body { + cs_probe { + proc ::tgt {args} {return [list base $args]} + set c1 [catch {commandstack::rename_command ::tgt {args} {return x} -renamer ::csA} msg1] + set c2 [catch {commandstack::rename_command ::tgt -renamer ::csA} msg2] + list $c1 [string match "*-renamer is recognised only as the leading argument*" $msg1] \ + $c2 [string match "*-renamer is recognised only as the leading argument*" $msg2] \ + [dict size [commandstack::get_stack]] + } + } -result {1 1 1 1 0} + #a same-renamer re-rename with an identical procbody is refused: record is - #'implementation {}', stack unchanged, warning + stack display captured. - test commandstack_samerenamer_same_body_aborted {same-renamer re-rename with identical procbody is refused with implementation {}}\ + #{implementation {} did_rename 0}, stack unchanged; silent with debug off, + #warning + stack display emitted with debug on (G-160 channel discipline). + test commandstack_samerenamer_same_body_aborted {same-renamer re-rename with identical procbody is refused with implementation {} did_rename 0}\ -constraints commandstacksrc -body { cs_probe { proc ::tgt {args} {return [list base $args]} @@ -383,41 +454,44 @@ namespace eval ::testspace { return [list A [uplevel 1 [list $COMMANDSTACKNEXT {*}$args]]] } commandstack::rename_command -renamer ::csA ::tgt {args} $body + set rec2_quiet [commandstack::rename_command -renamer ::csA ::tgt {args} $body] + set quiet_emissions [llength $::PUTS_LOG] + commandstack::debug 1 set rec2 [commandstack::rename_command -renamer ::csA ::tgt {args} $body] - list $rec2 [llength [commandstack::get_stack ::tgt]] [::tgt x] \ + list $rec2_quiet $quiet_emissions $rec2 [llength [commandstack::get_stack ::tgt]] [::tgt x] \ [putslog_matches "*same procbody - Aborting rename*"] } - } -result {{implementation {}} 1 {A {base x}} 1} - - #KNOWN DEFECT (pinned): the per-renamer token counter increments an apply-local - #renamer_command_tokens variable, so tokenid never advances past 1. A - #same-renamer re-rename with NEW code proceeds (warning captured) and stacks a - #second record - but with a DUPLICATE token {::tgt ::csA 1}. get_next_command - #finds the FIRST matching record, so the new override delegates straight to the - #ORIGINAL, silently bypassing the renamer's still-stacked first override. - test commandstack_GAP_samerenamer_new_body_duplicate_token_bypass {same-renamer new-body re-rename stacks a duplicate token and dispatch bypasses the first override}\ + } -result {{implementation {} did_rename 0} 0 {implementation {} did_rename 0} 1 {A {base x}} 1} + + #G-160 FIXED-BEHAVIOUR PIN (flipped from _GAP_ duplicate-token bypass): the + #tokenid counter increments the real namespace variable, so a same-renamer + #re-rename with NEW code gets a DISTINCT token {::tgt ::csA 2}, delegates to + #that renamer's PREVIOUS override (full chain, not the original), and the + #first override remains individually removable by its exact token - after + #which dispatch re-links to the original. + test commandstack_samerenamer_new_body_distinct_token_chain {same-renamer new-body re-rename gets a distinct token, chains through the first override, exact-token removal re-links}\ -constraints commandstacksrc -body { cs_probe { proc ::tgt {args} {return [list base $args]} - commandstack::rename_command -renamer ::csA ::tgt {args} { + set r1 [commandstack::rename_command -renamer ::csA ::tgt {args} { return [list A [uplevel 1 [list $COMMANDSTACKNEXT {*}$args]]] - } + }] set r2 [commandstack::rename_command -renamer ::csA ::tgt {args} { return [list A2 [uplevel 1 [list $COMMANDSTACKNEXT {*}$args]]] }] set stack [commandstack::get_stack ::tgt] - list [llength $stack] [dict get $r2 token] [dict get [lindex $stack 0] token] \ - [dict get $r2 implementation] [::tgt x] \ - [putslog_matches "*appears to be with new code - proceeding*"] - } - } -result {2 {::tgt ::csA 1} {::tgt ::csA 1} ::commandstack::renamed_commands::_ns_tgt-_ns_csA-_ns_csA-1 {A2 {base x}} 1} - - #KNOWN DEFECT (pinned): because tokenid is stuck at 1, a THIRD same-renamer - #rename computes the same renamed_commands target name as the second and the - #underlying [rename] errors ('command already exists'). The failure is at least - #clean: it occurs before the live command is touched - the stack keeps its 2 - #records and the command remains callable. - test commandstack_GAP_third_samerenamer_rename_name_collision {third same-renamer rename collides on the parked-implementation name and errors cleanly}\ + set chained [::tgt x] + commandstack::remove_rename [dict get $r1 token] + list [llength $stack] [dict get $r1 token] [dict get $r2 token] \ + [dict get $r2 implementation] $chained [::tgt x] \ + [llength [commandstack::get_stack ::tgt]] + } + } -result {2 {::tgt ::csA 1} {::tgt ::csA 2} ::commandstack::renamed_commands::_ns_tgt-_ns_csA-_ns_csA-2 {A2 {A {base x}}} {A2 {base x}} 1} + + #G-160 FIXED-BEHAVIOUR PIN (flipped from _GAP_ parked-name collision): with + #unique tokenids a THIRD same-renamer rename computes a fresh parked name and + #succeeds - the call chains through all three overrides to the original. + test commandstack_third_samerenamer_rename_succeeds {third same-renamer rename succeeds with a fresh token and the call chains through all three overrides}\ -constraints commandstacksrc -body { cs_probe { proc ::tgt {args} {return [list base $args]} @@ -427,23 +501,21 @@ namespace eval ::testspace { commandstack::rename_command -renamer ::csA ::tgt {args} { return [list A2 [uplevel 1 [list $COMMANDSTACKNEXT {*}$args]]] } - set c [catch { - commandstack::rename_command -renamer ::csA ::tgt {args} { - return [list A3 [uplevel 1 [list $COMMANDSTACKNEXT {*}$args]]] - } - } msg] - list $c [string match "*already exists*" $msg] \ + set r3 [commandstack::rename_command -renamer ::csA ::tgt {args} { + return [list A3 [uplevel 1 [list $COMMANDSTACKNEXT {*}$args]]] + }] + list [dict get $r3 token] [dict get $r3 did_rename] \ [llength [commandstack::get_stack ::tgt]] [::tgt x] } - } -result {1 1 2 {A2 {base x}}} - - #KNOWN DEFECT (pinned): a renamer re-renaming after ANOTHER renamer took the top - #proceeds with the 'not immediate predecessor' warning (and a stray bare - #'puts stderr' that writes the literal word 'stderr' to stdout - asserted via - #the shim's {stdout stderr} log entry), stacking a third record - but its - #duplicate token again resolves to the renamer's FIRST record, so dispatch - #bypasses both intermediate overrides. - test commandstack_GAP_rerename_after_other_renamer_bypasses_chain {re-rename after another renamer warns, stacks a third record, and dispatch bypasses both intermediate overrides}\ + } -result {{::tgt ::csA 3} 1 3 {A3 {A2 {A {base x}}}}} + + #G-160 FIXED-BEHAVIOUR PIN (flipped from _GAP_ chain bypass + stray stdout + #'stderr' write): a renamer re-renaming after ANOTHER renamer took the top + #stacks a third record with a distinct token and dispatch chains through BOTH + #intermediate overrides; with debug off the operation emits nothing at all + #(the 'not immediate predecessor' warning is debug-gated and the stray bare + #'puts stderr' is gone). + test commandstack_rerename_after_other_renamer_chains {re-rename after another renamer chains through both intermediate overrides silently}\ -constraints commandstacksrc -body { cs_probe { proc ::tgt {args} {return [list base $args]} @@ -457,11 +529,71 @@ namespace eval ::testspace { return [list A2 [uplevel 1 [list $COMMANDSTACKNEXT {*}$args]]] }] list [llength [commandstack::get_stack ::tgt]] \ - [dict get $r3 implementation] [::tgt x] \ - [putslog_matches "*is not immediate predecessor - proceeding anyway*"] \ - [expr {[list stdout stderr] in $::PUTS_LOG}] + [dict get $r3 implementation] [::tgt x] [llength $::PUTS_LOG] + } + } -result {3 ::commandstack::renamed_commands::_ns_tgt-_ns_csB-_ns_csA-2 {A2 {B {A {base x}}}} 0} + + #added 2026-08-03 (agent, G-160) + #channel discipline: with debug off (the default) a full workout of the rename + #machinery - first rename, same-renamer re-rename with new code, re-rename + #after another renamer took the top (the two historically-warning branches), + #and removal of every entry by exact token - emits NOTHING on stdout or + #stderr (the ::puts shim would have captured any emission). + test commandstack_silent_cycle_debug_off {with debug off a full rename/re-rename/remove cycle emits nothing on stdout or stderr}\ + -constraints commandstacksrc -body { + cs_probe { + proc ::tgt {args} {return [list base $args]} + set recs [list] + lappend recs [commandstack::rename_command -renamer ::csA ::tgt {args} { + return [list A [uplevel 1 [list $COMMANDSTACKNEXT {*}$args]]] + }] + lappend recs [commandstack::rename_command -renamer ::csB ::tgt {args} { + return [list B [uplevel 1 [list $COMMANDSTACKNEXT {*}$args]]] + }] + lappend recs [commandstack::rename_command -renamer ::csA ::tgt {args} { + return [list A2 [uplevel 1 [list $COMMANDSTACKNEXT {*}$args]]] + }] + lappend recs [commandstack::rename_command -renamer ::csA ::tgt {args} { + return [list A3 [uplevel 1 [list $COMMANDSTACKNEXT {*}$args]]] + }] + set full_chain [::tgt x] + foreach rec $recs { + commandstack::remove_rename [dict get $rec token] + } + list $full_chain [::tgt x] [llength [commandstack::get_stack ::tgt]] \ + [info commands ::commandstack::renamed_commands::*] [llength $::PUTS_LOG] } - } -result {3 ::commandstack::renamed_commands::_ns_tgt-_ns_csB-_ns_csA-1 {A2 {base x}} 1 1} + } -result {{A3 {A2 {B {A {base x}}}}} {base x} 0 {} 0} + + #added 2026-08-03 (agent, G-160) + #the commandstack::next delegation helper: called directly from an installed + #override body it delegates to the body's COMMANDSTACKNEXT at the override's + #caller level - result AND caller-context identical to the manual + #'uplevel 1 [list $COMMANDSTACKNEXT {*}$args]' convention (the base proc + #reports its caller's namespace to prove the frame); called from anywhere + #else it errors cleanly. + test commandstack_next_helper_delegation {commandstack::next delegates like the manual uplevel convention incl caller context; errors outside an override body}\ + -constraints commandstacksrc -body { + cs_probe { + proc ::tgtman {args} {return [list base $args [uplevel 1 {namespace current}]]} + proc ::tgthelp {args} {return [list base $args [uplevel 1 {namespace current}]]} + commandstack::rename_command -renamer ::csA ::tgtman {args} { + return [list M [uplevel 1 [list $COMMANDSTACKNEXT {*}$args]]] + } + commandstack::rename_command -renamer ::csA ::tgthelp {args} { + return [list M [commandstack::next {*}$args]] + } + namespace eval ::ctxprobe { + variable manual [::tgtman x] + variable helper [::tgthelp x] + } + set c [catch {commandstack::next foo} msg] + list [set ::ctxprobe::helper] \ + [expr {[lindex $::ctxprobe::manual 1] eq [lindex $::ctxprobe::helper 1]}] \ + [expr {[lindex [lindex $::ctxprobe::manual 1] 2] eq "::ctxprobe"}] \ + $c [string match "*must be called directly from a proc body installed by*" $msg] + } + } -result {{M {base x ::ctxprobe}} 1 1 1 1} #rename_command accepts arbitrary proc signatures (the punk auto_execok and #packagetrace tcl_findLibrary usage) - defaults still apply through the shim. @@ -494,9 +626,11 @@ namespace eval ::testspace { } } -result {1 1 1 1 1 {}} - #debug: defaults 0, set/query round-trip, non-boolean argument errors; with - #debug on, rename_command reports the first rename on stderr. - test commandstack_debug_accessor {debug accessor round-trip, non-boolean errors, debug-on rename reports progress}\ + #debug: defaults 0, set/query round-trip; a non-boolean argument raises a + #clean error NAMING the on_off argument (G-160 - the historical code + #validated the state variable and died inside expr instead); with debug on, + #rename_command reports the first rename on stderr. + test commandstack_debug_accessor {debug accessor round-trip, non-boolean argument errors naming on_off, debug-on rename reports progress}\ -constraints commandstacksrc -body { cs_probe { set a [commandstack::debug] @@ -508,59 +642,70 @@ namespace eval ::testspace { } set logged [putslog_matches "*1st detected rename of command '::tgt'*"] set d [commandstack::debug 0] - set e [catch {commandstack::debug notabool}] - list $a $b $c $logged $d $e + set e [catch {commandstack::debug notabool} emsg] + list $a $b $c $logged $d $e \ + [string match "*on_off*'notabool'*not a boolean*" $emsg] } - } -result {0 1 1 1 0 1} + } -result {0 1 1 1 0 1 1} - #Delete_stack always returns 1 (stack present or not) and does NOT undo renames. - #KNOWN FOOT-GUN (pinned): deleting the stack under a live override breaks - #COMMANDSTACKNEXT resolution - get_next_command falls back to the command name - #itself, so the next call recurses to the interp limit. - test commandstack_GAP_delete_stack_live_rename_recursion {Delete_stack under a live rename leaves the override calling itself - recursion limit error}\ + #G-160 FIXED-BEHAVIOUR PIN (flipped from _GAP_ self-delegation recursion): + #Delete_stack ERRORS while the stack still holds live rename records (the + #override keeps working - no recursion), still returns 1 for a never-stacked + #command, and deletes the empty stack entry left after the last remove_rename. + test commandstack_delete_stack_guard {Delete_stack errors under live renames leaving the override working; empty and missing stacks return 1}\ -constraints commandstacksrc -body { cs_probe { proc ::tgt {args} {return [list base $args]} - commandstack::rename_command -renamer ::csA ::tgt {args} { + set rec [commandstack::rename_command -renamer ::csA ::tgt {args} { uplevel 1 [list $COMMANDSTACKNEXT {*}$args] - } - set d1 [commandstack::Delete_stack ::tgt] + }] + set c1 [catch {commandstack::Delete_stack ::tgt} msg1] + set still_works [::tgt x] set d2 [commandstack::Delete_stack ::never_stacked] - set code [catch {::tgt x} msg] - list $d1 $d2 $code [string match "*too many nested evaluations*" $msg] + commandstack::remove_rename [dict get $rec token] + set empty_entry_exists [dict exists [commandstack::get_stack] ::tgt] + set d3 [commandstack::Delete_stack ::tgt] + list $c1 [string match "*live rename record*remove_rename first*" $msg1] \ + $still_works $d2 $empty_entry_exists $d3 \ + [dict exists [commandstack::get_stack] ::tgt] } - } -result {1 1 1 1} - - #Rename_stack re-keys stack records without touching commands; the parked key is - #invisible to get_stack (namespace which resolution fails for a - #non-command name) but present in the no-arg dict; renaming onto an existing - #stack key errors. - test commandstack_rename_stack_parks_records {Rename_stack parks records under a new key - visible only via the no-arg dict; existing key errors}\ + } -result {1 1 {base x} 1 1 1 0} + + #G-160: Rename_stack re-keys stack records without touching commands and + #returns 1 (moved) / 0 (no stack at oldname) instead of leaking the whole + #stacks dict; get_stack retrieves the parked records by raw key; delegation + #of the live override keeps working while parked (token map resolution); + #renaming onto an existing stack key errors. + test commandstack_rename_stack_parks_records {Rename_stack returns 1/0, parked records retrievable via get_stack, live dispatch survives parking; existing key errors}\ -constraints commandstacksrc -body { cs_probe { proc ::tgt {args} {return [list base $args]} commandstack::rename_command -renamer ::csA ::tgt {args} { - uplevel 1 [list $COMMANDSTACKNEXT {*}$args] + return [list A [uplevel 1 [list $COMMANDSTACKNEXT {*}$args]]] } - commandstack::Rename_stack ::tgt ::tgt_parked - set full [commandstack::get_stack] + set moved [commandstack::Rename_stack ::tgt ::tgt_parked] + set nomove [commandstack::Rename_stack ::tgt ::elsewhere] + set parked [commandstack::get_stack ::tgt_parked] + set keys_parked [dict keys [commandstack::get_stack] ::tgt*] set err [catch { commandstack::Rename_stack ::tgt_parked ::tgt_parked } msg] - list [commandstack::get_stack ::tgt_parked] [dict keys $full] \ - $err [string match "*already exists in stack*" $msg] - } - } -result {{} ::tgt_parked 1 1} - - #get_IMPLEMENTOR classification: magic-comment proc -> package name; plain proc - #-> unspecified; a commandstack-renamed command reports its renamer via the - #injected IMPLEMENTOR comment. KNOWN DEFECT (pinned): builtins report - #'undetermined' on EVERY Tcl version - the guard probes 'tcl::info::cmdtype' - #with an unqualified pattern from inside commandstack::util, and info commands - #pattern matching does not fall back to the global namespace, so the 'builtin' - #classification branch is unreachable even on 8.7+/9 where cmdtype exists (the - #guard_sees element pins the empty pattern-match result that causes it). - test commandstack_GAP_get_implementor_builtin_branch_unreachable {get_IMPLEMENTOR classifies magic-comment/plain/renamed procs but builtins report undetermined - cmdtype guard unreachable}\ + set while_parked [::tgt x] + commandstack::Rename_stack ::tgt_parked ::tgt + list $moved $nomove [llength $parked] [dict get [lindex $parked 0] renamer] \ + $keys_parked \ + $err [string match "*already exists in stack*" $msg] \ + $while_parked [::tgt y] [dict keys [commandstack::get_stack] ::tgt*] + } + } -result {1 0 1 ::csA ::tgt_parked 1 1 {A {base x}} {A {base y}} ::tgt} + + #G-160 FIXED-BEHAVIOUR PIN (flipped from _GAP_ unreachable builtin branch): + #get_IMPLEMENTOR classification - magic-comment proc -> package name; plain + #proc -> unspecified; a commandstack-renamed command reports its renamer via + #the injected IMPLEMENTOR comment; and a native command now classifies as + #'builtin' wherever ::tcl::info::cmdtype exists (the guard and call are fully + #qualified) - 'undetermined' where it does not (Tcl 8.6). + test commandstack_get_implementor_classification {get_IMPLEMENTOR classifies magic-comment/plain/renamed procs and builtins per cmdtype availability}\ -constraints commandstacksrc -body { cs_probe { proc ::withmagic {args} { @@ -572,13 +717,13 @@ namespace eval ::testspace { commandstack::rename_command -renamer ::csA ::tgt {args} { uplevel 1 [list $COMMANDSTACKNEXT {*}$args] } - set guard_sees [namespace eval ::commandstack::util {info commands tcl::info::cmdtype}] + set expect_builtin [expr {[info commands ::tcl::info::cmdtype] ne "" ? "builtin" : "undetermined"}] list [commandstack::util::get_IMPLEMENTOR ::withmagic] \ [commandstack::util::get_IMPLEMENTOR ::plainone] \ - [commandstack::util::get_IMPLEMENTOR ::lrepeat] \ - [commandstack::util::get_IMPLEMENTOR ::tgt] $guard_sees + [expr {[commandstack::util::get_IMPLEMENTOR ::lrepeat] eq $expect_builtin}] \ + [commandstack::util::get_IMPLEMENTOR ::tgt] } - } -result {mypkg unspecified undetermined ::csA {}} + } -result {mypkg unspecified 1 ::csA} #split_body splits an installed override body at the separator marker: header #carries the IMPLEMENTOR comment and COMMANDSTACKNEXT setup (marker line itself @@ -626,9 +771,10 @@ namespace eval ::testspace { list [expr {[string length $h] > 500}] \ [string match "*rename_command*" $h] [string match "*remove_rename*" $h] \ [string match "*COMMANDSTACKNEXT*" $h] [string match "*basecall*" $h] \ - [string match "*get_next_command*" $h] [string match "*get_stack*" $h] + [string match "*get_next_command*" $h] [string match "*get_stack*" $h] \ + [string match "*commandstack::next*" $h] } - } -result {1 1 1 1 1 1 1} + } -result {1 1 1 1 1 1 1 1} #the PUNKARGS documentation registers lazily with punk::args (no punk::args #dependency in the module itself) - every documented id resolves and renders a @@ -640,7 +786,8 @@ namespace eval ::testspace { foreach id { ::commandstack::help ::commandstack::debug ::commandstack::get_stack ::commandstack::get_next_command ::commandstack::basecall - ::commandstack::rename_command ::commandstack::remove_rename + ::commandstack::rename_command ::commandstack::next + ::commandstack::remove_rename ::commandstack::show_stack ::commandstack::Delete_stack ::commandstack::Rename_stack ::commandstack::util::get_IMPLEMENTOR ::commandstack::lib::splitx ::commandstack::lib::split_body diff --git a/src/tests/modules/punk/packagepreference/testsuites/packagepreference/installguard.test b/src/tests/modules/punk/packagepreference/testsuites/packagepreference/installguard.test new file mode 100644 index 00000000..f20d3912 --- /dev/null +++ b/src/tests/modules/punk/packagepreference/testsuites/packagepreference/installguard.test @@ -0,0 +1,115 @@ +# -*- tcl -*- +# punk::packagepreference install re-install guard (G-160). +# +# The install proc's already-installed check reads each ::package stack record's +# renamer field. The historical code read record key 'rename' (the key is +# 'renamer'), so [dict get] threw on the second install instead of silently +# returning 0 - latent in kits, which install exactly once per interp. +# +# Tests run against the SOURCE-TREE modules: a fresh child interp per test +# sources commandstack then punk::packagepreference by path (resolution-proof - +# a package require could satisfy from a bootsupport/kit-stamped snapshot that +# predates the fix). A ::puts shim captures module output so silence is +# assertable. ::package in the child is the real builtin - renames are confined +# to the child and the child is deleted afterwards. +# +# Run: tclsh src/tests/runtests.tcl -report compact -show-passes 0 -include-paths modules/punk/packagepreference/*** installguard.test + +package require tcltest + +namespace eval ::ppinstalltest { + namespace import ::tcltest::* + + #The SOURCE-TREE modules, located relative to this test file (highest + #version by vcompare should multiple copies coexist). + variable script_dir [file dirname [file normalize [info script]]] + variable srcmodules [file normalize [file join $script_dir .. .. .. .. .. .. modules]] + proc find_src_module {pattern} { + variable srcmodules + set best "" + set bestver "" + foreach candidate [glob -nocomplain [file join $srcmodules {*}$pattern]] { + set thisver [file rootname [lindex [split [file tail $candidate] -] end]] + if {$best eq "" || [package vcompare $thisver $bestver] == 1} { + set best $candidate + set bestver $thisver + } + } + return $best + } + variable commandstack_src [find_src_module {commandstack-*.tm}] + variable packagepreference_src [find_src_module {punk packagepreference-*.tm}] + testConstraint ppsrc [expr {$commandstack_src ne "" && $packagepreference_src ne ""}] + if {![testConstraint ppsrc]} { + puts stderr "installguard.test: cannot locate src commandstack/packagepreference modules relative to [info script] (tests will be skipped)" + } + + #fresh child interp with the source-tree commandstack + punk::packagepreference + #sourced by path; ::puts shim captures 1-arg and stdout/stderr 2-arg writes + #into ::PUTS_LOG for silence assertions (pattern from the commandstack suite) + proc pp_probe {script} { + variable commandstack_src + variable packagepreference_src + set i [interp create] + try { + interp eval $i { + set ::PUTS_LOG [list] + rename ::puts ::puts_real + proc ::puts {args} { + set a $args + if {[lindex $a 0] eq "-nonewline"} {set a [lrange $a 1 end]} + if {[llength $a] == 1} { + lappend ::PUTS_LOG [list stdout [lindex $a 0]] + } elseif {[llength $a] == 2 && [lindex $a 0] in {stdout stderr}} { + lappend ::PUTS_LOG [list [lindex $a 0] [lindex $a 1]] + } else { + ::puts_real {*}$args + } + return + } + } + interp eval $i [list source $commandstack_src] + interp eval $i [list source $packagepreference_src] + interp eval $i $script + } finally { + interp delete $i + } + } + + #added 2026-08-03 (agent, G-160) + #first install returns 1 and stacks one punk::packagepreference record; the + #SECOND install takes the already-installed guard (which now reads the + #record key that exists - renamer) and returns 0 silently without stacking + #anything; ::package keeps working through the override. + test packagepreference_double_install_returns_0 {second install returns 0 silently via the renamer-key guard, stack keeps one record, ::package still works}\ + -constraints ppsrc -body { + pp_probe { + set i1 [punk::packagepreference::install] + set i2 [punk::packagepreference::install] + set stack [commandstack::get_stack ::package] + list $i1 $i2 [llength $stack] [dict get [lindex $stack 0] renamer] \ + [expr {[package provide Tcl] ne ""}] [llength $::PUTS_LOG] + } + } -result {1 0 1 punk::packagepreference 1 0} + + #added 2026-08-03 (agent, G-160) + #install / double-install / uninstall / re-install cycle: uninstall restores + #the previous implementation, a fresh install then succeeds again with the + #next unique tokenid for the (punk::packagepreference,::package) pairing - + #all silently. + test packagepreference_reinstall_after_uninstall {uninstall then re-install succeeds with the next unique tokenid, silently}\ + -constraints ppsrc -body { + pp_probe { + set i1 [punk::packagepreference::install] + set t1 [dict get [lindex [commandstack::get_stack ::package] 0] token] + set i2 [punk::packagepreference::install] + punk::packagepreference::uninstall + set emptied [llength [commandstack::get_stack ::package]] + set i3 [punk::packagepreference::install] + set t3 [dict get [lindex [commandstack::get_stack ::package] 0] token] + list $i1 $t1 $i2 $emptied $i3 $t3 [llength $::PUTS_LOG] + } + } -result {1 {::package punk::packagepreference 1} 0 0 1 {::package punk::packagepreference 2} 0} + + cleanupTests +}