From 7c49fc844efeae863e8d79af81ee9ab474f5f7c1 Mon Sep 17 00:00:00 2001 From: Julian Noble Date: Mon, 13 Jul 2026 14:11:31 +1000 Subject: [PATCH] vfs: sync punk::args 0.11.2, punk::ns 0.5.0, punk::lib 0.4.3, punk 0.2.6, punk::repl 0.5.1, tclcore moduledoc 0.3.3 into _vfscommon.vfs make.tcl modules + vfscommonupdate + project: all four kits rebuilt (punkbi, punksys, punk91, punk902z). Kit-mode verification: punk902z loads args=0.11.2 ns=0.5.0 tclcore=0.3.3 lib=0.4.3 punk=0.2.6, 'i join' emits no bad-@dynamic warning; punksys (8.6) loads args=0.11.2 and the after cancel-id discrimination resolves 'cancel someid' to the cancelscript form (harvested id prefix working on 8.6). A stale tcl_oauth2_library install leftover in the project's root lib/ tree (its src/vendorlib source was removed 2026-07-12; the libs install step does not prune targets whose source vanished) was swept into the vfs lib by vfscommonupdate and removed again before the kit build - it is deliberately not part of the vendored set yet (G-065..G-068 first-test candidate). The root lib/ leftover itself was removed after this commit was first authored; its rows remain in lib/.punkcheck. Assisted-by: harness=claude; primary-model=claude-fable-5; api-location=anthropic.com --- .../modules/{punk-0.2.3.tm => punk-0.2.6.tm} | 57 +- .../punk/{args-0.6.0.tm => args-0.11.2.tm} | 893 +++++++++++++++--- .../{tclcore-0.2.0.tm => tclcore-0.3.3.tm} | 56 +- .../punk/{lib-0.4.0.tm => lib-0.4.3.tm} | 75 +- .../modules/punk/{ns-0.2.0.tm => ns-0.5.0.tm} | 162 +++- .../punk/{repl-0.5.0.tm => repl-0.5.1.tm} | 15 +- 6 files changed, 1086 insertions(+), 172 deletions(-) rename src/vfs/_vfscommon.vfs/modules/{punk-0.2.3.tm => punk-0.2.6.tm} (99%) rename src/vfs/_vfscommon.vfs/modules/punk/{args-0.6.0.tm => args-0.11.2.tm} (94%) rename src/vfs/_vfscommon.vfs/modules/punk/args/moduledoc/{tclcore-0.2.0.tm => tclcore-0.3.3.tm} (99%) rename src/vfs/_vfscommon.vfs/modules/punk/{lib-0.4.0.tm => lib-0.4.3.tm} (98%) rename src/vfs/_vfscommon.vfs/modules/punk/{ns-0.2.0.tm => ns-0.5.0.tm} (97%) rename src/vfs/_vfscommon.vfs/modules/punk/{repl-0.5.0.tm => repl-0.5.1.tm} (99%) diff --git a/src/vfs/_vfscommon.vfs/modules/punk-0.2.3.tm b/src/vfs/_vfscommon.vfs/modules/punk-0.2.6.tm similarity index 99% rename from src/vfs/_vfscommon.vfs/modules/punk-0.2.3.tm rename to src/vfs/_vfscommon.vfs/modules/punk-0.2.6.tm index b683f955..c623c2e3 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk-0.2.3.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk-0.2.6.tm @@ -8494,7 +8494,12 @@ namespace eval punk { } #keep help-text lines manually folded (~70 cols) - the usage tables don't yet #wrap to terminal width, so line lengths here directly set the table width - set basehelp {Help system for the punk shell. + #help text is authored as indented blocks (structural leading newline) and + #the generated definition declares @normalize (G-045): block-form + #multi-line values are re-based to the file-style convention at resolve + #time - no manual undent/trim and no left-margin authoring in this builder + set basehelp { + Help system for the punk shell. With no arguments - an overview of some key shell commands is displayed. When the first argument is a recognised topic - help @@ -8504,12 +8509,19 @@ 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.\nTopics accept their aliases and unique prefixes\n(some short words deliberately fall through to command lookup)." + set topichelp { + Help topic, or command words for basic command info. + Topics accept their aliases and unique prefixes + (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." + lappend specs ::punk::help_chunks punk::help_chunks "Punk shell help system - content as {channel text} chunks." { + + help_chunks returns the help content as a list of + {channel text} chunks rather than emitting it.} foreach {id name summary extra} $specs { set def "" + append def "@normalize" \n 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 @@ -8604,7 +8616,11 @@ namespace eval punk { warnings for known Tcl bugs affecting this interpreter and known bugs in bundled library packages (as detected by the punk::lib::check::has_tclbug_* - and has_libbug_* checks)." + and has_libbug_* checks). + A warning whose buginfo reports a shipped punkshell + mitigation keeps its severity level but is annotated + '(mitigated)' and rendered subdued (grey), with the + mitigation described." @values -min 0 -max 0 } proc tcl {context args} { @@ -8627,17 +8643,36 @@ namespace eval punk { if {[dict exists $buginfo level]} { set level [dict get $buginfo level] } - switch -- $level { - minor {set highlight [punk::ansi::a+ cyan]} - medium {set highlight [punk::ansi::a+ yellow]} - major {set highlight [punk::ansi::a+ red bold]} - default {set highlight ""} + #mitigated is an axis orthogonal to level: the defect keeps its severity + #classification but a shipped punkshell mitigation covers it, so the + #warning renders subdued (grey) with a '(mitigated)' annotation and any + #mitigation text from the buginfo dict. + set mitigated 0 + if {[dict exists $buginfo mitigated]} { + set mitigated [dict get $buginfo mitigated] + } + if {$mitigated} { + set highlight [punk::ansi::a+ term-grey] + } else { + switch -- $level { + minor {set highlight [punk::ansi::a+ cyan]} + medium {set highlight [punk::ansi::a+ yellow]} + major {set highlight [punk::ansi::a+ red bold]} + default {set highlight ""} + } + } + set levelshown $level + if {$mitigated} { + append levelshown " (mitigated)" } set indent " " - append warningblock \n $highlight "warning level: $level $bp triggered." + append warningblock \n $highlight "warning level: $levelshown $bp triggered." if {[dict exists $buginfo description]} { append warningblock \n "[punk::lib::indent [dict get $buginfo description] $indent]" } + if {[dict exists $buginfo mitigation] && [dict get $buginfo mitigation] ne ""} { + append warningblock \n "[punk::lib::indent "mitigated: [dict get $buginfo mitigation]" $indent]" + } if {[dict exists $buginfo url] && [dict get $buginfo url] ne ""} { #full reference url (e.g. non tcl-core trackers such as tcludp) append warningblock \n "${indent}see [punk::ansi::hyperlink [dict get $buginfo url]]" @@ -9403,7 +9438,7 @@ punkcheck::cli set_alias punkcheck package provide punk [namespace eval punk { #FUNCTL variable version - set version 0.2.3 + set version 0.2.6 }] diff --git a/src/vfs/_vfscommon.vfs/modules/punk/args-0.6.0.tm b/src/vfs/_vfscommon.vfs/modules/punk/args-0.11.2.tm similarity index 94% rename from src/vfs/_vfscommon.vfs/modules/punk/args-0.6.0.tm rename to src/vfs/_vfscommon.vfs/modules/punk/args-0.11.2.tm index 233dd0d3..5622a59d 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/args-0.6.0.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/args-0.11.2.tm @@ -8,7 +8,7 @@ # (C) 2024 # # @@ Meta Begin -# Application punk::args 0.6.0 +# Application punk::args 0.11.2 # Meta platform tcl # Meta license # @@ Meta End @@ -18,7 +18,7 @@ # doctools header # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #*** !doctools -#[manpage_begin punkshell_module_punk::args 0 0.6.0] +#[manpage_begin punkshell_module_punk::args 0 0.11.2] #[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 --}] @@ -683,6 +683,61 @@ tcl::namespace::eval punk::args { can be left entirely as documentation for interactive use with: i ... and for synopsis generation with: s ... + %B%Registration styles%N% + There are two ways for a package to provide definitions: + + 1) Direct calls to punk::args::define. The raw text is stored + immediately (parsing to the specifications dictionary still + happens lazily on first use). + + 2) Deferred registration: append definition text-block lists to + a namespace variable named PUNKARGS and add the namespace to the + public list variable punk::args::register::NAMESPACES. + Nothing is processed at load time. On the first id lookup that + misses (e.g punk::args::parse ... withid, or the i/s help + commands - via punk::args::update_definitions) registered + namespaces are scanned cheaply for @id values, and the + namespace's definitions are defined on demand. + This is the style used by the module templates (dev module.new) + and by the punk::args::moduledoc::* packages - which document + OTHER packages' commands (the scan records which namespaces each + registered namespace documents). Prefer it for anything large: + a package with many or lengthy definitions then adds essentially + nothing to load time. Command-id aliases can similarly be + registered in a PUNKARGS_aliases variable (list of + {aliasid id} pairs). + Per-namespace scan/load timings are visible via + punk::args::status. + + %B%Interpolation (tstr placeholders) and the defspace%N% + \$\{...\} placeholders in definition text use + punk::args::lib::tstr semantics, but WHEN they are expanded + depends on the field: + - display-only fields (-help of @cmd/@examples/arguments, + @formdisplay -header/-body) are deferred and expanded at + display time. + - all other (parse-relevant) fields are expanded when the + definition is first resolved. + - @dynamic definitions re-expand on every resolve. + Expansion happens in the definition's 'defspace' namespace: + for a direct define call, the calling namespace; for registered + PUNKARGS, the namespace's argdoc child IF IT EXISTS, otherwise + the namespace itself. This applies even when the PUNKARGS + variable itself is in the parent: a variable set in the parent + namespace is not visible to placeholder expansion when an + argdoc child exists. + A placeholder that cannot be resolved is currently left literal + in the field without warning - if a literal \$\{...\} shows up + in a parsed spec or rendered help, check the defspace. + For values computed once at package load (e.g a capability or + enumeration harvested from the runtime), the robust patterns + are: pre-expand the block explicitly + (punk::args::define \[punk::args::lib::tstr -return string {...}\]), + substitute a plain token at build time + (\[string map \[list %TOKEN% $val\] {...}\]), + or set the variable in the argdoc namespace. + Use @dynamic only when the value can change between resolves. + The definition should usually contain an initial line of the form: @id -id ::somecmd Blank lines are ignored at the top level, ie if they are not part of another structure. @@ -694,6 +749,14 @@ tcl::namespace::eval punk::args { The line continuation character (\\ at the end of the line) can be used to continue the set of arguments for a leading word. + The record-continuation token -& does the same job when it appears unquoted + as the last element on a line (trailing whitespace after it is tolerated): + the record continues on the next line, exactly as with a trailing \\. + Unlike a backslash, -& survives inside constructed (string-built) + definitions, where the building code's own quoting would consume a + backslash-newline. To pass a literal -& as a trailing value, brace or + quote it (e.g -default {-&}); a -& elsewhere on a line, or inside a braced + or quoted multi-line value, is ordinary data. Leading words beginning with the @ character are directives controlling argument parsing, defaults for subsequent arguments, and help display. directives include: @@ -706,6 +769,27 @@ tcl::namespace::eval punk::args { fields depend on values that can change after definition time. Dynamic definitions have a small performance cost and can interact with punk::args::parse -cache 1; see the parse -cache option. + %B%@normalize%N% + Bare directive (no options), conventionally placed near the top. + Opts the definition into indent normalization of BLOCK-FORM + multi-line field values - values whose first line is + whitespace-only, as authored by opening a braced literal with a + newline and indenting the content as a block. For such values the + structural first newline (and a whitespace-only trailing line) + are dropped, the content lines' common leading whitespace is + taken as the block's base indent, the first content line is + unindented fully and subsequent lines are re-based to the + standard 4-space continuation convention with deeper relative + indents preserved. + Head-form values (content starting on the first line) are never + altered: their base indent is ambiguous (uniform indent may be + deliberate relative convention), and they already follow the + absolute 4-space convention - so the directive is harmless on + conforming file-style definitions. + Fields named in a record's -unindentedfields are exempt. + Intended for constructed (string-built) definitions, which do not + get the whole-block indent treatment braced file-style sources + give records. %B%@id%N% ?opt val...? directive-options: -id %B%@cmd%N% ?opt val...? @@ -1037,6 +1121,8 @@ tcl::namespace::eval punk::args { should have their value strings placed with reference to the left margin in the source code. ie all whitespace in the source is preserved. + Valid on argument lines (e.g -help, -choicelabels) and on the + @cmd directive (-help). -minsize (type dependant) -maxsize (type dependant) -mincap {only valid for regex type - min number of captures} @@ -1050,10 +1136,26 @@ tcl::namespace::eval punk::args { For the @examples directive this is the text for examples as displayed with 'eg ' The -help string can be delimited with double quotes or with - curly braces, the choice will affect what inner chars require - backslash escaping - but neither type of help block is - automatically subject to variable or command substitution aside - from those specifically wrapped in placeholders. + curly braces. The container determines the quoting rules, + which apply to multi-line field values generally: + + Braced {...} values are fully literal: $, [] and backslash + sequences all survive as typed (\\n stays two characters, + and a bare backslash as in \\Deleted keeps its backslash). + Only tstr placeholders (when \$\{...\} content is present + anywhere in the definition block) and their backslash + escape are special. + + Double-quoted \"...\" values get Tcl backslash semantics + at record parse: \\n becomes a real newline and \\\\ + collapses to a single backslash - while $ and [] remain + literal. No variable or command substitution is performed + on record content outside \$\{...\} tstr placeholders. + + In a tstr-processed block, escaping the placeholder's + dollar sign and braces with backslashes renders a literal + placeholder - the idiom used for the \$\{...\} examples + throughout this help text. For cases where unbalanced braces, double quotes are to be displayed to the user without visible backslash escapes, @@ -1369,7 +1471,16 @@ tcl::namespace::eval punk::args { } set record_id 0 set record_line 0 ;#incremented at each incomplete record, set to zero after processing a complete record + set amp_trimnext 0 ;#previous line ended with the -& record-continuation token (G-045) foreach rawline $linelist { + if {$amp_trimnext} { + #the previous line ended with the -& record-continuation token and + #linebuild already ends with the joining space: collapse this line's + #leading whitespace, as the Tcl parser does for a backslash-newline + #continuation + set rawline [tcl::string::trimleft $rawline] + set amp_trimnext 0 + } set record_so_far [tcl::string::cat $linebuild $rawline] #ansi colours can stop info complete from working (contain square brackets) #review - when exactly are ansi codes allowed/expected in record lines. @@ -1404,6 +1515,24 @@ tcl::namespace::eval punk::args { incr record_line } else { #either we're on a single line record, or last line of multiline record + #G-045 record continuation: an unquoted trailing -& element continues + #the record on the next line. The token is dropped and the next line + #joins after a single space with its leading whitespace collapsed - + #exactly how the Tcl parser joins a backslash-newline continuation + #before a braced definition ever reaches this splitter - so a -& record + #assembles byte-identical to its backslash-continued equivalent. + #(Constructed/string-built definitions cannot author backslash-newline + #ergonomically - the building code's own quoting consumes it - which is + #what -& is for.) Rules: the token must be a bare word preceded by + #whitespace, or be the whole line; trailing whitespace after it is + #tolerated. A braced or double-quoted -& never matches (the raw line + #then ends with the closing delimiter) - brace a literal trailing -& + #value: {-&}. A -& inside a still-open braced/quoted value is data + #(info complete is false for those lines - handled in the branch above). + set is_ampcontinuation [regexp {(?:^|\s)-&\s*$} $rawline] + if {$is_ampcontinuation} { + regsub {\s*-&\s*$} $rawline "" rawline + } if {$record_line != 0} { if {[tcl::string::first $record_base_indent $rawline] == 0} { set trimmedline [tcl::string::range $rawline [tcl::string::length $record_base_indent] end] @@ -1414,12 +1543,23 @@ tcl::namespace::eval punk::args { } else { append linebuild $rawline } - lappend records $linebuild - set linebuild "" - #prep for next record - set in_record_continuation 0 - incr record_id - set record_line 0 + if {$is_ampcontinuation} { + #record continues on the next line + append linebuild " " + set amp_trimnext 1 + if {$record_line == 0} { + regexp {(\s*).*} $rawline _all record_base_indent + set in_record_continuation 1 + } + incr record_line + } else { + lappend records $linebuild + set linebuild "" + #prep for next record + set in_record_continuation 0 + incr record_id + set record_line 0 + } } } if {$in_record_continuation} { @@ -1429,6 +1569,124 @@ tcl::namespace::eval punk::args { return $records } + proc private::rebase_multiline_value {value} { + #G-045 @normalize: re-base a BLOCK-FORM multi-line field value to the + #file-style continuation convention. Block form = the first line is + #whitespace-only (the value was authored as an indented block, e.g. a braced + #literal opening with a newline). The structural first newline (and a + #whitespace-only trailing line) are dropped, the common leading whitespace of + #the content lines is the block's base indent: the first content line is + #unindented fully and subsequent lines have the base replaced with 4 spaces + #(deeper relative indents preserved). Whitespace-only inner lines become + #empty lines. + #Head-form values (content on the first line) are returned UNCHANGED: their + #base indent is unknowable - a value whose continuations sit uniformly at 6 + #may be base-4 with the deliberate +2 relative convention, or base-6 flush; + #re-basing would flatten the former. Head-form values follow the standard + #absolute convention (continuations at 4 + relative extras) as always, which + #also makes @normalize a no-op on conforming file-style definitions. + set lines [split $value \n] + if {[llength $lines] < 2} { + return $value + } + if {[tcl::string::trim [lindex $lines 0]] ne ""} { + #head form - unchanged + return $value + } + set lines [lrange $lines 1 end] + if {[llength $lines] > 1 && [tcl::string::trim [lindex $lines end]] eq ""} { + set lines [lrange $lines 0 end-1] + } + set prefix "" + set have_prefix 0 + foreach ln $lines { + if {[tcl::string::trim $ln] eq ""} {continue} + regexp {^[ \t]*} $ln thisprefix + if {!$have_prefix} { + set prefix $thisprefix + set have_prefix 1 + } else { + while {$prefix ne "" && [tcl::string::first $prefix $ln] != 0} { + set prefix [tcl::string::range $prefix 0 end-1] + } + } + if {$have_prefix && $prefix eq ""} {break} + } + if {!$have_prefix} { + #no content lines - degenerate block, structural lines dropped + return [join $lines \n] + } + set plen [tcl::string::length $prefix] + set out [list] + set done_first 0 + foreach ln $lines { + if {[tcl::string::trim $ln] eq ""} { + lappend out "" + } elseif {!$done_first} { + #first content line - unindent fully (it starts with the common prefix) + lappend out [tcl::string::range $ln $plen end] + set done_first 1 + } else { + lappend out " [tcl::string::range $ln $plen end]" + } + } + return [join $out \n] + } + + proc private::normalize_records {records} { + #G-045 @normalize pre-pass (value semantics in rebase_multiline_value). + #Records are list-shaped (resolve consumes them via lassign), so a record is + #rewritten as a canonical list only when one of its values changed; fields + #named in the record's own -unindentedfields are exempt. Malformed records + #pass through untouched - resolve's record loop raises the real errors. + set out [list] + foreach rec $records { + set trimrec [tcl::string::trim $rec] + switch -- [tcl::string::index $trimrec 0] { + "" - # { + lappend out $rec + continue + } + } + if {[tcl::string::first \n $rec] < 0} { + lappend out $rec + continue + } + if {[catch {set recvalues [lassign $trimrec firstword]}]} { + lappend out $rec + continue + } + if {[llength $recvalues] % 2 != 0} { + lappend out $rec + continue + } + if {[dict exists $recvalues -unindentedfields]} { + set unindented [dict get $recvalues -unindentedfields] + } else { + set unindented {} + } + set newrec [list $firstword] + set changed 0 + foreach {k v} $recvalues { + if {$k ni $unindented && [tcl::string::first \n $v] >= 0} { + set nv [rebase_multiline_value $v] + if {$nv ne $v} { + set changed 1 + } + lappend newrec $k $nv + } else { + lappend newrec $k $v + } + } + if {$changed} { + lappend out $newrec + } else { + lappend out $rec + } + } + return $out + } + proc private::classify_display_tokens {placeholdertext tokenlist} { #G-046: return the subset of tokenlist whose tokens land in display-only field #values. Display-only: -help on @cmd/@examples and on argument records, and @@ -1894,7 +2152,14 @@ tcl::namespace::eval punk::args { tcl::dict::set argdefcache_unresolved $cache_key [list {*}$pt_params $deferred_display] } else { #wasn't really a 'dynamic' definition - no 2nd round parameter substitution in definition - puts stderr "punk::args::resolve - bad @dynamic tag for id:$id - no 2nd round substitution required" + #(@dynamic is not a complete no-op for such a definition: deferred + # display fields still re-expand per render instead of caching) + puts stderr "punk::args::resolve - bad @dynamic tag for id:$id - no 2nd round substitution required (for this definition @dynamic only forces display-field re-expansion per render - remove it if that is not intended)" + #Cache as a zero-param unresolved entry so subsequent resolves take the + #cached branch above: no re-mask/re-tstr of round 1 (the same round-1 + #freezing legitimately dynamic definitions get) and this warning emits + #once per definition instead of on every resolve. + tcl::dict::set argdefcache_unresolved $cache_key [list [list $optionspecs] {} $deferred_display] } @@ -1951,6 +2216,17 @@ tcl::namespace::eval punk::args { set records [private::split_definition_records $optionspecs] + #G-045: a bare @normalize directive record opts the whole definition into + #indent normalization of multi-line field values - the treatment constructed + #(string-built) definitions don't otherwise get. Pre-pass, so values are + #already re-based when the record loop below processes them. + foreach rec $records { + if {[tcl::string::trim $rec] eq "@normalize"} { + set records [private::normalize_records $records] + break + } + } + set cmd_info {} set package_info {} set id_info {} ;#e.g -children ?? @@ -1988,12 +2264,14 @@ tcl::namespace::eval punk::args { incr record_number #after first word, the remaining list elements up to the first newline that isn't inside a value, form a dict if {[catch {set record_values [lassign $trimrec firstword]}]} { - puts stdout "----------------------------------------------" - puts stderr "rec: $rec" - set ::testrecord $rec - puts stdout "----------------------------------------------" - puts "records: $records" - puts stdout "==============================================" + #dev diagnostics for the malformed record - commented per the stray-debug + #convention; the raised message carries the offending record + #puts stdout "----------------------------------------------" + #puts stderr "rec: $rec" + #set ::testrecord $rec + #puts stdout "----------------------------------------------" + #puts "records: $records" + #puts stdout "==============================================" error "punk::args::resolve - bad optionspecs line - unable to parse first word of record '$trimrec' id:$DEF_definition_id" } #set record_values [lassign $trimrec firstword] @@ -2077,6 +2355,13 @@ tcl::namespace::eval punk::args { dynamic { set is_dynamic 1 } + normalize { + #G-045 - applied as a pre-pass over the split records (values + #are already re-based by the time this arm is reached) + if {[llength $at_specs]} { + error "punk::args::resolve - @normalize takes no options @id:$DEF_definition_id" + } + } id { #disallow duplicate @id line ? #review - nothing to stop multiple @id lines - or redefining as auto (which is ignored?) @@ -2676,7 +2961,7 @@ tcl::namespace::eval punk::args { set examples_info [dict merge $examples_info $at_specs] } default { - error "punk::args::resolve - unrecognised @ line in '$rec'. Expected @id @cmd @form... @leaders @opts @values @doc @examples @formdisplay - use @@name if paramname needs to be @name @id:$DEF_definition_id" + error "punk::args::resolve - unrecognised @ line in '$rec'. Expected @id @cmd @form... @leaders @opts @values @doc @examples @formdisplay @normalize - use @@name if paramname needs to be @name @id:$DEF_definition_id" } } #record_type directive @@ -4873,24 +5158,12 @@ tcl::namespace::eval punk::args { } } set formnames [dict get $spec_dict form_names] - if {[string is integer -strict $form]} { - if {$form < 0 || $form > [llength $formnames]-1} { - set arg_error_isrunning 0 - error "arg_error invalid value for option -form. Received '$v' Allowed values 0-[expr {[llength $formnames]-1}] or one of '$formnames'" - } - set selected_forms [list [lindex $formnames $form]] - } else { - if {$form eq "*"} { - set selected_forms $formnames - } else { - set fmatch [tcl::prefix::match -error "" $formnames $form] - if {$fmatch ne ""} { - set selected_forms [list $fmatch] - } else { - set arg_error_isrunning 0 - error "arg_error invalid value for option -form. Received '$v' Allowed values 0-[expr {[llength $formnames]-1}] or one of '$formnames'" - } - } + #G-041: -form accepts a list of form names/indices - supplied order is preserved + #(the first selected form is the one the argument table renders; all selected + #forms have their synopsis entries marked) + if {[catch {private::form_selection $formnames $form "arg_error"} selected_forms]} { + set arg_error_isrunning 0 + error "arg_error invalid value for option -form. Received '$form' Allowed values 0-[expr {[llength $formnames]-1}] or one of '$formnames'" } @@ -4965,9 +5238,13 @@ tcl::namespace::eval punk::args { set cmdsummary [Dict_getdef $spec_dict cmd_info -summary ""] set cmdhelp [Dict_getdef $spec_dict cmd_info -help ""] #=========== - #unindentedfields ? - set maxundent 4 - set cmdhelp [punk::lib::undent " $cmdhelp" $maxundent] + #@cmd -unindentedfields {-help} means the help text is authored at the left + #margin: skip the display-time indent transform (goal G-045; same gate as + #argument -help below) + if {"-help" ni [Dict_getdef $spec_dict cmd_info -unindentedfields {}]} { + set maxundent 4 + set cmdhelp [punk::lib::undent " $cmdhelp" $maxundent] + } #=========== set docname [Dict_getdef $spec_dict doc_info -name "Manual:"] @@ -6126,6 +6403,12 @@ tcl::namespace::eval punk::args { to another procedure which also requires solos, because the opts dict contains solo flags with a 1 value or a list of 1's if it was a solo with -multiple true specified. + + The form key records the name of the form the arguments were parsed against + (multiform definitions declare forms with the @form directive - see + punk::args::define). When -form permits several forms, the form that + auto-selection settled on is reported here, and a formstatus key is added + recording each attempted form's outcome (see punk::args::parse_status). } @form -form {withid withdef} @leaders -min 1 -max 1 @@ -6137,7 +6420,16 @@ tcl::namespace::eval punk::args { "Restrict parsing to the set of forms listed. Forms are the orthogonal sets of arguments a command can take - usually described in 'synopsis' - entries." + entries. Each list element is an ordinal index or + a form name. + With the default * (or a multi-form selection) the + arguments are attempted against each permitted form: + a clean match against exactly one form is + auto-selected (the result's 'form' key records it), + no match raises an error naming each candidate + form's failure, and matches against several forms + raise an error naming them - pass a single form to + disambiguate." #default to enhanced errorstyle despite slow 'catch' (unhappy path) performance #todo - configurable per interp/namespace -errorstyle -type string -default enhanced -choices {enhanced standard basic minimal} @@ -6312,6 +6604,24 @@ tcl::namespace::eval punk::args { } else { set msg [string map [list %caller% [Get_caller]] $msg] } + #G-041: display-form selection for the usage render. For the multi-form + #candidacy failures the engine reports, show the candidate forms rather than + #the caller's (usually *) -form selection - best candidate first so its + #argument table renders (arg_error marks all listed forms in the synopsis). + set displayform [dict get $opts -form] + set classinfo [lindex $ecode 2] + switch -- [lindex $classinfo 0] { + noformmatch { + set failuredict [lrange $ecode 3 end] + if {[dict exists $failuredict -formerrors]} { + #ranked best-first at raise time (see rank_form_failures) + set displayform [dict keys [dict get $failuredict -formerrors]] + } + } + multipleformmatches { + set displayform [Dict_getdef [lrange $classinfo 1 end] forms $displayform] + } + } switch -- $matched_errorstyle { minimal { #return -options [list -code error -errorcode $ecode] $msg @@ -6323,7 +6633,7 @@ tcl::namespace::eval punk::args { set argspecs [Dict_getdef $customdict -argspecs ""] set badarg [Dict_getdef $customdict -badarg ""] if {$argspecs ne ""} { - set msg [arg_error $msg $argspecs -aserror 0 -return string -badarg $badarg -form [dict get $opts -form]] + set msg [arg_error $msg $argspecs -aserror 0 -return string -badarg $badarg -form $displayform] } #return -options [list -code error -errorcode $ecode] $msg set elist [list -options [list -code error -errorcode $ecode] $msg] @@ -6333,7 +6643,7 @@ tcl::namespace::eval punk::args { set argspecs [Dict_getdef $customdict -argspecs ""] set badarg [Dict_getdef $customdict -badarg ""] if {$argspecs ne ""} { - set msg [arg_error $msg $argspecs -aserror 0 -badarg $badarg -form [dict get $opts -form]] + set msg [arg_error $msg $argspecs -aserror 0 -badarg $badarg -form $displayform] } #return -options [list -code error -errorcode $ecode] $msg set elist [list -options [list -code error -errorcode $ecode] $msg] @@ -6352,7 +6662,7 @@ tcl::namespace::eval punk::args { append msg \n [punk::lib::showdict -roottype list $estack */*] } if {$argspecs ne ""} { - set msg [arg_error $msg $argspecs -aserror 0 -badarg $badarg -form [dict get $opts -form]] + set msg [arg_error $msg $argspecs -aserror 0 -badarg $badarg -form $displayform] append msg \n "::errorCode summary: $ecode_summary" #return -options [list -code error -errorcode $ecode] $msg set elist [list -options [list -code error -errorcode $ecode] $msg] @@ -6407,6 +6717,14 @@ tcl::namespace::eval punk::args { } return invalid } + noformmatch { + #G-041 multi-form candidacy: payload is: forms classes + #incomplete when some candidate form needs only more words + if {"incomplete" in [Dict_getdef $payload classes {}]} { + return incomplete + } + return invalid + } default { return invalid } @@ -6424,8 +6742,10 @@ tcl::namespace::eval punk::args { -message "" -errorcode "" -failureclass "" + -argfailureclass "" -badarg "" -parsedargs {} + -formstatus {} }] set opts [dict merge $defaults $args] set parsedargs [dict get $opts -parsedargs] @@ -6473,7 +6793,14 @@ tcl::namespace::eval punk::args { set received [llength $argpositions] if {$arg eq $badarg} { set status bad - set argfailclass [dict get $opts -failureclass] + #G-041: for the multi-form noformmatch failure the badarg belongs to the + #best-candidate form - its own failureclass (via -argfailureclass) is the + #accurate per-argument classification, the overall failureclass stays + #truthful to the errorcode + set argfailclass [dict get $opts -argfailureclass] + if {$argfailclass eq ""} { + set argfailclass [dict get $opts -failureclass] + } } elseif {$received > 0} { set status ok set argfailclass "" @@ -6504,31 +6831,152 @@ tcl::namespace::eval punk::args { } badarg $badarg {*}{ } id [Dict_getdef $spec_dict id ""] {*}{ } form $fid {*}{ + } formstatus [dict get $opts -formstatus] {*}{ } receivednames $receivednames {*}{ } argstatus $argstatus {*}{ }] } - #resolve the form name whose argument set parse-status per-argument entries cover - #(first form matching the -form selection - mirrors arg_error's display-form resolution) - proc private::parse_status_formname {spec_dict formselection} { - set formnames [dict get $spec_dict form_names] - set first [lindex $formselection 0] - if {$formselection eq "*" || $formselection eq ""} { - return [lindex $formnames 0] - } - if {[string is integer -strict $first]} { - set fid [lindex $formnames $first] - if {$fid ne ""} { - return $fid + #G-041: resolve a -form selection to a list of form names. + #formselection is * (all forms) or a list whose elements are each an ordinal index or + #a form name (prefix-matchable). Supplied order is preserved (first element is the + #primary/display form for consumers that need a single form), duplicates removed. + #Raises an error naming $errprefix for an unrecognised element. + proc private::form_selection {form_names formselection {errprefix punk::args}} { + if {$formselection eq "*" || $formselection eq "" || "*" in $formselection} { + return $form_names + } + set selected [list] + foreach f $formselection { + if {[string is integer -strict $f]} { + if {$f < 0 || $f > [llength $form_names]-1} { + error "$errprefix invalid -form value '$f' Expected int 0-[expr {[llength $form_names]-1}] or one of '$form_names'" + } + set fid [lindex $form_names $f] + } else { + set fid [tcl::prefix::match -error "" $form_names $f] + if {$fid eq ""} { + error "$errprefix invalid -form value '$f' Expected int 0-[expr {[llength $form_names]-1}] or one of '$form_names'" + } + } + if {$fid ni $selected} { + lappend selected $fid } - return [lindex $formnames 0] } - set fmatch [tcl::prefix::match -error "" $formnames $first] - if {$fmatch ne ""} { - return $fmatch + return $selected + } + + #G-041: leading-discriminator affinity of a form for the supplied words - the ranking + #signal for candidate forms when no form parses cleanly (many multiform commands + #discriminate on a leading literal word, e.g 'after cancel id'). + #Walks the form's leading run of required single-member discriminator arguments + #(leaders then values) against the corresponding words: +1 per agreement, and a large + #negative on the first disagreement (the form's discriminator word was not supplied). + #A discriminator is a literal(x)/literalprefix(x) type-alternate or a RESTRICTED + #choice set (the tclcore models express subcommand-ish literals as -choices) - + #choice words matched via choiceword_match, the shared G-040 resolver, so ranking + #agreement cannot diverge from parse acceptance. + #Heuristic for ranking/display only - candidacy itself always comes from real parse + #attempts. Known limit (recorded in G-041): no word alignment through received + #options - the walk stops at the first non-discriminator argument. + proc private::form_literal_affinity {argspecs fid rawargs} { + set formdict [dict get $argspecs FORMS $fid] + set ARG_INFO [dict get $formdict ARG_INFO] + set score 0 + set widx 0 + foreach argname [list {*}[dict get $formdict LEADER_NAMES] {*}[dict get $formdict VAL_NAMES]] { + if {$widx >= [llength $rawargs]} { + break + } + if {[dict get $ARG_INFO $argname -optional]} { + break + } + set typelist [dict get $ARG_INFO $argname -type] + if {[llength $typelist] != 1} { + break + } + set tp [lindex $typelist 0] + if {[string match {\?*\?} $tp]} { + break + } + set word [lindex $rawargs $widx] + set is_discriminator 0 + set word_matched 0 + foreach alt [split $tp |] { + if {[string match {literal(*)} $alt]} { + set is_discriminator 1 + if {$word eq [string range $alt 8 end-1]} { + set word_matched 1 + break + } + } elseif {[string match {literalprefix(*)} $alt]} { + set is_discriminator 1 + set lit [string range $alt 14 end-1] + if {$word ne "" && [string equal -length [string length $word] $word $lit]} { + set word_matched 1 + break + } + } + } + if {!$is_discriminator} { + if {([dict exists $ARG_INFO $argname -choices] || [dict exists $ARG_INFO $argname -choicegroups]) + && [Dict_getdef $ARG_INFO $argname -choicerestricted 1]} { + set is_discriminator 1 + set cw_allchoices [list] + if {[dict exists $ARG_INFO $argname -choices]} { + set cw_allchoices [dict get $ARG_INFO $argname -choices] + } + if {[dict exists $ARG_INFO $argname -choicegroups]} { + dict for {_grp grpmembers} [dict get $ARG_INFO $argname -choicegroups] { + lappend cw_allchoices {*}$grpmembers + } + } + set cwm [choiceword_match $word\ + [Dict_getdef $ARG_INFO $argname -nocase 0]\ + $cw_allchoices\ + [Dict_getdef $ARG_INFO $argname -choicealiases {}]\ + [Dict_getdef $ARG_INFO $argname -choiceprefix 1]\ + [Dict_getdef $ARG_INFO $argname -choiceprefixdenylist {}]\ + [Dict_getdef $ARG_INFO $argname -choiceprefixreservelist {}]\ + ] + if {[dict get $cwm matched]} { + set word_matched 1 + } + } + } + if {!$is_discriminator} { + break + } + if {$word_matched} { + incr score + } else { + incr score -1000 + break + } + incr widx } - return [lindex $formnames 0] + return $score + } + + #G-041: order a formfailures dict (fid -> {status .. failureclass .. badarg .. message ..}) + #best-candidate first: literal affinity desc, then incomplete before invalid, then the + #incoming (declaration) order. Returns the re-ordered dict. + proc private::rank_form_failures {argspecs rawargs formfailures} { + set scored [list] + dict for {fid finfo} $formfailures { + set negaffinity [expr {-[form_literal_affinity $argspecs $fid $rawargs]}] + set classrank [expr {[dict get $finfo status] eq "incomplete" ? 0 : 1}] + lappend scored [list $fid $negaffinity $classrank] + } + #lsort is stable - sort least significant key first + set scored [lsort -integer -index 2 $scored] + set scored [lsort -integer -index 1 $scored] + set ranked [dict create] + foreach entry $scored { + set fid [lindex $entry 0] + dict set ranked $fid [dict get $formfailures $fid] + } + return $ranked } lappend PUNKARGS [list { @@ -6569,8 +7017,23 @@ tcl::namespace::eval punk::args { badarg empty | name of the offending/unfillable argument id the definition id form form name the per-argument statuses were built for - (the first form matching -form - the form usage - displays render) + (the form usage displays render). For multiform + definitions this is the parsed form when the parse + succeeded (auto-selected when -form permits several + - see punk::args::parse) and the best-candidate + form when no form matched (candidates ranked by + leading-literal affinity with the supplied words, + then incomplete before invalid, then declaration + order). + formstatus dict keyed by candidate form name - each value a + dict with at least the key 'status' + (valid | incomplete | invalid) and for failed + candidates failureclass, badarg and message. + Single-form parses report their one form; when + multi-form candidacy ran, every attempted form is + reported - partial-arglist consumers (e.g command + completion/hinting) can read per-form + compatibility from this key. receivednames received argument names normalized to definition argument names (opt aliases folded to their -alias|-name optionset) @@ -6663,7 +7126,13 @@ tcl::namespace::eval punk::args { punk::args::parse $args withid ::punk::args::parse_status } } - set fid [private::parse_status_formname $spec_dict [dict get $opts -form]] + #G-041: primary form of the caller's -form selection - the fallback display form + #when the parse outcome doesn't identify a better one (an invalid -form value is + #left to the parse call below to raise consistently) + if {[catch {private::form_selection [dict get $spec_dict form_names] [dict get $opts -form]} selected_forms]} { + set selected_forms [dict get $spec_dict form_names] + } + set fid [lindex $selected_forms 0] set caller [dict get $opts -caller] if {$caller eq ""} { #the frame walk parse would do by default names parse_status's own internal @@ -6684,6 +7153,35 @@ tcl::namespace::eval punk::args { set customdict [lrange $ecode 3 end] set badarg [Dict_getdef $customdict -badarg ""] set status [private::parse_status_classify $failureclass $payload] + #G-041 multi-form candidacy failures: the per-argument statuses are built for + #the best-candidate form (ranked at raise time), with its badarg and its own + #failureclass for the argument marking; formstatus carries every candidate. + set argfailureclass "" + set formstatus [dict create] + switch -- $failureclass { + noformmatch { + set formerrors [Dict_getdef $customdict -formerrors {}] + if {[dict size $formerrors]} { + set fid [lindex [dict keys $formerrors] 0] + set bestinfo [dict get $formerrors $fid] + set badarg [dict get $bestinfo badarg] + set argfailureclass [dict get $bestinfo failureclass] + set formstatus $formerrors + } + } + multipleformmatches { + set matchedforms [Dict_getdef $payload forms {}] + if {[llength $matchedforms]} { + set fid [lindex $matchedforms 0] + foreach mf $matchedforms { + dict set formstatus $mf [dict create status valid] + } + } + } + default { + set formstatus [dict create $fid [dict create status $status failureclass $failureclass badarg $badarg message $r]] + } + } #the -argspecs payload (the whole resolved spec) is display machinery - too bulky #for a status structure; keep the classification and the small custom keys set ecode_slim [lrange $ecode 0 2] @@ -6692,9 +7190,26 @@ tcl::namespace::eval punk::args { lappend ecode_slim $k $v } } - return [private::parse_status_build $spec_dict $fid -ok 0 -status $status -scheme error -message $r -errorcode $ecode_slim -failureclass $failureclass -badarg $badarg] + #engine-level per-form failure messages retain the %caller% placeholder - + #apply the same attribution the overall message received + dict for {ffid finfo} $formstatus { + if {[dict exists $finfo message]} { + dict set formstatus $ffid message [string map [list %caller% $caller] [dict get $finfo message]] + } + } + return [private::parse_status_build $spec_dict $fid -ok 0 -status $status -scheme error -message $r -errorcode $ecode_slim -failureclass $failureclass -argfailureclass $argfailureclass -badarg $badarg -formstatus $formstatus] } - return [private::parse_status_build $spec_dict $fid -ok 1 -status valid -scheme info -parsedargs $r] + #success - the parse result identifies the parsed form (auto-selected for + #multiform definitions - G-041) and, when candidacy ran, every candidate's status + set fid [Dict_getdef $r form $fid] + set formstatus [Dict_getdef $r formstatus [dict create $fid [dict create status valid]]] + #engine-level per-form failure messages retain the %caller% placeholder + dict for {ffid finfo} $formstatus { + if {[dict exists $finfo message]} { + dict set formstatus $ffid message [string map [list %caller% $caller] [dict get $finfo message]] + } + } + return [private::parse_status_build $spec_dict $fid -ok 1 -status valid -scheme info -parsedargs $r -formstatus $formstatus] } #return number of values we can assign to cater for variable length clauses such as: @@ -6844,7 +7359,7 @@ tcl::namespace::eval punk::args { set clause_member_optional 0 } set tp [string trim $tp ?] - puts "private::get_dict_can_assign_value: checking tp '$tp' against value '$rv'" + #puts "private::get_dict_can_assign_value: checking tp '$tp' against value '$rv'" switch -glob -- $tp { "literal(*" { set litmatch [string range $tp 8 end-1] @@ -6959,6 +7474,49 @@ tcl::namespace::eval punk::args { set tpidx 0 set newtypelist $thistype set has_choices [expr {[tcl::dict::exists $ARG_INFO $thisname -choices] || [tcl::dict::exists $ARG_INFO $thisname -choicegroups]}] + set choicescreen_applies 0 + if {$has_choices} { + #G-071: with a restricted choice set (the default) allocation SCREENS the + #candidate word against the choices rather than blanket-accepting - but + #ONLY where allocation has an alternative: optional arguments (and extra + #occurrences of -multiple arguments). Previously any word was consumed + #here whenever arity permitted, so an optional choice value (e.g the lseq + #'..'/'to' noise word) greedily took a word that belonged to later + #elements/clauses and the parse failed with a confusing trailing-choices + #error ('lseq 0 10 2' shape). The screen uses choiceword_match - the + #shared G-040 implementation - so allocation acceptance cannot diverge + #from parse acceptance (exact/alias/prefix/nocase semantics included); + #-choicemultiple words are screened per list member. For a REQUIRED + #argument the word must fill it regardless - rejecting here would only + #mask final validation's informative choiceviolation as a + #missingrequired* error, so required arguments are not screened. + #Final validation remains authoritative; the screen compares raw words + #(no ansistrip) - an ansi-wrapped choice word on an optional argument + #would be skipped here where validation would accept it (accepted edge - + #allocation errs toward yielding words onward). With -choicerestricted 0 + #any word remains allocatable (each tp in the clause then only validates + #values outside the choice-list). + if {[Dict_getdef $ARG_INFO $thisname -choicerestricted 1] + && ([tcl::dict::get $ARG_INFO $thisname -optional] + || ([tcl::dict::get $ARG_INFO $thisname -multiple] && $thisname in $namesreceived))} { + set choicescreen_applies 1 + set cw_allchoices [list] + if {[tcl::dict::exists $ARG_INFO $thisname -choices]} { + set cw_allchoices [tcl::dict::get $ARG_INFO $thisname -choices] + } + if {[tcl::dict::exists $ARG_INFO $thisname -choicegroups]} { + tcl::dict::for {_grp grpmembers} [tcl::dict::get $ARG_INFO $thisname -choicegroups] { + lappend cw_allchoices {*}$grpmembers + } + } + set cw_nocase [Dict_getdef $ARG_INFO $thisname -nocase 0] + set cw_prefix [Dict_getdef $ARG_INFO $thisname -choiceprefix 1] + 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 {}] + lassign [Dict_getdef $ARG_INFO $thisname -choicemultiple {1 1}] cw_cmmin cw_cmmax + } + } foreach tp $thistype { #usual case is a single tp (basic length-1 clause) - but tp may commonly have alternates eg int|literal(xxx) set v [lindex $all_remaining $alloc_count] @@ -6970,21 +7528,53 @@ tcl::namespace::eval punk::args { set tp [string trim $tp ?] set member_satisfied 0 + set member_choicechecked 0 if {$has_choices} { - #each tp in the clause is just for validating a value outside the choice-list when -choicerestricted 0 - set member_satisfied 1 + 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 member_satisfied [tcl::dict::get $cwm matched] + } else { + #-choicemultiple: the word is itself a list of choices - screen + #each member; count within the declared min/max (max -1 = no limit) + if {[catch {llength $v} v_len]} { + set member_satisfied 0 + } elseif {$v_len < $cw_cmmin || ($cw_cmmax > 0 && $v_len > $cw_cmmax)} { + set member_satisfied 0 + } 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] + if {![tcl::dict::get $cwm matched]} { + set member_satisfied 0 + break + } + } + } + } + } else { + #required argument with restricted choices (word must fill it - + #validation reports choice violations), or -choicerestricted 0 + #(each tp in the clause only validates values outside the + #choice-list) + set member_satisfied 1 + } } - if {!$member_satisfied} { + #category lists must exist even when the choice screen decided the member + #(the !member_satisfied blocks below consult their lengths) + set ctg_literals [list] + set ctg_literalprefixes [list] + set ctg_stringstartswith [list] + set ctg_stringendswith [list] + set ctg_other [list] + if {!$member_satisfied && !$member_choicechecked} { #----------------------------------------------------------------------------------- #first build category lists of any literal,literalprefix,stringstartwith,other # - set ctg_literals [list] - set ctg_literalprefixes [list] - set ctg_stringstartswith [list] - set ctg_stringendswith [list] - set ctg_other [list] #foreach tp_alternative [split $tp |] {} foreach tp_alternative [private::split_type_expression $tp] { #JJJJ @@ -9226,8 +9816,13 @@ tcl::namespace::eval punk::args { "list of arguments to parse against the definition" @opts -form -default * -help\ - "Ordinal index or name of the command form to parse against. - The default * considers all forms." + "Restrict parsing to the listed forms - a list whose elements are + each an ordinal index or name of a command form. + The default * attempts every form: an argument list cleanly + matching exactly one form is parsed against it (auto-selection), + matching none raises an error naming each candidate form's + failure, and matching several raises an error naming the + matching forms (pass a single form to disambiguate)." }] proc get_dict {deflist rawargs args} { #see arg_error regarding considerations around unhappy-path performance @@ -9301,27 +9896,83 @@ tcl::namespace::eval punk::args { #e.g id,FORMS,cmd_info,doc_info,package_info,seealso_info, instance_info,id_info,form_names # ----------------------------------------------- #we don't need all keys from argspecs - even if retrieving multiple as vars, generally faster than dict with - set FORMS [dict get $argspecs FORMS] set form_names [dict get $argspecs form_names] - - set opt_form [dict get $proc_opts -form] - if {$opt_form eq "*"} { - set selected_forms $form_names - } elseif {[string is integer -strict $opt_form]} { - if {$opt_form < 0 || $opt_form > [llength $form_names]-1} { - error "punk::args::get_dict invalid -form value '$opt_form' Expected int 0-[expr {[llength $form_names]-1}] or one of '$form_names'" + #G-041: -form accepts a list of form names/indices (default * = all forms) + set selected_forms [private::form_selection $form_names [dict get $proc_opts -form] "punk::args::get_dict"] + + if {[llength $selected_forms] == 1} { + return [private::get_dict_form $argspecs [lindex $selected_forms 0] $rawargs] + } + + #G-041 multi-form candidacy: attempt each selected form independently. + #Exactly one clean parse -> auto-selected. None -> a noformmatch error naming each + #candidate form's failure (ranked best-candidate first - see rank_form_failures). + #Several -> a multipleformmatches error: no silent preference between matching + #forms - callers with an intended form pass -form (decision recorded in G-041). + set matched [list] + set matchresult "" + set formfailures [dict create] + foreach fid $selected_forms { + if {[catch {private::get_dict_form $argspecs $fid $rawargs} fresult ropts]} { + set ecode [Dict_getdef $ropts -errorcode ""] + if {[lrange $ecode 0 1] ne [list PUNKARGS VALIDATION]} { + #not a per-form validation outcome (e.g definition error) - propagate + return -options $ropts $fresult + } + set classinfo [lindex $ecode 2] + set failureclass [lindex $classinfo 0] + dict set formfailures $fid [dict create\ + status [private::parse_status_classify $failureclass [lrange $classinfo 1 end]]\ + failureclass $failureclass\ + badarg [Dict_getdef [lrange $ecode 3 end] -badarg ""]\ + message [lindex [split $fresult \n] 0]\ + ] + } else { + lappend matched $fid + if {[llength $matched] == 1} { + set matchresult $fresult + } } - set selected_forms [list [lindex $form_names $opt_form]] - } else { - set fmatch [tcl::prefix::match -error "" $form_names $opt_form] - if {$fmatch eq ""} { - error "punk::args::get_dict invalid -form value '$opt_form' Expected int 0-[expr {[llength $form_names]-1}] or one of '$form_names'" + } + switch -- [llength $matched] { + 1 { + #auto-selected - report every candidate's status alongside the result + #(partial-arglist consumers e.g command completion want per-form + #compatibility, not only the winner - see G-044) + set formstatus [dict create] + foreach fid $selected_forms { + if {$fid eq [lindex $matched 0]} { + dict set formstatus $fid [dict create status valid] + } else { + dict set formstatus $fid [dict get $formfailures $fid] + } + } + dict set matchresult formstatus $formstatus + return $matchresult + } + 0 { + set formfailures [private::rank_form_failures $argspecs $rawargs $formfailures] + set candidate_fids [dict keys $formfailures] + set classes [lmap finfo [dict values $formfailures] {dict get $finfo status}] + set msg "Bad arguments for %caller%. No form of the command matches the supplied arguments. Candidate forms: $candidate_fids" + dict for {fid finfo} $formfailures { + append msg \n " form '$fid': [dict get $finfo message]" + } + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list noformmatch forms $candidate_fids classes $classes] -argspecs $argspecs -formerrors $formfailures]] $msg + } + default { + set msg "Ambiguous arguments for %caller%. The supplied arguments match more than one form: [join $matched {, }]. Use -form to select the intended form." + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list multipleformmatches forms $matched] -argspecs $argspecs]] $msg } - set selected_forms [list $fmatch] } + } - + #parse rawargs against a single form of a resolved definition - the raising engine + #body, extracted verbatim from get_dict when multi-form candidacy landed (G-041). + #argspecs is a RESOLVED spec dict (get_dict resolves the deflist in its caller's + #context before selecting forms - nothing here touches the caller's frame). + proc private::get_dict_form {argspecs fid rawargs} { #puts "-arg_info->$arg_info" set flagsreceived [list] ;#for checking if required flags satisfied set solosreceived [list] @@ -9337,9 +9988,7 @@ tcl::namespace::eval punk::args { # Handle leading positionals # todo - consider allowing last leading positional to have -multiple 1 but only if there exists an eopts marker later (--) ? - #todo - handle multiple fids? - set fid [lindex $selected_forms 0] - set formdict [dict get $FORMS $fid] + set formdict [dict get $argspecs FORMS $fid] # formdict keys: argspace ARG_INFO ARG_CHECKS LEADER_DEFAULTS LEADER_REQUIRED # LEADER_NAMES LEADER_MIN LEADER_MAX LEADER_TAKEWHENARGSMODULO LEADER_UNNAMED # LEADERSPEC_DEFAULTS LEADER_CHECKS_DEFAULTS OPT_DEFAULTS OPT_REQUIRED OPT_NAMES @@ -9589,7 +10238,7 @@ tcl::namespace::eval punk::args { incr tentative_idx } } - set assign_d [private::get_dict_can_assign_value 0 $tentative_pre_values 0 [list $leader_posn_name] $leadernames_seen $formdict] + set assign_d [get_dict_can_assign_value 0 $tentative_pre_values 0 [list $leader_posn_name] $leadernames_seen $formdict] set consumed [dict get $assign_d consumed] set resultlist [dict get $assign_d resultlist] set newtypelist [dict get $assign_d typelist] @@ -10530,13 +11179,13 @@ tcl::namespace::eval punk::args { set leadertypelist [tcl::dict::get $argstate $leadername -type] ;#often a single type, but can be a list of types (possibly with some optional) for a type that is a clause accepting multiple values. set leader_clause_size [llength $leadertypelist] - set assign_d [private::get_dict_can_assign_value $ldridx $leaders $nameidx $LEADER_NAMES $leadernames_received $formdict] + set assign_d [get_dict_can_assign_value $ldridx $leaders $nameidx $LEADER_NAMES $leadernames_received $formdict] set consumed [dict get $assign_d consumed] set resultlist [dict get $assign_d resultlist] set newtypelist [dict get $assign_d typelist] if {$consumed == 0} { if {[tcl::dict::get $argstate $leadername -optional]} { - puts stderr "get_dict cannot assign val:$ldr to leadername:$leadername leaders:$leaders (111)" + #puts stderr "get_dict cannot assign val:$ldr to leadername:$leadername leaders:$leaders (111)" #return -options [list -code error -errorcode [list PUNKARGS UNCONSUMED -argspecs $argspecs]] "private::get_dict_can_assign_value consumed 0 unexpected 1?" incr ldridx -1 set leadername_multiple "" @@ -10549,7 +11198,7 @@ tcl::namespace::eval punk::args { 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 } else { - puts stderr "get_dict cannot assign val:$ldr to leadername:$leadername (222)" + #puts stderr "get_dict cannot assign val:$ldr to leadername:$leadername (222)" #return -options [list -code error -errorcode [list PUNKARGS UNCONSUMED -argspecs $argspecs]] "private::get_dict_can_assign_value consumed 0 unexpected 2?" incr ldridx -1 set leadername_multiple "" @@ -10741,14 +11390,14 @@ tcl::namespace::eval punk::args { set valtypelist [tcl::dict::get $argstate $valname -type] set clause_size [llength $valtypelist] ;#common case is clause_size == 1 - set assign_d [private::get_dict_can_assign_value $validx $values $nameidx $VAL_NAMES $valnames_received $formdict] + set assign_d [get_dict_can_assign_value $validx $values $nameidx $VAL_NAMES $valnames_received $formdict] set consumed [dict get $assign_d consumed] ;#count set resultlist [dict get $assign_d resultlist] set newtypelist [dict get $assign_d typelist] if {$consumed == 0} { if {[tcl::dict::get $argstate $valname -optional]} { #error 333 - puts stderr "get_dict cannot assign val:$val to valname:$valname (333)" + #puts stderr "get_dict cannot assign val:$val to valname:$valname (333)" incr validx -1 set valname_multiple "" incr nameidx @@ -10761,7 +11410,7 @@ tcl::namespace::eval punk::args { return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list missingrequiredvalue $valname ] -badarg $valname -argspecs $argspecs]] $msg } else { #error 444 - puts stderr "get_dict cannot assign val:$val to valname:$valname (444)" + #puts stderr "get_dict cannot assign val:$val to valname:$valname (444)" incr validx -1 set valname_multiple "" incr nameidx @@ -11492,7 +12141,7 @@ tcl::namespace::eval punk::args { #todo - handle type-alternates e.g -type char|double #------------------------------------------------------------------------------------ #private::check_clausecolumn argname argclass thisarg thisarg_checks column default_type_expression list_of_clauses list_of_clauses_check list_of_clauses_typelist - private::check_clausecolumn $argname $argclass $thisarg $thisarg_checks $clausecolumn $type_expression $vlist $vlist_check $vlist_typelist $argspecs + check_clausecolumn $argname $argclass $thisarg $thisarg_checks $clausecolumn $type_expression $vlist $vlist_check $vlist_typelist $argspecs #------------------------------------------------------------------------------------ @@ -11546,7 +12195,10 @@ tcl::namespace::eval punk::args { } } set docid [dict get $argspecs id] - return [tcl::dict::create leaders $leaders_dict opts $finalopts values $values_dict received $received_posns solos $solosreceived multis $multisreceived id $docid] + #G-041: form records the parsed form (auto-selected for multiform definitions). + #Positional consumers (lassign [dict values ...]) rely on the first keys - new + #keys are appended after id. + return [tcl::dict::create leaders $leaders_dict opts $finalopts values $values_dict received $received_posns solos $solosreceived multis $multisreceived id $docid form $fid] } lappend PUNKARGS [list { @@ -11866,12 +12518,16 @@ tcl::namespace::eval punk::args { } append syn "## $GRY$formsummary$RST\n" } - append syn "$id" + #the form's synopsis line is assembled in formline so a @form -synopsis + #override can replace it wholesale (G-041 adjacent fix - the override was + #documented and stored in the spec but ignored by this renderer; arg_error's + #synopsis section already honoured it) + set formline "$id" set FORMARGS [list] foreach argname [dict get $forminfo LEADER_NAMES] { set display [private::synopsis_form_arg_display $forminfo $argname] - append syn " $display" + append formline " $display" set arginfo [dict get $forminfo ARG_INFO $argname] set ARGD [dict create argname $argname class leader] @@ -12087,7 +12743,7 @@ tcl::namespace::eval punk::args { #} #todo -mash - append syn " $display" + append formline " $display" dict set ARGD type [dict get $arginfo -type] dict set ARGD optional [dict get $arginfo -optional] dict set ARGD multiple [dict get $arginfo -multiple] @@ -12105,7 +12761,7 @@ tcl::namespace::eval punk::args { set arginfo [dict get $forminfo ARG_INFO $argname] set display [private::synopsis_form_arg_display $forminfo $argname] - append syn " $display" + append formline " $display" set ARGD [dict create argname $argname class value] dict set ARGD type [dict get $arginfo -type] dict set ARGD optional [dict get $arginfo -optional] @@ -12122,7 +12778,7 @@ tcl::namespace::eval punk::args { #accepts unnamed extra arguments e.g toplevel docid for ensembles and ensemble-like commands if {[dict get $forminfo VAL_UNNAMED]} { set display {[...]} - append syn " $display" + append formline " $display" set ARGD [dict create argname "" class value] dict set ARGD type any dict set ARGD optional 1 @@ -12130,7 +12786,13 @@ tcl::namespace::eval punk::args { dict set ARGD display $display lappend FORMARGS $ARGD } - append syn \n + if {[Dict_getdef $forminfo -synopsis ""] ne ""} { + #an explicit @form -synopsis override replaces the auto-calculated line + #(FORMARGS still describes the definition's arguments for dict consumers) + set formline [dict get $forminfo -synopsis] + dict set SYND FORMS $f synopsis $formline + } + append syn $formline \n dict set SYND FORMS $f args $FORMARGS } switch -- $opt_return { @@ -12144,6 +12806,11 @@ tcl::namespace::eval punk::args { } set FORMS [dict get $SYND FORMS] dict for {form arginfo} $FORMS { + if {[dict exists $arginfo synopsis]} { + #@form -synopsis override - already the compact authored line + append summary [dict get $arginfo synopsis] \n + continue + } set arglist [dict get $arginfo args] append summary $id set class_state leader @@ -13704,7 +14371,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.6.0 + set version 0.11.2 }] return diff --git a/src/vfs/_vfscommon.vfs/modules/punk/args/moduledoc/tclcore-0.2.0.tm b/src/vfs/_vfscommon.vfs/modules/punk/args/moduledoc/tclcore-0.3.3.tm similarity index 99% rename from src/vfs/_vfscommon.vfs/modules/punk/args/moduledoc/tclcore-0.2.0.tm rename to src/vfs/_vfscommon.vfs/modules/punk/args/moduledoc/tclcore-0.3.3.tm index e9aa41b9..b2753547 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/args/moduledoc/tclcore-0.2.0.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/args/moduledoc/tclcore-0.3.3.tm @@ -8,7 +8,7 @@ # (C) 2025 # # @@ Meta Begin -# Application punk::args::moduledoc::tclcore 0.2.0 +# Application punk::args::moduledoc::tclcore 0.3.3 # Meta platform tcl # Meta license MIT # @@ Meta End @@ -18,7 +18,7 @@ # doctools header # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #*** !doctools -#[manpage_begin punkshell_module_punk::args::moduledoc::tclcore 0 0.2.0] +#[manpage_begin punkshell_module_punk::args::moduledoc::tclcore 0 0.3.3] #[copyright "2025"] #[titledesc {punk::args definitions for tcl core commands}] [comment {-- Name section and table of contents description --}] #[moddesc {tcl core argument definitions}] [comment {-- Description at end of page heading --}] @@ -257,7 +257,7 @@ tcl::namespace::eval punk::args::moduledoc::tclcore { -summary\ "first start-of-word index after supplied index ${$I}start${$NI}"\ -help\ - "Returns the index of the first start-of-word location that occurs after a starting index start + {Returns the index of the first start-of-word location that occurs after a starting index start in the string str. A start-of-word location is defined to be the first word character following a non-word character. Returns -1 if there are no more start-of-word locations after the starting point. @@ -268,7 +268,7 @@ tcl::namespace::eval punk::args::moduledoc::tclcore { set idx [tcl_startOfNextWord $theString $idx]} { puts "Word start index: $idx" } - " + } @values -min 2 -max 2 str -type string start -type indexexpression @@ -4527,6 +4527,31 @@ tcl::namespace::eval punk::args::moduledoc::tclcore { ############################################################################################################################################################ + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + #the after-id shape is harvested from the RUNNING interpreter (G-054 technique; + #user-directed 2026-07-13, probe record in goals/G-055) rather than hard-coded: + #a scheduled command's id is "after#N" in all known releases (tclTimer.c + #"after#%d"), and the cancelid/info forms use it as their id discriminator so + #accept/reject parity follows the interpreter these docs load into. + #The probe is safe: create + immediately cancel - no event loop entry, no output, + #no lasting state. + #The harvested prefix is consumed via tstr ${$after_id_prefix} placeholders in the + #::after definition below. The variable MUST live in the argdoc namespace: that is + #the DEFSPACE registered PUNKARGS definitions resolve their placeholders in + #whenever an argdoc child exists - even when the PUNKARGS list itself is in the + #parent, as here - and an unresolvable param is left silently literal (see the + #'Interpolation and the defspace' section of the punk::args::define help). + namespace eval argdoc { + set after_id_prefix "after#" + if {![catch {after 999999 {}} _aip_id]} { + catch {after cancel $_aip_id} + if {[regexp {^(.+#)\d+$} $_aip_id -> _aip_prefix]} { + set after_id_prefix $_aip_prefix + } + } + unset -nocomplain _aip_id _aip_prefix + } + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- lappend PUNKARGS [list { #test of @form @id -id ::after @@ -4570,7 +4595,15 @@ tcl::namespace::eval punk::args::moduledoc::tclcore { @leaders -min 1 -max 1 cancel -choices {cancel} @values -min 1 -max 1 - id + #id typed by the harvested id shape: a word of any other shape belongs to the + #cancelscript form (real 'after cancel ' is a script-match no-op). + #An id-SHAPED word remains genuinely ambiguous with a script of the same text - + #real Tcl resolves that by id liveness at runtime (tries the id first, falls + #back to script match), which no static type expresses (goals/G-055 record). + id -type stringstartswith(${$after_id_prefix}) -typesynopsis id -help\ + "Identifier of the delayed command to cancel. + It must have been the return value from a previous + after command (${$after_id_prefix}N shaped)." #@form -form {cancelscript} -synopsis "after cancel script ?script...?" @@ -4593,7 +4626,13 @@ tcl::namespace::eval punk::args::moduledoc::tclcore { @leaders -min 1 -max 1 info -choices {info} -choiceprefixreservelist {idle} @values -min 0 -max 1 - id -optional 1 + #real 'after info ' errors at runtime ("event ... doesn't + #exist") - the model's shape rejection keeps error-vs-ok parity + id -optional 1 -type stringstartswith(${$after_id_prefix}) -typesynopsis id -help\ + "Identifier of an existing event handler - the + return value from some previous call to after + (${$after_id_prefix}N shaped). It must not have triggered + yet or been canceled." } "@doc -name Manpage: -url [manpage_tcl after]"\ { @@ -4848,7 +4887,6 @@ tcl::namespace::eval punk::args::moduledoc::tclcore { return [punk::args::ensemble_subcommands_definition -groupdict $groups -columns 2 array] } lappend PUNKARGS [list { - @dynamic @id -id ::array @cmd -name "Built-in: array"\ -summary\ @@ -6463,7 +6501,6 @@ tcl::namespace::eval punk::args::moduledoc::tclcore { # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- lappend PUNKARGS [list { - @dynamic @id -id ::join @cmd -name "Built-in: join"\ -summary\ @@ -9299,7 +9336,6 @@ tcl::namespace::eval punk::args::moduledoc::tclcore { }]} } punk::args::define { - @dynamic @id -id ::split @cmd -name "Built-in: split"\ -summary\ @@ -12543,7 +12579,7 @@ namespace eval ::punk::args::register { package provide punk::args::moduledoc::tclcore [tcl::namespace::eval punk::args::moduledoc::tclcore { variable pkg punk::args::moduledoc::tclcore variable version - set version 0.2.0 + set version 0.3.3 }] return diff --git a/src/vfs/_vfscommon.vfs/modules/punk/lib-0.4.0.tm b/src/vfs/_vfscommon.vfs/modules/punk/lib-0.4.3.tm similarity index 98% rename from src/vfs/_vfscommon.vfs/modules/punk/lib-0.4.0.tm rename to src/vfs/_vfscommon.vfs/modules/punk/lib-0.4.3.tm index af1b9541..cac04588 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/lib-0.4.0.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/lib-0.4.3.tm @@ -8,7 +8,7 @@ # (C) 2024 # # @@ Meta Begin -# Application punk::lib 0.4.0 +# Application punk::lib 0.4.3 # Meta platform tcl # Meta license BSD # @@ Meta End @@ -18,7 +18,7 @@ # doctools header # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #*** !doctools -#[manpage_begin punkshell_module_punk::lib 0 0.4.0] +#[manpage_begin punkshell_module_punk::lib 0 0.4.3] #[copyright "2024"] #[titledesc {punk general utility functions}] [comment {-- Name section and table of contents description --}] #[moddesc {punk library}] [comment {-- Description at end of page heading --}] @@ -250,6 +250,63 @@ tcl::namespace::eval punk::lib::check { return [dict create bug $bug bugref e38dc74e2 description $description level medium] } + #G-076: version gate for the tcl9 dead-console defect (upstream ticket f10d91c2d3, root-caused + #in G-039). Shared by the 'help tcl' warning and the repl dead-console watchdog arming (both + #consult has_tclbug_console_deadspin). Empty = no released Tcl is known to contain the upstream + #fix, so every Tcl 9 windows runtime classifies as affected. Set this only after the G-039 kill + #procedure, re-run on the fixed released runtime with the watchdog disabled, shows a clean + #script-visible eof exit (see goals/G-076-tcl9-deadconsole-fix-adoption.md). + variable tclbug_console_deadspin_fixed_in "" + + #pure classifier, separated for testability - facts in, verdict out + proc tclbug_console_deadspin_applies {platform tclversion fixed_in} { + if {$platform ne "windows"} { + return 0 + } + if {![package vsatisfies $tclversion 9]} { + #tcl 8.6 has a different console driver - out of scope per G-039 (user decision 2026-07-12) + return 0 + } + if {$fixed_in eq ""} { + #no released fix known - all Tcl 9 windows runtimes affected + return 1 + } + return [expr {[package vcompare $tclversion $fixed_in] < 0}] + } + proc has_tclbug_console_deadspin {} { + #Tcl 9 windows console driver defect pair (win/tclWinConsole.c): when the hosting + #console dies (killed conhost/terminal), (a) ConsoleEventProc drops the error/EOF + #notification so a stdin readable fileevent never fires - the script is blind to the + #dead console; (b) ConsoleReaderThread busy-loops on the persistent error, spinning + #~2 cores until the channel is closed. Root-caused 2026-07-12 - see archived goal + #G-039; upstream ticket f10d91c2d3 filed 2026-07-12. punk::repl >= 0.5.0 mitigates + #with a console liveness watchdog (repl::console_watchdog) gated on this same check. + #Version-based detection only - a behavioural probe would require killing a console. + #The buginfo dict carries the mitigated/mitigation axis: level stays major (the core + #defect's severity), mitigated reports whether punk::repl >= 0.5.0 (console liveness + #watchdog) is available to this runtime - 'help tcl' renders mitigated warnings subdued. + variable tclbug_console_deadspin_fixed_in + set bug [tclbug_console_deadspin_applies $::tcl_platform(platform) [info patchlevel] $tclbug_console_deadspin_fixed_in] + set description "Tcl 9 windows console driver: a dead console (killed conhost/terminal) is never\ndelivered to the script as a fileevent, and the core's console reader thread busy-loops\non the persistent error - an orphaned tclsh spins CPU indefinitely. Plain tclsh scripts\nreading a console stdin have no script-level escape (see goal G-076)." + set replversion [package provide punk::repl] + if {$replversion eq ""} { + #not loaded - determine what version would be provided, without loading it: + #an unsatisfiable require triggers the package unknown scan (registering ifneeded + #scripts) then fails before any load (0.4.3 dev modules are alpha - below 999999). + catch {package require punk::repl 999999} + set available [package versions punk::repl] + if {[llength $available]} { + set replversion [lindex [lsort -command {package vcompare} $available] end] + } + } + set mitigated [expr {$bug && $replversion ne "" && [package vsatisfies $replversion 0.5-]}] + set mitigation "" + if {$mitigated} { + set mitigation "punk::repl $replversion is available to this runtime: its console liveness watchdog\n(armed when the repl serves the process-default console) closes the dead channel and\nexits cleanly instead of spinning. Non-repl console reads remain exposed." + } + return [dict create bug $bug bugref f10d91c2d3 description $description level major mitigated $mitigated mitigation $mitigation] + } + #has_libbug_* procs report bugs in bundled/vendored library packages rather than the Tcl core. #They are surfaced through the same 'help tcl' warning report as the has_tclbug_* checks. @@ -2455,8 +2512,11 @@ namespace eval punk::lib { #no change in origin - so we are into the arguments of the command, or have an invalid subcommand - stop looking for subcommands #todo - detect invalid subcommand and count as unknown command? break - } elseif {[dict get $test_cinfo cmdtype] in {"proc" "native" "notfound"}} { + } elseif {[dict get $test_cinfo cmdtype] in {"proc" "native" "notfound" "doconly"}} { #we have a subcommand that won't be introspectable at a deeper level. + #(doconly: G-051 - cmdinfo's truthful cmdtype for documentation-only + #levels such as 'string is xdigit', previously reported 'notfound'; + #treated identically here to preserve prior analysis behaviour) set cinfo $test_cinfo set ctype [dict get $cinfo cmdtype] break @@ -2714,7 +2774,12 @@ namespace eval punk::lib { dict lappend resultd commands_native $dispatchwords } } - "notfound" { + "notfound" - + "doconly" { + #doconly: G-051 - documentation-only level (e.g 'string is xdigit'), + #previously reported as 'notfound'; bucketed identically to preserve + #prior analysis behaviour (a future refinement may count doconly as a + #valid command word rather than notfound) if {$dispatchwords ni [dict get $resultd commands_notfound]} { dict lappend resultd commands_notfound $dispatchwords } @@ -9173,7 +9238,7 @@ namespace eval ::punk::args::register { package provide punk::lib [tcl::namespace::eval punk::lib { variable pkg punk::lib variable version - set version 0.4.0 + set version 0.4.3 }] return diff --git a/src/vfs/_vfscommon.vfs/modules/punk/ns-0.2.0.tm b/src/vfs/_vfscommon.vfs/modules/punk/ns-0.5.0.tm similarity index 97% rename from src/vfs/_vfscommon.vfs/modules/punk/ns-0.2.0.tm rename to src/vfs/_vfscommon.vfs/modules/punk/ns-0.5.0.tm index 74d4cdcc..b8642dc5 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/ns-0.2.0.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/ns-0.5.0.tm @@ -7,7 +7,7 @@ # (C) 2023 # # @@ Meta Begin -# Application punk::ns 0.2.0 +# Application punk::ns 0.5.0 # Meta platform tcl # Meta license # @@ Meta End @@ -4845,6 +4845,15 @@ y" {return quirkykeyscript} return [cmdinfo {*}$next] } } + if {$cmdtype eq "notfound" && $docid ne ""} { + #G-051: resolution landed on a punk::args id with no corresponding real + #command - a documentation-only level below (or beside) a real command, + #e.g the per-class id "::tcl::string::is true" documenting a level below + #the real ::tcl::string::is (the class words are arguments, not + #subcommands). Report it distinctly so consumers can tell it from a + #genuinely unknown command. The docid remains authoritative for display. + set cmdtype doconly + } return [list origin $origin cmdtype $cmdtype args_resolved [list [lindex $commands 0] {*}$consumed_args] args_remaining $remainingargs docid $docid stack $stack] } proc cmd_traverse {ns formid args} { @@ -5023,8 +5032,49 @@ y" {return quirkykeyscript} #(would not support shor-form prefix of subcommand - even if the proc implementation did) set docid_exists 0 set eparams [list] + set a_spaceform "" if {[punk::args::id_exists "$origin [lindex $args $i]"]} { - set a [lindex $args $i] + set a_spaceform [lindex $args $i] + } elseif {$docid ne "" && [punk::args::id_exists $docid]} { + #G-051 space-form docid prefix parity: no space-form id exists for the + #exact word - if the current level's definition has a choices-bearing + #first leader, resolve the word with the same shared resolver argument + #parsing uses (punk::args::choiceword_match - honouring -choiceprefix, + #-nocase, -choicealiases, -choiceprefixdenylist, + #-choiceprefixreservelist) and retry the space-form lookup with the + #canonical word - so 'i string is tr' lands on the documentation for + #what 'string is tr' actually executes. No second matching rule: a word + #parse would reject resolves nothing here either, and a canonical with + #no space-form id falls through to the normal per-level handling. + set pf_spec [punk::args::get_spec $docid] + set pf_fid [lindex [dict get $pf_spec form_names] 0] + set pf_leaders [dict get $pf_spec FORMS $pf_fid LEADER_NAMES] + if {[llength $pf_leaders]} { + set pf_arginfo [dict get $pf_spec FORMS $pf_fid ARG_INFO [lindex $pf_leaders 0]] + set pf_allchoices [punk::args::system::Dict_getdef $pf_arginfo -choices {}] + foreach {_pf_g pf_members} [punk::args::system::Dict_getdef $pf_arginfo -choicegroups {}] { + lappend pf_allchoices {*}$pf_members + } + if {[llength $pf_allchoices]} { + set pf_matchinfo [punk::args::choiceword_match [lindex $args $i]\ + [punk::args::system::Dict_getdef $pf_arginfo -nocase 0]\ + $pf_allchoices\ + [punk::args::system::Dict_getdef $pf_arginfo -choicealiases {}]\ + [punk::args::system::Dict_getdef $pf_arginfo -choiceprefix 1]\ + [punk::args::system::Dict_getdef $pf_arginfo -choiceprefixdenylist {}]\ + [punk::args::system::Dict_getdef $pf_arginfo -choiceprefixreservelist {}]\ + ] + if {[dict get $pf_matchinfo matched]} { + set pf_canonical [dict get $pf_matchinfo canonical] + if {$pf_canonical ne [lindex $args $i] && [punk::args::id_exists "$origin $pf_canonical"]} { + set a_spaceform $pf_canonical + } + } + } + } + } + if {$a_spaceform ne ""} { + set a $a_spaceform #review - tests? #puts stderr "cmd_traverse - skipping to documented subcommand '$origin $a'" #we can only seek beyond an undocumented subcommand level via a space delimited path, as we can make no assumption about the actual location of a subcommand relative to its parent @@ -5034,7 +5084,7 @@ y" {return quirkykeyscript} set origin [list $origin $a] incr i set queryargs [lrange $args $i end] - set resolvedargs [list $a] ;# + set resolvedargs [list $a] ;#the canonical word (a resolved prefix/alias records its canonical, as parse normalization does) set queryargs_untested $queryargs } elseif {[punk::args::id_exists $docid]} { set docid_exists 1 @@ -5374,6 +5424,10 @@ y" {return quirkykeyscript} on separate lines. If -form formname| is given, supply only the synopsis for that form. + For a multiform command, trailing argument words + after the command path underline the form(s) they + match - the best candidate when no form fully + matches (G-041 multi-form candidacy). " @opts -form -type number|name -default * -help\ @@ -5422,10 +5476,38 @@ y" {return quirkykeyscript} return } + #G-041: for a multiform definition with trailing argument words and no explicit + #-form restriction, determine the form(s) the words match via the advisory parse + #(punk::args::parse_status multi-form candidacy) - the matching/best-candidate + #form's synopsis line is underlined below (e.g 's after cancel someid' marks the + #cancel form). Skipped when alias currying makes the remaining words unreliable. + set markforms [list] + set docid_forms [list] + if {$form eq "*" && !$excess && [llength $unresolved_args] && $doc_id ne ""} { + catch {set docid_forms [punk::args::forms $doc_id]} + if {[llength $docid_forms] > 1} { + if {![catch {punk::args::parse_status $unresolved_args withid $doc_id} pstat]} { + dict for {fname finfo} [dict get $pstat formstatus] { + if {[dict get $finfo status] eq "valid"} { + lappend markforms $fname + } + } + if {![llength $markforms]} { + #no form fully matches - mark the best candidate + set markforms [list [dict get $pstat form]] + } + } + } + } + #when we use list operations on $syn - it can get extra braces due to ANSI - use join to bring back to a string without extraneous bracing switch -- $opt_return { full - summary { set resultstr "" + #ordinal position of each non-comment line maps to the definition's form + #(declaration order - both the full and summary renders emit one synopsis + #line per form in that order) + set formidx 0 foreach synline [split $syn \n] { if {[string range $synline 0 1] in {"# " "##"}} { append resultstr $synline \n @@ -5454,8 +5536,14 @@ y" {return quirkykeyscript} append lineout " " [list $part] } } + set lineout [string trim $lineout] + #G-041: underline the form(s) the supplied trailing words match + if {[llength $markforms] && [lindex $docid_forms $formidx] in $markforms} { + set lineout "[punk::ansi::a+ underline]$lineout[punk::ansi::a+ nounderline]" + } + incr formidx #must be no leading space for tests in test::punk::args synopsis.test - append resultstr [string trim $lineout] \n + append resultstr $lineout \n } } @@ -5520,8 +5608,13 @@ y" {return quirkykeyscript} } {${[punk::args::resolved_def -types opts ::punk::args::arg_error -scheme]}} { - -form -default 0 -help\ - "Ordinal index or name of command form" + -form -default * -help\ + "Restrict to the listed command forms - each element an + ordinal index or form name (see punk::args::parse -form). + With the default * the usage display presents the form + best matching any supplied argument words (G-041 + multi-form candidacy) - e.g 'i after cancel ' + presents the cancel form." -grepstr -default "" -type list -typesynopsis regex -help\ "Case insensitive grep for pattern in the output. list consisting of regex, optionally followed by ANSI names for highlighting" @@ -5605,15 +5698,24 @@ y" {return quirkykeyscript} #-caller attributes any failure message to the queried command rather than #an internal parse call site. set pstatus [punk::args::parse_status $queryargs -form $opt_form -caller $querycommand withid $rootdoc] - #With NO supplied args a failure only reflects missing required - #leaders/values - nothing to mark and nothing wrong with the user's (absent) - #input, so we show plain usage in the info scheme instead of the - #internal-looking parse error (G-046 item 5). + #A failing advisory parse renders with the error scheme and its + #message even when NO args were supplied - see the matching site in + #the main cmdhelp body for the history (G-046 item 5 suppression + #reversed 2026-07-12 after the G-049 -caller attribution made the + #messages accurate). + #G-041: render the usage for the form the advisory parse selected + #(the matched or best-candidate form within the caller's -form + #selection); for a no-form-match pass every ranked candidate and for + #an ambiguous match every matching form - the first form's argument + #table renders and all passed forms are marked in the synopsis. + if {![dict get $pstatus ok] && [dict get $pstatus failureclass] in {noformmatch multipleformmatches}} { + dict set nextopts -form [dict keys [dict get $pstatus formstatus]] + } else { + dict set nextopts -form [dict get $pstatus form] + } if {$opt_return eq "dict"} { if {$scheme_received} { dict set pstatus scheme [dict get $opts -scheme] - } elseif {![dict get $pstatus ok] && ![llength $queryargs]} { - dict set pstatus scheme info } return [dict create origin $rootorigin docid $rootdoc cmdtype $rootorigintype args_remaining $queryargs parsestatus $pstatus] } @@ -5623,11 +5725,6 @@ y" {return quirkykeyscript} dict set nextopts -scheme info } set result [punk::args::arg_error "" [punk::args::get_spec $rootdoc] {*}$nextopts -aserror 0 -parsestatus $pstatus] - } elseif {![llength $queryargs]} { - if {!$scheme_received} { - dict set nextopts -scheme info - } - set result [punk::args::arg_error "" [punk::args::get_spec $rootdoc] {*}$nextopts -aserror 0] } else { set result [punk::args::arg_error [dict get $pstatus message] [punk::args::get_spec $rootdoc] {*}$nextopts -aserror 0 -parsestatus $pstatus] } @@ -5712,15 +5809,27 @@ y" {return quirkykeyscript} #-errorstyle minimal so no usage table is built inside a discarded error and #dynamically updated ensembles are reflected). set pstatus [punk::args::parse_status $args_remaining -form $opt_form -caller $caller_display withid $origindoc] - #With NO supplied trailing args a failure only reflects missing required - #leaders/values (e.g 'i string is') - nothing to mark and nothing wrong with the - #user's (absent) input, so we show plain usage in the info scheme instead of the - #internal-looking parse error (G-046 item 5). + #A failing advisory parse renders with the error scheme and its message even + #when NO trailing args were supplied: 'i if' indicating "Bad number of + #trailing values for if. Got 0 values. Expected at least 2" is useful signal + #that the command cannot be called bare. (History: G-046 item 5 suppressed + #this path because the pre-G-049 message was internal-looking - "for + #punk::args::parse $args_remaining" - but the G-049 -caller attribution made + #the messages accurate, so the suppression was reversed 2026-07-12 by user + #direction, restoring the pre-G-046 indication with the improved messages.) + #G-041: render the usage for the form the advisory parse selected (the + #matched or best-candidate form within the caller's -form selection); for a + #no-form-match pass every ranked candidate and for an ambiguous match every + #matching form - the first form's argument table renders and all passed + #forms are marked in the synopsis. + if {![dict get $pstatus ok] && [dict get $pstatus failureclass] in {noformmatch multipleformmatches}} { + dict set nextopts -form [dict keys [dict get $pstatus formstatus]] + } else { + dict set nextopts -form [dict get $pstatus form] + } if {$opt_return eq "dict"} { if {$scheme_received} { dict set pstatus scheme [dict get $opts -scheme] - } elseif {![dict get $pstatus ok] && ![llength $args_remaining]} { - dict set pstatus scheme info } return [dict create origin $origin docid $origindoc cmdtype $origintype args_remaining $args_remaining parsestatus $pstatus] } @@ -5730,11 +5839,6 @@ y" {return quirkykeyscript} dict set nextopts -scheme info } set result [punk::args::arg_error "" [punk::args::get_spec $origindoc] {*}$nextopts -aserror 0 -parsestatus $pstatus] - } elseif {![llength $args_remaining]} { - if {!$scheme_received} { - dict set nextopts -scheme info - } - set result [punk::args::arg_error "" [punk::args::get_spec $origindoc] {*}$nextopts -aserror 0] } else { set result [punk::args::arg_error [dict get $pstatus message] [punk::args::get_spec $origindoc] {*}$nextopts -aserror 0 -parsestatus $pstatus] } @@ -7657,6 +7761,6 @@ namespace eval ::punk::args::register { ## Ready package provide punk::ns [tcl::namespace::eval punk::ns { variable version - set version 0.2.0 + set version 0.5.0 }] return \ No newline at end of file diff --git a/src/vfs/_vfscommon.vfs/modules/punk/repl-0.5.0.tm b/src/vfs/_vfscommon.vfs/modules/punk/repl-0.5.1.tm similarity index 99% rename from src/vfs/_vfscommon.vfs/modules/punk/repl-0.5.0.tm rename to src/vfs/_vfscommon.vfs/modules/punk/repl-0.5.1.tm index 61e028d1..84c5867c 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/repl-0.5.0.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/repl-0.5.1.tm @@ -634,12 +634,16 @@ proc repl::start {args} { #thread busy-loops on the persistent error - an orphaned shell would spin CPU forever. #Poll liveness on the process console so the repl can finish via the normal eof path. #Armed only for a tcl9 console channel (-inputmode present) on the process-default - #console; piped/foreign/8.6 inputs are unaffected. + #console; piped/foreign/8.6 inputs are unaffected. The version gate (G-076) is + #punk::lib::check::has_tclbug_console_deadspin - shared with the 'help tcl' warning - + #so runtimes at or past a verified fixed Tcl release (check::tclbug_console_deadspin_fixed_in) + #don't arm the probe. variable console_watchdog_afterids variable console_watchdog_ms set watchdog_chan "" if {"windows" eq $::tcl_platform(platform) && [console_is_default] - && ![info exists console_watchdog_afterids($inchan)]} { + && ![info exists console_watchdog_afterids($inchan)] + && [dict get [punk::lib::check::has_tclbug_console_deadspin] bug]} { if {![catch {chan configure $inchan} wdconf] && [dict exists $wdconf -inputmode]} { set watchdog_chan $inchan set console_watchdog_afterids($inchan) [after $console_watchdog_ms [list [namespace current]::console_watchdog $inchan]] @@ -983,7 +987,10 @@ namespace eval repl::argdoc { Armed by repl::start only for a tcl9 console channel (-inputmode present in the chan configure dict) serving the process-default console on - windows. Scheduling state is kept per channel name in + windows, and only while punk::lib::check::has_tclbug_console_deadspin + reports the runtime affected (G-076 shared version gate - a Tcl release + containing the verified upstream fix for ticket f10d91c2d3 arms nothing). + Scheduling state is kept per channel name in repl::console_watchdog_afterids; a watchdog whose channel has disappeared disarms itself silently." @values -min 1 -max 1 @@ -4518,7 +4525,7 @@ namespace eval ::punk::args::register { package provide punk::repl [namespace eval punk::repl { variable version - set version 0.5.0 + set version 0.5.1 }] #repl::start $program_read_stdin_pipe