@ -8,7 +8,7 @@
# (C) 2024
#
# @@ Meta Begin
# Application punk::args 0.15.1
# Application punk::args 0.17.0
# Meta platform tcl
# Meta license <unspecified>
# @@ Meta End
@ -18,7 +18,7 @@
# doctools header
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[manpage_begin punkshell_module_punk::args 0 0.15.1 ]
#[manpage_begin punkshell_module_punk::args 0 0.17.0 ]
#[copyright "2024"]
#[titledesc {args parsing}] [comment {-- Name section and table of contents description --}]
#[moddesc {args to nested dict of opts and values}] [comment {-- Description at end of page heading --}]
@ -798,6 +798,18 @@ tcl::namespace::eval punk::args {
directive-options: -name <str>
-summary <str>
-help <str>
-formhint <str>
The -formhint value replaces the built-in ' i -form N ...'
hint labels rendered beside a multi-form definition's
synopsis lines in usage/arg_error table output.
Occurrences of %formindex% and %formname% are replaced
per form with the form's 0-based ordinal and its name.
An empty string suppresses the hint labels entirely.
Intended for definitions whose users cannot act on the
repl-oriented default - e.g script-level (script) ids,
which are unreachable from any repl - so the hint can
name that consumer's own navigation instead. Callers of
usage/arg_error may override with their -formhint option.
%B%@leaders%N% ?opt val...?
(used for leading args that come before switches/opts)
directive-options:
@ -1104,6 +1116,31 @@ tcl::namespace::eval punk::args {
Each alias must map to an existing choice, and must not
itself collide with a choice (validated when the
definition is resolved).
-choiceunavailable {<names>}
Names that are recognised but not available in the
current runtime/context (e.g a choice a newer version
provides - the version-adaptive definition declares it
here on runtimes that lack it). Unavailable names are
displayed among the choices under a dedicated
'Unavailable' group heading with their ordinary
-choicelabels notes, and participate in prefix
calculation exactly like -choiceprefixreservelist
entries - so a prefix shared between an available and
an unavailable name is ambiguous, preparing users for
contexts where the name is real. A word landing on an
unavailable name (exactly, or as a unique prefix) is
rejected with a tailored 'choiceunavailable' error
naming the entry and its -choicelabels note, instead
of the generic listed-values error. Applies under
-choicerestricted 1 (the default); with
-choicerestricted 0 any word remains an acceptable
ordinary value. Requires -choices and/or -choicegroups;
entries must not collide with choices, alias names or
reservelist entries, and -default may not be an
unavailable name (validated when the definition is
resolved). Synopsis choice-literal display and
value-in-effect highlighting never include unavailable
entries.
-choicegroups {<dict>}
Generally this would be used instead of -choices to allow
usage display of choices grouped by some name (or the empty
@ -3362,6 +3399,20 @@ tcl::namespace::eval punk::args {
}
tcl::dict::set spec_merged $spec $specval
}
-choiceunavailable {
#list of recognised-but-unavailable choice names (goal G-073).
#Displayed among the choices (dedicated display group, with their ordinary
#-choicelabels notes), prefix-pool members like -choiceprefixreservelist -
#but a word landing on one (exact, or unique prefix) is rejected with a
#tailored 'choiceunavailable' error instead of the generic choice error.
#Applies under -choicerestricted 1 (the default) - with -choicerestricted 0
#any word is an acceptable ordinary value and no tailored rejection occurs.
#Cross-validation against the final choice set happens after all specs merge.
if {[catch {llength $specval}]} {
error "punk::args::resolve - invalid value for key '$spec' in specifications for argument '$argname' - value must be a list of recognised-but-unavailable choice names @id:$DEF_definition_id"
}
tcl::dict::set spec_merged $spec $specval
}
-unindentedfields -
-solo -
-choices - -choicegroups - -choicemultiple - -choicecolumns -
@ -3481,7 +3532,7 @@ tcl::namespace::eval punk::args {
-minsize -maxsize -choices -choicegroups
-mincap -maxcap
-choicemultiple -choicecolumns -choiceprefix -choiceprefixdenylist -choiceprefixreservelist -choicerestricted
-choicelabels -choiceinfo -choicealiases
-choicelabels -choiceinfo -choicealiases -choiceunavailable
-unindentedfields
-nocase -optional -multiple -validate_ansistripped -allow_ansi -strip_ansi -help
-multipleunique -choicemultipleunique -choicemultipleuniqueset
@ -3510,6 +3561,33 @@ tcl::namespace::eval punk::args {
}
}
#cross-validate -choiceunavailable against the final merged choice set (goal G-073)
if {[tcl::dict::exists $spec_merged -choiceunavailable] && [llength [tcl::dict::get $spec_merged -choiceunavailable]]} {
set cu_allchoices [punk::args::system::Dict_getdef $spec_merged -choices {}]
foreach {_cugroup cumembers} [punk::args::system::Dict_getdef $spec_merged -choicegroups {}] {
lappend cu_allchoices {*}$cumembers
}
if {![llength $cu_allchoices]} {
error "punk::args::resolve - -choiceunavailable for argument '$argname' requires -choices and/or -choicegroups to also be declared (an argument whose every choice is unavailable is not expressible with this key) @id:$DEF_definition_id"
}
set cu_aliasnames [tcl::dict::keys [punk::args::system::Dict_getdef $spec_merged -choicealiases {}]]
set cu_reservelist [punk::args::system::Dict_getdef $spec_merged -choiceprefixreservelist {}]
foreach cu_entry [tcl::dict::get $spec_merged -choiceunavailable] {
if {$cu_entry in $cu_allchoices} {
error "punk::args::resolve - -choiceunavailable for argument '$argname' entry '$cu_entry' collides with a defined choice in -choices/-choicegroups @id:$DEF_definition_id"
}
if {$cu_entry in $cu_aliasnames} {
error "punk::args::resolve - -choiceunavailable for argument '$argname' entry '$cu_entry' collides with a -choicealiases alias name (the alias exact-match would silently accept the unavailable name) @id:$DEF_definition_id"
}
if {$cu_entry in $cu_reservelist} {
error "punk::args::resolve - -choiceunavailable for argument '$argname' entry '$cu_entry' also appears in -choiceprefixreservelist (the reservelist landing would mask the unavailable indication) @id:$DEF_definition_id"
}
}
if {[tcl::dict::exists $spec_merged -default] && [tcl::dict::get $spec_merged -default] in [tcl::dict::get $spec_merged -choiceunavailable]} {
error "punk::args::resolve - -default for argument '$argname' is a -choiceunavailable entry (an unavailable name cannot be the value in effect) @id:$DEF_definition_id"
}
}
if {$is_opt} {
#tcl::dict::set FDICT ARG_CHECKS $argname {*}{
# } [tcl::dict::remove $spec_merged -form -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi -choicecolumns -group -typesynopsis -help -ARGTYPE] ;#leave things like -range -minsize
@ -5005,6 +5083,16 @@ tcl::namespace::eval punk::args {
-scheme -default error -choices {nocolour info error}
-form -default 0 -help\
"Ordinal index or name of command form"
-formhint -type string -help\
"Template for the per-form hint labels displayed beside each
form's synopsis line when the definition has multiple forms.
Occurrences of %formindex% and %formname% in the template are
replaced per form with the form's ordinal index (0-based) and
its name. An empty string suppresses the hint labels entirely.
When this option is not supplied, a definition may carry its
own template via '@cmd -formhint'; with neither present the
built-in repl-oriented default renders ' i -form N ...' labels
(one per form)."
}] ]
@ -5174,8 +5262,10 @@ tcl::namespace::eval punk::args {
set as_error 1 ;#usual case is to raise an error
set scheme error
set form 0
set formhint ""
set formhint_received 0 ;#distinguish supplied-empty (suppress) from not-supplied (definition/default applies)
dict for {k v} $args {
set fullk [tcl::prefix::match -error "" {-badarg -parsedargs -parsestatus -aserror -return -scheme -form} $k]
set fullk [tcl::prefix::match -error "" {-badarg -parsedargs -parsestatus -aserror -return -scheme -form -formhint } $k]
switch -- $fullk {
-badarg {
set badarg $v
@ -5206,9 +5296,13 @@ tcl::namespace::eval punk::args {
-form {
set form $v
}
-formhint {
set formhint $v
set formhint_received 1
}
default {
set arg_error_isrunning 0
error "arg_error invalid option $k. Known_options: -badarg -parsedargs -parsestatus -aserror -scheme -return -form"
error "arg_error invalid option $k. Known_options: -badarg -parsedargs -parsestatus -aserror -scheme -return -form -formhint "
}
}
}
@ -5480,10 +5574,22 @@ tcl::namespace::eval punk::args {
set form_names [dict get $spec_dict form_names]
set synhelp "Synopsis:"
if {[llength $form_names] > 1} {
set fn 0
foreach fname $form_names {
append synhelp \n " i -form $fn \U2026"
incr fn
#G-149: the per-form hint labels beside the synopsis lines are a
#template substituted per form (%formindex% 0-based ordinal,
#%formname% form name). Precedence: caller -formhint > definition
#@cmd -formhint > builtin repl-oriented default. An empty template
#suppresses the labels (the cell keeps just the Synopsis: label).
if {$formhint_received} {
set hint_template $formhint
} else {
set hint_template [Dict_getdef $spec_dict cmd_info -formhint " i -form %formindex% \U2026"]
}
if {$hint_template ne ""} {
set fn 0
foreach fname $form_names {
append synhelp \n [string map [list %formindex% $fn %formname% $fname] $hint_template]
incr fn
}
}
}
$t configure_header $h -colspans $arg_colspans -values [list $synhelp [punk::ansi::ansiwrap brightwhite $synopsis]]
@ -5816,6 +5922,18 @@ tcl::namespace::eval punk::args {
} else {
set choicegroups [dict merge [dict create "" $choices] $choicegroups]
}
#G-073: recognised-but-unavailable names render among the choices under a
#dedicated display group (the heading is the distinguishing mechanism),
#with their ordinary -choicelabels notes. Joining choicegroups here also
#puts them in allchoices_originalcase below and therefore the prefix-calc
#pool, so displayed shortest-prefix marking reflects their parse-time
#reserving effect. Display-side injection only: they are never in
#-choices/-choicegroups, so parse acceptance, synopsis choice-literals
#and value-in-effect marking cannot pick them up.
set choiceunavailable_display [Dict_getdef $arginfo -choiceunavailable {}]
if {[llength $choiceunavailable_display]} {
dict lappend choicegroups "Unavailable (recognised, not selectable here)" {*}$choiceunavailable_display
}
#review - does choiceprefixdenylist need to be added?
dict for {groupname clist} $choicegroups {
lappend allchoices_originalcase {*}$clist
@ -6412,7 +6530,7 @@ tcl::namespace::eval punk::args {
"
-return -default table -choices {string table tableobject}
}\
{${[punk::args::resolved_def -types opts -override {-scheme {-default info}} ::punk::args::arg_error -scheme]}}\
{${[punk::args::resolved_def -types opts -override {-scheme {-default info}} ::punk::args::arg_error -scheme -formhint ]}}\
{${[punk::args::resolved_def -types opts ::punk::args::resolved_def -form]}}\
{
@ -7201,6 +7319,7 @@ tcl::namespace::eval punk::args {
[Dict_getdef $ARG_INFO $argname -choiceprefix 1]\
[Dict_getdef $ARG_INFO $argname -choiceprefixdenylist {}]\
[Dict_getdef $ARG_INFO $argname -choiceprefixreservelist {}]\
[Dict_getdef $ARG_INFO $argname -choiceunavailable {}]\
]
if {[dict get $cwm matched]} {
set word_matched 1
@ -7435,6 +7554,7 @@ tcl::namespace::eval punk::args {
[Dict_getdef $ARG_INFO $argname -choiceprefix 1]\
[Dict_getdef $ARG_INFO $argname -choiceprefixdenylist {}]\
[Dict_getdef $ARG_INFO $argname -choiceprefixreservelist {}]\
[Dict_getdef $ARG_INFO $argname -choiceunavailable {}]\
]
return [expr {[dict get $cwm matched] ? "yes" : "no"}]
}
@ -7724,11 +7844,15 @@ tcl::namespace::eval punk::args {
status valid | invalid | incomplete
invalid - a supplied word failed validation
incomplete - required arguments missing (a count or
allocation shortfall). Note a supplied word
failing its -type check can also surface as
an allocation shortfall (missingrequiredvalue)
- badarg and the per-argument statuses carry
the specifics in both situations. For a
allocation shortfall). A supplied word
failing a required argument's basic -type
screen reports typemismatch (invalid) as of
0.15.2; a word leaving a multi-member
clause short, or failing a literal-typed
member, still surfaces as an allocation
shortfall (missingrequiredvalue) - badarg
and the per-argument statuses carry the
specifics in both situations. For a
single-form parse this is the engine failure
classification, NOT a viability verdict -
read formstatus for that. For a multiform
@ -8281,6 +8405,7 @@ tcl::namespace::eval punk::args {
set cw_aliases [Dict_getdef $ARG_INFO $thisname -choicealiases {}]
set cw_deny [Dict_getdef $ARG_INFO $thisname -choiceprefixdenylist {}]
set cw_reserve [Dict_getdef $ARG_INFO $thisname -choiceprefixreservelist {}]
set cw_unavail [Dict_getdef $ARG_INFO $thisname -choiceunavailable {}] ;#G-073
lassign [Dict_getdef $ARG_INFO $thisname -choicemultiple {1 1}] cw_cmmin cw_cmmax
}
}
@ -8300,12 +8425,14 @@ tcl::namespace::eval punk::args {
set member_satisfied 0
set member_choicechecked 0
set member_cwm {} ;#G-073: singular-screen matchinfo (consulted by the rejection builder)
if {$has_choices} {
if {$choicescreen_applies} {
#G-071 allocation screen (see block above the loop)
set member_choicechecked 1
if {$cw_cmmax == 1} {
set cwm [choiceword_match $v $cw_nocase $cw_allchoices $cw_aliases $cw_prefix $cw_deny $cw_reserve]
set cwm [choiceword_match $v $cw_nocase $cw_allchoices $cw_aliases $cw_prefix $cw_deny $cw_reserve $cw_unavail]
set member_cwm $cwm
set member_satisfied [tcl::dict::get $cwm matched]
} else {
#-choicemultiple: the word is itself a list of choices - screen
@ -8317,7 +8444,7 @@ tcl::namespace::eval punk::args {
} else {
set member_satisfied 1
foreach v_member $v {
set cwm [choiceword_match $v_member $cw_nocase $cw_allchoices $cw_aliases $cw_prefix $cw_deny $cw_reserve]
set cwm [choiceword_match $v_member $cw_nocase $cw_allchoices $cw_aliases $cw_prefix $cw_deny $cw_reserve $cw_unavail ]
if {![tcl::dict::get $cwm matched]} {
set member_satisfied 0
break
@ -8489,7 +8616,14 @@ tcl::namespace::eval punk::args {
#words like lseq's 'to' - overflow remains the clearer report).
if {[llength $thistype] == 1} {
if {$member_choicechecked} {
set rejection [tcl::dict::create kind choice argname $thisname word $v choices $cw_allchoices nocase $cw_nocase prefix $cw_prefix]
if {$member_cwm ne "" && [tcl::dict::get $member_cwm unavailable]} {
#G-073: the screen's non-match was a landing on a
#recognised-but-unavailable name - record the distinct kind so
#raise-time selection can emit the tailored report
set rejection [tcl::dict::create kind unavailable argname $thisname word $v name [tcl::dict::get $member_cwm canonical] choices $cw_allchoices]
} else {
set rejection [tcl::dict::create kind choice argname $thisname word $v choices $cw_allchoices nocase $cw_nocase prefix $cw_prefix]
}
} elseif {[llength $ctg_other]} {
set rejection [tcl::dict::create kind type argname $thisname word $v type $tp]
}
@ -9304,6 +9438,30 @@ tcl::namespace::eval punk::args {
#rename get_dict
#
#G-073: assemble the tailored recognised-but-unavailable rejection message.
#Shared by final validation and the G-082 allocation-rejection raise sites so the
#report is identical wherever the unavailable landing surfaces. supplied = the
#check-form word as received; name = the resolved -choiceunavailable entry;
#choicelabeldict provides the entry's documentation note when present (the wording
#steers the user: the note names the why - e.g a version boundary).
proc private::unavailable_choice_msg {argclass argname supplied name choicelabeldict allchoices} {
if {$supplied eq $name} {
set msg "$argclass '$argname' for %caller%: '$name' is a recognised name here, but is not available in this runtime/context."
} else {
set msg "$argclass '$argname' for %caller%: '$supplied' resolves to '$name' - a recognised name that is not available in this runtime/context."
}
if {[tcl::dict::exists $choicelabeldict $name]} {
append msg "\n note:"
foreach ln [split [tcl::dict::get $choicelabeldict $name] \n] {
append msg "\n [string trim $ln]"
}
}
if {[llength $allchoices]} {
append msg "\nAvailable values:\n [join $allchoices "\n "]"
}
return $msg
}
#G-040: the single implementation of choice-word matching - shared by argument parsing
#(get_dict) and the punk::ns doc-lookup walk (cmd_traverse), so 'i <cmd> <word>'
#resolution can never diverge from what parsing accepts.
@ -9323,8 +9481,18 @@ tcl::namespace::eval punk::args {
prefix, or via an alias)
exact - boolean: the raw stored word already equals the resulting
choice (no rewrite needed)
canonical - the resulting choice value (empty when not matched)"
@values -min 7 -max 7
canonical - the resulting choice value (empty when not matched,
EXCEPT when unavailable is 1 - it then carries the
matched unavailable name)
unavailable - boolean (G-073): the word landed - exactly, or as a
unique prefix - on a -choiceunavailable entry
(recognised but not available). matched stays 0;
callers wanting the tailored unavailability report
consult this key, existing matched-only consumers
treat it as an ordinary non-match. A prefix shared
between an available and an unavailable name is a
plain ambiguous non-match (unavailable 0)."
@values -min 7 -max 8
word -type string -help\
"The supplied word.
Callers pass the check-form, e.g ansistripped when applicable"
@ -9340,8 +9508,12 @@ tcl::namespace::eval punk::args {
"-choiceprefixdenylist (full word required for these names)"
reservelist -type list -help\
"-choiceprefixreservelist (phantom prefix-calculation members)"
unavailablelist -type list -optional 1 -default {} -help\
"-choiceunavailable (recognised-but-unavailable names - prefix-pool
members like the reservelist, but a word landing on one reports
unavailable 1 with the name as canonical) (G-073)"
}]
proc choiceword_match {word nocase allchoices choicealiases choiceprefix denylist reservelist} {
proc choiceword_match {word nocase allchoices choicealiases choiceprefix denylist reservelist {unavailablelist {}} } {
set aliasnames [tcl::dict::keys $choicealiases]
set has_choicealiases [expr {[llength $aliasnames] > 0}]
set choicealiases_nocase [tcl::dict::create]
@ -9360,6 +9532,7 @@ tcl::namespace::eval punk::args {
set chosen ""
set choice_in_list 0
set choice_exact_match 0
set unavailable_hit 0 ;#G-073 recognised-but-unavailable landing
if {$choiceprefix} {
#can we handle empty string as a choice? It should just work - REVIEW/test
if {$word in $allchoices} {
@ -9386,6 +9559,14 @@ tcl::namespace::eval punk::args {
#exact alias match differing only by case - normalize to the canonical choice
set chosen [tcl::dict::get $choicealiases_nocase $v_test]
set choice_in_list 1
} elseif {[llength $unavailablelist] && ($word in $unavailablelist || ($nocase && [lsearch -exact -nocase $unavailablelist $word] >= 0))} {
#G-073: exact match (case per -nocase) on a recognised-but-unavailable name
set unavailable_hit 1
if {$word in $unavailablelist} {
set chosen $word
} else {
set chosen [lsearch -inline -exact -nocase $unavailablelist $word]
}
} else {
#PREFIX check required - any match here is not an exact match or it would have matched above.
#in this block we can treat empty result from prefix match as a non-match
@ -9393,10 +9574,19 @@ tcl::namespace::eval punk::args {
if {$nocase} {
#nocase prefixing with case-dups: see the -choiceprefixdenylist nocase notes at the original
#get_dict site - counterintuitive DEL/delete/Delete edge cases are documented feature-not-bug
set bestmatch [tcl::prefix::match -error "" [list {*}[lsort -unique $allchoices] {*}$aliasnames {*}$reservelist] $word]
if {$bestmatch eq "" || $bestmatch in $reservelist} {
set chosen [tcl::prefix::match -error "" [list {*}[lsort -unique $choices_test] {*}[tcl::dict::keys $choicealiases_nocase] {*}$reservelist] $v_test]
if {$chosen ne "" && [tcl::dict::exists $choicealiases_nocase $chosen]} {
set bestmatch [tcl::prefix::match -error "" [list {*}[lsort -unique $allchoices] {*}$aliasnames {*}$reservelist {*}$unavailablelist] $word]
if {$bestmatch ne "" && $bestmatch in $unavailablelist} {
#G-073: prefix landed uniquely on an unavailable name
set unavailable_hit 1
set chosen $bestmatch
} elseif {$bestmatch eq "" || $bestmatch in $reservelist} {
set unavailablelist_lc [string tolower $unavailablelist]
set chosen [tcl::prefix::match -error "" [list {*}[lsort -unique $choices_test] {*}[tcl::dict::keys $choicealiases_nocase] {*}$reservelist {*}$unavailablelist_lc] $v_test]
if {$chosen ne "" && $chosen in $unavailablelist_lc} {
#G-073: nocase prefix landed uniquely on an unavailable name - report with its defined casing
set unavailable_hit 1
set chosen [lsearch -inline -exact -nocase $unavailablelist $chosen]
} elseif {$chosen ne "" && [tcl::dict::exists $choicealiases_nocase $chosen]} {
#matched an alias (lowercased) - deny applies to the alias name, then normalize
if {[lsearch -nocase $denylist $chosen] >= 0} {
set chosen ""
@ -9427,10 +9617,15 @@ tcl::namespace::eval punk::args {
}
}
} else {
set matchedname [tcl::prefix::match -error "" [list {*}[lsort -unique $allchoices] {*}$aliasnames {*}$reservelist] $word]
set matchedname [tcl::prefix::match -error "" [list {*}[lsort -unique $allchoices] {*}$aliasnames {*}$reservelist {*}$unavailablelist ] $word]
if {$matchedname eq "" || $matchedname in $reservelist} {
set chosen ""
set choice_in_list 0
} elseif {$matchedname in $unavailablelist} {
#G-073: prefix landed uniquely on an unavailable name
set unavailable_hit 1
set chosen $matchedname
set choice_in_list 0
} elseif {$matchedname in $aliasnames} {
#prefix landed on an alias - deny applies to the alias name, then normalize
if {$matchedname in $denylist} {
@ -9448,9 +9643,11 @@ tcl::namespace::eval punk::args {
}
#don't allow prefixing for elements from -choiceprefixdenylist
#we still use all elements to calculate the prefixes though
#(a canonical reached via an alias is exempt - deny was already applied to the alias name)
#(a canonical reached via an alias is exempt - deny was already applied to the alias name;
# an unavailable landing is exempt - deny applies to choices, and the unavailable
# indication must survive to drive the tailored report)
#review - case difference edge cases in choiceprefixdenylist !todo
if {!$prefix_via_alias && $chosen in $denylist} {
if {!$unavailable_hit && !$ prefix_via_alias && $chosen in $denylist} {
set choice_in_list 0
set chosen ""
}
@ -9470,9 +9667,17 @@ tcl::namespace::eval punk::args {
#exact alias match differing only by case - normalize to the canonical choice
set chosen [tcl::dict::get $choicealiases_nocase $v_test]
set choice_in_list 1
} elseif {[llength $unavailablelist] && ($word in $unavailablelist || ($nocase && [lsearch -exact -nocase $unavailablelist $word] >= 0))} {
#G-073: exact match (case per -nocase) on a recognised-but-unavailable name
set unavailable_hit 1
if {$word in $unavailablelist} {
set chosen $word
} else {
set chosen [lsearch -inline -exact -nocase $unavailablelist $word]
}
}
}
return [tcl::dict::create matched $choice_in_list exact $choice_exact_match canonical $chosen]
return [tcl::dict::create matched $choice_in_list exact $choice_exact_match canonical $chosen unavailable $unavailable_hit ]
}
#generally we expect values to contain leading dashes only if -- specified. Otherwise no reliable way determine difference between bad flags and values
@ -10971,6 +11176,15 @@ tcl::namespace::eval punk::args {
} else {
#required named arg
if {$leadername ni $leadernames_received} {
#G-082 follow-on (0.15.2): mirrored from the values loop below
#(per the MAINTENANCE contract above) - a present word that
#failed this required leader's basic-type screen reports the
#pointed typemismatch instead of the generic shortfall.
if {$rj ne "" && [dict get $rj kind] eq "type" && [dict get $rj argname] eq $leadername} {
set rj_type [dict get $rj type]
set msg "Leading argument '$leadername' for %caller% requires type '$rj_type'. Received: '$ldr'"
return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $rj_type] -badarg $leadername -badval $ldr -argspecs $argspecs]] $msg
}
#puts stderr "private::get_dict_can_assign_value $ldridx $values $nameidx $VAL_NAMES"
set msg "Bad number of leaders for %caller%. Not enough remaining values to assign to required arguments (fail on $leadername)."
return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list missingrequiredleader $leadername ] -badarg $leadername -argspecs $argspecs]] $msg
@ -11087,6 +11301,12 @@ tcl::namespace::eval punk::args {
set rj_choices [dict get $rj choices]
set msg "$rj_argclass '$rj_argname' for %caller% must be one of the listed values:\n [join $rj_choices "\n "]\n$rj_casemsg$rj_prefixmsg. Received: '$ldr'"
return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list choiceviolation $ldr choices $rj_choices] -badarg $rj_argname -badval $ldr -argspecs $argspecs]] $msg
} elseif {[dict get $rj kind] eq "unavailable"} {
#G-073: recognised-but-unavailable landing recorded by the
#allocation screen - the tailored report, as final validation gives
set rj_name [dict get $rj name]
set msg [private::unavailable_choice_msg $rj_argclass $rj_argname $ldr $rj_name [Dict_getdef $argstate $rj_argname -choicelabels {}] [dict get $rj choices]]
return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list choiceunavailable $rj_name choices [dict get $rj choices]] -badarg $rj_argname -badval $ldr -argspecs $argspecs]] $msg
} else {
set rj_type [dict get $rj type]
set msg "$rj_argclass '$rj_argname' for %caller% requires type '$rj_type'. Received: '$ldr'"
@ -11213,6 +11433,19 @@ tcl::namespace::eval punk::args {
} else {
#required named arg
if {$valname ni $valnames_received} {
#G-082 follow-on (0.15.2): a word IS present but failed this
#required argument's basic-type allocation screen - report the
#pointed typemismatch (same message/errorcode shape as the
#overflow-site selection below) instead of the generic
#missingrequiredvalue shortfall. Only kind 'type' can arrive
#here (choice screens never apply to required args - G-071
#asymmetry); literal mismatches and multi-member clauses record
#no rejection, so those shapes keep the shortfall report.
if {$rj ne "" && [dict get $rj kind] eq "type" && [dict get $rj argname] eq $valname} {
set rj_type [dict get $rj type]
set msg "Trailing argument '$valname' for %caller% requires type '$rj_type'. Received: '$val'"
return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $rj_type] -badarg $valname -badval $val -argspecs $argspecs]] $msg
}
#puts stderr "private::get_dict_can_assign_value $validx $values $nameidx $VAL_NAMES"
set msg "Bad number of values for %caller%. Not enough remaining values to assign to required arguments (fail on $valname)."
return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list missingrequiredvalue $valname ] -badarg $valname -argspecs $argspecs]] $msg
@ -11325,6 +11558,13 @@ tcl::namespace::eval punk::args {
set rj_choices [dict get $rj choices]
set msg "$rj_argclass '$rj_argname' for %caller% must be one of the listed values:\n [join $rj_choices "\n "]\n$rj_casemsg$rj_prefixmsg. Received: '$val'"
return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list choiceviolation $val choices $rj_choices] -badarg $rj_argname -badval $val -argspecs $argspecs]] $msg
} elseif {[dict get $rj kind] eq "unavailable"} {
#G-073: recognised-but-unavailable landing recorded by the
#allocation screen - the tailored report, as final validation gives
#(MAINTENANCE - same selection logic as leaders loop above)
set rj_name [dict get $rj name]
set msg [private::unavailable_choice_msg $rj_argclass $rj_argname $val $rj_name [Dict_getdef $argstate $rj_argname -choicelabels {}] [dict get $rj choices]]
return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list choiceunavailable $rj_name choices [dict get $rj choices]] -badarg $rj_argname -badval $val -argspecs $argspecs]] $msg
} else {
set rj_type [dict get $rj type]
set msg "$rj_argclass '$rj_argname' for %caller% requires type '$rj_type'. Received: '$val'"
@ -11733,6 +11973,9 @@ tcl::namespace::eval punk::args {
#setting) and as prefix-calculation members when -choiceprefix is true; matched aliases
#normalize to their canonical choice in the parse result (see choiceword_match).
set choicealiases [Dict_getdef $thisarg -choicealiases {}]
#-choiceunavailable (G-073): recognised-but-unavailable names - prefix-pool members;
#a word landing on one earns the tailored choiceunavailable rejection below.
set choiceunavailable [Dict_getdef $thisarg -choiceunavailable {}]
set choicerestricted [tcl::dict::get $thisarg -choicerestricted]
set choicemultiple [tcl::dict::get $thisarg -choicemultiple]
if {[string is integer -strict $choicemultiple]} {
@ -11810,7 +12053,7 @@ tcl::namespace::eval punk::args {
#G-040: choice-word matching delegated to the shared resolver
#(punk::args::choiceword_match - also consumed by the punk::ns doc-lookup
# walk, so 'i <cmd> <word>' resolution cannot diverge from parsing)
set matchinfo [choiceword_match $c_check $nocase $allchoices $choicealiases $choiceprefix $choiceprefixdenylist $choiceprefixreservelist]
set matchinfo [choiceword_match $c_check $nocase $allchoices $choicealiases $choiceprefix $choiceprefixdenylist $choiceprefixreservelist $choiceunavailable ]
set choice_in_list [tcl::dict::get $matchinfo matched]
set choice_exact_match [tcl::dict::get $matchinfo exact]
set chosen [tcl::dict::get $matchinfo canonical]
@ -11887,6 +12130,16 @@ tcl::namespace::eval punk::args {
} else {
#unhappy path
#G-073: the word landed (exact, or unique prefix) on a
#recognised-but-unavailable name - tailored report naming the
#entry and its -choicelabels note instead of the generic
#listed-values error.
if {[tcl::dict::get $matchinfo unavailable]} {
set cu_name [tcl::dict::get $matchinfo canonical]
set msg [private::unavailable_choice_msg $argclass $argname $c_check $cu_name [Dict_getdef $thisarg -choicelabels {}] $allchoices]
return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list choiceunavailable $cu_name choices $allchoices] -badarg $argname -badval $c_check -argspecs $argspecs]] $msg
}
#if prefixes allowed, first see if c_check is an ambiguous prefix
#This is preferable to listing all (possibly many) choices in the error message.
if {$choiceprefix} {
@ -11894,11 +12147,20 @@ tcl::namespace::eval punk::args {
#review - case
if {$nocase} {
set longermatches [lsearch -all -inline -nocase $allchoices "$c_check*"]
set longermatches_unavail [lsearch -all -inline -nocase $choiceunavailable "$c_check*"]
} else {
set longermatches [lsearch -all -inline $allchoices "$c_check*"]
set longermatches_unavail [lsearch -all -inline $choiceunavailable "$c_check*"]
}
#G-073: unavailable names participate in prefix ambiguity -
#display them annotated so the ambiguity is explicable, but
#never as selectable suggestions
set longermatches_display $longermatches
foreach cu_lm $longermatches_unavail {
lappend longermatches_display "$cu_lm (recognised but unavailable)"
}
if {[llength $longermatches]} {
set msg "$argclass '$argname' for %caller% seems to be an ambiguous prefix. Try one of:\n [join $longermatches "\n "]\n$casemsg$prefixmsg. Received: '$c_check'"
if {[llength $longermatches] || [llength $longermatches_unavail] > 1 } {
set msg "$argclass '$argname' for %caller% seems to be an ambiguous prefix. Try one of:\n [join $longermatches_display "\n "]\n$casemsg$prefixmsg. Received: '$c_check'"
return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list choiceviolation $c choices $allchoices] -badarg $argname -badval $c_check -argspecs $argspecs]] $msg
}
} else {
@ -14365,7 +14627,7 @@ package provide punk::args [tcl::namespace::eval punk::args {
tcl::namespace::path {::punk::args::lib ::punk::args::system}
variable pkg punk::args
variable version
set version 0.15.1
set version 0.17.0
}]
return
