Browse Source
cmdtrace gains -pause <bool> (default 1, existing interactive behaviour unchanged): -pause 0 bypasses the "paused - hit enter key to continue" askuser in _cmdtrace_leave so cmdtrace runs unattended and the marked-up traced-body report (return value) can be captured by scripts and tests. Line-mismark investigation (all punk-free raw enterstep probes, results byte-identical on Tcl 8.6.17 / 8.7a6 / 9.0.3 - conclusively upstream): - with the ::switch argdoc available (punk::args::moduledoc::tclcore), cmdtrace marks flat single-block switches and 2-word-form nested switches correctly for EVERY arm; the residual mismarks match the raw trace data - empirical law, predictive across 4 command shapes x 6 arms and deeper nestings: an arm body at index j of the split pattern/body list reports container-relative lines (shift = switch command line within its containing script - 1) exactly when j lands on a LITERAL word of the switch command (options, --, or the block); dynamic words and j beyond the command word count fall back to correct arm-relative attribution. Position-based, not call-order based. Explains the ticket observation that the affected-arm count "varies based on switch options". - suspected machinery: Tcl_SwitchObjCmd passes split-list index j as the TclNREvalObjEx word; TclInitCompileEnv adopts ctx line[word] when the index happens to be in range of a per-word array describing the switch command itself (the splitObjs munging looks intended to prevent this) Artifacts: - new tests ns/cmdtrace.test (5): -pause 0 smoke + error-call count, flat-switch and 2-word-nested correct-mark guards, upstream mismark GAP pins (gated on have_tclcoredocs - cmdtrace arm-offset correction parses supplied switch commands against the ::switch argdoc) - scriptlib/developer/tcl_switch_traceline_repro.tcl: standalone pure-Tcl repro + findings write-up, suitable as an attachment/addition to the upstream ticket - cmdtrace argdoc caveat updated: cites the ticket and the characterized pattern (was "possibly an unreported bug") Verified: punk/ns suite 68/68 under Tcl 9.0.3; cmdtrace.test 5/5 under 8.7. punk::ns buildversion 0.5.0 -> 0.6.0 (new flag = minor); project 0.12.31 + CHANGELOG; tests AGENTS.md index updated. Assisted-by: harness=claude; primary-model=claude-fable-5; api-location=anthropic.commaster
7 changed files with 299 additions and 7 deletions
@ -1,4 +1,4 @@ |
|||||||
[project] |
[project] |
||||||
name = "punkshell" |
name = "punkshell" |
||||||
version = "0.12.30" |
version = "0.12.31" |
||||||
license = "BSD-2-Clause" |
license = "BSD-2-Clause" |
||||||
|
|||||||
@ -0,0 +1,98 @@ |
|||||||
|
# tcl_switch_traceline_repro.tcl |
||||||
|
# 2026-07-14 Agent-Generated (supporting material for upstream Tcl ticket |
||||||
|
# https://core.tcl-lang.org/tcl/tktview/5d5b1052280c976ea3d4 - execution trace on |
||||||
|
# nested switch: inconsistent line depending on options) |
||||||
|
# |
||||||
|
# Pure-Tcl minimal repro - no punkshell code. Run under any tclsh: |
||||||
|
# tclsh tcl_switch_traceline_repro.tcl |
||||||
|
# Verified byte-identical output pattern on Tcl 8.6.17, 8.7a6 and 9.0.3. |
||||||
|
# |
||||||
|
# Setup: proc bodies are passed via a variable so they have no source-file line |
||||||
|
# correlation (as for interactively defined procs) - enterstep 'info frame' line |
||||||
|
# values are then script-relative. Each switch arm body is "{\n <marker>\n }", so |
||||||
|
# a correctly attributed arm-body command always reports line 2 (arm-relative). |
||||||
|
# |
||||||
|
# Observed (WRONG marked *): the number of mis-attributed leading arms varies |
||||||
|
# with the words of the inner switch command: |
||||||
|
# switch $c <block> (3 words): arms 1-5,def -> 2 2 2 2 2 2 |
||||||
|
# switch -- $c <block> (4 words): arms -> 3* 3* 2 2 2 2 |
||||||
|
# switch -exact -- $c <block> (5 words): arms -> 3* 2 2 2 2 2 |
||||||
|
# switch -exact -nocase -- $c <block> (6 words): arms -> 3* 3* 3* 2 2 2 |
||||||
|
# |
||||||
|
# Empirical law (fits all shapes above plus deeper nestings): an arm body at |
||||||
|
# index j of the split pattern/body list is mis-attributed exactly when j lands |
||||||
|
# on a LITERAL word of the switch command itself (an option word, --, or the |
||||||
|
# block word) - i.e. j < (command word count) and that word is not dynamic. |
||||||
|
# The wrong value = arm-relative line + (line of the switch command within its |
||||||
|
# containing script - 1): the arm body is treated as if it began at the switch |
||||||
|
# command's own line. Dynamic words ($c) and out-of-range j fall back to correct |
||||||
|
# arm-relative attribution. Deeper nesting increases the shift accordingly (a |
||||||
|
# switch at line 5 of its containing arm script mis-attributes by +4). |
||||||
|
# |
||||||
|
# The mis-attribution is stable and position-based - NOT call-order based |
||||||
|
# (calling arm 3 first still reports arm 3 correctly and arm 1 wrongly later). |
||||||
|
# |
||||||
|
# Suspected machinery (from reading core-9-1-b1 sources): Tcl_SwitchObjCmd |
||||||
|
# (tclCmdMZ.c) passes the split-list index j as the 'word' argument to |
||||||
|
# TclNREvalObjEx for the matched body; TclInitCompileEnv (tclCompile.c) then |
||||||
|
# gates on (ctxPtr->nline <= word) || (ctxPtr->line[word] < 0) and otherwise |
||||||
|
# adopts ctxPtr->line[word] as the compile base line - consistent with j being |
||||||
|
# tested against a per-word line array describing the switch COMMAND's words |
||||||
|
# rather than the split list elements (the TIP280 munging in Tcl_SwitchObjCmd's |
||||||
|
# splitObjs block appears intended to prevent exactly this, so either it is not |
||||||
|
# reached on this path or the un-munged frame leaks through another route). |
||||||
|
|
||||||
|
foreach m {m1 m2 m3 m4 m5 m6} { |
||||||
|
proc $m {} [list return $m] |
||||||
|
} |
||||||
|
set armblock { |
||||||
|
1 { |
||||||
|
m1 |
||||||
|
} |
||||||
|
2 { |
||||||
|
m2 |
||||||
|
} |
||||||
|
3 { |
||||||
|
m3 |
||||||
|
} |
||||||
|
4 { |
||||||
|
m4 |
||||||
|
} |
||||||
|
5 { |
||||||
|
m5 |
||||||
|
} |
||||||
|
default { |
||||||
|
m6 |
||||||
|
} |
||||||
|
} |
||||||
|
foreach {pname header} { |
||||||
|
t_w3 {switch $c } |
||||||
|
t_w4 {switch -- $c } |
||||||
|
t_w5 {switch -exact -- $c } |
||||||
|
t_w6 {switch -exact -nocase -- $c } |
||||||
|
} { |
||||||
|
set body "\n set c \[string index \$s 1\]\n switch -- \[string index \$s 0\] {\n a {\n $header {$armblock}\n }\n default {\n m6\n }\n }\n" |
||||||
|
proc ::$pname {s} $body |
||||||
|
} |
||||||
|
|
||||||
|
proc stepper {target args} { |
||||||
|
set f [info frame -2] |
||||||
|
if {[dict exists $f proc] && [dict get $f proc] eq $target} { |
||||||
|
set line NA |
||||||
|
catch {set line [dict get $f line]} |
||||||
|
lappend ::steps [list [dict get $f type] $line] |
||||||
|
} |
||||||
|
} |
||||||
|
foreach pname {t_w3 t_w4 t_w5 t_w6} { |
||||||
|
trace add execution ::$pname enterstep [list stepper ::$pname] |
||||||
|
set report {} |
||||||
|
foreach input {a1 a2 a3 a4 a5 a9} { |
||||||
|
set ::steps {} |
||||||
|
::$pname $input |
||||||
|
#last step is the marker command inside the matched innermost arm body |
||||||
|
lappend report "arm[string index $input 1]=[lindex $::steps end 1]" |
||||||
|
} |
||||||
|
trace remove execution ::$pname enterstep [list stepper ::$pname] |
||||||
|
puts "$pname (expected arm-relative line 2 for every arm): $report" |
||||||
|
} |
||||||
|
puts "tcl: [info patchlevel]" |
||||||
@ -0,0 +1,167 @@ |
|||||||
|
package require tcltest |
||||||
|
|
||||||
|
package require punk::ns |
||||||
|
package require punk::console |
||||||
|
|
||||||
|
#added 2026-07-14 (agent) - punk::ns::cmdtrace characterization (still-primitive |
||||||
|
#debug utility - traces a proc and returns its corp -n body with traversed lines |
||||||
|
#red/underline highlighted; possible future hotspot-analysis use). |
||||||
|
# |
||||||
|
#The new -pause 0 option makes cmdtrace runnable non-interactively (bypasses the |
||||||
|
#'paused - hit enter key to continue' askuser in _cmdtrace_leave) - these tests |
||||||
|
#depend on it. |
||||||
|
# |
||||||
|
#Line-mark assertions are keyed on the machine-readable marking data |
||||||
|
#(::punk::ns::linedict <target> lines - a dict of corp -n line number -> type/calls) |
||||||
|
#rather than parsing the ANSI-marked body. Only the line-number KEYS are pinned: |
||||||
|
#call counts conflate ensemble double-callbacks (see _cmdtrace_enterstep notes) |
||||||
|
#and are not part of the contract being characterized. |
||||||
|
# |
||||||
|
#cmdtrace's switch-arm offset correction parses supplied switch commands against |
||||||
|
#the ::switch argdoc from punk::args::moduledoc::tclcore - without it every arm |
||||||
|
#falls back to eval_offset 1 and marks are uniformly wrong. All mark tests are |
||||||
|
#therefore gated on have_tclcoredocs (tclcoreparity.test convention). |
||||||
|
# |
||||||
|
#UPSTREAM Tcl bug (reported by the user: |
||||||
|
#https://core.tcl-lang.org/tcl/tktview/5d5b1052280c976ea3d4): |
||||||
|
#for procs without source-line correlation, an arm body of a NESTED single-block |
||||||
|
#switch reports enterstep 'line' values shifted by (line of the switch command |
||||||
|
#within its containing script - 1) exactly when the arm body's index into the |
||||||
|
#split pattern/body list lands on a literal word of the switch command (options, |
||||||
|
#--, or the block itself); arms whose index lands on a dynamic word or beyond the |
||||||
|
#command's word count report correctly arm-relative. Verified byte-identical on |
||||||
|
#Tcl 8.6.17 / 8.7a6 / 9.0.3 with a punk-free minimal repro (2026-07-14). |
||||||
|
#The _GAP-marked pins below encode the resulting mismarks; flip them if Tcl fixes |
||||||
|
#the attribution (or cmdtrace works around it). |
||||||
|
namespace eval ::testspace { |
||||||
|
namespace import ::tcltest::* |
||||||
|
|
||||||
|
testConstraint have_tclcoredocs [expr {![catch {package require punk::args::moduledoc::tclcore}]}] |
||||||
|
|
||||||
|
proc mock_console {} { |
||||||
|
if {[llength [info commands ::punk::console::get_tabstops]]} { |
||||||
|
rename ::punk::console::get_tabstops ::testspace::__orig_get_tabstops |
||||||
|
} |
||||||
|
proc ::punk::console::get_tabstops {{inoutchannels {stdin stdout}}} { |
||||||
|
set stops {} |
||||||
|
for {set c 9} {$c <= 201} {incr c 8} {lappend stops $c} |
||||||
|
return $stops |
||||||
|
} |
||||||
|
if {[llength [info commands ::punk::console::get_size]]} { |
||||||
|
rename ::punk::console::get_size ::testspace::__orig_get_size |
||||||
|
} |
||||||
|
proc ::punk::console::get_size {args} { |
||||||
|
return [dict create columns 80 rows 24] |
||||||
|
} |
||||||
|
} |
||||||
|
proc restore_console {} { |
||||||
|
catch {rename ::punk::console::get_tabstops {}} |
||||||
|
if {[llength [info commands ::testspace::__orig_get_tabstops]]} { |
||||||
|
rename ::testspace::__orig_get_tabstops ::punk::console::get_tabstops |
||||||
|
} |
||||||
|
catch {rename ::punk::console::get_size {}} |
||||||
|
if {[llength [info commands ::testspace::__orig_get_size]]} { |
||||||
|
rename ::testspace::__orig_get_size ::punk::console::get_size |
||||||
|
} |
||||||
|
} |
||||||
|
variable csetup { |
||||||
|
set result "" |
||||||
|
::testspace::mock_console |
||||||
|
} |
||||||
|
variable ccleanup { |
||||||
|
::testspace::restore_console |
||||||
|
} |
||||||
|
#run cmdtrace -pause 0 and return the sorted marked line numbers for the target |
||||||
|
proc marked_lines {target args} { |
||||||
|
punk::ns::cmdtrace -pause 0 $target {*}$args |
||||||
|
return [lsort -integer [dict keys [dict get $::punk::ns::linedict ::$target lines]]] |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
test cmdtrace_pause_flag_noninteractive {-pause 0 runs unattended and returns the marked-up report}\ |
||||||
|
-setup $csetup -body { |
||||||
|
set display [punk::ns::cmdtrace -pause 0 punk::ns::test_switch5 x] |
||||||
|
lappend result [string match "*success_calls: 1*" $display] |
||||||
|
lappend result [string match "*error_calls : 0*" $display] |
||||||
|
}\ |
||||||
|
-cleanup $ccleanup\ |
||||||
|
-result [list\ |
||||||
|
1 1 |
||||||
|
] |
||||||
|
|
||||||
|
test cmdtrace_marks_flat_switch {flat single-block switch: every arm's body line marks correctly (corp -n numbering)}\ |
||||||
|
-constraints have_tclcoredocs\ |
||||||
|
-setup $csetup -body { |
||||||
|
#test_switch5: set ch1@2, switch@3, arm returns at 5,8,11,14,17,20 |
||||||
|
foreach input {x y z a b _} { |
||||||
|
lappend result [marked_lines punk::ns::test_switch5 $input] |
||||||
|
} |
||||||
|
set result |
||||||
|
}\ |
||||||
|
-cleanup $ccleanup\ |
||||||
|
-result [list\ |
||||||
|
{2 3 5}\ |
||||||
|
{2 3 8}\ |
||||||
|
{2 3 11}\ |
||||||
|
{2 3 14}\ |
||||||
|
{2 3 17}\ |
||||||
|
{2 3 20} |
||||||
|
] |
||||||
|
|
||||||
|
test cmdtrace_marks_nested_2word_guard {nested switch in 2-word form (switch $var {block}): all arms mark correctly}\ |
||||||
|
-constraints have_tclcoredocs\ |
||||||
|
-setup $csetup -body { |
||||||
|
#test_switch4 inner switch uses the 2-word form (switch \$ch2 <block>) - |
||||||
|
#the arm-body list indices land on a |
||||||
|
#dynamic word or out of range, so the upstream mis-attribution cannot |
||||||
|
#trigger: outer switch@2, set ch2@4, inner switch@5, then per-arm |
||||||
|
#call_frame/return pairs at 7/8 (x) and 11/12 (y) |
||||||
|
lappend result [marked_lines punk::ns::test_switch4 ax] |
||||||
|
lappend result [marked_lines punk::ns::test_switch4 ay] |
||||||
|
}\ |
||||||
|
-cleanup $ccleanup\ |
||||||
|
-result [list\ |
||||||
|
{2 4 5 7 8}\ |
||||||
|
{2 4 5 11 12} |
||||||
|
] |
||||||
|
|
||||||
|
test cmdtrace_marks_nested_upstream_mismark_GAP {GAP (upstream tcl tktview 5d5b1052280c976ea3d4): first arms of a nested 'switch -- [cmd]' mismark by +1}\ |
||||||
|
-constraints have_tclcoredocs\ |
||||||
|
-setup $csetup -body { |
||||||
|
#test_switch2 inner switch (switch -- \[string index \$s 1\] <block>) is the 4-word shape: |
||||||
|
#arm-body list indices 1 and 3 land on the literal '--' and block words of |
||||||
|
#the switch command, so arms 1 and 2 report container-relative (+1 here - |
||||||
|
#the inner switch is at line 2 of its containing arm script). |
||||||
|
#Correct marks would be: |
||||||
|
# a1 -> {2 4 6} (return a1@6) - marked 7 |
||||||
|
# a2 -> {2 4 11 12} (set msg@11 return@12) - marked 12 13 |
||||||
|
#The innermost default arm (a3x) is beyond the affected indices and marks |
||||||
|
#correctly ({2 4 15 16 24}: set slen@15, innermost switch@16, return@24). |
||||||
|
lappend result [marked_lines punk::ns::test_switch2 a1] |
||||||
|
lappend result [marked_lines punk::ns::test_switch2 a2] |
||||||
|
lappend result [marked_lines punk::ns::test_switch2 a3x] |
||||||
|
}\ |
||||||
|
-cleanup $ccleanup\ |
||||||
|
-result [list\ |
||||||
|
{2 4 7}\ |
||||||
|
{2 4 12 13}\ |
||||||
|
{2 4 15 16 24} |
||||||
|
] |
||||||
|
|
||||||
|
test cmdtrace_marks_error_call {a traced call that raises still reports and counts the error}\ |
||||||
|
-setup $csetup -body { |
||||||
|
proc ::testspace::boom {x} { |
||||||
|
error "boom-$x" |
||||||
|
} |
||||||
|
set display [punk::ns::cmdtrace -pause 0 ::testspace::boom 1] |
||||||
|
lappend result [string match "*error_calls : 1*" $display] |
||||||
|
}\ |
||||||
|
-cleanup { |
||||||
|
rename ::testspace::boom "" |
||||||
|
::testspace::restore_console |
||||||
|
}\ |
||||||
|
-result [list\ |
||||||
|
1 |
||||||
|
] |
||||||
|
} |
||||||
|
tcltest::cleanupTests ;#needed to produce test summary. |
||||||
Loading…
Reference in new issue