Browse Source
- punk::args level (usagemarking.test, 14 tests): pins -parsedargs/-badarg/-scheme marking primitives, goodchoice highlighting of selected and default-in-effect choice words, and scheme border selection - asserted by SGR-parameter subset against the live colour arrays. GAP pins for the documented -scheme choice 'nocolour' falling through to 'na' (renders with the previous scheme's leftover colours) and the dash-spelling '-nocolour' leaking strike-only goodarg into the shared colour array (G-049 candidates). - punk::ns level (cmdhelp.test, 19 tests): pins scheme selection (error scheme on failed parse of supplied args, info scheme + goodarg marking on success), badarg marking via choiceviolation, the early alias-resolution branch, -return string parity, goodchoice highlighting through cmdhelp, and the cmdinfo result shape. GAP pins: pseudo-command cmdtype 'notfound' despite resolved docid + space-form docid exact-word-only jump (G-051; real 'string is true'/'is tr' pins behind the have_tclcoredocs constraint), TclOO undocumented-method class-summary fallback with info-scheme parse of bogus args (G-052), synopsis marking absence and curried-alias braced-target substitution (G-050), explicit -scheme ignored on the parse-failure path and caller-attribution leaking cmdhelp's internal parse source line at top-level call depth (G-049). - punk::ns 0.1.3 (doc-only): cmdhelp 'subcommand' argument help rewritten - was described as ensemble-subcommands-only; now covers tcl::oo methods and argument words, and documents the info/error scheme display driven by argument validity. - Verified: full punk::args + punk::ns suites green on Tcl 9.0.3 and 8.7. Assisted-by: harness=claude; primary-model=claude-fable-5; api-location=anthropic.commaster
4 changed files with 930 additions and 3 deletions
@ -1,5 +1,6 @@
|
||||
0.1.2 |
||||
0.1.3 |
||||
#First line must be a semantic version number |
||||
#all other lines are ignored. |
||||
#0.1.3 - documentation-only: cmdhelp 'subcommand' argument help rewritten to match actual behaviour (was described as ensemble-subcommands-only; also covers tcl::oo methods and argument words, whose validity drives the info/error scheme and received-argument marking of the usage display) |
||||
#0.1.2 - cmd_traverse subcommand walk resolves choice words via the shared punk::args::choiceword_match resolver (G-040 parity): -choiceprefixdenylist and -choiceprefixreservelist are now honoured in doc lookup (previously ignored - 'i <cmd> <word>' could accept words parsing rejects), -choicealiases normalize to their canonical before choiceinfo lookup, and -nocase is honoured in the walk |
||||
#0.1.1 - commented out five development trace puts in the doc-lookup machinery: "PROC auto def"/"ENSEMBLE auto def" (generate_autodef - emitted on STDOUT, polluting 'i'/'s' output in script/exec contexts), "cmd_traverse - skipping to documented subcommand" (space-form id path), "---> cmd_traverse ensembleparam" (ensemble -parameters traversal), and "cmd_traverse 10 ... - review" (fallthrough return). No functional change. |
||||
|
||||
@ -0,0 +1,432 @@
|
||||
package require tcltest |
||||
|
||||
package require punk::args |
||||
package require punk::ansi |
||||
|
||||
#Characterization of the parse-status visual marking in punk::args::arg_error - added |
||||
#2026-07-10 ahead of G-049 (parse-status data model). The -parsedargs / -badarg / -scheme |
||||
#options are the primitives punk::ns::cmdhelp uses to render the good/bad argument |
||||
#highlighting seen interactively ('i <cmd> <args...>'), so their behaviour is pinned here |
||||
#at the arg_error level before any restructuring. Integration through punk::ns::cmdhelp |
||||
#is covered in src/tests/modules/punk/ns/testsuites/ns/cmdhelp.test. |
||||
# |
||||
#Assertion approach: expected SGR styles are read from the live colour arrays |
||||
#(::punk::args::arg_error_CLR and the per-scheme override arrays) rather than hardcoded |
||||
#escape strings, and matched by SGR parameter subset (renderers may merge or reorder |
||||
#codes) - so the tests pin "the goodarg/badarg style, whatever it is configured as", |
||||
#not a specific colour choice. |
||||
# |
||||
#Scheme discrimination: the info scheme's border (arg_error_CLR_info(ansiborder), currently |
||||
#term-grey23) is the only style unique to one scheme - the error scheme's brightyellow bold |
||||
#border shares its SGR parameters with the info scheme's title. Tests therefore treat |
||||
#"info-border params present" as the info-scheme signature and its absence as error/other. |
||||
|
||||
namespace eval ::testspace { |
||||
namespace import ::tcltest::* |
||||
variable common { |
||||
set result "" |
||||
} |
||||
|
||||
#SGR colour generation (a+) is gated by punk::console colour state (e.g NO_COLOR env) |
||||
#force colour on for deterministic marking output; arg_error's own sentinel reloads |
||||
#its colour arrays when the state differs from that at array-build time. |
||||
catch {package require punk::console} |
||||
if {[info commands ::punk::console::colour] ne ""} { |
||||
punk::console::colour on |
||||
} |
||||
|
||||
#--- helpers ---------------------------------------------------------------------------- |
||||
#Origin note: punk has canonical implementations of "ANSI in effect at a position" |
||||
#(punk::ansi::ansistring INDEXCODE, opunk::Str INDEXCODE) and code splitting/testing |
||||
#(punk::ansi::ta, punk::ansi::codetype has_any_effective etc). The minimal SGR-parameter |
||||
#helpers below are deliberately kept test-local: this suite verifies punk::args/punk::ns |
||||
#RENDERING, and punk::ansi is a dependency of the code under test - verifying its output |
||||
#with punk's own higher-level ANSI introspection would leave a shared defect invisible. |
||||
#The canonical mechanisms have their own direct coverage in |
||||
#src/tests/modules/punk/ansi/testsuites/ansi/ (ansistring.test, ta.test, codetype.test). |
||||
|
||||
#parameter list of the first SGR sequence in $code e.g \x1b\[32;9m -> {32 9} |
||||
proc sgr_params {code} { |
||||
if {[regexp {\x1b\[([0-9;]*)m} $code -> params]} { |
||||
return [split $params \;] |
||||
} |
||||
return {} |
||||
} |
||||
#1 if any single SGR sequence in $text contains every parameter in $params |
||||
#and none of the parameters in $withoutparams |
||||
proc has_sgr_with {text params {withoutparams {}}} { |
||||
if {![llength $params]} { |
||||
return 0 |
||||
} |
||||
foreach {match plist} [regexp -all -inline {\x1b\[([0-9;]*)m} $text] { |
||||
set pl [split $plist \;] |
||||
set ok 1 |
||||
foreach p $params { |
||||
if {$p ni $pl} {set ok 0; break} |
||||
} |
||||
foreach p $withoutparams { |
||||
if {$p in $pl} {set ok 0; break} |
||||
} |
||||
if {$ok} { |
||||
return 1 |
||||
} |
||||
} |
||||
return 0 |
||||
} |
||||
#parameters in $params that are not in $subtractparams |
||||
proc lremove_params {params subtractparams} { |
||||
set out {} |
||||
foreach p $params { |
||||
if {$p ni $subtractparams} {lappend out $p} |
||||
} |
||||
return $out |
||||
} |
||||
#raw lines of $rendered whose ANSI-stripped content contains $needle |
||||
proc lines_with {rendered needle} { |
||||
set out {} |
||||
foreach ln [split $rendered \n] { |
||||
if {[string first $needle [punk::ansi::ansistrip $ln]] >= 0} { |
||||
lappend out $ln |
||||
} |
||||
} |
||||
return $out |
||||
} |
||||
#1 if any line mentioning $needle carries an SGR containing all of $params (and none of $withoutparams) |
||||
proc any_line_has_sgr {rendered needle params {withoutparams {}}} { |
||||
foreach ln [lines_with $rendered $needle] { |
||||
if {[has_sgr_with $ln $params $withoutparams]} { |
||||
return 1 |
||||
} |
||||
} |
||||
return 0 |
||||
} |
||||
|
||||
#active-SGR-parameter list per visible character of $ln (SGR codes applied in order; |
||||
#a code starting with parameter 0 - or an empty \x1b\[m - resets, other params accumulate) |
||||
proc char_sgr_map {ln} { |
||||
set map {} |
||||
set active {} |
||||
set i 0 |
||||
set len [string length $ln] |
||||
while {$i < $len} { |
||||
if {[string index $ln $i] eq "\x1b" && [regexp -start $i {\A\x1b\[([0-9;]*)m} $ln whole params]} { |
||||
set plist [split $params \;] |
||||
if {![llength $plist]} { |
||||
set active {} |
||||
} |
||||
foreach p $plist { |
||||
if {$p eq "" || $p == 0} { |
||||
set active {} |
||||
} elseif {$p ni $active} { |
||||
lappend active $p |
||||
} |
||||
} |
||||
incr i [string length $whole] |
||||
} else { |
||||
lappend map $active |
||||
incr i |
||||
} |
||||
} |
||||
return $map |
||||
} |
||||
#1 if every character of the first ANSI-stripped occurrence of $word in $ln has $param active |
||||
proc word_has_sgr_param {ln word param} { |
||||
set plain [punk::ansi::ansistrip $ln] |
||||
set start [string first $word $plain] |
||||
if {$start < 0} { |
||||
return 0 |
||||
} |
||||
set map [char_sgr_map $ln] |
||||
for {set i $start} {$i < $start + [string length $word]} {incr i} { |
||||
if {$param ni [lindex $map $i]} {return 0} |
||||
} |
||||
return 1 |
||||
} |
||||
#1 if any line of $rendered carries $word with every parameter of $params active across the whole word |
||||
proc rendered_word_has_sgr_params {rendered word params} { |
||||
if {![llength $params]} { |
||||
return 0 |
||||
} |
||||
foreach ln [lines_with $rendered $word] { |
||||
set all 1 |
||||
foreach p $params { |
||||
if {![word_has_sgr_param $ln $word $p]} {set all 0; break} |
||||
} |
||||
if {$all} { |
||||
return 1 |
||||
} |
||||
} |
||||
return 0 |
||||
} |
||||
|
||||
#--- fixture ---------------------------------------------------------------------------- |
||||
|
||||
proc markfix {args} {} |
||||
punk::args::define { |
||||
@id -id ::testspace::markfix |
||||
@cmd -name testspace::markfix -summary "markfix summary" -help "markfix help" |
||||
@leaders -min 1 -max 1 |
||||
lvarname -type string |
||||
@opts |
||||
-sh|--shape -type string -default square |
||||
-flag -type none |
||||
@values -min 2 -max 2 |
||||
firstval -type int |
||||
lastval -type int |
||||
} |
||||
|
||||
proc render_markfix {args} { |
||||
punk::args::arg_error "" [punk::args::get_spec ::testspace::markfix] -aserror 0 {*}$args |
||||
} |
||||
|
||||
#choice-bearing fixture for the goodchoice (selected/default choice reverse) highlighting |
||||
proc choicefix {args} {} |
||||
punk::args::define { |
||||
@id -id ::testspace::choicefix |
||||
@cmd -name testspace::choicefix -summary "choicefix summary" -help "choicefix help" |
||||
@leaders -min 1 -max 1 |
||||
animal -choices {cat dog emu} -default dog -optional 1 |
||||
@opts |
||||
-shade -choices {light dark} -default dark |
||||
@values -min 0 -max 1 |
||||
volume -type int -optional 1 |
||||
} |
||||
proc render_choicefix {args} { |
||||
punk::args::arg_error "" [punk::args::get_spec ::testspace::choicefix] -aserror 0 {*}$args |
||||
} |
||||
|
||||
#trigger the initial colour-array load, then capture the pristine styles the tests |
||||
#assert against (the shared arg_error_CLR array is mutated in place by scheme renders - |
||||
#see the leakage GAP pins at the end of this file - so capture before anything else) |
||||
render_markfix |
||||
variable GOOD [sgr_params $::punk::args::arg_error_CLR(goodarg)] |
||||
variable BAD [sgr_params $::punk::args::arg_error_CLR(badarg)] |
||||
variable GOODCHOICE [sgr_params $::punk::args::arg_error_CLR(goodchoice)] |
||||
variable INFOBORDER [sgr_params $::punk::args::arg_error_CLR_info(ansiborder)] |
||||
variable NCGOOD [sgr_params $::punk::args::arg_error_CLR_nocolour(goodarg)] |
||||
|
||||
#--- -parsedargs goodarg marking -------------------------------------------------------- |
||||
|
||||
test usagemarking_goodargs_table {received leaders, solo opt and values are goodarg-marked in the table renderer; an unreceived opt is not}\ |
||||
-setup $common -body { |
||||
variable GOOD |
||||
set argd [punk::args::parse {v1 -flag 0 1} withid ::testspace::markfix] |
||||
set out [render_markfix -scheme info -parsedargs $argd] |
||||
lappend result [any_line_has_sgr $out lvarname $GOOD] |
||||
lappend result [any_line_has_sgr $out -flag $GOOD] |
||||
lappend result [any_line_has_sgr $out firstval $GOOD] |
||||
lappend result [any_line_has_sgr $out lastval $GOOD] |
||||
#-sh|--shape was not received - its row must not carry the goodarg style |
||||
lappend result [any_line_has_sgr $out shape $GOOD] |
||||
}\ |
||||
-cleanup { |
||||
}\ |
||||
-result [list 1 1 1 1 0] |
||||
|
||||
test usagemarking_goodargs_optalias_folding {an opt received via one alias of an -alias|--fullname optionset marks the optionset's display row}\ |
||||
-setup $common -body { |
||||
variable GOOD |
||||
set argd [punk::args::parse {v1 -sh circle 0 1} withid ::testspace::markfix] |
||||
set out [render_markfix -scheme info -parsedargs $argd] |
||||
lappend result [any_line_has_sgr $out shape $GOOD] |
||||
}\ |
||||
-cleanup { |
||||
}\ |
||||
-result [list 1] |
||||
|
||||
test usagemarking_goodargs_string_renderer {goodarg marking also applies in the -return string renderer}\ |
||||
-setup $common -body { |
||||
variable GOOD |
||||
set argd [punk::args::parse {v1 0 1} withid ::testspace::markfix] |
||||
set out [render_markfix -scheme info -return string -parsedargs $argd] |
||||
lappend result [any_line_has_sgr $out lvarname $GOOD] |
||||
lappend result [any_line_has_sgr $out firstval $GOOD] |
||||
#-flag not received |
||||
lappend result [any_line_has_sgr $out -flag $GOOD] |
||||
}\ |
||||
-cleanup { |
||||
}\ |
||||
-result [list 1 1 0] |
||||
|
||||
#--- -badarg marking -------------------------------------------------------------------- |
||||
|
||||
test usagemarking_badarg_table {-badarg marks exactly the named argument row in the table renderer}\ |
||||
-setup $common -body { |
||||
variable BAD |
||||
set out [render_markfix -badarg firstval] |
||||
lappend result [any_line_has_sgr $out firstval $BAD] |
||||
lappend result [any_line_has_sgr $out lastval $BAD] |
||||
lappend result [any_line_has_sgr $out lvarname $BAD] |
||||
}\ |
||||
-cleanup { |
||||
}\ |
||||
-result [list 1 0 0] |
||||
|
||||
test usagemarking_badarg_string_renderer {-badarg marking also applies in the -return string renderer}\ |
||||
-setup $common -body { |
||||
variable BAD |
||||
set out [render_markfix -return string -badarg firstval] |
||||
lappend result [any_line_has_sgr $out firstval $BAD] |
||||
lappend result [any_line_has_sgr $out lastval $BAD] |
||||
}\ |
||||
-cleanup { |
||||
}\ |
||||
-result [list 1 0] |
||||
|
||||
test usagemarking_badarg_wins_over_goodarg {when an argument is both received and named as -badarg, the badarg style wins on its row}\ |
||||
-setup $common -body { |
||||
variable GOOD |
||||
variable BAD |
||||
set argd [punk::args::parse {v1 0 1} withid ::testspace::markfix] |
||||
set out [render_markfix -scheme info -parsedargs $argd -badarg firstval] |
||||
lappend result [any_line_has_sgr $out firstval $BAD] |
||||
lappend result [any_line_has_sgr $out firstval $GOOD] |
||||
#other received args keep goodarg marking |
||||
lappend result [any_line_has_sgr $out lvarname $GOOD] |
||||
}\ |
||||
-cleanup { |
||||
}\ |
||||
-result [list 1 0 1] |
||||
|
||||
#--- goodchoice highlighting (selected / default-in-effect choice) ----------------------- |
||||
#For arguments with -choices, a successful parse highlights the choice word matching the |
||||
#argument's value-in-effect with the goodchoice style (currently reverse video): the |
||||
#supplied choice for received arguments, the default choice for arguments the parse |
||||
#filled from -default. Applied per choice word (the trie prefix keeps its own style on |
||||
#the word's first letter(s)), independent of the row-level goodarg marking. |
||||
|
||||
test usagemarking_goodchoice_selected_choice {a received choice argument's supplied choice word is goodchoice-highlighted; the other choices are not}\ |
||||
-setup $common -body { |
||||
variable GOODCHOICE |
||||
set argd [punk::args::parse {cat} withid ::testspace::choicefix] |
||||
set out [render_choicefix -scheme info -parsedargs $argd] |
||||
lappend result [rendered_word_has_sgr_params $out cat $GOODCHOICE] |
||||
lappend result [rendered_word_has_sgr_params $out dog $GOODCHOICE] |
||||
lappend result [rendered_word_has_sgr_params $out emu $GOODCHOICE] |
||||
}\ |
||||
-cleanup { |
||||
}\ |
||||
-result [list 1 0 0] |
||||
|
||||
test usagemarking_goodchoice_default_in_effect {an unsupplied choice argument filled from -default gets its default choice word highlighted - without row-level goodarg marking}\ |
||||
-setup $common -body { |
||||
variable GOODCHOICE |
||||
variable GOOD |
||||
set argd [punk::args::parse {cat} withid ::testspace::choicefix] |
||||
set out [render_choicefix -scheme info -parsedargs $argd] |
||||
#-shade was not supplied - its default 'dark' is the value in effect |
||||
lappend result [rendered_word_has_sgr_params $out dark $GOODCHOICE] |
||||
lappend result [rendered_word_has_sgr_params $out light $GOODCHOICE] |
||||
#the -shade row itself is not goodarg-marked (not received) |
||||
lappend result [any_line_has_sgr $out light $GOOD] |
||||
}\ |
||||
-cleanup { |
||||
}\ |
||||
-result [list 1 0 0] |
||||
|
||||
test usagemarking_goodchoice_requires_parsedargs {without -parsedargs no choice word is highlighted - a -default matching a choice does not highlight on its own}\ |
||||
-setup $common -body { |
||||
variable GOODCHOICE |
||||
set out [render_choicefix] |
||||
lappend result [rendered_word_has_sgr_params $out dog $GOODCHOICE] |
||||
lappend result [rendered_word_has_sgr_params $out dark $GOODCHOICE] |
||||
set out [render_choicefix -scheme info] |
||||
lappend result [rendered_word_has_sgr_params $out dog $GOODCHOICE] |
||||
lappend result [rendered_word_has_sgr_params $out dark $GOODCHOICE] |
||||
}\ |
||||
-cleanup { |
||||
}\ |
||||
-result [list 0 0 0 0] |
||||
|
||||
test usagemarking_goodchoice_string_renderer {selected and default-in-effect choice highlighting also applies in the -return string renderer}\ |
||||
-setup $common -body { |
||||
variable GOODCHOICE |
||||
set argd [punk::args::parse {cat} withid ::testspace::choicefix] |
||||
set out [render_choicefix -scheme info -return string -parsedargs $argd] |
||||
lappend result [rendered_word_has_sgr_params $out cat $GOODCHOICE] |
||||
lappend result [rendered_word_has_sgr_params $out dog $GOODCHOICE] |
||||
lappend result [rendered_word_has_sgr_params $out dark $GOODCHOICE] |
||||
lappend result [rendered_word_has_sgr_params $out light $GOODCHOICE] |
||||
}\ |
||||
-cleanup { |
||||
}\ |
||||
-result [list 1 0 1 0] |
||||
|
||||
#--- scheme selection ------------------------------------------------------------------- |
||||
|
||||
test usagemarking_scheme_border {-scheme info renders the info border; default and explicit error do not}\ |
||||
-setup $common -body { |
||||
variable INFOBORDER |
||||
set out [render_markfix -scheme info] |
||||
lappend result [has_sgr_with $out $INFOBORDER] |
||||
#default scheme is error |
||||
set out [render_markfix] |
||||
lappend result [has_sgr_with $out $INFOBORDER] |
||||
set out [render_markfix -scheme error] |
||||
lappend result [has_sgr_with $out $INFOBORDER] |
||||
}\ |
||||
-cleanup { |
||||
}\ |
||||
-result [list 1 0 0] |
||||
|
||||
#--- GAP pins: the nocolour scheme and shared colour-array statefulness ------------------ |
||||
#arg_error normalizes its -scheme value with a switch whose nocolour arm matches "", |
||||
#"-nocolor" and "-nocolour" (leading dash) - so the DOCUMENTED choice value "nocolour" |
||||
#falls through to the catch-all "na" scheme: no override array is merged and the render |
||||
#uses whatever colours the most recent info/error render left in the shared |
||||
#arg_error_CLR array. The dash spelling "-nocolour" does merge the nocolour overrides - |
||||
#and because the merge writes the shared array in place, its strike-only goodarg/badarg |
||||
#styles then LEAK into all subsequent renders (nothing restores them until a colour |
||||
#on/off state flip forces an array reload). |
||||
#Pinned 2026-07-10 as characterization - a fix (accept the documented choice value + |
||||
#per-render colour resolution, G-049 candidates) should flip these pins. |
||||
|
||||
test usagemarking_GAP_scheme_nocolour_renders_with_leftover_colours {the documented choice value 'nocolour' is treated as an unknown scheme and renders with the previous scheme's colours}\ |
||||
-setup $common -body { |
||||
variable INFOBORDER |
||||
#prime the shared array with the info scheme, then render 'nocolour' |
||||
render_markfix -scheme info |
||||
set out [render_markfix -scheme nocolour] |
||||
lappend result [has_sgr_with $out $INFOBORDER] |
||||
#prime with the error scheme instead - the same call now renders differently |
||||
render_markfix -scheme error |
||||
set out [render_markfix -scheme nocolour] |
||||
lappend result [has_sgr_with $out $INFOBORDER] |
||||
}\ |
||||
-cleanup { |
||||
punk::args::private::argerror_load_colours 1 |
||||
}\ |
||||
-result [list 1 0] |
||||
|
||||
test usagemarking_GAP_dash_nocolour_leaks_into_shared_array {a -scheme -nocolour (dash spelling) render overwrites goodarg in the shared colour array}\ |
||||
-setup $common -body { |
||||
variable GOOD |
||||
variable NCGOOD |
||||
render_markfix -scheme -nocolour |
||||
set leaked [sgr_params $::punk::args::arg_error_CLR(goodarg)] |
||||
#the shared array now holds the strike-only nocolour style, not the pristine one |
||||
lappend result [expr {$leaked eq $NCGOOD}] |
||||
lappend result [expr {$leaked eq $GOOD}] |
||||
}\ |
||||
-cleanup { |
||||
punk::args::private::argerror_load_colours 1 |
||||
}\ |
||||
-result [list 1 0] |
||||
|
||||
test usagemarking_GAP_dash_nocolour_leak_affects_later_info_render {after a -scheme -nocolour render, an info-scheme render marks goodargs with the leaked strike-only style}\ |
||||
-setup $common -body { |
||||
variable GOOD |
||||
variable NCGOOD |
||||
render_markfix -scheme -nocolour |
||||
set argd [punk::args::parse {v1 0 1} withid ::testspace::markfix] |
||||
set out [render_markfix -scheme info -parsedargs $argd] |
||||
#marking present as strike (9) without the green (32) of the pristine goodarg style |
||||
lappend result [any_line_has_sgr $out lvarname $NCGOOD [lremove_params $GOOD $NCGOOD]] |
||||
lappend result [any_line_has_sgr $out lvarname $GOOD] |
||||
}\ |
||||
-cleanup { |
||||
punk::args::private::argerror_load_colours 1 |
||||
}\ |
||||
-result [list 1 0] |
||||
} |
||||
tcltest::cleanupTests ;#needed to produce test summary line. |
||||
@ -0,0 +1,487 @@
|
||||
package require tcltest |
||||
|
||||
package require punk::args |
||||
package require punk::ns |
||||
package require punk::ansi |
||||
|
||||
#Characterization of punk::ns::cmdhelp usage rendering ('i <cmd> <args...>') - added |
||||
#2026-07-10 ahead of G-049..G-052: scheme selection (error scheme for a failed parse of |
||||
#the supplied arguments, info scheme with goodarg marking for a successful one), badarg |
||||
#marking, the -return string renderer, the alias path, cmdinfo result shape, and GAP pins |
||||
#for the pseudo-command cmdtype (G-051), space-delimited-docid prefix matching (G-051), |
||||
#TclOO undocumented-method fallback (G-052) and synopsis marking absence (G-050). |
||||
#The marking primitives themselves (punk::args::arg_error -parsedargs/-badarg/-scheme) |
||||
#are pinned in src/tests/modules/punk/args/testsuites/args/usagemarking.test - this file |
||||
#pins that cmdhelp drives them correctly. |
||||
# |
||||
#Assertion approach (as usagemarking.test): expected SGR styles are read from the live |
||||
#colour arrays and matched by SGR parameter subset - renderers may merge/reorder codes. |
||||
#The info scheme's border (arg_error_CLR_info(ansiborder)) is the discriminating |
||||
#signature: present <=> info scheme; the error scheme's border shares its parameters |
||||
#with the info scheme's title so cannot discriminate on its own. |
||||
|
||||
namespace eval ::testspace { |
||||
namespace import ::tcltest::* |
||||
variable common { |
||||
set result "" |
||||
} |
||||
|
||||
#SGR colour generation (a+) is gated by punk::console colour state (e.g NO_COLOR env) |
||||
#force colour on for deterministic marking output |
||||
catch {package require punk::console} |
||||
if {[info commands ::punk::console::colour] ne ""} { |
||||
punk::console::colour on |
||||
} |
||||
|
||||
#--- helpers (same implementations as usagemarking.test - harmless if both loaded) ------ |
||||
#Origin note: deliberately test-local miniatures of punk's canonical ANSI-at-position |
||||
#mechanisms (punk::ansi::ansistring INDEXCODE / punk::ansi::ta / punk::ansi::codetype) |
||||
#- see the fuller origin note in usagemarking.test; the canonical mechanisms are |
||||
#covered directly in src/tests/modules/punk/ansi/testsuites/ansi/. |
||||
|
||||
#parameter list of the first SGR sequence in $code e.g \x1b\[32;9m -> {32 9} |
||||
proc sgr_params {code} { |
||||
if {[regexp {\x1b\[([0-9;]*)m} $code -> params]} { |
||||
return [split $params \;] |
||||
} |
||||
return {} |
||||
} |
||||
#1 if any single SGR sequence in $text contains every parameter in $params |
||||
#and none of the parameters in $withoutparams |
||||
proc has_sgr_with {text params {withoutparams {}}} { |
||||
if {![llength $params]} { |
||||
return 0 |
||||
} |
||||
foreach {match plist} [regexp -all -inline {\x1b\[([0-9;]*)m} $text] { |
||||
set pl [split $plist \;] |
||||
set ok 1 |
||||
foreach p $params { |
||||
if {$p ni $pl} {set ok 0; break} |
||||
} |
||||
foreach p $withoutparams { |
||||
if {$p in $pl} {set ok 0; break} |
||||
} |
||||
if {$ok} { |
||||
return 1 |
||||
} |
||||
} |
||||
return 0 |
||||
} |
||||
#raw lines of $rendered whose ANSI-stripped content contains $needle |
||||
proc lines_with {rendered needle} { |
||||
set out {} |
||||
foreach ln [split $rendered \n] { |
||||
if {[string first $needle [punk::ansi::ansistrip $ln]] >= 0} { |
||||
lappend out $ln |
||||
} |
||||
} |
||||
return $out |
||||
} |
||||
#1 if any line mentioning $needle carries an SGR containing all of $params (and none of $withoutparams) |
||||
proc any_line_has_sgr {rendered needle params {withoutparams {}}} { |
||||
foreach ln [lines_with $rendered $needle] { |
||||
if {[has_sgr_with $ln $params $withoutparams]} { |
||||
return 1 |
||||
} |
||||
} |
||||
return 0 |
||||
} |
||||
#active-SGR-parameter list per visible character of $ln (SGR codes applied in order; |
||||
#a code starting with parameter 0 - or an empty \x1b\[m - resets, other params accumulate) |
||||
proc char_sgr_map {ln} { |
||||
set map {} |
||||
set active {} |
||||
set i 0 |
||||
set len [string length $ln] |
||||
while {$i < $len} { |
||||
if {[string index $ln $i] eq "\x1b" && [regexp -start $i {\A\x1b\[([0-9;]*)m} $ln whole params]} { |
||||
set plist [split $params \;] |
||||
if {![llength $plist]} { |
||||
set active {} |
||||
} |
||||
foreach p $plist { |
||||
if {$p eq "" || $p == 0} { |
||||
set active {} |
||||
} elseif {$p ni $active} { |
||||
lappend active $p |
||||
} |
||||
} |
||||
incr i [string length $whole] |
||||
} else { |
||||
lappend map $active |
||||
incr i |
||||
} |
||||
} |
||||
return $map |
||||
} |
||||
#1 if every character of the first ANSI-stripped occurrence of $word in $ln has $param active |
||||
proc word_has_sgr_param {ln word param} { |
||||
set plain [punk::ansi::ansistrip $ln] |
||||
set start [string first $word $plain] |
||||
if {$start < 0} { |
||||
return 0 |
||||
} |
||||
set map [char_sgr_map $ln] |
||||
for {set i $start} {$i < $start + [string length $word]} {incr i} { |
||||
if {$param ni [lindex $map $i]} {return 0} |
||||
} |
||||
return 1 |
||||
} |
||||
#1 if any line of $rendered carries $word with every parameter of $params active across the whole word |
||||
proc rendered_word_has_sgr_params {rendered word params} { |
||||
if {![llength $params]} { |
||||
return 0 |
||||
} |
||||
foreach ln [lines_with $rendered $word] { |
||||
set all 1 |
||||
foreach p $params { |
||||
if {![word_has_sgr_param $ln $word $p]} {set all 0; break} |
||||
} |
||||
if {$all} { |
||||
return 1 |
||||
} |
||||
} |
||||
return 0 |
||||
} |
||||
|
||||
#--- fixtures ---------------------------------------------------------------------------- |
||||
|
||||
#the 'i ledit v1 0 1' shape: leader + solo opt + two typed values |
||||
proc helpfix {args} {} |
||||
punk::args::define { |
||||
@id -id ::testspace::helpfix |
||||
@cmd -name testspace::helpfix -summary "helpfix summary" -help "helpfix help" |
||||
@leaders -min 1 -max 1 |
||||
lvarname -type string |
||||
@opts |
||||
-flag -type none |
||||
@values -min 2 -max 2 |
||||
firstval -type int |
||||
lastval -type int |
||||
} |
||||
interp alias {} ::testspace::helpalias {} ::testspace::helpfix |
||||
interp alias {} ::testspace::helpcurry {} ::testspace::helpfix v1 |
||||
|
||||
#leader with restricted choices - a choiceviolation is the parse failure that carries -badarg |
||||
proc choosy {args} {} |
||||
punk::args::define { |
||||
@id -id ::testspace::choosy |
||||
@cmd -name testspace::choosy -summary "choosy summary" -help "choosy help" |
||||
@leaders -min 1 -max 1 |
||||
animal -choices {cat dog emu} |
||||
@opts |
||||
-shade -choices {light dark} -default dark |
||||
@values -min 1 -max 1 |
||||
volume -type int |
||||
} |
||||
|
||||
#documented parent whose subcommand doc exists only as a space-delimited id and whose |
||||
#choiceinfo has no subhelp mapping - models the tclcore 'string is <class>' docs |
||||
proc helpstr {args} {} |
||||
punk::args::define { |
||||
@id -id ::testspace::helpstr |
||||
@cmd -name testspace::helpstr -summary "helpstr parent" -help "helpstr parent" |
||||
@leaders -min 1 -max 1 |
||||
subcmd -choices {is compare} |
||||
@values -min 0 -max -1 |
||||
arg -optional 1 -multiple 1 |
||||
} |
||||
punk::args::define { |
||||
@id -id "::testspace::helpstr is" |
||||
@cmd -name "testspace::helpstr is" -summary "helpstr is summary" -help "helpstr is" |
||||
@values -min 1 -max 1 |
||||
str -type string |
||||
} |
||||
|
||||
#TclOO instance with one documented and one undocumented method (the |
||||
#punk::ansi::class::class_ansi rendertest/checksum situation) |
||||
oo::class create ::testspace::HelpClass { |
||||
method docmeth {a b} {return dm} |
||||
method plainmeth {x {y 1}} {return pm} |
||||
} |
||||
::testspace::HelpClass create ::testspace::helpobj |
||||
punk::args::define { |
||||
@id -id "::testspace::HelpClass docmeth" |
||||
@cmd -name "testspace::HelpClass docmeth" -summary "docmeth summary" -help "docmeth help" |
||||
@values -min 2 -max 2 |
||||
avalue -type string |
||||
bvalue -type string |
||||
} |
||||
|
||||
#tclcore doc module supplies the real 'string is <class>' space-delimited ids |
||||
testConstraint have_tclcoredocs [expr {![catch {package require punk::args::moduledoc::tclcore}]}] |
||||
|
||||
#trigger the colour-array load, then capture the styles the tests assert against |
||||
punk::ns::cmdhelp ::testspace::helpfix |
||||
variable GOOD [sgr_params $::punk::args::arg_error_CLR(goodarg)] |
||||
variable BAD [sgr_params $::punk::args::arg_error_CLR(badarg)] |
||||
variable GOODCHOICE [sgr_params $::punk::args::arg_error_CLR(goodchoice)] |
||||
variable INFOBORDER [sgr_params $::punk::args::arg_error_CLR_info(ansiborder)] |
||||
|
||||
#--- cmdinfo result shape ---------------------------------------------------------------- |
||||
|
||||
test cmdhelp_cmdinfo_result_shape {cmdinfo returns the documented key set - synopsis and cmdhelp consume this shape}\ |
||||
-setup $common -body { |
||||
set cinfo [punk::ns::cmdinfo ::testspace::helpfix] |
||||
lappend result [dict keys $cinfo] |
||||
lappend result [dict get $cinfo cmdtype] [dict get $cinfo docid] |
||||
}\ |
||||
-cleanup { |
||||
}\ |
||||
-result [list {origin cmdtype args_resolved args_remaining docid stack} proc ::testspace::helpfix] |
||||
|
||||
#--- scheme selection -------------------------------------------------------------------- |
||||
|
||||
test cmdhelp_scheme_error_on_incomplete_args {insufficient arguments render the error scheme (no info border) with the parse error message}\ |
||||
-setup $common -body { |
||||
variable INFOBORDER |
||||
set out [punk::ns::cmdhelp ::testspace::helpfix v1] |
||||
lappend result [has_sgr_with $out $INFOBORDER] |
||||
#message wording varies by which check fails (count vs allocation) - both start "Bad number of" |
||||
lappend result [string match "Bad number of*" [punk::ansi::ansistrip [lindex [split $out \n] 0]]] |
||||
}\ |
||||
-cleanup { |
||||
}\ |
||||
-result [list 0 1] |
||||
|
||||
test cmdhelp_scheme_info_on_valid_args {a complete valid argument set renders the info scheme with received arguments goodarg-marked}\ |
||||
-setup $common -body { |
||||
variable INFOBORDER |
||||
variable GOOD |
||||
set out [punk::ns::cmdhelp ::testspace::helpfix v1 0 1] |
||||
lappend result [has_sgr_with $out $INFOBORDER] |
||||
lappend result [any_line_has_sgr $out lvarname $GOOD] |
||||
lappend result [any_line_has_sgr $out firstval $GOOD] |
||||
lappend result [any_line_has_sgr $out lastval $GOOD] |
||||
#-flag was not supplied - its row is not marked |
||||
lappend result [any_line_has_sgr $out -flag $GOOD] |
||||
}\ |
||||
-cleanup { |
||||
}\ |
||||
-result [list 1 1 1 1 0] |
||||
|
||||
test cmdhelp_badarg_marking_choiceviolation {a choice violation badarg-marks exactly the violating argument's row (error scheme)}\ |
||||
-setup $common -body { |
||||
variable INFOBORDER |
||||
variable BAD |
||||
set out [punk::ns::cmdhelp ::testspace::choosy horse 5] |
||||
lappend result [has_sgr_with $out $INFOBORDER] |
||||
lappend result [any_line_has_sgr $out animal $BAD] |
||||
lappend result [any_line_has_sgr $out volume $BAD] |
||||
}\ |
||||
-cleanup { |
||||
}\ |
||||
-result [list 0 1 0] |
||||
|
||||
test cmdhelp_goodchoice_highlighting {a valid invocation highlights the supplied choice word and the default-in-effect choice of an unsupplied opt (the 'i i' behaviour), in table and string renderers}\ |
||||
-setup $common -body { |
||||
variable GOODCHOICE |
||||
set out [punk::ns::cmdhelp ::testspace::choosy cat 5] |
||||
#supplied choice highlighted, siblings not |
||||
lappend result [rendered_word_has_sgr_params $out cat $GOODCHOICE] |
||||
lappend result [rendered_word_has_sgr_params $out dog $GOODCHOICE] |
||||
#-shade not supplied - its default 'dark' is the value in effect |
||||
lappend result [rendered_word_has_sgr_params $out dark $GOODCHOICE] |
||||
lappend result [rendered_word_has_sgr_params $out light $GOODCHOICE] |
||||
set out [punk::ns::cmdhelp -return string ::testspace::choosy cat 5] |
||||
lappend result [rendered_word_has_sgr_params $out cat $GOODCHOICE] |
||||
lappend result [rendered_word_has_sgr_params $out dark $GOODCHOICE] |
||||
lappend result [rendered_word_has_sgr_params $out light $GOODCHOICE] |
||||
}\ |
||||
-cleanup { |
||||
}\ |
||||
-result [list 1 0 1 0 1 1 0] |
||||
|
||||
test cmdhelp_explicit_scheme_honoured_on_success {an explicit -scheme overrides the automatic info scheme for a valid argument set}\ |
||||
-setup $common -body { |
||||
variable INFOBORDER |
||||
set out [punk::ns::cmdhelp -scheme error ::testspace::helpfix v1 0 1] |
||||
lappend result [has_sgr_with $out $INFOBORDER] |
||||
}\ |
||||
-cleanup { |
||||
}\ |
||||
-result [list 0] |
||||
|
||||
test cmdhelp_return_string_marking {goodarg marking is also applied by the -return string renderer}\ |
||||
-setup $common -body { |
||||
variable GOOD |
||||
set out [punk::ns::cmdhelp -return string ::testspace::helpfix v1 0 1] |
||||
lappend result [any_line_has_sgr $out lvarname $GOOD] |
||||
lappend result [any_line_has_sgr $out firstval $GOOD] |
||||
lappend result [any_line_has_sgr $out -flag $GOOD] |
||||
}\ |
||||
-cleanup { |
||||
}\ |
||||
-result [list 1 1 0] |
||||
|
||||
test cmdhelp_alias_path_marking {scheme selection and goodarg marking also work through the early alias resolution branch}\ |
||||
-setup $common -body { |
||||
variable INFOBORDER |
||||
variable GOOD |
||||
set out [punk::ns::cmdhelp ::testspace::helpalias v1 0 1] |
||||
lappend result [has_sgr_with $out $INFOBORDER] |
||||
lappend result [any_line_has_sgr $out lvarname $GOOD] |
||||
set out [punk::ns::cmdhelp ::testspace::helpalias v1] |
||||
lappend result [has_sgr_with $out $INFOBORDER] |
||||
}\ |
||||
-cleanup { |
||||
}\ |
||||
-result [list 1 1 0] |
||||
|
||||
#--- GAP pins: scheme/badarg asymmetries (G-049 candidates) ------------------------------- |
||||
#Pinned 2026-07-10 as characterization of current behaviour - a fix should flip these. |
||||
|
||||
test cmdhelp_GAP_no_badarg_marking_for_failed_typed_value {a value failing its -type check reports 'missingrequiredvalue' with NO badarg marking - only choice violations mark the bad argument}\ |
||||
-setup $common -body { |
||||
variable BAD |
||||
set out [punk::ns::cmdhelp ::testspace::helpfix v1 x x] |
||||
#the message names the failing argument but no row is badarg-marked |
||||
lappend result [string match "*fail on firstval*" [punk::ansi::ansistrip [lindex [split $out \n] 0]]] |
||||
lappend result [any_line_has_sgr $out firstval $BAD] |
||||
lappend result [any_line_has_sgr $out lastval $BAD] |
||||
}\ |
||||
-cleanup { |
||||
}\ |
||||
-result [list 1 0 0] |
||||
|
||||
test cmdhelp_GAP_explicit_scheme_ignored_on_failure {an explicit -scheme is honoured on the success path but IGNORED on the parse-failure path (the rendered error keeps the error scheme)}\ |
||||
-setup $common -body { |
||||
variable INFOBORDER |
||||
set out [punk::ns::cmdhelp -scheme info ::testspace::helpfix v1] |
||||
lappend result [has_sgr_with $out $INFOBORDER] |
||||
}\ |
||||
-cleanup { |
||||
}\ |
||||
-result [list 0] |
||||
|
||||
test cmdhelp_GAP_errormsg_leaks_internal_source {called at the global level (as from a repl), the parse-failure message shows cmdhelp's own unsubstituted source line as the caller instead of the queried command}\ |
||||
-setup $common -body { |
||||
#caller attribution depends on the invocation depth: from a nested context the |
||||
#message names the user's cmdhelp invocation (correct), but a top-level call - |
||||
#the interactive 'i <cmd>' case - walks to cmdhelp's internal parse call and |
||||
#shows its raw source text |
||||
set out [uplevel #0 [list punk::ns::cmdhelp ::testspace::helpfix v1]] |
||||
set line1 [punk::ansi::ansistrip [lindex [split $out \n] 0]] |
||||
lappend result [string match {*punk::args::parse $args_remaining*} $line1] |
||||
#from a nested context the same call attributes correctly |
||||
set out [punk::ns::cmdhelp ::testspace::helpfix v1] |
||||
set line1 [punk::ansi::ansistrip [lindex [split $out \n] 0]] |
||||
lappend result [string match {*punk::ns::cmdhelp*} $line1] |
||||
}\ |
||||
-cleanup { |
||||
}\ |
||||
-result [list 1 1] |
||||
|
||||
#--- GAP pins: pseudo-command cmdtype + space-delimited docid prefixes (G-051) ------------ |
||||
|
||||
test cmdhelp_GAP_pseudo_command_cmdtype_notfound {a space-delimited docid below a real command resolves its documentation but reports cmdtype 'notfound'}\ |
||||
-setup $common -body { |
||||
set cinfo [punk::ns::cmdinfo ::testspace::helpstr is] |
||||
lappend result [dict get $cinfo docid] [dict get $cinfo cmdtype] |
||||
set cinfo [punk::ns::cmdinfo ::testspace::helpstr is hello] |
||||
lappend result [dict get $cinfo docid] [dict get $cinfo args_remaining] |
||||
}\ |
||||
-cleanup { |
||||
}\ |
||||
-result [list {::testspace::helpstr is} notfound {::testspace::helpstr is} hello] |
||||
|
||||
test cmdhelp_GAP_spaceform_docid_prefix_not_honoured {parse accepts a unique choice prefix for the subcommand word but the space-delimited docid jump requires the exact word}\ |
||||
-setup $common -body { |
||||
#parse side: unique prefix 'i' of choice 'is' is accepted and normalized |
||||
set argd [punk::args::parse {i} withid ::testspace::helpstr] |
||||
lappend result [dict get [dict get $argd leaders] subcmd] |
||||
#doc-walk side: the same prefix does not reach the child docid |
||||
set cinfo [punk::ns::cmdinfo ::testspace::helpstr i] |
||||
lappend result [dict get $cinfo docid] [dict get $cinfo args_remaining] |
||||
}\ |
||||
-cleanup { |
||||
}\ |
||||
-result [list is ::testspace::helpstr i] |
||||
|
||||
test cmdhelp_GAP_string_is_true_pseudo {real-world pin: 'string is true' resolves its tclcore docid but reports cmdtype 'notfound'}\ |
||||
-constraints have_tclcoredocs\ |
||||
-setup $common -body { |
||||
set cinfo [punk::ns::cmdinfo ::string is true] |
||||
lappend result [dict get $cinfo docid] [dict get $cinfo cmdtype] |
||||
}\ |
||||
-cleanup { |
||||
}\ |
||||
-result [list {::tcl::string::is true} notfound] |
||||
|
||||
test cmdhelp_GAP_string_is_prefix_not_honoured {real-world pin: 'string is tr' works in Tcl but the doc walk stays at the parent docid}\ |
||||
-constraints have_tclcoredocs\ |
||||
-setup $common -body { |
||||
#Tcl itself accepts the class prefix |
||||
lappend result [string is tr 1] |
||||
set cinfo [punk::ns::cmdinfo ::string is tr] |
||||
lappend result [dict get $cinfo docid] [dict get $cinfo args_remaining] |
||||
}\ |
||||
-cleanup { |
||||
}\ |
||||
-result [list 1 ::tcl::string::is tr] |
||||
|
||||
#--- TclOO methods (G-052) ----------------------------------------------------------------- |
||||
|
||||
test cmdhelp_oo_documented_method {a documented method on an instance resolves to its class-level docid and gets goodarg marking}\ |
||||
-setup $common -body { |
||||
variable INFOBORDER |
||||
variable GOOD |
||||
set cinfo [punk::ns::cmdinfo ::testspace::helpobj docmeth] |
||||
lappend result [dict get $cinfo docid] |
||||
set out [punk::ns::cmdhelp ::testspace::helpobj docmeth aa bb] |
||||
lappend result [has_sgr_with $out $INFOBORDER] |
||||
lappend result [any_line_has_sgr $out avalue $GOOD] |
||||
lappend result [any_line_has_sgr $out bvalue $GOOD] |
||||
}\ |
||||
-cleanup { |
||||
}\ |
||||
-result [list {::testspace::HelpClass docmeth} 1 1 1] |
||||
|
||||
test cmdhelp_GAP_oo_undocumented_method_class_summary_only {an undocumented method falls back to the autogenerated class summary - bogus trailing arguments still render info scheme with the method word goodarg-marked}\ |
||||
-setup $common -body { |
||||
variable INFOBORDER |
||||
variable GOOD |
||||
set cinfo [punk::ns::cmdinfo ::testspace::helpobj plainmeth] |
||||
lappend result [dict get $cinfo cmdtype] [dict get $cinfo docid] |
||||
#no method-level (autodef) is generated from the method's own parameter list |
||||
set cinfo [punk::ns::cmdinfo ::testspace::helpobj plainmeth bogus1 bogus2 bogus3] |
||||
lappend result [dict get $cinfo docid] [dict get $cinfo args_remaining] |
||||
#the class-summary usage renders as a *valid* parse (info scheme, method marked) |
||||
#even though the trailing arguments are meaningless for plainmeth |
||||
set out [punk::ns::cmdhelp ::testspace::helpobj plainmeth bogus1 bogus2 bogus3] |
||||
lappend result [has_sgr_with $out $INFOBORDER] |
||||
lappend result [any_line_has_sgr $out method $GOOD] |
||||
}\ |
||||
-cleanup { |
||||
}\ |
||||
-result [list\ |
||||
ooobject (autodef)::testspace::helpobj\ |
||||
(autodef)::testspace::helpobj {plainmeth bogus1 bogus2 bogus3}\ |
||||
1 1\ |
||||
] |
||||
|
||||
#--- synopsis (G-050) ---------------------------------------------------------------------- |
||||
|
||||
test synopsis_GAP_no_argument_validity_marking {synopsis output carries no goodarg marking and is identical for valid, invalid and absent argument words}\ |
||||
-setup $common -body { |
||||
variable GOOD |
||||
set s1 [punk::ns::synopsis ::testspace::helpfix v1 0 1] |
||||
set s2 [punk::ns::synopsis ::testspace::helpfix v1 x x] |
||||
set s3 [punk::ns::synopsis ::testspace::helpfix] |
||||
lappend result [expr {$s1 eq $s2}] [expr {$s1 eq $s3}] |
||||
lappend result [has_sgr_with $s1 $GOOD] |
||||
}\ |
||||
-cleanup { |
||||
}\ |
||||
-result [list 1 1 0] |
||||
|
||||
test synopsis_curried_alias_shows_braced_target {REVIEW pin: synopsis of a curried alias substitutes the braced alias target, not the alias name (the 's pse' excess-args fudge)}\ |
||||
-setup $common -body { |
||||
set syn [punk::ansi::ansistrip [punk::ns::synopsis ::testspace::helpcurry]] |
||||
lappend result [lindex [split $syn \n] end] |
||||
}\ |
||||
-cleanup { |
||||
}\ |
||||
-result [list {{::testspace::helpfix v1} [-flag] firstval lastval}] |
||||
} |
||||
tcltest::cleanupTests ;#needed to produce test summary line. |
||||
Loading…
Reference in new issue