Browse Source
punk::lib 0.6.0: tclparser_tcl stub replaced by delegation to punk::tclparser; new tclparser_prefer (memoized auto c|tcl dispatch via namespace-local parse aliases, forcible); tclscript_info and tclword_to_scriptlist route through it; a+ -using debug puts commented out (crashed plain tclsh); tclword_to_scriptlist PUNKARGS argdoc added. New suites: tclparser_engine.test (20 oracle-verified pins + dispatch, runs everywhere) and tclparser_parity.test (77-case recorded corpus + range-walk + entry-point parity, capability-gated, oracle dir via PUNK_TCLPARSER_ORACLE_DIR). 23/23 under tclsh 8.7a6 and 9.0.3; lib subtree green (8.7 compat.test lpop failure proven pre-existing). Real 8.6.13 (punksys kit): corpus parity clean; \xHH model corrected - TIP 388 2-hex cap holds on 8.6 too, version-conditional removed from the engine. Plain-tclsh fallback demo green both gens (auto_path cleared): prefer->tcl, tclword_to_scriptlist correct incl nested array-index command substitutions, output identical to the c path. Assisted-by: harness=claude; primary-model=claude-fable-5; api-location=anthropic.commaster
6 changed files with 605 additions and 41 deletions
@ -0,0 +1,174 @@
|
||||
package require tcltest |
||||
package require punk::tclparser |
||||
package require punk::lib |
||||
|
||||
#added 2026-08-02 (agent, G-070) - pure-Tcl tclparser engine + punk::lib dispatch/fallback. |
||||
#Result-shape pins in this file are values verified against the tclparser c |
||||
#library oracle (the tclparser_punk fork dlls) during G-070 increments 2-3: |
||||
#the engine ran parity-clean against the c library across a 117-case edge |
||||
#corpus and ~50k organic command-parses per Tcl generation. This file runs |
||||
#everywhere (no c library needed); live comparison against a present c |
||||
#library is tclparser_parity.test. |
||||
|
||||
namespace eval ::testspace { |
||||
namespace import ::tcltest::* |
||||
variable common { |
||||
set result "" |
||||
} |
||||
|
||||
test tclparser_engine_basic {parse command: plain words, 4-tuple shape with byte ranges}\ |
||||
-setup $common -body { |
||||
punk::tclparser::parse command {cmd arg1 arg2} {} |
||||
}\ |
||||
-result {{0 0} {0 13} {13 0} {{simple {0 3} {{text {0 3} {}}}} {simple {4 4} {{text {4 4} {}}}} {simple {9 4} {{text {9 4} {}}}}}} |
||||
|
||||
test tclparser_engine_range0end {parse command: {0 end} range form equals {} range form}\ |
||||
-setup $common -body { |
||||
set s {cmd arg1 arg2} |
||||
expr {[punk::tclparser::parse command $s {0 end}] eq [punk::tclparser::parse command $s {}]} |
||||
}\ |
||||
-result 1 |
||||
|
||||
test tclparser_engine_bogus1 {parse command: the punk::lib bogus1-prefix pattern - tree node 0 is simple {0 6}}\ |
||||
-setup $common -body { |
||||
punk::tclparser::parse command {bogus1 someargument} {} |
||||
}\ |
||||
-result {{0 0} {0 19} {19 0} {{simple {0 6} {{text {0 6} {}}}} {simple {7 12} {{text {7 12} {}}}}}} |
||||
|
||||
test tclparser_engine_quoted_word {parse command: dquoted word with variable - word node, text/variable/text subnodes, quotes inside word range}\ |
||||
-setup $common -body { |
||||
punk::tclparser::parse command {cmd "a $x b"} {} |
||||
}\ |
||||
-result {{0 0} {0 12} {12 0} {{simple {0 3} {{text {0 3} {}}}} {word {4 8} {{text {5 2} {}} {variable {7 2} {{text {8 1} {}}}} {text {9 2} {}}}}}} |
||||
|
||||
test tclparser_engine_braced_opaque {parse command: braced word is simple/opaque - text range excludes braces (quote-state arithmetic)}\ |
||||
-setup $common -body { |
||||
punk::tclparser::parse command {cmd {a [x] b}} {} |
||||
}\ |
||||
-result {{0 0} {0 13} {13 0} {{simple {0 3} {{text {0 3} {}}}} {simple {4 9} {{text {5 7} {}}}}}} |
||||
|
||||
test tclparser_engine_expand_literal {parse command: literal {*} expansion expands at parse time - per-element simple nodes with element quoting stripped in text ranges}\ |
||||
-setup $common -body { |
||||
#this exact sample (with expected output) is documented in punk::lib tclscript_info comments |
||||
punk::tclparser::parse command {{*}{"a" {b} c}} {} |
||||
}\ |
||||
-result {{0 0} {0 14} {14 0} {{simple {4 3} {{text {5 1} {}}}} {simple {8 3} {{text {9 1} {}}}} {simple {12 1} {{text {12 1} {}}}}}} |
||||
|
||||
test tclparser_engine_expand_complex {parse command: non-literal {*} stays an expand node covering the whole word}\ |
||||
-setup $common -body { |
||||
punk::tclparser::parse command {{*}[somecmd]} {} |
||||
}\ |
||||
-result {{0 0} {0 12} {12 0} {{expand {0 12} {{command {3 9} {}}}}}} |
||||
|
||||
test tclparser_engine_expand_empty {parse command: empty literal expansion produces zero word nodes}\ |
||||
-setup $common -body { |
||||
punk::tclparser::parse command {cmd {*}{ }} {} |
||||
}\ |
||||
-result {{0 0} {0 11} {11 0} {{simple {0 3} {{text {0 3} {}}}}}} |
||||
|
||||
test tclparser_engine_restrange {parse command: newline terminates command (included in commandRange) - restRange walks to the next command}\ |
||||
-setup $common -body { |
||||
set s "cmd1 a\ncmd2 b" |
||||
set p1 [punk::tclparser::parse command $s {}] |
||||
lappend result [lindex $p1 1] [lindex $p1 2] |
||||
lassign [lindex $p1 2] rstart rlen |
||||
set p2 [punk::tclparser::parse command $s [list $rstart $rlen]] |
||||
lappend result [lindex $p2 1] [lindex $p2 2] |
||||
}\ |
||||
-result {{0 7} {7 6} {7 6} {13 0}} |
||||
|
||||
test tclparser_engine_vararray_nested {parse command: array variable with command substitution in index - variable subnodes name/text/command}\ |
||||
-setup $common -body { |
||||
punk::tclparser::parse command {cmd $arr(x,[inner y])} {} |
||||
}\ |
||||
-result {{0 0} {0 21} {21 0} {{simple {0 3} {{text {0 3} {}}}} {word {4 17} {{variable {4 17} {{text {5 3} {}} {text {9 2} {}} {command {11 9} {}}}}}}}} |
||||
|
||||
test tclparser_engine_multibyte_ranges {parse command: ranges are BYTE offsets - multibyte char occupies its utf-8 byte length}\ |
||||
-setup $common -body { |
||||
#the e-acute char (U+00E9) is 2 utf-8 bytes, so the word is 5 bytes |
||||
punk::tclparser::parse command "cmd caf\u00e9 x" {} |
||||
}\ |
||||
-result {{0 0} {0 11} {11 0} {{simple {0 3} {{text {0 3} {}}}} {simple {4 5} {{text {4 5} {}}}} {simple {10 1} {{text {10 1} {}}}}}} |
||||
|
||||
test tclparser_engine_getstring_bytes {parse getstring: extracts by byte range across multibyte content}\ |
||||
-setup $common -body { |
||||
punk::tclparser::parse getstring "cmd caf\u00e9 x" {4 5} |
||||
}\ |
||||
-result "caf\u00e9" |
||||
|
||||
test tclparser_engine_countnewline {parse countnewline: whole string via empty range}\ |
||||
-setup $common -body { |
||||
punk::tclparser::parse countnewline "a\nb\nc" {} |
||||
}\ |
||||
-result 2 |
||||
|
||||
test tclparser_engine_err_messages {parse command: incomplete-parse error messages match the c library}\ |
||||
-setup $common -body { |
||||
foreach s [list "cmd \x7bunclosed" {cmd "unclosed} {cmd [unclosed}] { |
||||
catch {punk::tclparser::parse command $s {}} msg |
||||
lappend result $msg |
||||
} |
||||
set result |
||||
}\ |
||||
-result [list "missing close-brace" "missing \"" "missing close-bracket"] |
||||
|
||||
test tclparser_engine_uncovered_subcommand {parse: uncovered subcommands error advising the c library}\ |
||||
-setup $common -body { |
||||
catch {punk::tclparser::parse expr {1+1} {}} msg |
||||
string match "*not implemented in the pure-Tcl engine*package require parser*" $msg |
||||
}\ |
||||
-result 1 |
||||
|
||||
test tclparser_engine_no_parser_package {the engine deliberately does not provide the package name 'parser' (capability probe for the c library)}\ |
||||
-setup $common -body { |
||||
#package provide parser may or may not be non-empty on this runner |
||||
#(a kit or installed c library) - but punk::tclparser must never be |
||||
#what provides it. Check the ifneeded script for our engine name. |
||||
expr {[package provide punk::tclparser] ne "" && [string match "*punk::tclparser*" [package ifneeded parser [package provide punk::tclparser]]] == 0} |
||||
}\ |
||||
-result 1 |
||||
|
||||
# -- punk::lib dispatch / fallback ------------------------------------ |
||||
|
||||
test tclparser_dispatch_forced_tcl {tclword_to_scriptlist works through the forced pure-Tcl engine}\ |
||||
-setup $common -body { |
||||
punk::lib::tclparser_prefer tcl |
||||
set probe {"a string with [puts hello] and [puts world]"} |
||||
lappend result [punk::lib::tclparser_prefer] |
||||
lappend result [punk::lib::tclscript_info::tclword_to_scriptlist $probe] |
||||
}\ |
||||
-cleanup { |
||||
#restore c preference when the c library is present on this runner |
||||
if {![catch {package require parser}]} { |
||||
punk::lib::tclparser_prefer c |
||||
} |
||||
}\ |
||||
-result {tcl {{puts hello} {puts world}}} |
||||
|
||||
test tclparser_dispatch_forced_tcl_nestedvar {tclword_to_scriptlist (pure-Tcl path) recurses into array-index command substitutions}\ |
||||
-setup $common -body { |
||||
punk::lib::tclparser_prefer tcl |
||||
punk::lib::tclscript_info::tclword_to_scriptlist {pre[string map [list \n {}] $seg]post$v(x,[inner y])} |
||||
}\ |
||||
-cleanup { |
||||
if {![catch {package require parser}]} { |
||||
punk::lib::tclparser_prefer c |
||||
} |
||||
}\ |
||||
-result {{string map {[list \n {}]} {$seg}} {inner y}} |
||||
|
||||
test tclparser_tcl_delegation {punk::lib::tclparser_tcl delegates to the engine (former error stub now functional)}\ |
||||
-setup $common -body { |
||||
punk::lib::tclparser_tcl command {cmd "a b" {c d}} {0 end} |
||||
}\ |
||||
-result {{0 0} {0 15} {15 0} {{simple {0 3} {{text {0 3} {}}}} {simple {4 5} {{text {5 3} {}}}} {simple {10 5} {{text {11 3} {}}}}}} |
||||
|
||||
test tclparser_prefer_badarg {tclparser_prefer rejects unknown preferences}\ |
||||
-setup $common -body { |
||||
catch {punk::lib::tclparser_prefer nonsense} msg |
||||
set msg |
||||
}\ |
||||
-result {punk::lib::tclparser_prefer: unknown preference 'nonsense' - must be c or tcl} |
||||
|
||||
} |
||||
tcltest::cleanupTests ;#needed to produce test summary. |
||||
@ -0,0 +1,205 @@
|
||||
package require tcltest |
||||
package require punk::tclparser |
||||
package require punk::lib |
||||
|
||||
#added 2026-08-02 (agent, G-070) - live parity: punk::tclparser pure-Tcl engine |
||||
#vs the tclparser c library, across the recorded probe corpus (edge cases plus |
||||
#representative punkshell-style script snippets). Capability-gated: these |
||||
#tests run only where the c library is loadable ('package require parser' - |
||||
#e.g. a kit shipping the binary, a magicsplat install, or a dir of the |
||||
#tclparser_punk fork's built dlls supplied via env PUNK_TCLPARSER_ORACLE_DIR, |
||||
#which is appended to auto_path before probing). The engine's behaviour is |
||||
#pinned unconditionally (no c library needed) in tclparser_engine.test. |
||||
|
||||
if {[info exists ::env(PUNK_TCLPARSER_ORACLE_DIR)] && [file isdirectory $::env(PUNK_TCLPARSER_ORACLE_DIR)]} { |
||||
lappend ::auto_path $::env(PUNK_TCLPARSER_ORACLE_DIR) |
||||
} |
||||
tcltest::testConstraint have_c_parser [expr {![catch {package require parser}]}] |
||||
|
||||
namespace eval ::testspace { |
||||
namespace import ::tcltest::* |
||||
variable common { |
||||
set result "" |
||||
} |
||||
|
||||
#the recorded probe corpus: label + string pairs. Strings cover quoting, |
||||
#expansion, variables (incl generation-sensitive forms), command |
||||
#substitution, backslashes, comments, terminators, multibyte content and |
||||
#error cases - plus representative punkshell-style snippets at the end. |
||||
variable corpus [list] |
||||
proc case {label string} { |
||||
variable corpus |
||||
lappend corpus [list $label $string] |
||||
} |
||||
case bare2 {cmd arg1 arg2} |
||||
case bare3 { cmd arg } |
||||
case empty {} |
||||
case onlynewline "\n" |
||||
case onlysemi {;} |
||||
case twocmds_nl "cmd1 a\ncmd2 b" |
||||
case twocmds_semi {cmd1 a;cmd2 b} |
||||
case leading_nl_ws " \n cmd a" |
||||
case empty_semis {a;;b} |
||||
case bogus1_pattern {bogus1 someargument} |
||||
case dquote_var {cmd "a $x b"} |
||||
case dquote_cmdsub {cmd "a [inner] b"} |
||||
case dquote_nl "cmd \"a\nb\"" |
||||
case brace_nested {cmd {a {b c} d}} |
||||
case brace_bsbrace "cmd \x7ba\\\x7bb\x7d" |
||||
case brace_bsnl "cmd {a\\\n b}" |
||||
case midword_brace {cmd a{b}c} |
||||
case var_ns {cmd $ns::sub::var} |
||||
case var_braced {cmd ${weird name}} |
||||
case var_array_cmd {cmd $arr(x,[inner y])} |
||||
case var_array_nest {cmd $v(x,$v2(y,[c2]))} |
||||
case var_array_empty {cmd $()} |
||||
case var_lone_end {cmd a$} |
||||
case var_punct {cmd $-} |
||||
case varbrace_nest {cmd ${a{b}c}} |
||||
case varbrace_esc "cmd \$\x7ba\\\x7db\x7d" |
||||
case varbrace_arr {cmd ${a(i)}} |
||||
case varbrace_inquote {cmd "pre${a{b}c}post"} |
||||
case cmdsub_adjacent {cmd [foo $x bar]z} |
||||
case cmdsub_nested {cmd [outer [inner]]} |
||||
case cmdsub_multi "cmd \[c1 a\nc2 b\]" |
||||
case cmdsub_comment "cmd \[#comment\nreal x\]" |
||||
case cmdsub_braced_br {cmd [c1 {a]b}]} |
||||
case expand_braced {cmd {*}{a b c}} |
||||
case expand_bquoted {cmd {*}{"a" {b} c}} |
||||
case expand_quoted {cmd {*}"a b c"} |
||||
case expand_empty {cmd {*}{ }} |
||||
case expand_ws_list "cmd {*}{\n k1 v1\n k2 v2\n}" |
||||
case expand_cmdsub {cmd {*}[getargs]} |
||||
case expand_mixed {cmd {*}"a [s] c"} |
||||
case expand_var {cmd {*}$var} |
||||
case expand_alone {cmd {*}} |
||||
case expand_badlist "cmd {*}\"a \x7bb\"" |
||||
case expand_bslist {cmd {*}{a\ b c}} |
||||
case expand_bracedbs {cmd {*}{{a\ b}}} |
||||
case expand_bsnlsep "cmd {*}\\\n next" |
||||
case bs_dollar {cmd \$novar} |
||||
case bs_hex {cmd \x41BC} |
||||
case bs_u4 {cmd \u0041BC} |
||||
case bs_octal {cmd \101BC} |
||||
case bs_wordsep "cmd a\\\nb" |
||||
case bs_quoted_nl "cmd \"a\\\n b\"" |
||||
case bs_at_end "cmd a\\" |
||||
case comment_cmd "# comment\ncmd a" |
||||
case comment_multi "# c1\n# c2\ncmd a" |
||||
case comment_cont "# comment \\\ncontinues\ncmd a" |
||||
case comment_after_word "cmd a # not comment" |
||||
case mb_word "cmd caf\u00e9 after" |
||||
case mb_dquote "cmd \"caf\u00e9 \[inner\] x\"" |
||||
case mb_var "cmd pre\u00e9\$var" |
||||
case mb_high "cmd \u4e2d\u6587 arg" |
||||
case mb_astral "cmd a\U0001F600b arg" |
||||
case mb_bs_mb "cmd a\\\u00e9b" |
||||
case err_brace "cmd \x7bunclosed" |
||||
case err_quote {cmd "unclosed} |
||||
case err_bracket {cmd [unclosed} |
||||
case err_extra_brace {cmd {a}b} |
||||
case err_extra_quote {cmd "a"b} |
||||
case err_varbrace "cmd \$\x7bunclosed" |
||||
case err_varparen {cmd $a(unclosed} |
||||
#representative punkshell-style snippets (real source shapes) |
||||
case real_dictcreate "dict create {*}{\n key1 value1\n key2 value2\n}" |
||||
case real_ifblock {if {$x > 1} {puts "big $x"} else {puts small}} |
||||
case real_setcmd {set out [string map [list \n {}] $seg]} |
||||
case real_lappend {lappend PUNKARGS [list {stuff here}]} |
||||
case real_proc "proc f {a b} {\n return \[expr {\$a + \$b}\]\n}" |
||||
case real_argdoc "test x {desc}\\\n -setup \$common -body {\n parse command \$s {}\n }\\\n -result {ok}" |
||||
|
||||
proc compare_one {s range} { |
||||
#returns {} on parity, else a description |
||||
set cerr [catch {::parse command $s $range} cres] |
||||
set perr [catch {::punk::tclparser::parse command $s $range} pres] |
||||
if {$cerr != $perr} { |
||||
return "error-status differs (c=$cerr pure=$perr) c:'$cres' pure:'$pres'" |
||||
} |
||||
if {$cres ne $pres} { |
||||
if {$cerr} { |
||||
return "error message differs c:'$cres' pure:'$pres'" |
||||
} |
||||
return "result differs c:'$cres' pure:'$pres'" |
||||
} |
||||
return {} |
||||
} |
||||
|
||||
test tclparser_parity_corpus {parse command parity across the recorded probe corpus (both range forms)}\ |
||||
-constraints have_c_parser\ |
||||
-setup $common -body { |
||||
variable corpus |
||||
foreach entry $corpus { |
||||
lassign $entry label s |
||||
foreach range {{} {0 end}} { |
||||
set diff [compare_one $s $range] |
||||
if {$diff ne ""} { |
||||
lappend result "$label range=[list $range]: $diff" |
||||
} |
||||
} |
||||
} |
||||
set result |
||||
}\ |
||||
-result {} |
||||
|
||||
test tclparser_parity_getstring_walk {parse getstring/countnewline parity over every range in every corpus parse tree}\ |
||||
-constraints have_c_parser\ |
||||
-setup $common -body { |
||||
variable corpus |
||||
foreach entry $corpus { |
||||
lassign $entry label s |
||||
if {[catch {::parse command $s {}} cres]} { |
||||
continue |
||||
} |
||||
set ranges [list [lindex $cres 0] [lindex $cres 1] [lindex $cres 2]] |
||||
set stack [lindex $cres 3] |
||||
while {[llength $stack]} { |
||||
set node [lindex $stack 0] |
||||
set stack [lrange $stack 1 end] |
||||
lappend ranges [lindex $node 1] |
||||
foreach sub [lindex $node 2] { |
||||
lappend stack $sub |
||||
} |
||||
} |
||||
foreach r $ranges { |
||||
set cg [::parse getstring $s $r] |
||||
set pg [::punk::tclparser::parse getstring $s $r] |
||||
if {$cg ne $pg} { |
||||
lappend result "$label getstring $r" |
||||
} |
||||
} |
||||
if {[::parse countnewline $s {}] != [::punk::tclparser::parse countnewline $s {}]} { |
||||
lappend result "$label countnewline" |
||||
} |
||||
} |
||||
set result |
||||
}\ |
||||
-result {} |
||||
|
||||
test tclparser_parity_entrypoint {tclword_to_scriptlist returns identical results through the c library and the pure-Tcl engine}\ |
||||
-constraints have_c_parser\ |
||||
-setup $common -body { |
||||
set probes [list\ |
||||
{"a string with [puts hello] and [puts world]"}\ |
||||
{pre[string map [list \n {}] $seg]post$v(x,[inner y])}\ |
||||
{{fully opaque [not a command]}}\ |
||||
{plainword}\ |
||||
] |
||||
foreach probe $probes { |
||||
punk::lib::tclparser_prefer c |
||||
set rc [punk::lib::tclscript_info::tclword_to_scriptlist $probe] |
||||
punk::lib::tclparser_prefer tcl |
||||
set rt [punk::lib::tclscript_info::tclword_to_scriptlist $probe] |
||||
if {$rc ne $rt} { |
||||
lappend result "mismatch for $probe : c='$rc' tcl='$rt'" |
||||
} |
||||
} |
||||
set result |
||||
}\ |
||||
-cleanup { |
||||
punk::lib::tclparser_prefer c |
||||
}\ |
||||
-result {} |
||||
|
||||
} |
||||
tcltest::cleanupTests ;#needed to produce test summary. |
||||
Loading…
Reference in new issue