You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
488 lines
18 KiB
488 lines
18 KiB
#!/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}]
|
|
|