Browse Source
The hand-rolled -report json emitter in runtests.tcl classified values as JSON numbers via `string is entier -strict`, which (a) is deprecated in Tcl 9.0 per TIP 514 (string is integer became the canonical unlimited-range form) and (b) accepted several forms that are NOT valid JSON numbers, emitting them bare: 007 (leading zeros), +5 (leading plus), 0x10/0o17/0b101 (hex/octal/binary). The G-093 work already patched one symptom (a "0\n" result embedded a raw newline) but left the rest of the class open. The string escaper (runtests_json_string) also left most C0 control chars (0x00-0x1F) raw, which RFC 8259 forbids in strings - a test whose result_was carries a bell or NUL corrupted the report the same way. Hardening (src/tests/testsupport/json_emit.tcl, extracted from runtests.tcl so the new suite can unit-test it without a child run): - runtests_json_int? replaces `string is entier -strict` with an RFC 8259 integer regex (^-?(0|[1-9][0-9]*)$) - version-independent, eliminates entier entirely (no Tcl-9 deprecation exposure), subsumes the G-093 whitespace guard via ^...$ anchoring. - runtests_json_string now escapes the whole C0 range: 0x08 -> \b, 0x0C -> \f, others -> \u00XX. The existing \n \r \t \ \" escapes are preserved byte-for-byte (the multilinebanner.test end-to-end suite probes exact substrings such as "result_was":"x\n"). Pinning suite (src/tests/runner/testsuites/parser/jsonemit.test, 8 tests): RFC 8259 number syntax (007/+5/0x10/0o17/0b101 emitted as quoted strings; valid integers bare), C0 control-char escaping (no raw 0x00-0x1F survives; \b \f short escapes; \u00XX for the rest), entier-deprecation hygiene (asserts the loaded predicate proc body uses regexp and mentions no entier), named-escape byte regression, and tcllib-json round-trip of a representative testdict array. DOX: src/tests/AGENTS.md testsupport bullet records json_emit.tcl; src/tests/runner/AGENTS.md parser description records jsonemit.test. Verification: jsonemit.test 8/8 on Tcl 9.0.5 and Tcl 8.6; multilinebanner.test 2/2 (no regression to the existing emitter output contract); full runner/ subtree 40/40; mode parity runtests_parity.tcl PARITY: ok on a broad real-data subset (modules/punk/args, 35 files / 341 tests, singleproc vs multiproc). Tests-only change - no punkproject.toml bump per the versioning policy. Assisted-by: harness=pi; primary-model=zai-org/GLM-5.2; api-location=huggingface.comaster
5 changed files with 224 additions and 34 deletions
@ -0,0 +1,134 @@
|
||||
# -*- tcl -*- |
||||
# Unit suite for the runtests.tcl JSON emitter (testsupport/json_emit.tcl). |
||||
# Sources the emitter directly so the tests are fast (no child runtests run), |
||||
# and pins the defect class the hardening closed: |
||||
# - RFC 8259 number syntax: Tcl-integer-class forms that are NOT valid JSON |
||||
# numbers (leading zeros 007, a leading +, hex/octal/binary 0x/0o/0b) must |
||||
# take the quoted-string path, not be emitted bare. |
||||
# - C0 control-char escaping: RFC 8259 forbids raw 0x00-0x1F in strings; the |
||||
# emitter must escape the whole range (not just \n \r \t). |
||||
# - entier deprecation hygiene (TIP 514): the predicate must not use |
||||
# 'string is entier', which is deprecated in Tcl 9.0. |
||||
# - regression of the named escapes: \n \r \t backslash quote must still |
||||
# produce the exact bytes the multilinebanner.test end-to-end suite probes. |
||||
# - round-trip: a representative testdict array re-parses via tcllib json. |
||||
# |
||||
# Run: tclsh src/tests/runtests.tcl -report compact -show-passes 0 -include-paths runner/testsuites/parser jsonemit.test |
||||
|
||||
package require tcltest |
||||
#tcllib json decoder for the round-trip test (skipped if unavailable - the |
||||
#native-tclsh runner may not have tcllib on the auto_path; the kit runner does). |
||||
tcltest::testConstraint jsonAvailable [expr {![catch {package require json}]}] |
||||
|
||||
namespace eval ::testspace { |
||||
namespace import ::tcltest::* |
||||
|
||||
variable testbase [file dirname [file dirname [file dirname [file dirname [file normalize [info script]]]]]] |
||||
#load the emitter under test (procs only, no side effects). |
||||
source [file join $testbase testsupport json_emit.tcl] |
||||
|
||||
#added 2026-08-07 (agent - runtests json emitter hardening: RFC8259 number syntax, C0 control-char escaping, entier deprecation per TIP 514) |
||||
test jsonemit-number-1.0 {Tcl-integer forms that are not valid JSON numbers are emitted as quoted strings} -body { |
||||
set result [list] |
||||
foreach v {007 +5 0x10 0o17 0b101 1e3 1.5} { |
||||
lappend result [runtests_json_int? $v] |
||||
set emit [runtests_json_testdict_array [list [list k $v]]] |
||||
set needle "\"k\":\"$v\"" |
||||
lappend result [expr {[string first $needle $emit] >= 0}] |
||||
} |
||||
set result |
||||
} -result {0 1 0 1 0 1 0 1 0 1 0 1 0 1} |
||||
|
||||
#added 2026-08-07 (agent - runtests json emitter hardening) |
||||
test jsonemit-number-1.1 {valid JSON integers are emitted bare} -body { |
||||
set result [list] |
||||
foreach v {0 -0 -5 42 999999999999999999999999999999} { |
||||
lappend result [runtests_json_int? $v] |
||||
set emit [runtests_json_testdict_array [list [list k $v]]] |
||||
set needle "\"k\":$v" |
||||
lappend result [expr {[string first $needle $emit] >= 0}] |
||||
} |
||||
set result |
||||
} -result {1 1 1 1 1 1 1 1 1 1} |
||||
|
||||
#added 2026-08-07 (agent - runtests json emitter hardening) |
||||
test jsonemit-number-1.2 {whitespace-padded integers take the quoted path (G-093 regression)} -body { |
||||
set result [list] |
||||
lappend result [runtests_json_int? " 5"] |
||||
lappend result [runtests_json_int? "5 "] |
||||
lappend result [runtests_json_int? " 0 "] |
||||
set result |
||||
} -result {0 0 0} |
||||
|
||||
#added 2026-08-07 (agent - runtests json emitter hardening) |
||||
test jsonemit-ctrl-1.0 {no raw C0 control char survives in a string} -body { |
||||
#build a string with one of every C0 control 0x00-0x1F |
||||
set s "" |
||||
for {set cp 0} {$cp < 32} {incr cp} { |
||||
append s [format %c $cp] |
||||
} |
||||
set enc [runtests_json_string $s] |
||||
set bad 0 |
||||
foreach ch [split $enc ""] { |
||||
set icp [scan $ch %c] |
||||
if {$icp < 32} { incr bad } |
||||
} |
||||
set bad |
||||
} -result 0 |
||||
|
||||
#added 2026-08-07 (agent - runtests json emitter hardening) |
||||
test jsonemit-ctrl-1.1 {backspace and formfeed use short escapes, others use u00XX} -body { |
||||
set result [list] |
||||
lappend result [expr {[string first "\\b" [runtests_json_string [format %c 8]]] >= 0}] |
||||
lappend result [expr {[string first "\\f" [runtests_json_string [format %c 12]]] >= 0}] |
||||
lappend result [expr {[string first "\\u0007" [runtests_json_string [format %c 7]]] >= 0}] |
||||
lappend result [expr {[string first "\\u0000" [runtests_json_string [format %c 0]]] >= 0}] |
||||
lappend result [expr {[string first "\\u001f" [runtests_json_string [format %c 31]]] >= 0}] |
||||
set result |
||||
} -result {1 1 1 1 1} |
||||
|
||||
#added 2026-08-07 (agent - runtests json emitter hardening) |
||||
test jsonemit-escapes-1.0 {named escapes produce exact bytes probed by multilinebanner.test} -body { |
||||
set result [list] |
||||
lappend result [string equal [runtests_json_string "x\n"] "\"x\\n\""] |
||||
lappend result [string equal [runtests_json_string "y\r"] "\"y\\r\""] |
||||
lappend result [string equal [runtests_json_string "z\t"] "\"z\\t\""] |
||||
lappend result [string equal [runtests_json_string "\\"] "\"\\\\\""] |
||||
lappend result [string equal [runtests_json_string "\""] "\"\\\"\""] |
||||
set result |
||||
} -result {1 1 1 1 1} |
||||
|
||||
#added 2026-08-07 (agent - runtests json emitter hardening - TIP 514) |
||||
test jsonemit-deprec-1.0 {the number predicate uses no deprecated string-is-entier} -body { |
||||
set result [list] |
||||
set body [info body runtests_json_int?] |
||||
lappend result [expr {[string first "regexp" $body] >= 0}] |
||||
lappend result [expr {[string first "entier" $body] < 0}] |
||||
set abody [info body runtests_json_testdict_array] |
||||
lappend result [expr {[string first "runtests_json_int?" $abody] >= 0}] |
||||
lappend result [expr {[string first "string is entier" $abody] < 0}] |
||||
set result |
||||
} -result {1 1 1 1} |
||||
|
||||
#added 2026-08-07 (agent - runtests json emitter hardening) |
||||
test jsonemit-roundtrip-1.0 {a representative testdict array re-parses via tcllib json} -constraints jsonAvailable -body { |
||||
set td [list \ |
||||
[dict create name "t1" status "FAILED" result_was "007" microseconds 12345] \ |
||||
[dict create name "t2" status "PASS" microseconds 999999999999999999999999999999] \ |
||||
] |
||||
set j [runtests_json_testdict_array $td] |
||||
set d [json::json2dict $j] |
||||
set r0 [lindex $d 0] |
||||
set result [list] |
||||
lappend result [dict get $r0 name] |
||||
lappend result [dict get $r0 result_was] |
||||
lappend result [dict get $r0 microseconds] |
||||
set result |
||||
} -result {t1 007 12345} |
||||
|
||||
cleanupTests |
||||
} |
||||
|
||||
# Local Variables: |
||||
# mode: tcl |
||||
# End: |
||||
@ -0,0 +1,81 @@
|
||||
#testsupport/json_emit.tcl - JSON emitter for the runtests.tcl -report json output. |
||||
# |
||||
#Sourced by runtests.tcl and by the runner jsonemit.test unit suite. Defines |
||||
#procs only - no side effects, no package requires - so sourcing it for unit |
||||
#tests is free. Hand-rolled (not tcllib json::write) deliberately, to keep the |
||||
#runner's dependency surface minimal at the boot level where the json report is |
||||
#emitted; the jsonemit.test suite pins the defect class this guards against. |
||||
# |
||||
#Why hand-rolled instead of json::write: the runtests runner is the bootstrap |
||||
#path for the whole source-tree suite and is expected to run under bare native |
||||
#tclsh too (8.6 runner supported per src/tests/AGENTS.md), where tcllib may not |
||||
#be on the auto_path. The emitter is small and the regression suite keeps it |
||||
#honest. The punk::path -return json machine-returns work (G-NNN, proposed) |
||||
#uses tcllib json::write instead - that path always has tcllib available. |
||||
|
||||
#RFC 8259 integer grammar: optional minus, then "0" or a non-zero-led digit |
||||
#run. This rejects the Tcl-integer-class forms that are NOT valid JSON numbers |
||||
#(leading zeros like 007, a leading +, hex/octal/binary 0x/0o/0b prefixes) and |
||||
#any whitespace padding. It replaces the prior `string is entier -strict` |
||||
#predicate: entier is deprecated in Tcl 9.0 per TIP 514 (string is integer |
||||
#became the canonical unlimited-range form), and this regex is version- |
||||
#independent and syntax-correct, so it eliminates entier use entirely rather |
||||
#than gating it by Tcl version. The G-093 "0\n" whitespace-padded-entier bug |
||||
#(a failed test's result_was carried a trailing newline that string is entier |
||||
#-strict accepted, embedding a raw newline in the json line) is subsumed: the |
||||
#regex anchors with ^...$, so surrounding whitespace fails the match and the |
||||
#value takes the quoted-string path. |
||||
proc runtests_json_int? {value} { |
||||
regexp -- {^-?(0|[1-9][0-9]*)$} $value |
||||
} |
||||
|
||||
#Escape a string for JSON. RFC 8259 forbids raw control chars 0x00-0x1F in |
||||
#strings. The named escapes below (\\ \" \n \r \t) are preserved byte-for-byte: |
||||
#the multilinebanner.test end-to-end suite probes exact substrings such as |
||||
#"result_was":"x\n" where \n is the literal backslash-n byte pair the emitter |
||||
#produces. The second pass then handles the REST of the C0 control set that |
||||
#the first map left raw: 0x08 (backspace) and 0x0C (formfeed) use the short |
||||
#escapes \b \f; every other control char uses \u00XX. (G-093 patched only the |
||||
#whitespace-padded-entier path; this closes the rest of the C0 set - found |
||||
#2026-08-07.) |
||||
proc runtests_json_string {text} { |
||||
set text [string map [list \\ \\\\ \" \\\" \n \\n \r \\r \t \\t] $text] |
||||
set out "" |
||||
foreach ch [split $text ""] { |
||||
set cp [scan $ch %c] |
||||
if {$cp < 32} { |
||||
switch -- $cp { |
||||
8 { append out "\\b" } |
||||
12 { append out "\\f" } |
||||
default { append out [format "\\u%04x" $cp] } |
||||
} |
||||
} else { |
||||
append out $ch |
||||
} |
||||
} |
||||
return "\"$out\"" |
||||
} |
||||
|
||||
proc runtests_json_string_array {values} { |
||||
set parts [list] |
||||
foreach value $values { |
||||
lappend parts [runtests_json_string $value] |
||||
} |
||||
return "\[[join $parts ,]\]" |
||||
} |
||||
|
||||
proc runtests_json_testdict_array {testdicts} { |
||||
set parts [list] |
||||
foreach testdict $testdicts { |
||||
set fields [list] |
||||
foreach {key value} $testdict { |
||||
if {[runtests_json_int? $value]} { |
||||
lappend fields "[runtests_json_string $key]:$value" |
||||
} else { |
||||
lappend fields "[runtests_json_string $key]:[runtests_json_string $value]" |
||||
} |
||||
} |
||||
lappend parts "{[join $fields ,]}" |
||||
} |
||||
return "\[[join $parts ,]\]" |
||||
} |
||||
Loading…
Reference in new issue