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] |
||||
name = "punkshell" |
||||
version = "0.12.30" |
||||
version = "0.12.31" |
||||
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