Browse Source
Module (src/modules/commandstack-999999.0a1.0.tm, 0.4.1 -> 0.5.0):
- commandstack::help now returns a real dependency-free API overview (was
an empty string): rename/remove workflow, COMMANDSTACKNEXT delegation
contract, inspection commands, in-tree users.
- PUNKARGS documentation blocks added for every API proc (help, debug,
get_stack, get_next_command, basecall, rename_command, remove_rename,
show_stack, Delete_stack, Rename_stack, util::get_IMPLEMENTOR,
lib::splitx, lib::split_body), registered lazily via
::punk::args::register::NAMESPACES - no punk::args dependency added.
Tests (new src/tests/modules/commandstack/testsuites/commandstack/commandstack.test,
29 tests, green on tclsh90 9.0.3 + punk86 8.6):
- usage-driven characterisation of the behaviours in-tree consumers rely on
(punk::packagepreference, packagetrace, packagesuppress, punk auto_execok,
punk::nav::fs cd): record shape/key-order contract, implementation {} as
the no-rename signal, COMMANDSTACKNEXT/COMMANDSTACKNEXT_ORIGINAL
delegation, multi-renamer stacking with removal in any order, builtin
renames, remove_rename argument forms, show_stack fallback render,
get_IMPLEMENTOR/split_body/splitx, help, lazy punk::args registration.
- known defects pinned as _GAP_ tests: per-renamer tokenid stuck at 1
(apply-local counter var) so same-renamer re-renames stack duplicate
tokens whose dispatch bypasses intermediate layers, and a third rename
collides on the parked-implementation name; get_IMPLEMENTOR builtin
branch unreachable (unqualified info commands pattern inside
commandstack::util); Delete_stack under a live rename self-delegates to
recursion; stray bare puts stderr writes literal stderr to stdout.
- behavioural tests run in fresh child interps (module sourced by path,
::puts shim captures module warnings for assertion).
Docs:
- src/tests/AGENTS.md: new contract - test descriptions must be single
content line (multi-line descriptions make tcltest failure banners
multi-line; punk::tcltestrun parser then swallows all later events
including the summary line - discovered authoring this suite).
- src/tests/modules/AGENTS.md: commandstack child index entry.
- punkproject.toml 0.49.2 + CHANGELOG entry.
Assisted-by: harness=claude; primary-model=claude-fable-5; api-location=anthropic.com
master
7 changed files with 1040 additions and 7 deletions
@ -1,3 +1,7 @@
|
||||
0.4.1 |
||||
0.5.0 |
||||
#First line must be a tm version number |
||||
#all other lines are ignored. |
||||
#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 |
||||
# dependency added; module remains dependency-free) |
||||
|
||||
@ -0,0 +1,656 @@
|
||||
# -*- tcl -*- |
||||
# Characterisation tests for the commandstack module (cooperative command |
||||
# renaming / stacked command overrides). |
||||
# |
||||
# Coverage is usage-driven - the pinned behaviours are the ones in-tree |
||||
# consumers rely on (punk::packagepreference and packagetrace/packagesuppress |
||||
# rename ::package; punk::nav::fs renames the ::cd builtin and uses basecall; |
||||
# punk renames ::auto_execok with a single-arg signature): |
||||
# 1. rename_command record shape: a dict whose KEY ORDER is a documented |
||||
# contract (token renamer next_implementor next_getter implementation - |
||||
# cooperating code uses lsearch -index 1 / -index 3), token |
||||
# {command renamer tokenid}, and 'implementation' empty string as the |
||||
# no-rename-performed signal consumers test for. |
||||
# 2. Delegation through the injected COMMANDSTACKNEXT (re-resolved each call |
||||
# via get_next_command) and static COMMANDSTACKNEXT_ORIGINAL variables. |
||||
# 3. Stacked overrides from different renamers and removal in ANY order |
||||
# (the design goal: entry above a removed entry is re-pointed), including |
||||
# renames of true builtins (next_implementor 'original') and non-{args} |
||||
# proc signatures. |
||||
# 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. |
||||
# 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, |
||||
# and lazy punk::args registration of the PUNKARGS documentation. |
||||
# |
||||
# Tests run against the SOURCE-TREE module. Behavioural tests use a fresh |
||||
# child interp per test (sourcing the module by path) so that: module state |
||||
# (all_stacks/known_renamers) starts clean every time, renames of builtins |
||||
# cannot damage the shared testinterp, show_stack deterministically takes its |
||||
# no-punk::lib fallback branch, and the module's stderr warnings are captured |
||||
# (a ::puts shim in the child) rather than polluting runner output. |
||||
# |
||||
# NOTE (runner parsing contract, discovered 2026-08-03): test DESCRIPTIONS in |
||||
# this suite are deliberately single-line. tcltest prints a failing test's |
||||
# banner as one puts of "==== <name> <description> FAILED"; a description with |
||||
# embedded newlines makes that banner multi-line and punk::tcltestrun's |
||||
# per-line output parser then misses the opening banner, misreads the closing |
||||
# "==== <name> FAILED" line as an opener, and swallows every subsequent event |
||||
# INCLUDING the summary line (file reports warn/missing-cleanupTests with no |
||||
# failure detail). Longer prose lives in comments above each test instead. |
||||
# |
||||
# Run: tclsh src/tests/runtests.tcl -report compact -show-passes 0 -include-paths modules/commandstack/*** commandstack.test |
||||
|
||||
package require tcltest |
||||
package require commandstack |
||||
|
||||
namespace eval ::testspace { |
||||
namespace import ::tcltest::* |
||||
|
||||
#The SOURCE-TREE commandstack module, located relative to this test file |
||||
#(highest version by vcompare should multiple commandstack-*.tm coexist). |
||||
variable commandstack_src "" |
||||
variable commandstack_ver "" |
||||
variable script_dir [file dirname [file normalize [info script]]] |
||||
set srcmodules [file normalize [file join $script_dir .. .. .. .. .. modules]] |
||||
foreach candidate [glob -nocomplain [file join $srcmodules commandstack-*.tm]] { |
||||
set thisver [file rootname [lindex [split [file tail $candidate] -] 1]] |
||||
if {$commandstack_src eq "" || [package vcompare $thisver $commandstack_ver] == 1} { |
||||
set commandstack_src $candidate |
||||
set commandstack_ver $thisver |
||||
} |
||||
} |
||||
testConstraint commandstacksrc [expr {$commandstack_src ne ""}] |
||||
if {$commandstack_src eq ""} { |
||||
puts stderr "commandstack.test: cannot locate src/modules/commandstack-*.tm relative to [info script] (probe tests will be skipped)" |
||||
} |
||||
|
||||
testConstraint havepunkargs [expr {![catch {package require punk::args}]}] |
||||
if {[testConstraint havepunkargs]} { |
||||
#guarded punk::lib require AFTER punk::args - 8.6 render paths use |
||||
#forward-compat commands from punk::lib (recorded project trap) |
||||
catch {package require punk::lib} |
||||
} |
||||
|
||||
# ------------------------------------------------------------------------- |
||||
# Probe: fresh child interp with the source-tree commandstack sourced. |
||||
# A ::puts shim captures 1-arg and stdout/stderr 2-arg writes into |
||||
# ::PUTS_LOG (list of {channel text}) - assertable, and keeps module |
||||
# warnings out of runner output. Other/real channel writes pass through. |
||||
# ------------------------------------------------------------------------- |
||||
proc cs_probe {script} { |
||||
variable commandstack_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} { |
||||
#note - a bare 'puts stderr' (no message) lands here as {stdout stderr} |
||||
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 |
||||
} |
||||
proc ::putslog_matches {pattern} { |
||||
set n 0 |
||||
foreach entry $::PUTS_LOG { |
||||
if {[string match $pattern [lindex $entry 1]]} {incr n} |
||||
} |
||||
return $n |
||||
} |
||||
} |
||||
interp eval $i [list source $commandstack_src] |
||||
interp eval $i $script |
||||
} finally { |
||||
interp delete $i |
||||
} |
||||
} |
||||
|
||||
#added 2026-08-03 (agent) - characterisation suite for commandstack (usage-driven: |
||||
#punk::packagepreference / packagetrace / packagesuppress / punk auto_execok / punk::nav::fs cd) |
||||
|
||||
test commandstack_package_version {package require commandstack resolves the source-tree magic version via prefer-latest}\ |
||||
-body { |
||||
package require commandstack |
||||
package provide commandstack |
||||
} -result {999999.0a1.0} |
||||
|
||||
#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}\ |
||||
-constraints commandstacksrc -body { |
||||
cs_probe { |
||||
proc ::tgt {args} {return [list base $args]} |
||||
commandstack::rename_command -renamer ::csA ::tgt {args} { |
||||
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} |
||||
|
||||
#installed body sees COMMANDSTACKNEXT (dynamic, re-resolved per call) and |
||||
#COMMANDSTACKNEXT_ORIGINAL (static) - both equal the record implementation |
||||
#after a single rename, and delegation reaches the original. |
||||
test commandstack_rename_delegation_variables {installed body sees COMMANDSTACKNEXT + COMMANDSTACKNEXT_ORIGINAL and delegates to the original}\ |
||||
-constraints commandstacksrc -body { |
||||
cs_probe { |
||||
proc ::tgt {args} {return [list base $args]} |
||||
set rec [commandstack::rename_command -renamer ::csA ::tgt {args} { |
||||
return [list $COMMANDSTACKNEXT $COMMANDSTACKNEXT_ORIGINAL [uplevel 1 [list $COMMANDSTACKNEXT {*}$args]]] |
||||
}] |
||||
set impl [dict get $rec implementation] |
||||
lassign [::tgt x y] next orig delegated |
||||
list [expr {$next eq $impl}] [expr {$orig eq $impl}] $delegated |
||||
} |
||||
} -result {1 1 {base {x y}}} |
||||
|
||||
#rename_command on a true builtin (::lrepeat): the not-a-proc path records |
||||
#next_implementor 'original' with the dash-form implementation name; delegation |
||||
#works and remove_rename restores the native command, leaving |
||||
#::commandstack::renamed_commands empty. |
||||
test commandstack_rename_builtin_original_and_restore {builtin rename: next_implementor original, delegation, remove restores native command}\ |
||||
-constraints commandstacksrc -body { |
||||
cs_probe { |
||||
set rec [commandstack::rename_command -renamer ::csB ::lrepeat {args} { |
||||
uplevel 1 [list $COMMANDSTACKNEXT {*}$args] |
||||
}] |
||||
set through [lrepeat 2 ab] |
||||
commandstack::remove_rename {::lrepeat ::csB} |
||||
list [dict get $rec next_implementor] [dict get $rec implementation] \ |
||||
$through [lrepeat 2 cd] [llength [commandstack::get_stack ::lrepeat]] \ |
||||
[info procs ::lrepeat] [info commands ::commandstack::renamed_commands::*] |
||||
} |
||||
} -result {original ::commandstack::renamed_commands::_ns_lrepeat-original-_ns_csB-1 {ab ab} {cd cd} 0 {} {}} |
||||
|
||||
#get_stack: no-arg returns the all-stacks dict keyed by fq name; command arg |
||||
#returns that command's record list; unstacked and nonexistent commands return |
||||
#an empty list. |
||||
test commandstack_get_stack_forms {get_stack: all-stacks dict, per-command list, empty for unstacked and nonexistent commands}\ |
||||
-constraints commandstacksrc -body { |
||||
cs_probe { |
||||
proc ::tgt {args} {return [list base $args]} |
||||
commandstack::rename_command -renamer ::csA ::tgt {args} { |
||||
uplevel 1 [list $COMMANDSTACKNEXT {*}$args] |
||||
} |
||||
set all [commandstack::get_stack] |
||||
list [dict size $all] [dict keys $all] [llength [commandstack::get_stack ::tgt]] \ |
||||
[commandstack::get_stack ::lrepeat] [commandstack::get_stack ::no_such_cmd] |
||||
} |
||||
} -result {1 ::tgt 1 {} {}} |
||||
|
||||
#get_next_command: a valid token resolves to the record implementation; a |
||||
#command with no stack passes through unchanged; a stacked command with a |
||||
#non-matching token raises the pinned error. |
||||
test commandstack_get_next_command_resolution {get_next_command: token resolves implementation, no-stack passthrough, bad token errors}\ |
||||
-constraints commandstacksrc -body { |
||||
cs_probe { |
||||
proc ::tgt {args} {return [list base $args]} |
||||
set rec [commandstack::rename_command -renamer ::csA ::tgt {args} { |
||||
uplevel 1 [list $COMMANDSTACKNEXT {*}$args] |
||||
}] |
||||
set good [commandstack::get_next_command ::tgt ::csA 1] |
||||
set passthrough [commandstack::get_next_command ::lrepeat ::whoever 1] |
||||
set code [catch {commandstack::get_next_command ::tgt ::csA 99} msg] |
||||
list [expr {$good eq [dict get $rec implementation]}] $passthrough \ |
||||
$code [string match "*unable to determine next command*" $msg] |
||||
} |
||||
} -result {1 ::lrepeat 1 1} |
||||
|
||||
#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. |
||||
test commandstack_two_renamers_stack_and_chain {two renamers stack bottom-first and calls chain top-down through both to the original}\ |
||||
-constraints commandstacksrc -body { |
||||
cs_probe { |
||||
proc ::tgt {args} {return [list base $args]} |
||||
commandstack::rename_command -renamer ::csA ::tgt {args} { |
||||
return [list A [uplevel 1 [list $COMMANDSTACKNEXT {*}$args]]] |
||||
} |
||||
set r2 [commandstack::rename_command -renamer ::csB ::tgt {args} { |
||||
return [list B [uplevel 1 [list $COMMANDSTACKNEXT {*}$args]]] |
||||
}] |
||||
set stack [commandstack::get_stack ::tgt] |
||||
list [::tgt x] [llength $stack] \ |
||||
[dict get [lindex $stack 0] renamer] [dict get [lindex $stack 1] renamer] \ |
||||
[dict get $r2 next_implementor] [dict get $r2 implementation] |
||||
} |
||||
} -result {{B {A {base x}}} 2 ::csA ::csB ::csA ::commandstack::renamed_commands::_ns_tgt-_ns_csA-_ns_csB-1} |
||||
|
||||
#basecall reaches the bottom-of-stack original implementation regardless of |
||||
#stacked overrides; on a never-renamed command it just calls the command. |
||||
test commandstack_basecall_bypasses_overrides {basecall reaches the original under stacked overrides and calls unstacked commands directly}\ |
||||
-constraints commandstacksrc -body { |
||||
cs_probe { |
||||
proc ::tgt {args} {return [list base $args]} |
||||
proc ::plainproc {args} {return [list plain $args]} |
||||
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]]] |
||||
} |
||||
list [commandstack::basecall ::tgt x] [commandstack::basecall ::plainproc y] |
||||
} |
||||
} -result {{base x} {plain y}} |
||||
|
||||
#the load/unload-any-order design goal: removing the BOTTOM entry re-points the |
||||
#entry above at what the removed entry delegated to (implementation and |
||||
#next_implementor copied down), deletes the removed renamer's parked proc, and |
||||
#dispatch skips the removed layer; removing the remaining entry then restores |
||||
#the original completely. |
||||
test commandstack_remove_bottom_entry_relinks {removing the bottom entry re-links the entry above; final remove restores the original}\ |
||||
-constraints commandstacksrc -body { |
||||
cs_probe { |
||||
proc ::tgt {args} {return [list base $args]} |
||||
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]]] |
||||
} |
||||
commandstack::remove_rename {::tgt ::csA} |
||||
set stack [commandstack::get_stack ::tgt] |
||||
set rec [lindex $stack 0] |
||||
set midcall [::tgt x] |
||||
set aparked [info commands ::commandstack::renamed_commands::_ns_tgt-_ns_csA-_ns_csB-1] |
||||
commandstack::remove_rename {::tgt ::csB} |
||||
list $midcall [llength $stack] $aparked \ |
||||
[dict get $rec implementation] [dict get $rec next_implementor] \ |
||||
[::tgt x] [llength [commandstack::get_stack ::tgt]] \ |
||||
[info commands ::commandstack::renamed_commands::*] |
||||
} |
||||
} -result {{B {base x}} 1 {} ::commandstack::renamed_commands::_ns_tgt_unspecified-_ns_csA-1 unspecified {base x} 0 {}} |
||||
|
||||
#removing the TOP entry (by exact token) reinstates the previous override as the |
||||
#live command; removing the last entry restores the original. |
||||
test commandstack_remove_top_entry_restores_previous {removing the top entry by token reinstates the previous override, then the original}\ |
||||
-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]]] |
||||
}] |
||||
set r2 [commandstack::rename_command -renamer ::csB ::tgt {args} { |
||||
return [list B [uplevel 1 [list $COMMANDSTACKNEXT {*}$args]]] |
||||
}] |
||||
commandstack::remove_rename [dict get $r2 token] |
||||
set midcall [::tgt x] |
||||
set midlen [llength [commandstack::get_stack ::tgt]] |
||||
commandstack::remove_rename [dict get $r1 token] |
||||
list $midcall $midlen [::tgt x] [llength [commandstack::get_stack ::tgt]] |
||||
} |
||||
} -result {{A {base x}} 1 {base x} 0} |
||||
|
||||
#rename_command without -renamer records the calling namespace as renamer and |
||||
#resolves a relative command name in the caller's context; remove_rename with a |
||||
#bare command name works from that same namespace context. |
||||
test commandstack_default_renamer_and_bare_remove {default renamer is the calling namespace; bare-name remove works from that context}\ |
||||
-constraints commandstacksrc -body { |
||||
cs_probe { |
||||
namespace eval ::csC {} |
||||
proc ::csC::victim {args} {return [list vbase $args]} |
||||
set rec [namespace eval ::csC { |
||||
commandstack::rename_command victim {args} { |
||||
return [list wrapped [uplevel 1 [list $COMMANDSTACKNEXT {*}$args]]] |
||||
} |
||||
}] |
||||
set call1 [::csC::victim k] |
||||
set after [namespace eval ::csC {commandstack::remove_rename victim}] |
||||
list [dict get $rec token] $call1 [::csC::victim k] [llength $after] |
||||
} |
||||
} -result {{::csC::victim ::csC 1} {wrapped {vbase k}} {vbase k} 0} |
||||
|
||||
#remove_rename errors for a renamer commandstack has never seen - including the |
||||
#bare-command form called from a namespace context (here ::) that performed no |
||||
#rename. |
||||
test commandstack_remove_unknown_renamer_errors {remove_rename errors for unknown renamers, including bare-name form from a non-renamer context}\ |
||||
-constraints commandstacksrc -body { |
||||
cs_probe { |
||||
proc ::tgt {args} {return [list base $args]} |
||||
commandstack::rename_command -renamer ::csA ::tgt {args} { |
||||
uplevel 1 [list $COMMANDSTACKNEXT {*}$args] |
||||
} |
||||
set c1 [catch {commandstack::remove_rename {::tgt ::neverheardof}} msg1] |
||||
set c2 [catch {commandstack::remove_rename ::tgt} msg2] ;#renamer defaults to caller ns :: |
||||
list $c1 [string match "*not in list of known_renamers*" $msg1] \ |
||||
$c2 [string match "*not in list of known_renamers*" $msg2] |
||||
} |
||||
} -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}\ |
||||
-constraints commandstacksrc -body { |
||||
cs_probe { |
||||
set initial $::commandstack::known_renamers |
||||
proc ::tgt {args} {return [list base $args]} |
||||
commandstack::rename_command -renamer ::csA ::tgt {args} { |
||||
uplevel 1 [list $COMMANDSTACKNEXT {*}$args] |
||||
} |
||||
list $initial $::commandstack::known_renamers |
||||
} |
||||
} -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}\ |
||||
-constraints commandstacksrc -body { |
||||
cs_probe { |
||||
set rec [commandstack::rename_command -renamer ::csX ::definitely_not_here {args} {}] |
||||
list $rec [dict size [commandstack::get_stack]] \ |
||||
[putslog_matches "*not found in calling context*"] |
||||
} |
||||
} -result {{implementation {}} 0 1} |
||||
|
||||
test commandstack_rename_command_usage_error {rename_command arg-count validation message is pinned}\ |
||||
-constraints commandstacksrc -body { |
||||
cs_probe { |
||||
catch {commandstack::rename_command ::whatever} msg |
||||
set msg |
||||
} |
||||
} -result {commandstack::rename_command usage: rename_command ?-renamer <string>? command procargs procbody} |
||||
|
||||
#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 {}}\ |
||||
-constraints commandstacksrc -body { |
||||
cs_probe { |
||||
proc ::tgt {args} {return [list base $args]} |
||||
set body { |
||||
return [list A [uplevel 1 [list $COMMANDSTACKNEXT {*}$args]]] |
||||
} |
||||
commandstack::rename_command -renamer ::csA ::tgt {args} $body |
||||
set rec2 [commandstack::rename_command -renamer ::csA ::tgt {args} $body] |
||||
list $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}\ |
||||
-constraints commandstacksrc -body { |
||||
cs_probe { |
||||
proc ::tgt {args} {return [list base $args]} |
||||
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}\ |
||||
-constraints commandstacksrc -body { |
||||
cs_probe { |
||||
proc ::tgt {args} {return [list base $args]} |
||||
commandstack::rename_command -renamer ::csA ::tgt {args} { |
||||
return [list A [uplevel 1 [list $COMMANDSTACKNEXT {*}$args]]] |
||||
} |
||||
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] \ |
||||
[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}\ |
||||
-constraints commandstacksrc -body { |
||||
cs_probe { |
||||
proc ::tgt {args} {return [list base $args]} |
||||
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]]] |
||||
} |
||||
set r3 [commandstack::rename_command -renamer ::csA ::tgt {args} { |
||||
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}] |
||||
} |
||||
} -result {3 ::commandstack::renamed_commands::_ns_tgt-_ns_csB-_ns_csA-1 {A2 {base x}} 1 1} |
||||
|
||||
#rename_command accepts arbitrary proc signatures (the punk auto_execok and |
||||
#packagetrace tcl_findLibrary usage) - defaults still apply through the shim. |
||||
test commandstack_non_args_signature {rename_command works with non-args signatures including defaulted arguments}\ |
||||
-constraints commandstacksrc -body { |
||||
cs_probe { |
||||
proc ::tgt3 {first {second dflt}} {return [list orig $first $second]} |
||||
commandstack::rename_command -renamer ::csS ::tgt3 {first {second dflt}} { |
||||
return [list shim [uplevel 1 [list $COMMANDSTACKNEXT $first $second]]] |
||||
} |
||||
list [::tgt3 a] [::tgt3 a b] |
||||
} |
||||
} -result {{shim {orig a dflt}} {shim {orig a b}}} |
||||
|
||||
#show_stack (punk::lib absent - plain fallback branch): exact command name is |
||||
#resolved in the caller's context, output carries the record fields, a glob |
||||
#matching the same single key renders identically, no match returns empty. |
||||
test commandstack_show_stack_fallback_render {show_stack fallback render carries record fields; glob and exact forms agree; no match is empty}\ |
||||
-constraints commandstacksrc -body { |
||||
cs_probe { |
||||
proc ::tgt {args} {return [list base $args]} |
||||
commandstack::rename_command -renamer ::csA ::tgt {args} { |
||||
uplevel 1 [list $COMMANDSTACKNEXT {*}$args] |
||||
} |
||||
set out [commandstack::show_stack ::tgt] |
||||
set outglob [commandstack::show_stack ::tg*] |
||||
list [string match "::tgt = *" $out] [string match "*token*" $out] \ |
||||
[string match "*renamer*" $out] [string match "*implementation*" $out] \ |
||||
[expr {$outglob eq $out}] [commandstack::show_stack ::zzz_nomatch*] |
||||
} |
||||
} -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}\ |
||||
-constraints commandstacksrc -body { |
||||
cs_probe { |
||||
set a [commandstack::debug] |
||||
set b [commandstack::debug 1] |
||||
set c [commandstack::debug] |
||||
proc ::tgt {args} {return [list base $args]} |
||||
commandstack::rename_command -renamer ::csA ::tgt {args} { |
||||
uplevel 1 [list $COMMANDSTACKNEXT {*}$args] |
||||
} |
||||
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 |
||||
} |
||||
} -result {0 1 1 1 0 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}\ |
||||
-constraints commandstacksrc -body { |
||||
cs_probe { |
||||
proc ::tgt {args} {return [list base $args]} |
||||
commandstack::rename_command -renamer ::csA ::tgt {args} { |
||||
uplevel 1 [list $COMMANDSTACKNEXT {*}$args] |
||||
} |
||||
set d1 [commandstack::Delete_stack ::tgt] |
||||
set d2 [commandstack::Delete_stack ::never_stacked] |
||||
set code [catch {::tgt x} msg] |
||||
list $d1 $d2 $code [string match "*too many nested evaluations*" $msg] |
||||
} |
||||
} -result {1 1 1 1} |
||||
|
||||
#Rename_stack re-keys stack records without touching commands; the parked key is |
||||
#invisible to get_stack <name> (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}\ |
||||
-constraints commandstacksrc -body { |
||||
cs_probe { |
||||
proc ::tgt {args} {return [list base $args]} |
||||
commandstack::rename_command -renamer ::csA ::tgt {args} { |
||||
uplevel 1 [list $COMMANDSTACKNEXT {*}$args] |
||||
} |
||||
commandstack::Rename_stack ::tgt ::tgt_parked |
||||
set full [commandstack::get_stack] |
||||
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}\ |
||||
-constraints commandstacksrc -body { |
||||
cs_probe { |
||||
proc ::withmagic {args} { |
||||
#IMPLEMENTOR_mypkg! (magic comment convention) |
||||
return ok |
||||
} |
||||
proc ::plainone {args} {return ok} |
||||
proc ::tgt {args} {return [list base $args]} |
||||
commandstack::rename_command -renamer ::csA ::tgt {args} { |
||||
uplevel 1 [list $COMMANDSTACKNEXT {*}$args] |
||||
} |
||||
set guard_sees [namespace eval ::commandstack::util {info commands tcl::info::cmdtype}] |
||||
list [commandstack::util::get_IMPLEMENTOR ::withmagic] \ |
||||
[commandstack::util::get_IMPLEMENTOR ::plainone] \ |
||||
[commandstack::util::get_IMPLEMENTOR ::lrepeat] \ |
||||
[commandstack::util::get_IMPLEMENTOR ::tgt] $guard_sees |
||||
} |
||||
} -result {mypkg unspecified undetermined ::csA {}} |
||||
|
||||
#split_body splits an installed override body at the separator marker: header |
||||
#carries the IMPLEMENTOR comment and COMMANDSTACKNEXT setup (marker line itself |
||||
#dropped from both parts), code round-trips the renamer-supplied procbody; a |
||||
#body without the marker returns {{} body}. |
||||
test commandstack_lib_split_body_roundtrip {split_body separates commandstack header from procbody and round-trips the original code}\ |
||||
-constraints commandstacksrc -body { |
||||
cs_probe { |
||||
proc ::tgt {args} {return [list base $args]} |
||||
set body { |
||||
return [list A [uplevel 1 [list $COMMANDSTACKNEXT {*}$args]]] |
||||
} |
||||
commandstack::rename_command -renamer ::csA ::tgt {args} $body |
||||
lassign [commandstack::lib::split_body [info body ::tgt]] header code |
||||
list [string match "*IMPLEMENTOR_::csA!*" $header] \ |
||||
[string match "*COMMANDSTACKNEXT*" $header] \ |
||||
[string match "*<commandstack_separator>*" $header] \ |
||||
[string match "*<commandstack_separator>*" $code] \ |
||||
[expr {[string trim $code] eq [string trim $body]}] \ |
||||
[commandstack::lib::split_body {a body without marker}] |
||||
} |
||||
} -result {1 1 0 0 1 {{} {a body without marker}}} |
||||
|
||||
#splitx (vendored textutil::splitx): whitespace default, empty string, empty |
||||
#regexp splits chars, custom class, parenthesised submatch keeps separators, |
||||
#empty-matching regexp raises the infinite-loop error. |
||||
test commandstack_lib_splitx {splitx splits on regexp with submatch-keeps-separator and infinite-loop guard semantics}\ |
||||
-constraints commandstacksrc -body { |
||||
cs_probe { |
||||
list [commandstack::lib::splitx "a b c"] \ |
||||
[commandstack::lib::splitx ""] \ |
||||
[commandstack::lib::splitx "abc" ""] \ |
||||
[commandstack::lib::splitx "a+b-c" {[+-]}] \ |
||||
[commandstack::lib::splitx "a+b" {(\+)}] \ |
||||
[catch {commandstack::lib::splitx "abc" {x*}}] |
||||
} |
||||
} -result {{a b c} {} {a b c} {a b c} {a + b} 1} |
||||
|
||||
#help returns a substantial dependency-free overview naming the core API and the |
||||
#COMMANDSTACKNEXT delegation contract. |
||||
test commandstack_help_overview {help returns a substantial overview naming the core API and delegation variables}\ |
||||
-constraints commandstacksrc -body { |
||||
cs_probe { |
||||
set h [commandstack::help] |
||||
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] |
||||
} |
||||
} -result {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 |
||||
#synopsis. |
||||
test commandstack_punkargs_docs_resolve {every commandstack PUNKARGS id resolves through punk::args lazy registration}\ |
||||
-constraints {commandstacksrc havepunkargs} -body { |
||||
package require commandstack |
||||
set problems [list] |
||||
foreach id { |
||||
::commandstack::help ::commandstack::debug ::commandstack::get_stack |
||||
::commandstack::get_next_command ::commandstack::basecall |
||||
::commandstack::rename_command ::commandstack::remove_rename |
||||
::commandstack::show_stack ::commandstack::Delete_stack |
||||
::commandstack::Rename_stack ::commandstack::util::get_IMPLEMENTOR |
||||
::commandstack::lib::splitx ::commandstack::lib::split_body |
||||
} { |
||||
if {[catch {punk::args::synopsis $id} err]} { |
||||
lappend problems [list $id $err] |
||||
} |
||||
} |
||||
set problems |
||||
} -result {} |
||||
|
||||
cleanupTests |
||||
} |
||||
Loading…
Reference in new issue