Browse Source
Tests-first coverage pass (user-directed) before any changes to the definition-parsing/indentation machinery. punk/args suite: 128 tests, 15 files. - rendering.test (15): nesting independence (plain + tstr definitions render identically regardless of source-block indentation), relative-indent preservation (2-space help and 1-space choicelabel conventions, single and multiline - preservation, not enforcement), -unindentedfields (arg -help works left-margin; @cmd accepts-but-ignores it - GAP pinned), constructed (string-built) definition absolute-indent characterization ('constructed' to avoid confusion with the @dynamic directive), multiline ${[cmd]}/${$var}/ resolved_def insertions (aligned at insertion column, nesting-independent), and @dynamic ${$DYN_X} double substitution: stable across repeated resolutions, provider refresh honoured in help text, choice display and parse acceptance, textblock::frame-style art choicelabels byte-aligned - but multiline -help insertions land lines 2+ at insertion-4 (GAP pinned: the second-round subst path lacks paramindent re-alignment) - choicegroups.test (5): group/-choices union parsing, cross-group prefixes, duplicate-entry dedup, per-group titled choice tables (the punk::imap4 multi-table display), imap4-style {\Deleted}/{$MDNSent} values with labels incl. through tstr-bearing blocks; GAP pinned: prefix-normalization list-quotes special-character choices (exact '\Deleted' stores the plain string, prefix '\De' stores a one-element list) - value shape depends on input style - defquoting.test (3): container quoting rules pinned - braced values fully literal ($, [], two-char \n, bare backslashes), quoted values get Tcl backslash semantics (\n -> newline, \ -> \) with $/[] still literal, and \$\{...\} renders a literal ${...} in tstr-processed blocks - examples.test (6): helpers::example box/title/-tstr toggle (no-dedent direct-call contract pinned), ${[example ...]} insertion into @cmd help (bars at insertion column, content +2, automatic 'Example: eg <id>' row), @examples -> punk::args::eg with #<nodisplay>/@#<nodisplay> stripping (ANSI-tolerant), strip_nodisplay_lines unit, live tclcore ::lseq smoke - punk::args 0.3.1: helpers::example -title path called bare [a] (resolvable only where a punk shell's global alias exists - errored under plain tclsh); now punk::ansi::a. Found by examples.test in the runtests environment. - investigated punk::ansi::mark_columns first-call slowness (3.94s first, 60us after): argdoc -help calls a proc that calls mark_columns, whose parse resolves the same still-resolving definition - hazard already documented in-source with candidate fixes; recorded in CHANGELOG for goal consideration, deliberately not patched - project 0.4.11 (CHANGELOG entry) Assisted-by: harness=claude; primary-model=claude-fable-5; api-location=anthropic.commaster
8 changed files with 1066 additions and 3 deletions
@ -1,3 +1,3 @@
|
||||
[project] |
||||
name = "punkshell" |
||||
version = "0.4.10" |
||||
version = "0.4.11" |
||||
|
||||
@ -1,6 +1,7 @@
|
||||
0.3.0 |
||||
0.3.1 |
||||
#First line must be a semantic version number |
||||
#all other lines are ignored. |
||||
#0.3.1 - fixed helpers::example -title path calling bare [a] (only resolvable where a global 'a' alias exists, e.g. punk shells) - now punk::ansi::a; found by the new examples.test running under plain tclsh |
||||
#0.3.0 - new: -choicealiases {alias canonical ...} argument option (G-040) - aliases accepted exact under any -choiceprefix/-nocase setting, join the prefix-calculation pool when -choiceprefix is true, and normalize to their canonical choice in parse results; deny applies to the matched name (alias deny requires full alias; canonical reached via alias exempt from the canonical's own deny); usage display folds aliases into the canonical entry's label as an (alias:...) note and includes alias names in display prefix calculation; alias->existing-choice and no-collision validated at definition resolve. new public helper punk::args::choiceword_match - the single choice-word matching implementation extracted from get_dict, also consumed by punk::ns cmd_traverse for doc-lookup parity |
||||
#0.2.3 - fixed "@opts -any 1" adhoc option passthrough: an option not in the definition crashed get_dict ("can't read argname") at the name-mapping stage instead of passing through - adhoc opts now fall back to their raw supplied name (argstate/arg_checks already carried them); commented out a debug puts stderr (">>>_get_dict_can_assign_value NOT alloc_ok...") that fired on every failed clause type assignment (e.g. any multiform parse miss) |
||||
#0.2.2 - documentation-only: define doc clarifies -choicerestricted 0 passthrough (non-matching/ambiguous/denied/reserved words accepted as ordinary values), -choiceprefix result normalization to the canonical choice + minimal-prefix display highlighting, -choiceprefixdenylist behaviour for shorter prefixes in both restricted modes, and -choiceprefixreservelist phantom-entry idiom for per-choice minimum-prefix control |
||||
|
||||
@ -0,0 +1,161 @@
|
||||
package require tcltest |
||||
|
||||
package require punk::args |
||||
package require punk::ansi |
||||
|
||||
#-choicegroups coverage - added 2026-07-09 (motivating consumer: punk::imap4's flagname |
||||
#argument, which uses multiple named groups displayed as separate choice tables, with |
||||
#choice values containing leading backslashes ({\Deleted}) and dollar signs ({$MDNSent})). |
||||
|
||||
namespace eval ::testspace { |
||||
namespace import ::tcltest::* |
||||
variable common { |
||||
set result "" |
||||
} |
||||
|
||||
proc cg_render {id} { |
||||
return [punk::ansi::ansistrip [punk::args::arg_error "" [punk::args::get_spec $id] -aserror 0]] |
||||
} |
||||
|
||||
punk::args::define { |
||||
@id -id ::testspace::cgroups |
||||
@cmd -name testspace::cgroups -summary\ |
||||
"Choicegroups fixture."\ |
||||
-help\ |
||||
"cmd help." |
||||
@values -min 1 -max 1 |
||||
flag -choices {GDELTA} -choicegroups { |
||||
GroupOne {GALPHA GBETA} |
||||
GroupTwo {GGAMMA GALPHA} |
||||
} -choicelabels { |
||||
GALPHA " alpha label" |
||||
} -help\ |
||||
"flag help." |
||||
} |
||||
|
||||
test choicegroups_parse_union {members of any group and of -choices all parse; prefixes resolve across the union; an entry duplicated across groups still prefix-matches}\ |
||||
-setup $common -body { |
||||
foreach word {GALPHA GGAMMA GDELTA} { |
||||
lappend result [dict get [punk::args::parse [list $word] withid ::testspace::cgroups] values] |
||||
} |
||||
#unique prefix across the whole union |
||||
lappend result [dict get [punk::args::parse {GG} withid ::testspace::cgroups] values] |
||||
#GALPHA appears in two groups - deduped for prefix calculation (GA still unique) |
||||
lappend result [dict get [punk::args::parse {GA} withid ::testspace::cgroups] values] |
||||
#a non-member is rejected (restricted default) |
||||
if {[catch {punk::args::parse {GZZZ} withid ::testspace::cgroups}]} { |
||||
lappend result nonmember-rejected |
||||
} else { |
||||
lappend result nonmember-UNEXPECTEDLY-accepted |
||||
} |
||||
}\ |
||||
-cleanup { |
||||
}\ |
||||
-result [list\ |
||||
{flag GALPHA}\ |
||||
{flag GGAMMA}\ |
||||
{flag GDELTA}\ |
||||
{flag GGAMMA}\ |
||||
{flag GALPHA}\ |
||||
nonmember-rejected\ |
||||
] |
||||
|
||||
test choicegroups_display_group_tables {each named group renders as its own titled choice table; ungrouped -choices render first; labels attach within groups}\ |
||||
-setup $common -body { |
||||
set r [cg_render ::testspace::cgroups] |
||||
#group names appear (as table titles) |
||||
lappend result [string match "*GroupOne*" $r] |
||||
lappend result [string match "*GroupTwo*" $r] |
||||
#all members and the ungrouped choice present |
||||
foreach word {GALPHA GBETA GGAMMA GDELTA} { |
||||
lappend result [expr {[string first $word $r] >= 0}] |
||||
} |
||||
#the label attaches to the grouped choice |
||||
lappend result [string match "*alpha label*" $r] |
||||
#ungrouped table comes before the group tables |
||||
lappend result [expr {[string first GDELTA $r] < [string first GroupOne $r]}] |
||||
}\ |
||||
-cleanup { |
||||
}\ |
||||
-result [list 1 1 1 1 1 1 1 1] |
||||
|
||||
punk::args::define { |
||||
@id -id ::testspace::cgimap |
||||
@cmd -name testspace::cgimap -summary\ |
||||
"Imap-style values fixture."\ |
||||
-help\ |
||||
"cmd help." |
||||
@values -min 1 -max 1 |
||||
flagname -choicerestricted 0 -choicegroups { |
||||
SystemFlags {{\Deleted} {\Flagged}} |
||||
Keywords {{$MDNSent} {$Forwarded}} |
||||
} -choicelabels { |
||||
{\Deleted}\ |
||||
{ Message is deleted} |
||||
$Forwarded\ |
||||
" Message forwarded" |
||||
} -help\ |
||||
"flagname help." |
||||
} |
||||
|
||||
test choicegroups_imap_special_values_parse_and_display {choice values with leading backslashes and dollar signs parse exactly and display with their labels (the punk::imap4 flagname pattern)}\ |
||||
-setup $common -body { |
||||
set argd [punk::args::parse [list "\\Deleted"] withid ::testspace::cgimap] |
||||
lappend result [expr {[dict get [dict get $argd values] flagname] eq "\\Deleted"}] |
||||
set argd [punk::args::parse [list "\$MDNSent"] withid ::testspace::cgimap] |
||||
lappend result [expr {[dict get [dict get $argd values] flagname] eq "\$MDNSent"}] |
||||
set r [cg_render ::testspace::cgimap] |
||||
lappend result [expr {[string first "\\Deleted" $r] >= 0}] |
||||
lappend result [expr {[string first "\$MDNSent" $r] >= 0}] |
||||
lappend result [string match "*Message is deleted*" $r] |
||||
lappend result [string match "*Message forwarded*" $r] |
||||
}\ |
||||
-cleanup { |
||||
}\ |
||||
-result [list 1 1 1 1 1 1] |
||||
|
||||
test choicegroups_imap_prefix_listwrap_GAP {GAP: prefix-normalizing a choice containing a backslash stores a list-quoted value ({\Deleted}) where exact input stores the plain string - value shape depends on how the user typed it}\ |
||||
-setup $common -body { |
||||
#the prefix-normalization writeback (lset into the stored value) list-quotes |
||||
#values needing quoting (backslashes, spaces). Exact input bypasses the |
||||
#writeback and stays a plain string. Pinned as characterization pending a fix. |
||||
set exact [dict get [dict get [punk::args::parse [list "\\Deleted"] withid ::testspace::cgimap] values] flagname] |
||||
set viapfx [dict get [dict get [punk::args::parse [list "\\De"] withid ::testspace::cgimap] values] flagname] |
||||
lappend result [expr {$exact eq "\\Deleted"}] |
||||
#current (GAP) behaviour: the prefix path yields a one-element list |
||||
lappend result [expr {$viapfx ne "\\Deleted"}] |
||||
lappend result [expr {[lindex $viapfx 0] eq "\\Deleted"}] |
||||
}\ |
||||
-cleanup { |
||||
}\ |
||||
-result [list 1 1 1] |
||||
|
||||
test choicegroups_special_values_survive_tstr_block {backslash/dollar choice values are untouched when the definition block also contains ${...} tstr content}\ |
||||
-setup $common -body { |
||||
variable CGEXTRA "tstr-extra" |
||||
punk::args::define { |
||||
@id -id ::testspace::cgimaptstr |
||||
@cmd -name testspace::cgimaptstr -summary\ |
||||
"Imap-tstr fixture ${$CGEXTRA}."\ |
||||
-help\ |
||||
"cmd help." |
||||
@values -min 1 -max 1 |
||||
flagname -choicegroups { |
||||
SystemFlags {{\Deleted} {\Flagged}} |
||||
Keywords {{$MDNSent}} |
||||
} -help\ |
||||
"flagname help." |
||||
} |
||||
set argd [punk::args::parse [list "\\Flagged"] withid ::testspace::cgimaptstr] |
||||
lappend result [expr {[dict get [dict get $argd values] flagname] eq "\\Flagged"}] |
||||
set argd [punk::args::parse [list "\$MDNSent"] withid ::testspace::cgimaptstr] |
||||
lappend result [expr {[dict get [dict get $argd values] flagname] eq "\$MDNSent"}] |
||||
#and the tstr content itself expanded |
||||
lappend result [string match "*tstr-extra*" [cg_render ::testspace::cgimaptstr]] |
||||
}\ |
||||
-cleanup { |
||||
punk::args::undefine ::testspace::cgimaptstr 1 |
||||
}\ |
||||
-result [list 1 1 1] |
||||
} |
||||
tcltest::cleanupTests ;#needed to produce test summary line. |
||||
@ -0,0 +1,127 @@
|
||||
package require tcltest |
||||
|
||||
package require punk::args |
||||
package require punk::ansi |
||||
|
||||
#Quoting/escaping characterization for punk::args definition blocks - added 2026-07-09. |
||||
#Definition records pass through record parsing and (when ${ is present) tstr - these |
||||
#tests pin what survives in each container type so documenters know the rules: |
||||
# |
||||
# braced {...} values : fully literal - $, [], backslash sequences (\n stays two chars, |
||||
# \Deleted keeps its backslash). Only ${...} tstr placeholders |
||||
# (when present anywhere in the block) and the \$\{ escape are |
||||
# special. |
||||
# quoted "..." values : Tcl backslash semantics apply at record parse - \n becomes a |
||||
# real newline, \\ collapses to \ - while $ and [] remain literal |
||||
# (no variable/command substitution on record content outside |
||||
# tstr placeholders). |
||||
|
||||
namespace eval ::testspace { |
||||
namespace import ::tcltest::* |
||||
variable common { |
||||
set result "" |
||||
} |
||||
|
||||
proc dq_render {id} { |
||||
return [punk::ansi::ansistrip [punk::args::arg_error "" [punk::args::get_spec $id] -aserror 0]] |
||||
} |
||||
proc dq_linewith {rendered marker} { |
||||
foreach ln [split $rendered \n] { |
||||
if {[string first $marker $ln] >= 0} { |
||||
return $ln |
||||
} |
||||
} |
||||
return "" |
||||
} |
||||
|
||||
test defquoting_braced_help_literal {braced -help values are literal: $, [], backslash-n (two chars) and bare backslashes all survive}\ |
||||
-setup $common -body { |
||||
punk::args::define { |
||||
@id -id ::testspace::dqbraced |
||||
@cmd -name testspace::dqbraced -summary\ |
||||
"Braced quoting fixture."\ |
||||
-help\ |
||||
"cmd help." |
||||
@values -min 1 -max 1 |
||||
v1 -type string -help\ |
||||
{BDOLLAR literal $notavar stays. |
||||
BBRACKET literal [lindex x 0] stays. |
||||
BBACKSLASHN one\ntwo stays two chars. |
||||
BSINGLE bare \Deleted keeps backslash.} |
||||
} |
||||
set r [dq_render ::testspace::dqbraced] |
||||
lappend result [expr {[string first {$notavar} $r] >= 0}] |
||||
lappend result [expr {[string first {[lindex x 0]} $r] >= 0}] |
||||
#backslash-n stays literal two characters (one\ntwo on ONE line) |
||||
lappend result [expr {[string first {one\ntwo} [dq_linewith $r BBACKSLASHN]] >= 0}] |
||||
lappend result [expr {[string first "\\Deleted" $r] >= 0}] |
||||
}\ |
||||
-cleanup { |
||||
punk::args::undefine ::testspace::dqbraced 1 |
||||
}\ |
||||
-result [list 1 1 1 1] |
||||
|
||||
test defquoting_quoted_help_backslash_semantics {quoted -help values get Tcl backslash processing (\n -> newline, \\ -> \) while $ and [] stay literal}\ |
||||
-setup $common -body { |
||||
punk::args::define { |
||||
@id -id ::testspace::dqquoted |
||||
@cmd -name testspace::dqquoted -summary\ |
||||
"Quoted quoting fixture."\ |
||||
-help\ |
||||
"cmd help." |
||||
@values -min 1 -max 1 |
||||
v1 -type string -help\ |
||||
"QDOLLAR literal $notavar stays. |
||||
QBRACKET literal [lindex x 0] stays. |
||||
QSPLIT one\ntwo becomes a real newline. |
||||
QDOUBLEBS double \\Deleted collapses to one backslash." |
||||
} |
||||
set r [dq_render ::testspace::dqquoted] |
||||
lappend result [expr {[string first {$notavar} $r] >= 0}] |
||||
lappend result [expr {[string first {[lindex x 0]} $r] >= 0}] |
||||
#the \n split: 'one' ends its line - 'two becomes' is on a different line |
||||
set splitline [dq_linewith $r QSPLIT] |
||||
lappend result [expr {[string first "two becomes" $splitline] < 0}] |
||||
lappend result [expr {[string first "two becomes" $r] >= 0}] |
||||
#escaped backslash collapses to a single one |
||||
lappend result [expr {[string first "\\Deleted" $r] >= 0}] |
||||
lappend result [expr {[string first "\\\\Deleted" $r] < 0}] |
||||
}\ |
||||
-cleanup { |
||||
punk::args::undefine ::testspace::dqquoted 1 |
||||
}\ |
||||
-result [list 1 1 1 1 1 1] |
||||
|
||||
test defquoting_tstr_placeholder_escape {in a tstr-processed block (contains ${...}), the \$\{...\} escape renders a literal ${...}}\ |
||||
-setup $common -body { |
||||
variable DQX "expanded-value" |
||||
punk::args::define { |
||||
@id -id ::testspace::dqescape |
||||
@cmd -name testspace::dqescape -summary\ |
||||
"Tstr escape fixture."\ |
||||
-help\ |
||||
"TSUB gives ${$DQX} here. |
||||
TLIT shows \$\{$DQX\} literally." |
||||
@values -min 0 -max 0 |
||||
} |
||||
set r [dq_render ::testspace::dqescape] |
||||
#the unescaped placeholder substituted |
||||
lappend result [expr {[string first "TSUB gives expanded-value" $r] >= 0}] |
||||
#the escaped form renders as a literal ${...} (documentation-of-tstr idiom, |
||||
#as used in punk::args' own define doc) |
||||
lappend result [expr {[string first "TLIT shows \$\{\$DQX\}" $r] >= 0 || [string first {TLIT shows ${$DQX}} $r] >= 0}] |
||||
#record which literal form rendered (characterization) |
||||
if {[string first {TLIT shows ${$DQX}} $r] >= 0} { |
||||
lappend result rendered-as-dollarbrace |
||||
} elseif {[string first "TLIT shows" $r] >= 0} { |
||||
lappend result [dq_linewith $r TLIT] |
||||
} else { |
||||
lappend result tlit-line-missing |
||||
} |
||||
}\ |
||||
-cleanup { |
||||
punk::args::undefine ::testspace::dqescape 1 |
||||
}\ |
||||
-result [list 1 1 rendered-as-dollarbrace] |
||||
} |
||||
tcltest::cleanupTests ;#needed to produce test summary line. |
||||
@ -0,0 +1,152 @@
|
||||
package require tcltest |
||||
|
||||
package require punk::args |
||||
package require punk::ansi |
||||
|
||||
#punk::args::helpers::example / @examples directive / punk::args::eg coverage - added |
||||
#2026-07-09. The example helper is heavily used by punk::args::moduledoc::tclcore (e.g. |
||||
#::lseq uses it both inside @cmd -help and in the @examples directive shown via 'eg'). |
||||
#See also punk::args::helpers::strip_nodisplay_lines whose own doc describes the |
||||
##<nodisplay> / @#<nodisplay> line conventions these tests exercise. |
||||
|
||||
namespace eval ::testspace { |
||||
namespace import ::tcltest::* |
||||
variable common { |
||||
set result "" |
||||
} |
||||
|
||||
proc eg_render {id} { |
||||
return [punk::ansi::ansistrip [punk::args::arg_error "" [punk::args::get_spec $id] -aserror 0]] |
||||
} |
||||
proc eg_markercol {rendered marker} { |
||||
foreach ln [split $rendered \n] { |
||||
set ix [string first $marker $ln] |
||||
if {$ix >= 0} { |
||||
return $ix |
||||
} |
||||
} |
||||
return -1 |
||||
} |
||||
|
||||
test example_box_structure {helpers::example wraps text in a bar-bounded box; text is used as-is (no dedent - callers/definition blocks are expected to have dedented already)}\ |
||||
-setup $common -body { |
||||
#direct calls receive the text VERBATIM (the helper documents that it performs |
||||
#no further dedenting - in define blocks the block normalization handles it, |
||||
#so authors there write examples with a 2-space relative indent) |
||||
set ex [punk::ansi::ansistrip [punk::args::helpers::example " set x 1\n puts \"hello\""]] |
||||
set lines [split $ex \n] |
||||
#top and bottom bars are unicode block characters (visible even ANSI-stripped) |
||||
lappend result [string match "▀*" [string trim [lindex $lines 0]]] |
||||
lappend result [string match "▄*" [string trim [lindex $lines end]]] |
||||
#content preserved with the author's 2-space indent intact |
||||
lappend result [expr {[eg_markercol $ex {set x 1}] == 2}] |
||||
lappend result [expr {[eg_markercol $ex {puts "hello"}] == 2}] |
||||
}\ |
||||
-cleanup { |
||||
}\ |
||||
-result [list 1 1 1 1] |
||||
|
||||
test example_title_and_tstr_options {-title appears in the top bar; -tstr 1 (default) substitutes ${[...]}; -tstr 0 leaves it literal}\ |
||||
-setup $common -body { |
||||
set ex [punk::ansi::ansistrip [punk::args::helpers::example -title "EXTITLE" { |
||||
content line |
||||
}]] |
||||
lappend result [string match "*EXTITLE*" [lindex [split $ex \n] 0]] |
||||
#default -tstr 1: placeholder substituted |
||||
set ex2 [punk::ansi::ansistrip [punk::args::helpers::example { |
||||
value is ${[string repeat X 3]} |
||||
}]] |
||||
lappend result [expr {[string first "value is XXX" $ex2] >= 0}] |
||||
#-tstr 0: placeholder left literal |
||||
set ex3 [punk::ansi::ansistrip [punk::args::helpers::example -tstr 0 -syntax none { |
||||
value is ${[string repeat X 3]} |
||||
}]] |
||||
lappend result [expr {[string first "value is \$\{\[string repeat X 3\]\}" $ex3] >= 0}] |
||||
}\ |
||||
-cleanup { |
||||
}\ |
||||
-result [list 1 1 1] |
||||
|
||||
test example_inserted_in_cmd_help {an ${[helpers::example {...}]} block inside @cmd -help renders its box aligned at the insertion column}\ |
||||
-setup $common -body { |
||||
punk::args::define { |
||||
@id -id ::testspace::egincmd |
||||
@cmd -name testspace::egincmd -summary\ |
||||
"Example-in-help fixture."\ |
||||
-help\ |
||||
"XFIRST help line. |
||||
${[punk::args::helpers::example { |
||||
set demo 1 |
||||
puts XBODY |
||||
}]} |
||||
XLAST help line." |
||||
@values -min 0 -max 0 |
||||
} |
||||
set r [eg_render ::testspace::egincmd] |
||||
set x0 [eg_markercol $r XFIRST] |
||||
#the box bars align at the insertion column; content sits 2 inside |
||||
lappend result [expr {[eg_markercol $r ▀] - $x0}] |
||||
lappend result [expr {[eg_markercol $r {set demo 1}] - $x0}] |
||||
lappend result [expr {[eg_markercol $r XBODY] - [eg_markercol $r {set demo 1}]}] |
||||
lappend result [expr {[eg_markercol $r XLAST] - $x0}] |
||||
}\ |
||||
-cleanup { |
||||
punk::args::undefine ::testspace::egincmd 1 |
||||
}\ |
||||
-result [list 0 2 5 0] |
||||
|
||||
test atexamples_eg_and_usage_row {@examples -help is returned by punk::args::eg with #<nodisplay>/@#<nodisplay> lines stripped, and the usage table gains an Example row}\ |
||||
-setup $common -body { |
||||
punk::args::define { |
||||
@id -id ::testspace::egdirective |
||||
@cmd -name testspace::egdirective -summary\ |
||||
"Examples directive fixture."\ |
||||
-help\ |
||||
"cmd help." |
||||
@values -min 0 -max 0 |
||||
@examples -help\ |
||||
"EGLINE1 first example line |
||||
#<nodisplay> hidden balancing line |
||||
@#<nodisplay> also hidden |
||||
EGLINE2 second example line" |
||||
} |
||||
set eg [punk::args::eg ::testspace::egdirective] |
||||
lappend result [string match "*EGLINE1*" $eg] |
||||
lappend result [string match "*EGLINE2*" $eg] |
||||
lappend result [string match "*hidden*" $eg] |
||||
#the usage table advertises the examples |
||||
set r [eg_render ::testspace::egdirective] |
||||
lappend result [string match "*Example:*" $r] |
||||
lappend result [string match "*eg ::testspace::egdirective*" $r] |
||||
}\ |
||||
-cleanup { |
||||
punk::args::undefine ::testspace::egdirective 1 |
||||
}\ |
||||
-result [list 1 1 0 1 1] |
||||
|
||||
test strip_nodisplay_lines_unit {strip_nodisplay_lines removes #<nodisplay> and @#<nodisplay> lines (ANSI and leading whitespace tolerated) and keeps the rest}\ |
||||
-setup $common -body { |
||||
set intext "keep1\n #<nodisplay> gone\n@#<nodisplay> also gone\n\x1b\[31m #<nodisplay> ansi-prefixed gone\x1b\[m\nkeep2" |
||||
set out [punk::args::helpers::strip_nodisplay_lines $intext] |
||||
lappend result [string map [list \n |] $out] |
||||
}\ |
||||
-cleanup { |
||||
}\ |
||||
-result [list "keep1|keep2"] |
||||
|
||||
test tclcore_lseq_examples_live {the tclcore moduledoc's ::lseq definition (a heavy example consumer) resolves, renders, and serves 'eg' content}\ |
||||
-setup $common -body { |
||||
package require punk::args::moduledoc::tclcore |
||||
set spec [punk::args::get_spec ::lseq] |
||||
lappend result [dict exists $spec examples_info -help] |
||||
#eg output substantial (the helper-formatted example blocks) |
||||
lappend result [expr {[string length [punk::args::eg ::lseq]] > 100}] |
||||
#the usage render (which processes the @cmd -help example blocks) succeeds |
||||
set r [eg_render ::lseq] |
||||
lappend result [expr {[string length $r] > 500}] |
||||
}\ |
||||
-cleanup { |
||||
}\ |
||||
-result [list 1 1 1] |
||||
} |
||||
tcltest::cleanupTests ;#needed to produce test summary line. |
||||
@ -0,0 +1,612 @@
|
||||
package require tcltest |
||||
|
||||
package require punk::args |
||||
package require punk::ansi |
||||
|
||||
#Rendering/indentation characterization for punk::args usage output - added 2026-07-09 |
||||
#before any changes to the definition-block parsing / indentation machinery (per user |
||||
#direction). These tests encode the load-bearing properties as RELATIVE-position |
||||
#assertions on unique marker strings, so they don't depend on table geometry and don't |
||||
#require eyeballing snapshots: |
||||
# |
||||
# P1 nesting independence: a definition renders identically regardless of the source |
||||
# code indentation of the block it is written in (with and without ${...} tstr |
||||
# content) |
||||
# P2 relative-indent preservation: the documenter's continuation-line indentation |
||||
# conventions (e.g. lines 2+ indented by 2) survive to display, measured relative |
||||
# to the first line - punk::args preserves but does not enforce them |
||||
# P3 -unindentedfields: left-margin authoring works for argument -help (and is |
||||
# currently accepted but IGNORED for @cmd -help - pinned as a GAP) |
||||
# P4 constructed (string-built) definitions receive no whole-block indent |
||||
# normalization ('constructed' - not to be confused with the @dynamic directive): |
||||
# embedded continuation indentation is interpreted via the display-time |
||||
# undent(prefix4,max4) transform, so continuations written at exactly 4 spaces |
||||
# align flush with the first line, and any other depth misaligns (pinned as |
||||
# characterization - this is why ::punk::helptopic::define_docs pre-normalizes) |
||||
# P5 tstr ${...} substitutions with MULTILINE results (command or variable) insert |
||||
# aligned at the insertion column with the inserted text's own relative indents |
||||
# preserved (the -paramindents machinery) - including whole-definition insertion |
||||
# via punk::args::resolved_def |
||||
# P6 @dynamic definitions (the ${$DYN_SOMENAME} double-substitution idiom: an |
||||
# UPPERCASE-by-convention variable whose value is itself a tstr placeholder, |
||||
# re-evaluated at parse/help time): rendering is stable across repeated |
||||
# resolutions, refreshes when the underlying provider changes, and the |
||||
# textblock::frame art-choicelabel pattern renders byte-aligned - but multiline |
||||
# results inserted into -help lose the insertion-column alignment for lines 2+ |
||||
# (pinned as a GAP: the second-round subst path lacks the paramindent |
||||
# re-alignment that single-level ${[cmd]} insertion gets in P5) |
||||
# |
||||
#Renderers covered: the default table renderer (punk::args::arg_error) and the |
||||
#-return string renderer. |
||||
|
||||
namespace eval ::testspace { |
||||
namespace import ::tcltest::* |
||||
variable common { |
||||
set result "" |
||||
} |
||||
|
||||
proc render_table {id} { |
||||
return [punk::ansi::ansistrip [punk::args::arg_error "" [punk::args::get_spec $id] -aserror 0]] |
||||
} |
||||
proc render_string {id} { |
||||
return [punk::ansi::ansistrip [punk::args::arg_error "" [punk::args::get_spec $id] -aserror 0 -return string]] |
||||
} |
||||
#column (0-based) at which a unique marker string appears in the rendered text, -1 if absent |
||||
proc markercol {rendered marker} { |
||||
foreach ln [split $rendered \n] { |
||||
set ix [string first $marker $ln] |
||||
if {$ix >= 0} { |
||||
return $ix |
||||
} |
||||
} |
||||
return -1 |
||||
} |
||||
|
||||
#--- P1 nesting independence -------------------------------------------------------- |
||||
|
||||
test rendering_nesting_independence_plain {a plain definition renders identically at different source-block indentations}\ |
||||
-setup $common -body { |
||||
punk::args::define { |
||||
@id -id ::testspace::rnest |
||||
@cmd -name testspace::rnest -summary\ |
||||
"Nest fixture."\ |
||||
-help\ |
||||
"NFIRST line. |
||||
NFLUSH line. |
||||
NPLUS2 line." |
||||
@values -min 1 -max 1 |
||||
v1 -type string -help\ |
||||
"NAFIRST line. |
||||
NAPLUS2 line." |
||||
} |
||||
set r_shallow [render_table ::testspace::rnest] |
||||
punk::args::undefine ::testspace::rnest 1 |
||||
namespace eval nestlevel1 { |
||||
namespace eval nestlevel2 { |
||||
namespace eval nestlevel3 { |
||||
punk::args::define { |
||||
@id -id ::testspace::rnest |
||||
@cmd -name testspace::rnest -summary\ |
||||
"Nest fixture."\ |
||||
-help\ |
||||
"NFIRST line. |
||||
NFLUSH line. |
||||
NPLUS2 line." |
||||
@values -min 1 -max 1 |
||||
v1 -type string -help\ |
||||
"NAFIRST line. |
||||
NAPLUS2 line." |
||||
} |
||||
} |
||||
} |
||||
} |
||||
set r_deep [render_table ::testspace::rnest] |
||||
lappend result [expr {$r_shallow eq $r_deep}] |
||||
#and the deep rendering is properly aligned in its own right |
||||
lappend result [expr {[markercol $r_deep NFIRST] == [markercol $r_deep NFLUSH]}] |
||||
}\ |
||||
-cleanup { |
||||
punk::args::undefine ::testspace::rnest 1 |
||||
}\ |
||||
-result [list 1 1] |
||||
|
||||
test rendering_nesting_independence_tstr {a definition containing ${...} tstr content renders identically at different source-block indentations}\ |
||||
-setup $common -body { |
||||
variable RSUM "Tstr nest fixture." |
||||
punk::args::define { |
||||
@id -id ::testspace::rtnest |
||||
@cmd -name testspace::rtnest -summary\ |
||||
"${$RSUM}"\ |
||||
-help\ |
||||
"TFIRST line. |
||||
TFLUSH line. |
||||
TPLUS2 line." |
||||
@values -min 1 -max 1 |
||||
v1 -type string -help\ |
||||
"TAFIRST line. |
||||
TAPLUS2 line." |
||||
} |
||||
set r_shallow [render_table ::testspace::rtnest] |
||||
punk::args::undefine ::testspace::rtnest 1 |
||||
namespace eval nestlevel1 { |
||||
namespace eval nestlevel2 { |
||||
namespace eval nestlevel3 { |
||||
variable RSUM "Tstr nest fixture." |
||||
punk::args::define { |
||||
@id -id ::testspace::rtnest |
||||
@cmd -name testspace::rtnest -summary\ |
||||
"${$RSUM}"\ |
||||
-help\ |
||||
"TFIRST line. |
||||
TFLUSH line. |
||||
TPLUS2 line." |
||||
@values -min 1 -max 1 |
||||
v1 -type string -help\ |
||||
"TAFIRST line. |
||||
TAPLUS2 line." |
||||
} |
||||
} |
||||
} |
||||
} |
||||
set r_deep [render_table ::testspace::rtnest] |
||||
lappend result [expr {$r_shallow eq $r_deep}] |
||||
#tstr summary expanded (not left as a placeholder) |
||||
lappend result [string match "*Tstr nest fixture.*" $r_deep] |
||||
}\ |
||||
-cleanup { |
||||
punk::args::undefine ::testspace::rtnest 1 |
||||
}\ |
||||
-result [list 1 1] |
||||
|
||||
#--- P2 relative-indent preservation (canonical file-style authoring) ---------------- |
||||
|
||||
test rendering_table_alignment_canonical {table renderer: cmd-help and arg-help continuations align with their first line; the +2 convention is preserved}\ |
||||
-setup $common -body { |
||||
punk::args::define { |
||||
@id -id ::testspace::ralign |
||||
@cmd -name testspace::ralign -summary\ |
||||
"Align fixture."\ |
||||
-help\ |
||||
"CFIRST line. |
||||
CFLUSH line. |
||||
CPLUS2 line." |
||||
@values -min 1 -max 1 |
||||
v1 -type string -help\ |
||||
"AFIRST line. |
||||
AFLUSH line. |
||||
APLUS2 line." |
||||
} |
||||
set r [render_table ::testspace::ralign] |
||||
#cmd help: flush continuation same column as first line, +2 line two right |
||||
set c0 [markercol $r CFIRST] |
||||
lappend result [expr {[markercol $r CFLUSH] - $c0}] |
||||
lappend result [expr {[markercol $r CPLUS2] - $c0}] |
||||
#arg help: same properties in the Help column |
||||
set a0 [markercol $r AFIRST] |
||||
lappend result [expr {[markercol $r AFLUSH] - $a0}] |
||||
lappend result [expr {[markercol $r APLUS2] - $a0}] |
||||
}\ |
||||
-cleanup { |
||||
punk::args::undefine ::testspace::ralign 1 |
||||
}\ |
||||
-result [list 0 2 0 2] |
||||
|
||||
test rendering_string_renderer_characterization {string renderer: arg-help aligned with +2 preserved; cmd-help first line joins the Description label while continuations sit flush-left (first-vs-rest offset is a known wart)}\ |
||||
-setup $common -body { |
||||
punk::args::define { |
||||
@id -id ::testspace::rstring |
||||
@cmd -name testspace::rstring -summary\ |
||||
"String renderer fixture."\ |
||||
-help\ |
||||
"SFIRST line. |
||||
SFLUSH line. |
||||
SPLUS2 line." |
||||
@values -min 1 -max 1 |
||||
v1 -type string -help\ |
||||
"SAFIRST line. |
||||
SAPLUS2 line." |
||||
} |
||||
set r [render_string ::testspace::rstring] |
||||
#arg help: relative +2 preserved, first line and continuation share a base |
||||
set a0 [markercol $r SAFIRST] |
||||
lappend result [expr {[markercol $r SAPLUS2] - $a0}] |
||||
#cmd help: first line rendered on the Description: line ... |
||||
set descline "" |
||||
foreach ln [split $r \n] { |
||||
if {[string match "Description:*" $ln]} {set descline $ln} |
||||
} |
||||
lappend result [string match "Description:*SFIRST*" $descline] |
||||
#... while continuations are flush-left with relative indent preserved |
||||
#(characterization: the string renderer does not re-indent cmd-help |
||||
# continuations under the label - first-vs-rest misalignment by design/wart) |
||||
lappend result [markercol $r SFLUSH] |
||||
lappend result [expr {[markercol $r SPLUS2] - [markercol $r SFLUSH]}] |
||||
}\ |
||||
-cleanup { |
||||
punk::args::undefine ::testspace::rstring 1 |
||||
}\ |
||||
-result [list 2 1 0 2] |
||||
|
||||
#--- P3 -unindentedfields ------------------------------------------------------------ |
||||
|
||||
test rendering_unindentedfields_arg_help {argument -help with -unindentedfields: left-margin authoring renders aligned with +2 preserved}\ |
||||
-setup $common -body { |
||||
punk::args::define { |
||||
@id -id ::testspace::runind |
||||
@cmd -name testspace::runind -summary\ |
||||
"Unindented fixture."\ |
||||
-help\ |
||||
"cmd help." |
||||
@values -min 1 -max 1 |
||||
v1 -unindentedfields {-help} -help\ |
||||
"UFIRST line |
||||
UPLUS2 line" |
||||
} |
||||
set r [render_table ::testspace::runind] |
||||
set u0 [markercol $r UFIRST] |
||||
lappend result [expr {[markercol $r UPLUS2] - $u0}] |
||||
}\ |
||||
-cleanup { |
||||
punk::args::undefine ::testspace::runind 1 |
||||
}\ |
||||
-result [list 2] |
||||
|
||||
test rendering_unindentedfields_cmd_help_GAP {GAP: @cmd accepts -unindentedfields but ignores it - left-margin authored cmd-help misaligns (first line +4 vs continuations)}\ |
||||
-setup $common -body { |
||||
#the display transform undent(" "+help, max 4) still applies: with |
||||
#continuations at the left margin the common prefix is 0, nothing is |
||||
#removed, and the first line keeps its injected 4-space prefix. |
||||
#(see punk::args arg_error cmd_info handling: '#unindentedfields ?' todo) |
||||
punk::args::define { |
||||
@id -id ::testspace::rcmdunind |
||||
@cmd -name testspace::rcmdunind -summary\ |
||||
"Cmd-unindented fixture."\ |
||||
-unindentedfields {-help}\ |
||||
-help\ |
||||
"GFIRST line |
||||
GFLUSH line" |
||||
@values -min 0 -max 0 |
||||
} |
||||
set r [render_table ::testspace::rcmdunind] |
||||
#pinned CURRENT behaviour: first line renders 4 right of its continuation |
||||
lappend result [expr {[markercol $r GFIRST] - [markercol $r GFLUSH]}] |
||||
}\ |
||||
-cleanup { |
||||
punk::args::undefine ::testspace::rcmdunind 1 |
||||
}\ |
||||
-result [list 4] |
||||
|
||||
#--- P4 constructed (string-built) definitions ----------------------------------------- |
||||
|
||||
test rendering_constructed_def_indent_characterization {constructed (string-built) definitions: continuation indentation is absolute - exactly 4 spaces aligns flush; other depths shift (why constructed-def builders must pre-normalize)}\ |
||||
-setup $common -body { |
||||
#continuations at exactly 4 -> aligned flush with first line (the current |
||||
#correct authoring convention for constructed definitions) |
||||
set mydef "" |
||||
append mydef "@id -id ::testspace::rdyn4" \n |
||||
append mydef "@cmd -name testspace::rdyn4 -summary \"Dyn4.\" -help \"DFIRST line\n DFLUSH line\n DPLUS2 line\"" \n |
||||
append mydef "@values -min 0 -max 0" |
||||
punk::args::define $mydef |
||||
set r [render_table ::testspace::rdyn4] |
||||
set d0 [markercol $r DFIRST] |
||||
lappend result [expr {[markercol $r DFLUSH] - $d0}] |
||||
lappend result [expr {[markercol $r DPLUS2] - $d0}] |
||||
|
||||
#continuations at other depths leak: 8-space source renders +4 right of the |
||||
#first line (GAP-ish characterization: no whole-block normalization for |
||||
#constructed defs - contrast with the nesting independence of file-style defs) |
||||
set mydef "" |
||||
append mydef "@id -id ::testspace::rdyn8" \n |
||||
append mydef "@cmd -name testspace::rdyn8 -summary \"Dyn8.\" -help \"EFIRST line\n EDEEP line\"" \n |
||||
append mydef "@values -min 0 -max 0" |
||||
punk::args::define $mydef |
||||
set r [render_table ::testspace::rdyn8] |
||||
lappend result [expr {[markercol $r EDEEP] - [markercol $r EFIRST]}] |
||||
}\ |
||||
-cleanup { |
||||
punk::args::undefine ::testspace::rdyn4 1 |
||||
punk::args::undefine ::testspace::rdyn8 1 |
||||
}\ |
||||
-result [list 0 2 4] |
||||
|
||||
#--- choicelabels conventions ---------------------------------------------------------- |
||||
|
||||
test rendering_choicelabel_one_space_convention {a single-line choicelabel's leading one-space indent (the 'i string is' convention) is preserved relative to its choice name}\ |
||||
-setup $common -body { |
||||
punk::args::define { |
||||
@id -id ::testspace::rlabels |
||||
@cmd -name testspace::rlabels -summary\ |
||||
"Labels fixture."\ |
||||
-help\ |
||||
"cmd help." |
||||
@values -min 1 -max 1 |
||||
mode -choices {LCALPHA LCBETA} -choicelabels { |
||||
LCALPHA " LALABEL text" |
||||
LCBETA " LBLABEL text" |
||||
} -help\ |
||||
"arg help." |
||||
} |
||||
set r [render_table ::testspace::rlabels] |
||||
#the label renders one column right of its choice name |
||||
lappend result [expr {[markercol $r LALABEL] - [markercol $r LCALPHA]}] |
||||
lappend result [expr {[markercol $r LBLABEL] - [markercol $r LCBETA]}] |
||||
}\ |
||||
-cleanup { |
||||
punk::args::undefine ::testspace::rlabels 1 |
||||
}\ |
||||
-result [list 1 1] |
||||
|
||||
test rendering_choicelabel_multiline {multiline choicelabels: the documenter's relative indentation is preserved (tclcore 'string is' geometry gives equal columns; a deeper-authored continuation stays deeper by the authored offset)}\ |
||||
-setup $common -body { |
||||
#MLEQUAL: authored like tclcore's tcl::string::is labels - the quoted value's |
||||
#continuation line placed so it lands at the same +1 column as the first line |
||||
#(here: definition-block records at 16, first label line effectively at +1 |
||||
# after processing, continuation authored at 21 = block indent + 5) |
||||
#MLDEEP: continuation deliberately authored 4 deeper than that - the +4 |
||||
#relative offset must be preserved, not corrected. |
||||
punk::args::define { |
||||
@id -id ::testspace::rmlabels |
||||
@cmd -name testspace::rmlabels -summary\ |
||||
"Multiline labels fixture."\ |
||||
-help\ |
||||
"cmd help." |
||||
@values -min 1 -max 1 |
||||
mode -choices {MLEQUAL MLDEEP} -choicelabels { |
||||
MLEQUAL\ |
||||
" QLA_L1 label line |
||||
QLA_L2 label line" |
||||
MLDEEP\ |
||||
" DLA_L1 label line |
||||
DLA_L2 label line" |
||||
} -help\ |
||||
"arg help." |
||||
} |
||||
set r [render_table ::testspace::rmlabels] |
||||
set n0 [markercol $r MLEQUAL] |
||||
lappend result [expr {[markercol $r QLA_L1] - $n0}] |
||||
lappend result [expr {[markercol $r QLA_L2] - $n0}] |
||||
set n1 [markercol $r MLDEEP] |
||||
lappend result [expr {[markercol $r DLA_L1] - $n1}] |
||||
lappend result [expr {[markercol $r DLA_L2] - $n1}] |
||||
}\ |
||||
-cleanup { |
||||
punk::args::undefine ::testspace::rmlabels 1 |
||||
}\ |
||||
-result [list 1 1 1 5] |
||||
|
||||
#--- P5 multiline tstr ${...} substitutions -------------------------------------------- |
||||
|
||||
test rendering_tstr_multiline_command_insertion {a ${[command]} returning multiline text inserts aligned at the insertion column with internal relative indents preserved; nesting-independent}\ |
||||
-setup $common -body { |
||||
proc multitext {} { |
||||
return "INS_L1 inserted first\nINS_L2 inserted second\n INS_L3 inserted plus2" |
||||
} |
||||
punk::args::define { |
||||
@id -id ::testspace::rtins |
||||
@cmd -name testspace::rtins -summary\ |
||||
"Tstr insertion fixture."\ |
||||
-help\ |
||||
"HFIRST before insertion. |
||||
${[::testspace::multitext]} |
||||
HAFTER after insertion." |
||||
@values -min 0 -max 0 |
||||
} |
||||
set r [render_table ::testspace::rtins] |
||||
set h0 [markercol $r HFIRST] |
||||
lappend result [expr {[markercol $r INS_L1] - $h0}] |
||||
lappend result [expr {[markercol $r INS_L2] - $h0}] |
||||
lappend result [expr {[markercol $r INS_L3] - $h0}] |
||||
lappend result [expr {[markercol $r HAFTER] - $h0}] |
||||
#nesting independence with a multiline substitution present (same id redefined |
||||
#from a deeper source block - rendering must be identical) |
||||
punk::args::undefine ::testspace::rtins 1 |
||||
namespace eval nestlevel1 { |
||||
namespace eval nestlevel2 { |
||||
punk::args::define { |
||||
@id -id ::testspace::rtins |
||||
@cmd -name testspace::rtins -summary\ |
||||
"Tstr insertion fixture."\ |
||||
-help\ |
||||
"HFIRST before insertion. |
||||
${[::testspace::multitext]} |
||||
HAFTER after insertion." |
||||
@values -min 0 -max 0 |
||||
} |
||||
} |
||||
} |
||||
lappend result [expr {[render_table ::testspace::rtins] eq $r}] |
||||
}\ |
||||
-cleanup { |
||||
punk::args::undefine ::testspace::rtins 1 |
||||
rename ::testspace::multitext "" |
||||
}\ |
||||
-result [list 0 0 2 0 1] |
||||
|
||||
test rendering_tstr_multiline_var_insertion {a ${$var} with a multiline value inserts aligned at the insertion column}\ |
||||
-setup $common -body { |
||||
variable RMULTIVAR "VAR_L1 var first\nVAR_L2 var second" |
||||
punk::args::define { |
||||
@id -id ::testspace::rtvins |
||||
@cmd -name testspace::rtvins -summary\ |
||||
"Tstr var insertion fixture."\ |
||||
-help\ |
||||
"VFIRST before. |
||||
${$RMULTIVAR} |
||||
VAFTER after." |
||||
@values -min 0 -max 0 |
||||
} |
||||
set r [render_table ::testspace::rtvins] |
||||
set v0 [markercol $r VFIRST] |
||||
lappend result [expr {[markercol $r VAR_L1] - $v0}] |
||||
lappend result [expr {[markercol $r VAR_L2] - $v0}] |
||||
lappend result [expr {[markercol $r VAFTER] - $v0}] |
||||
}\ |
||||
-cleanup { |
||||
punk::args::undefine ::testspace::rtvins 1 |
||||
}\ |
||||
-result [list 0 0 0] |
||||
|
||||
test rendering_resolved_def_insertion {a ${[punk::args::resolved_def ...]} inserts working definition records: the inherited option renders with its help (+2 preserved) and parses}\ |
||||
-setup $common -body { |
||||
punk::args::define { |
||||
@id -id ::testspace::rdbase |
||||
@cmd -name testspace::rdbase -summary\ |
||||
"Base def."\ |
||||
-help\ |
||||
"base help." |
||||
@opts |
||||
-alpha -default 1 -type boolean -help\ |
||||
"RD_L1 alpha help. |
||||
RD_L2 alpha help plus2." |
||||
@values -min 0 -max 0 |
||||
} |
||||
punk::args::define { |
||||
@id -id ::testspace::rdconsumer |
||||
@cmd -name testspace::rdconsumer -summary\ |
||||
"Consumer def."\ |
||||
-help\ |
||||
"consumer help." |
||||
@opts |
||||
${[punk::args::resolved_def -types opts ::testspace::rdbase -alpha]} |
||||
@values -min 0 -max 0 |
||||
} |
||||
set r [render_table ::testspace::rdconsumer] |
||||
#inherited option present in synopsis and its help text carried over |
||||
lappend result [string match "*-alpha*" $r] |
||||
set l0 [markercol $r RD_L1] |
||||
lappend result [expr {$l0 >= 0}] |
||||
lappend result [expr {[markercol $r RD_L2] - $l0}] |
||||
#and the inherited option actually parses |
||||
set argd [punk::args::parse {-alpha 0} withid ::testspace::rdconsumer] |
||||
lappend result [dict get $argd opts] |
||||
}\ |
||||
-cleanup { |
||||
punk::args::undefine ::testspace::rdbase 1 |
||||
punk::args::undefine ::testspace::rdconsumer 1 |
||||
}\ |
||||
-result [list 1 1 2 {-alpha 0}] |
||||
|
||||
#--- P6 @dynamic double substitution (${$DYN_SOMENAME} idiom) --------------------------- |
||||
|
||||
test rendering_atdynamic_stability_and_refresh {an @dynamic definition renders identically on repeated resolution, and reflects provider changes in help text, choices display, and parsing}\ |
||||
-setup $common -body { |
||||
variable rdyn_counter 0 |
||||
proc rdyn_help {} { |
||||
variable rdyn_counter |
||||
return "DYNHELP call$rdyn_counter" |
||||
} |
||||
proc rdyn_choices {} { |
||||
variable rdyn_counter |
||||
if {$rdyn_counter == 0} { |
||||
return [list redx greenx] |
||||
} |
||||
return [list redx greenx bluex] |
||||
} |
||||
variable DYN_RHELP {${[::testspace::rdyn_help]}} |
||||
variable DYN_RCHOICES {${[::testspace::rdyn_choices]}} |
||||
punk::args::define { |
||||
@dynamic |
||||
@id -id ::testspace::rdynref |
||||
@cmd -name testspace::rdynref -summary\ |
||||
"Dyn refresh fixture."\ |
||||
-help\ |
||||
"${$DYN_RHELP}" |
||||
@values -min 1 -max 1 |
||||
mode -choices {${$DYN_RCHOICES}} -help\ |
||||
"mode help." |
||||
} |
||||
set r1 [render_table ::testspace::rdynref] |
||||
#repeated resolution is stable |
||||
lappend result [expr {[render_table ::testspace::rdynref] eq $r1}] |
||||
lappend result [string match "*call0*" $r1] |
||||
lappend result [string match "*bluex*" $r1] |
||||
#restricted choices honour the CURRENT provider output at parse time |
||||
if {[catch {punk::args::parse {bluex} withid ::testspace::rdynref}]} { |
||||
lappend result bluex-rejected-at-counter0 |
||||
} else { |
||||
lappend result bluex-UNEXPECTEDLY-accepted |
||||
} |
||||
#provider changes -> help text, choice display and parse acceptance refresh |
||||
set rdyn_counter 1 |
||||
set r2 [render_table ::testspace::rdynref] |
||||
lappend result [string match "*call1*" $r2] |
||||
lappend result [string match "*bluex*" $r2] |
||||
set argd [punk::args::parse {bluex} withid ::testspace::rdynref] |
||||
lappend result [dict get $argd values] |
||||
}\ |
||||
-cleanup { |
||||
punk::args::undefine ::testspace::rdynref 1 |
||||
rename ::testspace::rdyn_help "" |
||||
rename ::testspace::rdyn_choices "" |
||||
}\ |
||||
-result [list 1 1 0 bluex-rejected-at-counter0 1 1 {mode bluex}] |
||||
|
||||
test rendering_atdynamic_multiline_help_insertion_GAP {GAP: @dynamic double substitution of a MULTILINE result into -help loses insertion-column alignment for lines 2+ (they land 4 left; internal relative indents preserved)}\ |
||||
-setup $common -body { |
||||
#contrast with rendering_tstr_multiline_command_insertion where single-level |
||||
#${[cmd]} insertion aligns all lines at the insertion column. The @dynamic |
||||
#second-round substitution (plain subst of the cached parameters) has no |
||||
#paramindent re-alignment - a known fragility of the double-substitution |
||||
#path, pinned here pending a fix. |
||||
proc rdyn_multi {} { |
||||
return "YINS_L1 first\nYINS_L2 second\n YINS_L3 plus2" |
||||
} |
||||
variable DYN_RMULTI {${[::testspace::rdyn_multi]}} |
||||
punk::args::define { |
||||
@dynamic |
||||
@id -id ::testspace::rdynmulti |
||||
@cmd -name testspace::rdynmulti -summary\ |
||||
"Dyn multiline fixture."\ |
||||
-help\ |
||||
"YFIRST before insertion. |
||||
${$DYN_RMULTI} |
||||
YAFTER after insertion." |
||||
@values -min 0 -max 0 |
||||
} |
||||
set r [render_table ::testspace::rdynmulti] |
||||
set y0 [markercol $r YFIRST] |
||||
lappend result [expr {[markercol $r YINS_L1] - $y0}] |
||||
lappend result [expr {[markercol $r YINS_L2] - $y0}] |
||||
lappend result [expr {[markercol $r YINS_L3] - $y0}] |
||||
lappend result [expr {[markercol $r YAFTER] - $y0}] |
||||
}\ |
||||
-cleanup { |
||||
punk::args::undefine ::testspace::rdynmulti 1 |
||||
rename ::testspace::rdyn_multi "" |
||||
}\ |
||||
-result [list 0 -4 -2 0] |
||||
|
||||
test rendering_atdynamic_art_choicelabels {the textblock::frame pattern: @dynamic multiline art choicelabels via ${$DYN_...} with -unindentedfields render byte-aligned}\ |
||||
-setup $common -body { |
||||
proc rdyn_artlabels {} { |
||||
set art_a " ART_TOP+--+\n ART_MID|xx|\n ART_BOT+--+" |
||||
return [list arta $art_a artb " plain b label"] |
||||
} |
||||
variable DYN_RART {${[::testspace::rdyn_artlabels]}} |
||||
punk::args::define { |
||||
@dynamic |
||||
@id -id ::testspace::rdynart |
||||
@cmd -name testspace::rdynart -summary\ |
||||
"Dyn art labels fixture."\ |
||||
-help\ |
||||
"cmd help." |
||||
@values -min 1 -max 1 |
||||
ftype -choices {arta artb} -unindentedfields {-choicelabels} -choicelabels { |
||||
${$DYN_RART} |
||||
} -help\ |
||||
"ftype help." |
||||
} |
||||
set r [render_table ::testspace::rdynart] |
||||
#all art rows at the same column, one right of the choice name |
||||
set n0 [markercol $r arta] |
||||
lappend result [expr {[markercol $r ART_TOP] - $n0}] |
||||
lappend result [expr {[markercol $r ART_MID] - $n0}] |
||||
lappend result [expr {[markercol $r ART_BOT] - $n0}] |
||||
}\ |
||||
-cleanup { |
||||
punk::args::undefine ::testspace::rdynart 1 |
||||
rename ::testspace::rdyn_artlabels "" |
||||
}\ |
||||
-result [list 1 1 1] |
||||
} |
||||
tcltest::cleanupTests ;#needed to produce test summary line. |
||||
Loading…
Reference in new issue