From 25398b9c6db599f0d4a42393ef4e847688cfb12e Mon Sep 17 00:00:00 2001 From: Julian Noble Date: Thu, 9 Jul 2026 13:51:04 +1000 Subject: [PATCH] update vfs: _vfscommon modules punk 0.2.2->0.2.3, punk::args 0.2.3->0.3.1, punk::ns 0.1.1->0.1.2 Assisted-by: harness=opencode; primary-model=openrouter/z-ai/glm-5.2; api-location=openrouter.ai --- .../modules/{punk-0.2.2.tm => punk-0.2.3.tm} | 30 +- .../punk/{args-0.2.3.tm => args-0.3.1.tm} | 379 ++++++++++++------ .../modules/punk/{ns-0.1.1.tm => ns-0.1.2.tm} | 28 +- 3 files changed, 309 insertions(+), 128 deletions(-) rename src/vfs/_vfscommon.vfs/modules/{punk-0.2.2.tm => punk-0.2.3.tm} (99%) rename src/vfs/_vfscommon.vfs/modules/punk/{args-0.2.3.tm => args-0.3.1.tm} (97%) rename src/vfs/_vfscommon.vfs/modules/punk/{ns-0.1.1.tm => ns-0.1.2.tm} (99%) diff --git a/src/vfs/_vfscommon.vfs/modules/punk-0.2.2.tm b/src/vfs/_vfscommon.vfs/modules/punk-0.2.3.tm similarity index 99% rename from src/vfs/_vfscommon.vfs/modules/punk-0.2.2.tm rename to src/vfs/_vfscommon.vfs/modules/punk-0.2.3.tm index b34f1b43..b683f955 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk-0.2.2.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk-0.2.3.tm @@ -8464,16 +8464,32 @@ namespace eval punk { #(re)generate the punk::args definitions for ::punk::help and ::punk::help_chunks from the registry #so that 'i help' shows a documented topic table matching the registered topics. + #minimum-prefix policy for topic words (user decision 2026-07-08): + # - prefixes of the 'help' alias are denied: h/he/hel stay available as command + # words ('help' itself must be typed in full) + # - c, to and tc are reserved phantoms so they fall through to command lookup + # (co.../top.../full 'tcl' still match; e/en and te/ter fall through naturally + # as ambiguous prefixes of env|environment and term|terminal) + variable topic_prefixdenylist {help} + variable topic_prefixreservelist {c to tc} + proc define_docs {} { variable topics + variable topic_prefixdenylist + variable topic_prefixreservelist + #G-040: canonical topic names are the choices; registry aliases become + #-choicealiases (accepted + normalized at parse, folded into the canonical + #entry in usage display). choiceinfo/choicelabels key on canonicals only. set choices [list] + set choicealiases [dict create] set choiceinfo [dict create] set choicelabels [dict create] dict for {topic tinfo} $topics { - foreach name [list $topic {*}[dict get $tinfo aliases]] { - lappend choices $name - dict set choiceinfo $name [list [list doctype punkargs] [list subhelp [namespace current]::$topic]] - dict set choicelabels $name [dict get $tinfo summary] + lappend choices $topic + dict set choiceinfo $topic [list [list doctype punkargs] [list subhelp [namespace current]::$topic]] + dict set choicelabels $topic [dict get $tinfo summary] + foreach al [dict get $tinfo aliases] { + dict set choicealiases $al $topic } } #keep help-text lines manually folded (~70 cols) - the usage tables don't yet @@ -8488,7 +8504,7 @@ namespace eval punk { command info (type and synopsis) is shown for a resolvable command, or the resolved path for an external executable.} - set topichelp "Help topic, or command words for basic command info.\n(topics must match exactly - no prefix matching)" + set topichelp "Help topic, or command words for basic command info.\nTopics accept their aliases and unique prefixes\n(some short words deliberately fall through to command lookup)." set specs [list] lappend specs ::punk::help help "Punk shell help system." "" lappend specs ::punk::help_chunks punk::help_chunks "Punk shell help system - content as {channel text} chunks." "\n\nhelp_chunks returns the help content as a list of\n{channel text} chunks rather than emitting it." @@ -8497,7 +8513,7 @@ namespace eval punk { append def "@id -id $id" \n append def "@cmd -name $name -summary \"$summary\" -help \"$basehelp$extra\"" \n append def "@leaders -min 0 -max -1" \n - append def "topic -optional 1 -multiple 1 -type string -choiceprefix 0 -choicerestricted 0 -choicecolumns 2 -choices {$choices} -choiceinfo {$choiceinfo} -choicelabels {$choicelabels} -help \"$topichelp\"" \n + append def "topic -optional 1 -multiple 1 -type string -choiceprefix 1 -choicerestricted 0 -choicecolumns 2 -choices {$choices} -choicealiases {$choicealiases} -choiceprefixdenylist {$topic_prefixdenylist} -choiceprefixreservelist {$topic_prefixreservelist} -choiceinfo {$choiceinfo} -choicelabels {$choicelabels} -help \"$topichelp\"" \n append def "@values -min 0 -max 0" if {[punk::args::id_exists $id]} { #quiet undefine - redefinition on registry change is expected, not noteworthy @@ -9387,7 +9403,7 @@ punkcheck::cli set_alias punkcheck package provide punk [namespace eval punk { #FUNCTL variable version - set version 0.2.2 + set version 0.2.3 }] diff --git a/src/vfs/_vfscommon.vfs/modules/punk/args-0.2.3.tm b/src/vfs/_vfscommon.vfs/modules/punk/args-0.3.1.tm similarity index 97% rename from src/vfs/_vfscommon.vfs/modules/punk/args-0.2.3.tm rename to src/vfs/_vfscommon.vfs/modules/punk/args-0.3.1.tm index e8b2c3bf..613074be 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/args-0.2.3.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/args-0.3.1.tm @@ -8,7 +8,7 @@ # (C) 2024 # # @@ Meta Begin -# Application punk::args 0.2.3 +# Application punk::args 0.3.1 # Meta platform tcl # Meta license # @@ Meta End @@ -18,7 +18,7 @@ # doctools header # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #*** !doctools -#[manpage_begin punkshell_module_punk::args 0 0.2.3] +#[manpage_begin punkshell_module_punk::args 0 0.3.1] #[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 --}] @@ -416,7 +416,7 @@ tcl::namespace::eval ::punk::args::helpers { } if {$opt_title ne ""} { - set title "[punk::ansi::a+ term-black Term-silver]$opt_title[a]" + set title "[punk::ansi::a+ term-black Term-silver]$opt_title[punk::ansi::a]" } else { set title "" } @@ -911,6 +911,25 @@ tcl::namespace::eval punk::args { env, envi, ... environment all normalize to environment. (To require a longer minimum, reserve each shorter form: reserving {en env} raises the minimum to envi.) + -choicealiases {} + Dictionary mapping alias names to canonical choice names. + An alias is accepted wherever its canonical choice is: an + exact alias match works regardless of -choiceprefix, and + when -choiceprefix is true alias names participate in + prefix calculation so a unique prefix of an alias also + matches. A matched alias is normalized: the parse result + contains the canonical choice, never the alias. + Aliases are not displayed as separate choice entries - + usage display folds them into the canonical entry as an + '(alias: name)' note on its label. -choicelabels keys + should be canonical names only. + An alias listed in -choiceprefixdenylist must be typed + in full (denial applies to the alias name; a canonical + reached via its alias is not subject to the canonical's + own denylist entry). + Each alias must map to an existing choice, and must not + itself collide with a choice (validated when the + definition is resolved). -choicegroups {} Generally this would be used instead of -choices to allow usage display of choices grouped by some name (or the empty @@ -2642,6 +2661,17 @@ tcl::namespace::eval punk::args { } tcl::dict::set spec_merged -mash $specval } + -choicealiases { + #dict of alias -> canonical choice (goal G-040). + #Aliases are accepted at parse (exact, and as prefix-calculation members when + #-choiceprefix applies) and normalize to their canonical choice in the parse + #result; usage display folds them into the canonical entry. + #Cross-validation against the final choice set happens after all specs merge. + if {![punk::args::lib::string_is_dict $specval]} { + error "punk::args::resolve - invalid value for key '$spec' in specifications for argument '$argname' - value must be a dictionary of alias -> canonical-choice @id:$DEF_definition_id" + } + tcl::dict::set spec_merged $spec $specval + } -unindentedfields - -solo - -choices - -choicegroups - -choicemultiple - -choicecolumns - @@ -2761,7 +2791,7 @@ tcl::namespace::eval punk::args { -minsize -maxsize -choices -choicegroups -mincap -maxcap -choicemultiple -choicecolumns -choiceprefix -choiceprefixdenylist -choiceprefixreservelist -choicerestricted - -choicelabels -choiceinfo + -choicelabels -choiceinfo -choicealiases -unindentedfields -nocase -optional -multiple -validate_ansistripped -allow_ansi -strip_ansi -help -multipleunique -choicemultipleunique -choicemultipleuniqueset @@ -2774,6 +2804,21 @@ tcl::namespace::eval punk::args { } } ;# end foreach {spec specval} argdef_values + #cross-validate -choicealiases against the final merged choice set (goal G-040) + if {[tcl::dict::exists $spec_merged -choicealiases] && [tcl::dict::size [tcl::dict::get $spec_merged -choicealiases]]} { + set ca_allchoices [punk::args::system::Dict_getdef $spec_merged -choices {}] + foreach {_cagroup camembers} [punk::args::system::Dict_getdef $spec_merged -choicegroups {}] { + lappend ca_allchoices {*}$camembers + } + tcl::dict::for {ca_alias ca_canonical} [tcl::dict::get $spec_merged -choicealiases] { + if {$ca_canonical ni $ca_allchoices} { + error "punk::args::resolve - -choicealiases for argument '$argname' maps alias '$ca_alias' to '$ca_canonical' which is not in -choices/-choicegroups @id:$DEF_definition_id" + } + if {$ca_alias in $ca_allchoices} { + error "punk::args::resolve - -choicealiases for argument '$argname' alias '$ca_alias' collides with a defined choice @id:$DEF_definition_id" + } + } + } if {$is_opt} { #tcl::dict::set FDICT ARG_CHECKS $argname {*}{ @@ -4811,12 +4856,15 @@ tcl::namespace::eval punk::args { if {$has_choices} { if {$help ne ""} {append help \n} + #G-040: alias names participate in prefix calculation (as at parse time) + set choicealiases_display [Dict_getdef $arginfo -choicealiases {}] + set choicealias_names [dict keys $choicealiases_display] if {[dict get $arginfo -nocase]} { set casemsg " (case insensitive)" - set allchoices_prefixcalc [list {*}[string tolower $allchoices_originalcase] {*}$choiceprefixreservelist] + set allchoices_prefixcalc [list {*}[string tolower $allchoices_originalcase] {*}[string tolower $choicealias_names] {*}$choiceprefixreservelist] } else { set casemsg " (case sensitive)" - set allchoices_prefixcalc [list {*}$allchoices_originalcase {*}$choiceprefixreservelist] + set allchoices_prefixcalc [list {*}$allchoices_originalcase {*}$choicealias_names {*}$choiceprefixreservelist] } if {[dict get $arginfo -choiceprefix]} { set prefixmsg " (choice prefix allowed)" @@ -4825,6 +4873,22 @@ tcl::namespace::eval punk::args { } set choicelabeldict [Dict_getdef $arginfo -choicelabels {}] set choiceinfodict [Dict_getdef $arginfo -choiceinfo {}] + #G-040: aliases are not displayed as separate choice entries - fold each + #canonical's alias names into its label so every display path shows them once + if {[dict size $choicealiases_display]} { + set aliasesbycanonical [dict create] + dict for {ca_al ca_cn} $choicealiases_display { + dict lappend aliasesbycanonical $ca_cn $ca_al + } + dict for {ca_cn ca_als} $aliasesbycanonical { + set aliasnote "(alias[expr {[llength $ca_als] > 1 ? {es} : {}}]: [join $ca_als |])" + if {[dict exists $choicelabeldict $ca_cn]} { + dict set choicelabeldict $ca_cn "$aliasnote\n[dict get $choicelabeldict $ca_cn]" + } else { + dict set choicelabeldict $ca_cn $aliasnote + } + } + } set formattedchoices [dict create] ;#use dict rather than array to preserve order if {$help eq ""} { #first line of help - no included base of 4 indent is the normal state of first help lines in definitions scripts @@ -8074,6 +8138,155 @@ tcl::namespace::eval punk::args { #rename get_dict # + #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 ' + #resolution can never diverge from what parsing accepts. + #Arguments: + # word - the supplied word (callers pass the check-form, e.g. ansistripped when applicable) + # nocase - value of -nocase for the argument + # allchoices - flat list of -choices plus all -choicegroups members (dups allowed) + # choicealiases - -choicealiases dict (alias -> canonical choice) + # choiceprefix - value of -choiceprefix + # denylist - -choiceprefixdenylist (full word required for these names) + # reservelist - -choiceprefixreservelist (phantom prefix-calculation members) + #Returns dict: + # matched - boolean: word identifies a choice (directly, by unique 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) + proc choiceword_match {word nocase allchoices choicealiases choiceprefix denylist reservelist} { + set aliasnames [tcl::dict::keys $choicealiases] + set has_choicealiases [expr {[llength $aliasnames] > 0}] + set choicealiases_nocase [tcl::dict::create] + if {$has_choicealiases} { + tcl::dict::for {ca_al ca_cn} $choicealiases { + tcl::dict::set choicealiases_nocase [tcl::string::tolower $ca_al] $ca_cn + } + } + if {$nocase} { + set choices_test [tcl::string::tolower $allchoices] + set v_test [tcl::string::tolower $word] + } else { + set choices_test $allchoices + set v_test $word + } + set chosen "" + set choice_in_list 0 + set choice_exact_match 0 + if {$choiceprefix} { + #can we handle empty string as a choice? It should just work - REVIEW/test + if {$word in $allchoices} { + #for case when there are case-differenced duplicates - allow exact match to avoid selecting earlier match of another casing + set chosen $word + set choice_in_list 1 + set choice_exact_match 1 + } elseif {$has_choicealiases && [tcl::dict::exists $choicealiases $word]} { + #exact alias match - normalize to the canonical choice + #(deliberately not 'exact' - the stored raw value must be overwritten with the canonical) + set chosen [tcl::dict::get $choicealiases $word] + set choice_in_list 1 + } elseif {$nocase && $v_test in $choices_test} { + #full-length match except for case + #select the case from the choice list - not the supplied value + foreach avail [lsort -unique $allchoices] { + if {[tcl::string::match -nocase $word $avail]} { + set chosen $avail + } + } + #assert chosen will always get set + set choice_in_list 1 + } elseif {$has_choicealiases && $nocase && [tcl::dict::exists $choicealiases_nocase $v_test]} { + #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 + } 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 + set prefix_via_alias 0 ;#set when the prefix match landed on an alias name (deny already applied to the alias) + 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]} { + #matched an alias (lowercased) - deny applies to the alias name, then normalize + if {[lsearch -nocase $denylist $chosen] >= 0} { + set chosen "" + } else { + set chosen [tcl::dict::get $choicealiases_nocase $chosen] + set prefix_via_alias 1 + } + set choice_in_list [expr {$chosen ne ""}] + } else { + #now pick the earliest match in the actually defined list so that case of chosen always matches a defined entry with casing + set chosen [lsearch -inline -nocase $allchoices $chosen] + set choice_in_list [expr {$chosen ne ""}] + } + } else { + if {$bestmatch in $aliasnames} { + #prefix landed on an alias - deny applies to the alias name, then normalize + if {$bestmatch in $denylist} { + set chosen "" + set choice_in_list 0 + } else { + set chosen [tcl::dict::get $choicealiases $bestmatch] + set choice_in_list 1 + set prefix_via_alias 1 + } + } else { + set chosen $bestmatch + set choice_in_list 1 + } + } + } else { + set matchedname [tcl::prefix::match -error "" [list {*}[lsort -unique $allchoices] {*}$aliasnames {*}$reservelist] $word] + if {$matchedname eq "" || $matchedname in $reservelist} { + set chosen "" + 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} { + set chosen "" + set choice_in_list 0 + } else { + set chosen [tcl::dict::get $choicealiases $matchedname] + set choice_in_list 1 + set prefix_via_alias 1 + } + } else { + set chosen $matchedname + set choice_in_list 1 + } + } + #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) + #review - case difference edge cases in choiceprefixdenylist !todo + if {!$prefix_via_alias && $chosen in $denylist} { + set choice_in_list 0 + set chosen "" + } + } + } else { + #-choiceprefix false - exact matching only + if {$v_test in $choices_test} { + #value as stored is ok (raw word kept - historical behaviour, including nocase raw retention) + set chosen $word + set choice_in_list 1 + set choice_exact_match 1 + } elseif {$has_choicealiases && [tcl::dict::exists $choicealiases $word]} { + #exact alias match - normalize to the canonical choice + set chosen [tcl::dict::get $choicealiases $word] + set choice_in_list 1 + } elseif {$has_choicealiases && $nocase && [tcl::dict::exists $choicealiases_nocase $v_test]} { + #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 + } + } + return [tcl::dict::create matched $choice_in_list exact $choice_exact_match canonical $chosen] + } + #generally we expect values to contain leading dashes only if -- specified. Otherwise no reliable way determine difference between bad flags and values #If no eopts (--) specified we stop looking for opts at the first nondash encountered in a position we'd expect a dash - so without eopt, values could contain dashes - but not in first position after flags. #only supports -flag val pairs, not solo options @@ -10023,6 +10236,10 @@ tcl::namespace::eval punk::args { set choiceprefix [tcl::dict::get $thisarg -choiceprefix] set choiceprefixdenylist [Dict_getdef $thisarg -choiceprefixdenylist {}] set choiceprefixreservelist [Dict_getdef $thisarg -choiceprefixreservelist {}] + #-choicealiases (G-040): alias -> canonical choice. Accepted exact (any -choiceprefix + #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 {}] set choicerestricted [tcl::dict::get $thisarg -choicerestricted] set choicemultiple [tcl::dict::get $thisarg -choicemultiple] if {[string is integer -strict $choicemultiple]} { @@ -10097,122 +10314,60 @@ tcl::namespace::eval punk::args { set choice_in_list 0 set matches_default [expr {$has_default && $c eq $defaultval}] ;# defaultval could be a list when -choicemultiple? if {!$matches_default} { - if {$choiceprefix} { - #can we handle empty string as a choice? It should just work - REVIEW/test - set choice_exact_match 0 - if {$c_check in $allchoices} { - #for case when there are case-differenced duplicates - allow exact match to avoid selecting earlier match of another casing - set chosen $c_check - set choice_in_list 1 - set choice_exact_match 1 - } elseif {$v_test in $choices_test} { - #assert - if we're here, nocase must be true - #we know choice is present as full-length match except for case - #now we want to select the case from the choice list - not the supplied value - #we don't set choice_exact_match - because we will need to override the optimistic existing val below - #review - foreach avail [lsort -unique $allchoices] { - if {[string match -nocase $c $avail]} { - set chosen $avail - } - } - #assert chosen will always get set - set choice_in_list 1 - } else { - #puts ">>>> choiceprefixreservelist: $choiceprefixreservelist" - #PREFIX check required - any 'chosen' here is not an exact match or it would have matched above. - #assert - if empty string was a provided choice and empty string was a provided arg - we would have matched above. - #in this block we can treat empty result from prefix match as a non-match - if {$nocase} { - #nocase implies that our entered value doesn't have to match case of choices - - #but we would still like to select the best match if there are case-dups. - #e.g arg -choices {delete Delete} -nocase 1 -choiceprefixdenylist delete - # selecting Del will find Delete, del will match delete (and raise error) - # but DEL will also match delete rather than Delete - so again an error is raised. - #This is counterintuitive with -nocase - #This is probably such an edge case that best served with documentation as a feature-not-bug - #Rationale being that in a nocase situation it's arbitrary/counterintuitive to consider DEL, or DeL a better match for Delete than delete? - #The choice of the user to use -choiceprefixdenylist along with case-dups is the issue. - - set bestmatch [tcl::prefix::match -error "" [list {*}[lsort -unique $allchoices] {*}$choiceprefixreservelist] $c_check] - if {$bestmatch eq "" || $bestmatch in $choiceprefixreservelist} { - set chosen [tcl::prefix::match -error "" [list {*}[lsort -unique $choices_test] {*}$choiceprefixreservelist] $v_test] - #now pick the earliest match in the actually defined list so that case of chosen always matches a defined entry with casing - set chosen [lsearch -inline -nocase $allchoices $chosen] - set choice_in_list [expr {$chosen ne ""}] + #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 ' resolution cannot diverge from parsing) + set matchinfo [choiceword_match $c_check $nocase $allchoices $choicealiases $choiceprefix $choiceprefixdenylist $choiceprefixreservelist] + 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] + #override the optimistic existing val (prefix-normalized or alias-normalized matches) + #our existing values in $dname are not list-protected - so we need to check clause_size + if {$choice_in_list && !$choice_exact_match} { + set existing [tcl::dict::get [set $dname] $argname_or_ident] + if {$choicemultiple_max != -1 && $choicemultiple_max < 2} { + #single choice allowed per clause-member + if {$is_multiple} { + if {$clause_size == 1} { + #no list wrapping of single element in $dname dict - so don't index into it with element_index + #lset existing $element_index $chosen ;#wrong - test::punk::args test: choice_multiple_with_choiceprefix. + lset existing $clause_index $chosen } else { - set chosen $bestmatch - set choice_in_list 1 + lset existing $clause_index $element_index $chosen } + tcl::dict::set $dname $argname_or_ident $existing } else { - set chosen [tcl::prefix::match -error "" [list {*}[lsort -unique $allchoices] {*}$choiceprefixreservelist] $c_check] - if {$chosen eq "" || $chosen in $choiceprefixreservelist} { - set choice_in_list 0 - } else { - set choice_in_list 1 - } - } - #override choice_in_list if in deny list - #don't allow prefixing for elements from -choiceprefixdenylist - #we still use all elements to calculate the prefixes though - #review - case difference edge cases in choiceprefixdenylist !todo - if {$chosen in $choiceprefixdenylist} { - set choice_in_list 0 - set chosen "" + #test: choice_multielement_clause + lset existing $element_index $chosen + tcl::dict::set $dname $argname_or_ident $existing } - } - - #override the optimistic existing val - #our existing values in $dname are not list-protected - so we need to check clause_size - if {$choice_in_list && !$choice_exact_match} { - set existing [tcl::dict::get [set $dname] $argname_or_ident] - if {$choicemultiple_max != -1 && $choicemultiple_max < 2} { - #single choice allowed per clause-member - if {$is_multiple} { - if {$clause_size == 1} { - #no list wrapping of single element in $dname dict - so don't index into it with element_index - #lset existing $element_index $chosen ;#wrong - test::punk::args test: choice_multiple_with_choiceprefix. - lset existing $clause_index $chosen - } else { - lset existing $clause_index $element_index $chosen - } - tcl::dict::set $dname $argname_or_ident $existing + } else { + if {$is_multiple} { + #puts ">>> existing $existing $choice_idx" + if {$clause_size == 1} { + #no list wrapping of single element in $dname dict - so don't index into it with element_index + lset existing $clause_index $choice_idx $chosen } else { - #test: choice_multielement_clause - lset existing $element_index $chosen - tcl::dict::set $dname $argname_or_ident $existing + lset existing $clause_index $element_index $choice_idx $chosen } + tcl::dict::set $dname $argname_or_ident $existing } else { - if {$is_multiple} { - #puts ">>> existing $existing $choice_idx" - if {$clause_size == 1} { - #no list wrapping of single element in $dname dict - so don't index into it with element_index - lset existing $clause_index $choice_idx $chosen - } else { - lset existing $clause_index $element_index $choice_idx $chosen - } - tcl::dict::set $dname $argname_or_ident $existing + #test required. + # punk::args::parse {{read write w}} withdef @values {mode -type list -choices {read write} -choicemultiple {1 -1}} + #puts ">>> clause_size $clause_size" + #puts ">>> existing $existing" + #puts ">>> lset existing $element_index $choice_idx $chosen" + if {$clause_size == 1} { + #e.g -type list + #we have multiple choices allowed for a single element clause because that clause type is a list. + lset existing $choice_idx $chosen } else { - #test required. - # punk::args::parse {{read write w}} withdef @values {mode -type list -choices {read write} -choicemultiple {1 -1}} - #puts ">>> clause_size $clause_size" - #puts ">>> existing $existing" - #puts ">>> lset existing $element_index $choice_idx $chosen" - if {$clause_size == 1} { - #e.g -type list - #we have multiple choices allowed for a single element clause because that clause type is a list. - lset existing $choice_idx $chosen - } else { - #e.g -type {any any} - lset existing $element_index $choice_idx $chosen - } - tcl::dict::set $dname $argname_or_ident $existing + #e.g -type {any any} + lset existing $element_index $choice_idx $chosen } + tcl::dict::set $dname $argname_or_ident $existing } } - } else { - #value as stored in $dname is ok - set choice_in_list [expr {$v_test in $choices_test}] } } @@ -12395,7 +12550,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.2.3 + set version 0.3.1 }] return diff --git a/src/vfs/_vfscommon.vfs/modules/punk/ns-0.1.1.tm b/src/vfs/_vfscommon.vfs/modules/punk/ns-0.1.2.tm similarity index 99% rename from src/vfs/_vfscommon.vfs/modules/punk/ns-0.1.1.tm rename to src/vfs/_vfscommon.vfs/modules/punk/ns-0.1.2.tm index 114d980b..b18bbfdf 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/ns-0.1.1.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/ns-0.1.2.tm @@ -7,7 +7,7 @@ # (C) 2023 # # @@ Meta Begin -# Application punk::ns 0.1.1 +# Application punk::ns 0.1.2 # Meta platform tcl # Meta license # @@ Meta End @@ -5154,16 +5154,26 @@ y" {return quirkykeyscript} return [list 3 $origin $resolvedargs [list {*}$eparams {*}$queryargs_untested] $docid] break } - set resolved_q [tcl::prefix::match -error "" $allchoices $q] - if {$resolved_q eq ""} { + #G-040: resolve the subcommand word with the same shared resolver argument + #parsing uses (punk::args::choiceword_match) - so aliases normalize to their + #canonical (choiceinfo is keyed on canonicals), -choiceprefixdenylist and + #-choiceprefixreservelist are honoured, and 'i ' can never accept + #a word that parsing would reject. + set ct_matchinfo [punk::args::choiceword_match $q\ + [punk::args::system::Dict_getdef $arginfo -nocase 0]\ + $allchoices\ + [punk::args::system::Dict_getdef $arginfo -choicealiases {}]\ + [dict get $arginfo -choiceprefix]\ + [punk::args::system::Dict_getdef $arginfo -choiceprefixdenylist {}]\ + [punk::args::system::Dict_getdef $arginfo -choiceprefixreservelist {}]\ + ] + if {![dict get $ct_matchinfo matched]} { + #no match under parse rules (covers: unknown word, ambiguous prefix, + #reserved word, denied prefix, and non-exact word when -choiceprefix 0) return [list 4 $origin $resolvedargs $queryargs_untested $docid] break } - if {![dict get $arginfo -choiceprefix] && $resolved_q ne $q} { - #a unique prefix is not sufficient for this arg - return [list 5 $origin $resolvedargs $queryargs_untested $docid] - break - } + set resolved_q [dict get $ct_matchinfo canonical] #if {$resolved_q ne $q} { @@ -7591,6 +7601,6 @@ namespace eval ::punk::args::register { ## Ready package provide punk::ns [tcl::namespace::eval punk::ns { variable version - set version 0.1.1 + set version 0.1.2 }] return \ No newline at end of file