Browse Source
- scriptlib/developer/testbody_lint.tcl (new): tcltest .test lint per
src/tests/AGENTS.md Verification. E-level: a -body whose final command
always returns empty vs a -result that cannot match empty under its
-match mode; test invocations with no -body at all (vacuous pass);
unbalanced-brace parse kills. W-level: uninterpretable shapes.
Hand-rolled command-word splitter (the corpus '{desc}\' style is
command-legal but list-illegal), namespace-eval recursion, literal
{*}{...} splices, -selftest (8 fixtures) + -stats. 142 files /
1674 tests parse clean.
- src/tests/runtests.tcl: FAILED reports with an empty actual and a
non-empty expected append a hint= (compact) / hint : (markdown) line
naming the trailing 'set result'/'return $result' convention, so the
failure carries its own diagnosis. JSON reports unchanged.
- src/tests/modules/punk/args/testsuites/args/args.test: the
literalprefix sibling of parse_withdef_value_leading_multiple_not_greedy
was passing VACUOUSLY - a missing description made the braced
description word swallow -setup/-body/-cleanup/-result, so tcltest ran
an empty body against the default -result "". Description restored,
orphan closing brace removed; the de-vacuized test executes and passes
(file 34/34).
- AGENTS.md (root), src/tests/AGENTS.md, .agents/.claude tcl-runtests
SKILL.md (byte-identical copies): the body-ender convention now
sanctions 'return $result' alongside 'set result' (verified on 8.6 and
9.0: default -returnCodes {ok return} accepts the return form,
-cleanup still runs, an explicit -returnCodes list omitting 'return'
rejects it loudly); linter and hint documented.
Verification: testbody_lint -selftest PASS on tclsh90s and tclsh86ts;
corpus lint clean; args.test 34/34; full suite in both runner modes with
runtests_parity.tcl PARITY: ok (1677 tests, 1631 pass). Residual 23
failures are pre-existing/environment, not this change: 12 maketclhelp
(auto_execok tclsh Bash-env trap; pass under PowerShell), 8
maketcllibfetch + 2 maketclbakelist (reproduce identically with this
runtests.tcl change stashed), core exec-14.3 (pins the pre-'-encoding'
exec error message vs tcl 9.0.5).
Claude-Session: https://claude.ai/code/session_016Bk571eG3prsJWYnewboW2
Assisted-by: harness=claude; primary-model=claude-fable-5; api-location=anthropic.com
master
7 changed files with 534 additions and 6 deletions
@ -0,0 +1,488 @@
|
||||
#!/usr/bin/env tclsh |
||||
# testbody_lint.tcl - lint tcltest .test files for result-yield authoring defects |
||||
# |
||||
# The defect class (see src/tests/AGENTS.md Local Contracts and the tcl-runtests |
||||
# agent skill): tcltest compares the -body's RETURN VALUE against -result, so a |
||||
# body whose final command always returns the empty string (a loop, unset, |
||||
# close ...) discards whatever the body computed - the test can never pass, and |
||||
# the FAILED report shows an empty actual far from the cause. A related shape |
||||
# passes VACUOUSLY: a test invocation with no -body at all (e.g. a missing |
||||
# description lets the braced description word swallow all the option words) |
||||
# runs an empty body against the default -result "" and reports PASS. |
||||
# |
||||
# Findings (E = error, exit 1; W = warning, reported but exit stays 0): |
||||
# E empty-ender : final -body command always returns "" but the test's |
||||
# -result (under its -match mode) cannot match "" (skipped |
||||
# when -returnCodes expects an abnormal completion) |
||||
# E no-body : test invocation carrying no -body option |
||||
# E incomplete : a file or namespace-eval block whose final command never |
||||
# completes - an unbalanced brace ANYWHERE (including inside |
||||
# a # comment) kills the whole file's parse |
||||
# W odd-shape : a test invocation whose argument shape the linter cannot |
||||
# interpret (reported so it is never silently unchecked) |
||||
# |
||||
# Convention being backed: bodies that accumulate into $result end with an |
||||
# explicit `set result` or `return $result` (tcltest's default -returnCodes |
||||
# {ok return} accepts the return form and -cleanup still runs; an explicit |
||||
# -returnCodes list omitting `return` rejects it loudly). |
||||
# |
||||
# Plain tclsh (8.6+ or 9), no package dependencies: |
||||
# tclsh scriptlib/developer/testbody_lint.tcl ;# lints src/tests |
||||
# tclsh scriptlib/developer/testbody_lint.tcl <dir-or-file> ?...? |
||||
# tclsh scriptlib/developer/testbody_lint.tcl -stats ;# adds final-command distribution |
||||
# tclsh scriptlib/developer/testbody_lint.tcl -selftest ;# embedded fixtures |
||||
# Exit 0 when clean (warnings allowed), 1 on E-level findings, 2 usage/environment. |
||||
|
||||
# ---------------------------------------------------------------- script splitting |
||||
# Split a script into top-level command chunks by [info complete] line |
||||
# accumulation. Returns a list of {startline chunktext} pairs; a non-empty |
||||
# leftover tail (the unbalanced-brace parse-killer class) is returned as a |
||||
# chunk whose text carries a leading \x00INCOMPLETE\x00 marker. |
||||
proc split_script {script} { |
||||
set chunks {} |
||||
set cur "" |
||||
set startline 1 |
||||
set lineno 0 |
||||
foreach line [split $script \n] { |
||||
incr lineno |
||||
if {$cur eq ""} { |
||||
set startline $lineno |
||||
} |
||||
append cur $line \n |
||||
if {[info complete $cur]} { |
||||
lappend chunks [list $startline $cur] |
||||
set cur "" |
||||
} |
||||
} |
||||
if {[string trim $cur] ne ""} { |
||||
lappend chunks [list $startline "\x00INCOMPLETE\x00$cur"] |
||||
} |
||||
return $chunks |
||||
} |
||||
|
||||
# Split ONE command's text into its words without substitution. Outer braces |
||||
# and quotes are stripped (one level). Handles backslash-newline whitespace - |
||||
# including the corpus style `{description}\` with the continuation backslash |
||||
# hard against the closing brace, which is legal command syntax but NOT list |
||||
# syntax (so [lindex]/[lrange] on the command text would error) - bracket |
||||
# nesting in bare words, and literal `{*}{...}` argument expansion (spliced; |
||||
# dynamic `{*}$x`/`{*}[...]` expansions are kept as single opaque words). |
||||
proc cmdwords {cmd} { |
||||
set words {} |
||||
set types {} |
||||
set i 0 |
||||
set prevend -1 |
||||
set n [string length $cmd] |
||||
while {$i < $n} { |
||||
while {$i < $n} { |
||||
set c [string index $cmd $i] |
||||
if {$c eq " " || $c eq "\t" || $c eq "\n"} { incr i ; continue } |
||||
if {$c eq "\\" && [string index $cmd $i+1] eq "\n"} { incr i 2 ; continue } |
||||
break |
||||
} |
||||
if {$i >= $n} break |
||||
set wstart $i |
||||
set c [string index $cmd $i] |
||||
if {$c eq "\{"} { |
||||
set depth 1 |
||||
set j [expr {$i+1}] |
||||
while {$j < $n && $depth > 0} { |
||||
set d [string index $cmd $j] |
||||
if {$d eq "\\"} { incr j 2 ; continue } |
||||
if {$d eq "\{"} { incr depth } elseif {$d eq "\}"} { incr depth -1 } |
||||
incr j |
||||
} |
||||
set text [string range $cmd $i+1 $j-2] |
||||
set type brace |
||||
set i $j |
||||
} elseif {$c eq "\""} { |
||||
set j [expr {$i+1}] |
||||
while {$j < $n} { |
||||
set d [string index $cmd $j] |
||||
if {$d eq "\\"} { incr j 2 ; continue } |
||||
if {$d eq "\""} break |
||||
incr j |
||||
} |
||||
set text [string range $cmd $i+1 $j-1] |
||||
set type quote |
||||
set i [expr {$j+1}] |
||||
} else { |
||||
set j $i |
||||
set bdepth 0 |
||||
while {$j < $n} { |
||||
set d [string index $cmd $j] |
||||
if {$d eq "\\"} { incr j 2 ; continue } |
||||
if {$d eq "\["} { incr bdepth } |
||||
if {$d eq "\]" && $bdepth > 0} { incr bdepth -1 } |
||||
if {$bdepth == 0 && ($d eq " " || $d eq "\t" || $d eq "\n")} break |
||||
incr j |
||||
} |
||||
set text [string range $cmd $i $j-1] |
||||
set type bare |
||||
set i $j |
||||
} |
||||
if {[llength $words] && [lindex $types end] eq "brace" && [lindex $words end] eq "*" && $wstart == $prevend} { |
||||
# the previous word was a braced * hard against this word: {*}word |
||||
set words [lrange $words 0 end-1] |
||||
set types [lrange $types 0 end-1] |
||||
if {$type eq "brace" && ![catch {llength $text}]} { |
||||
foreach el $text { |
||||
lappend words $el |
||||
lappend types expanded |
||||
} |
||||
} else { |
||||
lappend words "{*}$text" |
||||
lappend types opaque |
||||
} |
||||
} else { |
||||
lappend words $text |
||||
lappend types $type |
||||
} |
||||
set prevend $i |
||||
} |
||||
return $words |
||||
} |
||||
|
||||
# Last non-comment command of a script; returns {lineoffset text} where text is |
||||
# \x00INCOMPLETE\x00 when the script never completes (unbalanced quote/brace). |
||||
proc last_command {body} { |
||||
set last {} |
||||
foreach pair [split_script $body] { |
||||
lassign $pair ln chunk |
||||
set t [string trim $chunk] |
||||
if {$t eq "" || [string index $t 0] eq "#"} continue |
||||
if {[string match "\x00INCOMPLETE\x00*" $chunk]} { |
||||
return [list $ln "\x00INCOMPLETE\x00"] |
||||
} |
||||
set last [list $ln $t] |
||||
} |
||||
return $last |
||||
} |
||||
|
||||
# ---------------------------------------------------------------- classification |
||||
# Command words (and first-two-word pairs) that ALWAYS return the empty string. |
||||
set EMPTY1 {foreach while for unset proc destroy close puts update vwait rename} |
||||
set EMPTY2 {{array set} {array unset} {namespace delete} {namespace forget} |
||||
{dict for} {file delete} {file mkdir} {file copy} {file rename} |
||||
{chan close} {chan puts} {interp delete}} |
||||
|
||||
# Can the empty string satisfy this -result under this -match mode? |
||||
proc result_matchable_empty {res matchmode} { |
||||
switch -- $matchmode { |
||||
exact { |
||||
return [expr {$res eq ""}] |
||||
} |
||||
glob { |
||||
if {[catch {string match $res ""} m]} { return 1 } |
||||
return $m |
||||
} |
||||
regexp { |
||||
if {[catch {regexp -- $res ""} m]} { return 1 } |
||||
return $m |
||||
} |
||||
default { |
||||
# custom match commands - cannot judge, never flag |
||||
return 1 |
||||
} |
||||
} |
||||
} |
||||
|
||||
# ---------------------------------------------------------------- lint engine |
||||
proc lint_reset {} { |
||||
set ::stats [dict create files 0 tests 0] |
||||
set ::enddist [dict create] |
||||
set ::findings {} |
||||
} |
||||
|
||||
proc flag {path line level rule name detail} { |
||||
lappend ::findings [dict create path $path line $line level $level rule $rule name $name detail $detail] |
||||
} |
||||
|
||||
proc lint_file {path} { |
||||
set f [open $path r] |
||||
fconfigure $f -encoding utf-8 |
||||
set src [read $f] |
||||
close $f |
||||
dict incr ::stats files |
||||
scan_script $path $src 0 |
||||
} |
||||
|
||||
proc scan_script {path src baseline} { |
||||
global EMPTY1 EMPTY2 |
||||
foreach pair [split_script $src] { |
||||
lassign $pair chunkline chunk |
||||
set startline [expr {$baseline + $chunkline}] |
||||
if {[string match "\x00INCOMPLETE\x00*" $chunk]} { |
||||
flag $path $startline E incomplete "" "script never completes from this line - an unbalanced brace (possibly inside a comment) kills the file's parse" |
||||
continue |
||||
} |
||||
set t [string trim $chunk] |
||||
if {$t eq "" || [string index $t 0] eq "#"} continue |
||||
set w0 "" |
||||
regexp {^(\S+)} $t -> w0 |
||||
if {$w0 eq "namespace"} { |
||||
# recurse into namespace eval wrappers (the corpus-wide pattern) |
||||
set words [cmdwords $t] |
||||
if {[lindex $words 1] eq "eval"} { |
||||
set nsbody [lindex $words end] |
||||
if {[string first \n $nsbody] >= 0} { |
||||
set idx [string first $nsbody $chunk] |
||||
set off 0 |
||||
if {$idx > 0} { |
||||
set off [regexp -all {\n} [string range $chunk 0 [expr {$idx-1}]]] |
||||
} |
||||
scan_script $path $nsbody [expr {$startline - 1 + $off}] |
||||
} |
||||
} |
||||
continue |
||||
} |
||||
if {$w0 ni {test tcltest::test ::tcltest::test}} continue |
||||
dict incr ::stats tests |
||||
set words [cmdwords $t] |
||||
set name [lindex $words 1] |
||||
if {[llength $words] < 3} { |
||||
flag $path $startline W odd-shape $name "test invocation with fewer than 3 words - linter cannot check it" |
||||
continue |
||||
} |
||||
set body "" ; set hasbody 0 ; set res "" ; set rcodes "" ; set match exact |
||||
if {[llength $words] == 3 || [string index [lindex $words 3] 0] eq "-"} { |
||||
# option form: test name description ?-flag value ...? |
||||
set tail [lrange $words 3 end] |
||||
if {[llength $tail] % 2 != 0} { |
||||
flag $path $startline W odd-shape $name "odd option/value word count - linter cannot check it" |
||||
continue |
||||
} |
||||
set badkey "" |
||||
foreach {k v} $tail { |
||||
if {[string index $k 0] ne "-"} { set badkey $k ; break } |
||||
switch -- $k { |
||||
-body { set body $v ; set hasbody 1 } |
||||
-result { set res $v } |
||||
-returnCodes { set rcodes $v } |
||||
-match { set match $v } |
||||
} |
||||
} |
||||
if {$badkey ne ""} { |
||||
flag $path $startline W odd-shape $name "expected an option at word '[string range $badkey 0 40]' - linter cannot check it" |
||||
continue |
||||
} |
||||
if {!$hasbody} { |
||||
flag $path $startline E no-body $name "test invocation has no -body (a missing description makes the braced description swallow the option words) - the test passes vacuously" |
||||
continue |
||||
} |
||||
} else { |
||||
# legacy positional form: test name description ?constraints? body result |
||||
set tail [lrange $words 3 end] |
||||
switch -- [llength $tail] { |
||||
2 { lassign $tail body res ; set hasbody 1 } |
||||
3 { lassign $tail cons body res ; set hasbody 1 } |
||||
default { |
||||
flag $path $startline W odd-shape $name "unrecognised positional argument shape - linter cannot check it" |
||||
continue |
||||
} |
||||
} |
||||
} |
||||
lassign [last_command $body] lastln lastcmd |
||||
if {$lastcmd eq "\x00INCOMPLETE\x00"} { |
||||
flag $path $startline W odd-shape $name "-body does not parse as a script - linter cannot check it" |
||||
continue |
||||
} |
||||
if {$lastcmd eq ""} continue |
||||
set lw [cmdwords $lastcmd] |
||||
set e0 [lindex $lw 0] |
||||
set e1 [lindex $lw 1] |
||||
set key $e0 |
||||
if {[list $e0 $e1] in $EMPTY2} { set key "$e0 $e1" } |
||||
dict incr ::enddist $key |
||||
set rc_abnormal 0 |
||||
foreach tok $rcodes { |
||||
if {$tok in {error 1 break 3 continue 4}} { set rc_abnormal 1 } |
||||
} |
||||
if {!$rc_abnormal && ($e0 in $EMPTY1 || [list $e0 $e1] in $EMPTY2) && ![result_matchable_empty $res $match]} { |
||||
flag $path $startline E empty-ender $name "final -body command '$key' always returns empty but -result ($match match) cannot match empty - end the body with 'set result' or 'return \$result'" |
||||
} |
||||
} |
||||
} |
||||
|
||||
proc walk {path} { |
||||
if {[file isfile $path]} { |
||||
lint_file $path |
||||
return |
||||
} |
||||
foreach sub [lsort [glob -nocomplain -directory $path *]] { |
||||
if {[file isdirectory $sub]} { |
||||
walk $sub |
||||
} elseif {[string match *.test $sub]} { |
||||
lint_file $sub |
||||
} |
||||
} |
||||
} |
||||
|
||||
proc report {opt_stats} { |
||||
set errors 0 |
||||
foreach f $::findings { |
||||
if {[dict get $f level] eq "E"} { incr errors } |
||||
set name [dict get $f name] |
||||
if {$name ne ""} { set name " $name" } |
||||
puts "[dict get $f path]:[dict get $f line]: [dict get $f level] [dict get $f rule]$name - [dict get $f detail]" |
||||
} |
||||
puts "testbody_lint: [dict get $::stats files] files, [dict get $::stats tests] tests, $errors error(s), [expr {[llength $::findings] - $errors}] warning(s)" |
||||
if {$opt_stats} { |
||||
puts "final -body command distribution:" |
||||
set sorted [lsort -integer -decreasing -index 1 [lmap {k v} $::enddist {list $k $v}]] |
||||
foreach pair $sorted { |
||||
lassign $pair k v |
||||
puts [format " %6d %s" $v $k] |
||||
} |
||||
} |
||||
return $errors |
||||
} |
||||
|
||||
# ---------------------------------------------------------------- selftest |
||||
proc selftest {} { |
||||
set fails {} |
||||
|
||||
# helper: run the scanner over fixture text, return list of {rule line} pairs |
||||
proc st_scan {src} { |
||||
lint_reset |
||||
scan_script fx $src 0 |
||||
return [lmap f $::findings {list [dict get $f rule] [dict get $f line]}] |
||||
} |
||||
|
||||
set fx_good {test g1 {desc} -body { |
||||
set result {} |
||||
foreach x {a b} { lappend result $x } |
||||
set result |
||||
} -result {a b} |
||||
test g2 {desc} -body { |
||||
set result {} |
||||
foreach x {a b} { lappend result $x } |
||||
return $result |
||||
} -result {a b} |
||||
test g3 {desc} -body { |
||||
lappend result done |
||||
} -result {done} |
||||
test g4 {desc} -body { |
||||
set ok 1 |
||||
foreach x {a b} { if {$x eq "c"} { set ok 0 } } |
||||
set ok |
||||
# trailing comment is ignored when finding the final command |
||||
} -result 1} |
||||
set got [st_scan $fx_good] |
||||
if {$got ne ""} { lappend fails "good fixture flagged: $got" } |
||||
if {[dict get $::stats tests] != 4} { lappend fails "good fixture: expected 4 tests, got [dict get $::stats tests]" } |
||||
|
||||
set fx_bad {test b1 {desc} -body { |
||||
set result {} |
||||
foreach x {a b} { lappend result $x } |
||||
} -result {a b}} |
||||
set got [st_scan $fx_bad] |
||||
if {$got ne {{empty-ender 1}}} { lappend fails "empty-ender fixture: expected {{empty-ender 1}}, got $got" } |
||||
|
||||
set fx_nobody {test n1 { |
||||
-setup {set result ""} -body { |
||||
set result done |
||||
} -result done |
||||
} |
||||
test n2 {desc} -result 1} |
||||
set got [st_scan $fx_nobody] |
||||
if {$got ne {{no-body 1} {no-body 6}}} { lappend fails "no-body fixture: expected {{no-body 1} {no-body 6}}, got $got" } |
||||
|
||||
set fx_match {test m1 {desc} -body { |
||||
foreach x {a} {} |
||||
} -match glob -result * |
||||
test m2 {desc} -body { |
||||
foreach x {a} {} |
||||
} -match glob -result {a*} |
||||
test m3 {desc} -body { |
||||
foreach x {a} {} |
||||
} -match regexp -result {^$} |
||||
test m4 {desc} -body { |
||||
foreach x {a} {} |
||||
} -match regexp -result {abc}} |
||||
set got [st_scan $fx_match] |
||||
if {$got ne {{empty-ender 4} {empty-ender 10}}} { lappend fails "match fixture: expected m2/m4 flagged, got $got" } |
||||
|
||||
set fx_rcodes {test r1 {desc} -body { |
||||
if {1} { error oops } |
||||
foreach x {a} {} |
||||
} -returnCodes error -result oops} |
||||
set got [st_scan $fx_rcodes] |
||||
if {$got ne ""} { lappend fails "returnCodes fixture flagged: $got" } |
||||
|
||||
set fx_expand {test e1 {desc} {*}{ |
||||
} -setup {set result ""} -body { |
||||
lappend result ok |
||||
} {*}{ |
||||
} -result [list {*}{ |
||||
ok |
||||
}]} |
||||
set got [st_scan $fx_expand] |
||||
if {$got ne ""} { lappend fails "expand fixture flagged: $got" } |
||||
if {[dict get $::stats tests] != 1} { lappend fails "expand fixture: expected 1 test, got [dict get $::stats tests]" } |
||||
|
||||
set fx_nseval {namespace eval ::t { |
||||
namespace import ::tcltest::* |
||||
test v1 {desc}\ |
||||
-body { |
||||
set result x |
||||
foreach x {a} {} |
||||
}\ |
||||
-result x |
||||
}} |
||||
set got [st_scan $fx_nseval] |
||||
if {$got ne {{empty-ender 3}}} { lappend fails "nseval fixture: expected {{empty-ender 3}}, got $got" } |
||||
|
||||
set fx_incomplete "test t1 {d} -body \{\n set x 1\n" |
||||
set got [st_scan $fx_incomplete] |
||||
if {$got ne {{incomplete 1}}} { lappend fails "incomplete fixture: expected {{incomplete 1}}, got $got" } |
||||
|
||||
if {[llength $fails]} { |
||||
foreach f $fails { puts "selftest FAIL: $f" } |
||||
return 1 |
||||
} |
||||
puts "selftest: PASS (8 fixtures)" |
||||
return 0 |
||||
} |
||||
|
||||
# ---------------------------------------------------------------- main |
||||
set opt_stats 0 |
||||
set opt_selftest 0 |
||||
set paths {} |
||||
foreach a $argv { |
||||
switch -- $a { |
||||
-stats { set opt_stats 1 } |
||||
-selftest { set opt_selftest 1 } |
||||
default { |
||||
if {[string index $a 0] eq "-"} { |
||||
puts stderr "testbody_lint: unknown option '$a' (known: -stats -selftest)" |
||||
exit 2 |
||||
} |
||||
lappend paths $a |
||||
} |
||||
} |
||||
} |
||||
|
||||
if {$opt_selftest} { |
||||
exit [selftest] |
||||
} |
||||
|
||||
if {![llength $paths]} { |
||||
set root [file dirname [file dirname [file dirname [file normalize [info script]]]]] |
||||
set default [file join $root src tests] |
||||
if {![file isdirectory $default]} { |
||||
puts stderr "testbody_lint: default target '$default' not found - pass a directory or file" |
||||
exit 2 |
||||
} |
||||
set paths [list $default] |
||||
} |
||||
|
||||
lint_reset |
||||
foreach p $paths { |
||||
if {![file exists $p]} { |
||||
puts stderr "testbody_lint: no such path '$p'" |
||||
exit 2 |
||||
} |
||||
walk $p |
||||
} |
||||
exit [expr {[report $opt_stats] ? 1 : 0}] |
||||
Loading…
Reference in new issue